feat: add notify command and cli args

backend/app/Main.hs

@@ -4,10 +4,24 @@ import ClassyPrelude
 import GHC.IO.Encoding (setLocaleEncoding)
 import GHC.IO.Encoding.UTF8 (utf8)
 import Lib (runBothServers)
+import Options.Applicative
+import Types.Config (ServerOptions, serverOptionsParser)
 
 main :: IO ()
 main = do
   setLocaleEncoding utf8
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
-  runBothServers
+
+  opts <- execParser serverOptions
+
+  runBothServers opts
+
+serverOptions :: ParserInfo ServerOptions
+serverOptions =
+  info
+    (serverOptionsParser <**> helper)
+    ( fullDesc
+        <> progDesc "Run the server with specified options"
+        <> header "Haskell Server - A configurable server application"
+    )

backend/jitsi-rooms.cabal

@@ -33,6 +33,7 @@ library
       State.RoomDataState
       State.RoomsState
       Types.AppTypes
+      Types.Config
       Types.ConnectionState
       Types.Participant
       Types.RoomData
@@ -62,6 +63,7 @@ library
     , http-types
     , lifted-base
     , mtl
+    , optparse-applicative
     , process
     , text
     , time
@@ -90,6 +92,7 @@ executable jitsi-rooms-exe
     , jitsi-rooms
     , lifted-base
     , mtl
+    , optparse-applicative
     , process
     , text
     , time

backend/package.yaml

@@ -35,6 +35,7 @@ dependencies:
   - time
   - wai-extra
   - process
+  - optparse-applicative
 
 ghc-options:
   - -Wall

backend/src/Lib.hs

@@ -9,11 +9,12 @@ import ClassyPrelude
 import State.ConnectedClientsState (initConnectionsState)
 import State.RoomsState (initRoomsState)
 import Types.AppTypes
+import Types.Config (ServerOptions)
 import WebServer (runWebServer)
 import WebSocket.Server (runWebSocketServer)
 
-runBothServers :: IO ()
-runBothServers = do
+runBothServers :: ServerOptions -> IO ()
+runBothServers serverOptions = do
   connectedClientsState <- initConnectionsState
   roomsState <- initRoomsState
 
@@ -21,7 +22,8 @@ runBothServers = do
         Env
           { connectedClientsState = connectedClientsState,
             profile = Dev,
-            roomsState = roomsState
+            roomsState = roomsState,
+            config = serverOptions
           }
 
   _ <- concurrently (unApp runWebSocketServer env) (unApp runWebServer env)

backend/src/RoomDataHandler.hs

@@ -27,6 +27,8 @@ import State.RoomsState
   )
 import System.Process
 import Text.Printf (printf)
+import Types.AppTypes (HasConfig (getConfig))
+import Types.Config (ServerOptions (..))
 import Types.RoomData (RoomData, prettyPrintOpenedRoom)
 import Types.WebEnv
   ( HasWebEnv (getRequest),
@@ -40,7 +42,8 @@ roomDataHandler ::
     MonadError ResponseReceived m,
     MonadRoomDataStateRead m,
     MonadRoomDataStateModify m,
-    MonadBroadcast m
+    MonadBroadcast m,
+    HasConfig env
   ) =>
   m ResponseReceived
 roomDataHandler = do
@@ -115,16 +118,21 @@ success = do
         [("Content-Type", "text/plain")]
         ""
 
-notifyRoomOpend :: (MonadIO m) => RoomData -> m ()
+notifyRoomOpend :: (MonadIO m, HasConfig a0, MonadReader a0 m) => RoomData -> m ()
 notifyRoomOpend room = do
