diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 4a56c85..aee6c9a 100644 --- a/backend/app/Main.hs +++ b/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" + ) diff --git a/backend/jitsi-rooms.cabal b/backend/jitsi-rooms.cabal index a9d635e..2f4d9fc 100644 --- a/backend/jitsi-rooms.cabal +++ b/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 diff --git a/backend/package.yaml b/backend/package.yaml index 9446666..a2df9ff 100644 --- a/backend/package.yaml +++ b/backend/package.yaml @@ -35,6 +35,7 @@ dependencies: - time - wai-extra - process + - optparse-applicative ghc-options: - -Wall diff --git a/backend/src/Lib.hs b/backend/src/Lib.hs index 0c93106..0a01244 100644 --- a/backend/src/Lib.hs +++ b/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) diff --git a/backend/src/RoomDataHandler.hs b/backend/src/RoomDataHandler.hs index 41edf7a..23f0b2b 100644 --- a/backend/src/RoomDataHandler.hs +++ b/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 diff --git a/backend/src/Types/AppTypes.hs b/backend/src/Types/AppTypes.hs index 29aaf00..112f480 100644 --- a/backend/src/Types/AppTypes.hs +++ b/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, diff --git a/backend/src/Types/Config.hs b/backend/src/Types/Config.hs new file mode 100644 index 0000000..7211e51 --- /dev/null +++ b/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 + ) diff --git a/backend/src/Types/WebEnv.hs b/backend/src/Types/WebEnv.hs index 2e4f07b..f27d348 100644 --- a/backend/src/Types/WebEnv.hs +++ b/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 diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 4e5a650..5981ee7 100644 --- a/backend/src/WebServer.hs +++ b/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 () diff --git a/backend/src/WebSocket/Server.hs b/backend/src/WebSocket/Server.hs index 666a8e0..14c6e66 100644 --- a/backend/src/WebSocket/Server.hs +++ b/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