+  config' <- getConfig <$> ask
+  let ServerOptions {notifyExecutable = notifyExecutable'} = config'
   let (name, user) = prettyPrintOpenedRoom room
   liftIO $ printf "Room %s opened by %s\n" name user
-  exitCode <- liftIO $ system $ printf "/nix/store/23nz5mjk3dj7027byc6g5avx3mfwwnqm-libnotify-0.8.3/bin/notify-send 'Room %s opened by %s'" name user
-  when (exitCode /= ExitSuccess) $ liftIO $ printf "Failed to notify room %s opened by %s\n" name user
+  let command = printf "%s open '%s' '%s'" notifyExecutable' name user
+  exitCode <- liftIO $ system command
+  when (exitCode /= ExitSuccess) $ liftIO $ printf "Failed to notify room %s opened by %s running command %s\n" name user command
 
-notifyRoomClosed :: (MonadIO m) => RoomData -> m ()
+notifyRoomClosed :: (MonadIO m, HasConfig a0, MonadReader a0 m) => RoomData -> m ()
 notifyRoomClosed room = do
+  config' <- getConfig <$> ask
+  let ServerOptions {notifyExecutable = notifyExecutable'} = config'
   let (name, _) = prettyPrintOpenedRoom room
   liftIO $ printf "Room %s closed\n" name
-  exitCode <- liftIO $ system $ printf "/nix/store/23nz5mjk3dj7027byc6g5avx3mfwwnqm-libnotify-0.8.3/bin/notify-send 'Room %s closed'" name
+  exitCode <- liftIO $ system $ printf "%s closed '%s'" notifyExecutable' name
   when (exitCode /= ExitSuccess) $ liftIO $ printf "Failed to notify room %s closed\n" name

backend/src/Types/AppTypes.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DerivingVia #-}
 
-module Types.AppTypes (Env (..), App (..), getConnectedClientState, AppProfile (Prod, Dev)) where
+module Types.AppTypes (Env (..), App (..), HasConfig (getConfig), getConnectedClientState, AppProfile (Prod, Dev)) where
 
 import ClassyPrelude
 import State.ConnectedClientsState
@@ -8,13 +8,15 @@ import State.RoomsState
   ( HasRoomsState (getRoomsState),
     RoomsState,
   )
+import Types.Config (ServerOptions)
 
 data AppProfile = Prod | Dev
 
 data Env = Env
   { connectedClientsState :: ConnectedClientsState,
     roomsState :: RoomsState,
-    profile :: AppProfile
+    profile :: AppProfile,
+    config :: ServerOptions
   }
 
 instance HasConnectedClientState Env where
@@ -23,6 +25,12 @@ instance HasConnectedClientState Env where
 instance HasRoomsState Env where
   getRoomsState = roomsState
 
+class HasConfig a where
+  getConfig :: a -> ServerOptions
+
+instance HasConfig Env where
+  getConfig = config
+
 newtype App env a = App {unApp :: env -> IO a}
   deriving
     ( Functor,

backend/src/Types/Config.hs

@@ -0,0 +1,61 @@
+module Types.Config
+  ( ServerOptions (..),
+    serverOptionsParser,
+  )
+where
+
+import ClassyPrelude
+  ( Applicative ((<*>)),
+    Int,
+    Semigroup ((<>)),
+    Show,
+    String,
+    (<$>),
+  )
+import Options.Applicative (Parser, auto, help, long, metavar, option, short, showDefault, strOption, value)
+
+data ServerOptions = ServerOptions
+  { port :: Int, -- Main server port
+    websocketPort :: Int, -- WebSocket server port
+    listenAddress :: String, -- Address to bind the server
+    notifyExecutable :: String -- Path to the notify executable
+  }
+  deriving (Show)
+
+serverOptionsParser :: Parser ServerOptions
+serverOptionsParser =
+  ServerOptions
+    <$> option
+      auto
+      ( long "port"
+          <> short 'p'
+          <> metavar "PORT"
+          <> help "Port number for the main server (default: 8081)"
+          <> value 8081
+          <> showDefault
+      )
+    <*> option
+      auto
+      ( long "websocketPort"
+          <> short 'w'
+          <> metavar "WS_PORT"
+          <> help "Port number for the WebSocket server (default: 9160)"
+          <> value 9160
+          <> showDefault
+      )
+    <*> strOption
+      ( long "listenAddress"
+          <> short 'l'
+          <> metavar "ADDRESS"
+          <> help "IP address or hostname to bind the server (default: 127.0.0.1)"
+          <> value "127.0.0.1"
+          <> showDefault
+      )
+    <*> strOption
+      ( long "notifyExecutable"
+          <> short 'n'
+          <> metavar "EXECUTABLE"
+          <> help "Path to the notify executable (default: /usr/bin/notify)"
+          <> value "/usr/bin/notify"
+          <> showDefault
+      )

backend/src/Types/WebEnv.hs

@@ -10,6 +10,7 @@ import State.ConnectedClientsState (HasConnectedClientState (getConnectedClientS
 import State.RoomsState (HasRoomsState (getRoomsState))
 import Types.AppTypes
   ( Env (..),
+    HasConfig (getConfig),
   )
 
 class HasWebEnv a where
@@ -31,3 +32,6 @@ instance HasRoomsState WebEnv where
 instance HasWebEnv WebEnv where
   getRequest = request
   getRespond = respond
+
+instance HasConfig WebEnv where
+  getConfig = getConfig . appEnv

backend/src/WebServer.hs

@@ -29,7 +29,9 @@ import State.RoomsState
   ( getRoomState,
     updateRoomState,
   )
-import Types.AppTypes (Env (..))
+import Text.Printf (printf)
+import Types.AppTypes (Env (..), HasConfig (getConfig))
+import Types.Config (ServerOptions (..))
 import Types.WebEnv
 
 newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
@@ -82,7 +84,8 @@ app ::
     MonadError ResponseReceived m,
     MonadRoomDataStateModify m,
     MonadRoomDataStateRead m,
-    MonadBroadcast m
+    MonadBroadcast m,
+    HasConfig env
   ) =>
   m ResponseReceived
 app = requestPathHandler
@@ -94,7 +97,8 @@ requestPathHandler ::
     MonadError ResponseReceived m,
     MonadRoomDataStateModify m,
     MonadRoomDataStateRead m,
-    MonadBroadcast m
+    MonadBroadcast m,
+    HasConfig env
   ) =>
   m ResponseReceived
 requestPathHandler = do
@@ -122,7 +126,9 @@ notFound = do
 
 runWebApp ::
   ( MonadIO m,
-    MonadReader Env m
+    MonadReader Env m,
+    HasConfig Env,
+    HasConfig WebEnv
   ) =>
   m Application
 runWebApp = do
@@ -141,10 +147,14 @@ runWebApp = do
 
 runWebServer ::
   ( MonadIO m,
-    MonadReader Env m
+    MonadReader Env m,
+    HasConfig Env,
+    HasConfig WebEnv
   ) =>
   m ()
 runWebServer = do
-  putStrLn "Webserver up and running at http://localhost:8081/"
-  runWebApp >>= liftIO . (run 8081 . logStdout)
+  config' <- getConfig <$> ask
+  let ServerOptions {port = webPort, listenAddress = address} = config'
+  putStrLn $ pack $ printf "Webserver up and running at http://%s:%d/" address webPort
+  runWebApp >>= liftIO . (run webPort . logStdout)
   return ()

backend/src/WebSocket/Server.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
 
 module WebSocket.Server
   ( runWebSocketServer,
@@ -9,22 +10,27 @@ where
 import ClassyPrelude
 import Data.UUID.V4 (nextRandom)
 import Network.WebSockets qualified as WS
-import Types.AppTypes
+import Text.Printf
+import Types.AppTypes (Env, HasConfig (getConfig))
+import Types.Config (ServerOptions (..))
 import WebSocket.WSApp (WSApp (..), WSEnv (..), wsApp)
 
 runWebSocketServer ::
   ( MonadIO m,
-    MonadReader Env m
+    Types.AppTypes.HasConfig Types.AppTypes.Env,
+    MonadReader Types.AppTypes.Env m
   ) =>
   m ()
 runWebSocketServer = do
-  putStrLn "Websocket up at 0.0.0.0:9160"
+  config' <- getConfig <$> ask
+  let ServerOptions {websocketPort = wsPort, listenAddress = address} = config'
+  putStrLn $ pack $ printf "WebSocket server up and running at ws://%s:%d/" address wsPort
   wsApp' <- runWSApp
-  liftIO $ WS.runServer "0.0.0.0" 9160 wsApp'
+  liftIO $ WS.runServer address wsPort wsApp'
 
 runWSApp ::
   ( MonadIO m,
-    MonadReader Env m
+    MonadReader Types.AppTypes.Env m
   ) =>
   m WS.ServerApp
 runWSApp = do