From ac303abcc094e12c444e7f59ff04d984566b25ed Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Mon, 5 Apr 2021 22:11:07 +0200 Subject: [PATCH] wrapped everything in the EnvM Monad, the logging might commence --- app/Backend/Backend.hs | 5 ++-- app/Backend/Http.hs | 13 ++++----- app/Backend/Https.hs | 10 ++++--- app/Config.hs | 14 +++++----- app/Main.hs | 18 +++++++------ app/WaiApp.hs | 8 ++++-- app/WebSocketApp.hs | 61 ++++++++++++++++++++++++++---------------- 7 files changed, 78 insertions(+), 51 deletions(-) diff --git a/app/Backend/Backend.hs b/app/Backend/Backend.hs index 5f988ff..fceb050 100644 --- a/app/Backend/Backend.hs +++ b/app/Backend/Backend.hs @@ -3,6 +3,7 @@ module Backend.Backend where import Control.Concurrent.MVar import qualified Network.Wai as Wai +import Environment #ifdef HTTP_SUPPORT import qualified Backend.Http as HTTP @@ -25,8 +26,8 @@ import qualified Backend.Https as HTTPS -- type Backend = (Wai.Application -> FilePath -> IO [MVar ()],T.Text,Bool) data Backend = - BackendWithConfig (Wai.Application -> FilePath -> IO [MVar ()]) String String - | BackendWithoutConfig (Wai.Application -> IO [MVar ()]) String String + BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String + | BackendWithoutConfig (Wai.Application -> EnvM [MVar ()]) String String backends :: [Backend] backends = diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index e448f27..e99c8be 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -3,9 +3,8 @@ module Backend.Http where -#endif -#ifdef HTTP_SUPPORT +#else {-# LANGUAGE OverloadedStrings #-} -- we export a bit more than we have to, because the https module can reuse these things. @@ -32,6 +31,8 @@ import qualified Toml import Data.Semigroup (getFirst, First(..)) import Data.Maybe(fromJust) import Data.Coerce +import Environment +import Control.Monad.IO.Class type BindPreference = String @@ -73,8 +74,8 @@ httpConfigCodec = httpConfigsCodec :: TomlCodec [HttpConfiguration] httpConfigsCodec = Toml.list httpConfigCodec "http" -forkHttpBackend :: Wai.Application -> FilePath -> IO [MVar ()] -forkHttpBackend app configFile = forkWithConfigs (backend app) httpConfigsCodec configFile +forkHttpBackend :: Wai.Application -> FilePath -> EnvM [MVar ()] +forkHttpBackend app = forkWithConfigs (backend app) httpConfigsCodec httpToWarpConfig :: HttpConfiguration -> HTTP.Settings httpToWarpConfig config' = HTTP.setPort confPort $ HTTP.setHost (fromString confBindPref) HTTP.defaultSettings @@ -84,6 +85,6 @@ httpToWarpConfig config' = HTTP.setPort confPort $ HTTP.setHost (fromString conf confBindPref = getConfigM $ bindPref config -backend :: Wai.Application -> HttpConfiguration -> IO () -backend app config = HTTP.runSettings (httpToWarpConfig config) app +backend :: Wai.Application -> HttpConfiguration -> EnvM () +backend app config = liftIO $ HTTP.runSettings (httpToWarpConfig config) app #endif diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 51cfba2..69afa1e 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -18,6 +18,8 @@ import qualified Network.Wai.Handler.Warp as HTTP import qualified Network.Wai.Handler.WarpTLS as HTTPS import Toml (TomlCodec, (.=)) import qualified Toml +import Control.Monad.IO.Class +import Environment type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) @@ -63,8 +65,8 @@ httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' httpsConfigsCodec :: TomlCodec [HttpsConfiguration] httpsConfigsCodec = Toml.list httpsConfigCodec "https" -forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] -forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile +forkHttpsBackend :: Wai.Application -> FilePath -> EnvM [MVar ()] +forkHttpsBackend app = forkWithConfigs (backend app) httpsConfigsCodec httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain confCerfFile confCertChain confKeyFile @@ -78,6 +80,6 @@ httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain confCerfFile confCe httpsToWarpConfig :: HttpsConfiguration -> HTTP.Settings httpsToWarpConfig = httpToWarpConfig . fst -backend :: Wai.Application -> HttpsConfiguration -> IO () -backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app +backend :: Wai.Application -> HttpsConfiguration -> EnvM () +backend app conf = liftIO $ HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app #endif diff --git a/app/Config.hs b/app/Config.hs index 16923a4..d5a0dcb 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -8,11 +8,13 @@ import Toml (TomlCodec, (.=)) import qualified Toml import System.IO import qualified Data.Text as T -import Control.Concurrent.MVar -import Control.Concurrent +import UnliftIO.MVar +import UnliftIO.Concurrent import WaiApp import Data.Maybe(fromJust) import Data.Coerce +import Environment +import Colog.Message -- This Type is here to replace Toml.Codec.Monoid.First as the First Monoid @@ -29,20 +31,20 @@ setConfigM = Just . coerce configM :: (Toml.Key -> TomlCodec a) -> Toml.Key -> TomlCodec (ConfigM a) configM codec = Toml.diwrap . Toml.dioptional . codec -forkWithConfigs :: (a -> IO ()) -> TomlCodec [a] -> FilePath -> IO [MVar ()] +forkWithConfigs :: (a -> EnvM ()) -> TomlCodec [a] -> FilePath -> EnvM [MVar ()] forkWithConfigs f = withConfigs (forkBackend . f) -withConfigs :: (a -> IO (MVar ())) -> TomlCodec [a] -> FilePath -> IO [MVar ()] +withConfigs :: (a -> EnvM b) -> TomlCodec [a] -> FilePath -> EnvM [b] withConfigs f codec configFile = do parseResult <- Toml.decodeFileEither codec configFile either - (error . show) + (\x -> (logError . T.pack . show) x >> return []) (mapM f) parseResult -- Note for later: -- TODO this may need logging if f dies with an exception -forkBackend :: IO () -> IO (MVar ()) +forkBackend :: EnvM () -> EnvM (MVar ()) forkBackend f = do mVar <- newEmptyMVar forkFinally f (const $ putMVar mVar ()) diff --git a/app/Main.hs b/app/Main.hs index 2c851ba..61525d5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,12 +8,12 @@ module Main where -- We need some way too configure things, like the port we run on. -- see Network.Wai.Handler.Warp.Settings and Network.Wai.Handler.Warp.runSettings -import Control.Concurrent.MVar import qualified Network.Wai as Wai import WaiApp -import Control.Concurrent +import UnliftIO.Concurrent import Backend.Backend import Options.Applicative +import Environment -- maybe we should use Control.Concurrent.ParallelIO but right -- now we just rely that the backends fork and don't block @@ -21,15 +21,17 @@ main :: IO () main = do options <- execParser commandLineParser serverState <- newMVar newServerState - let backs = zipWith (runBackend $ waiApplication serverState) options backends - waitFor' <- sequence backs - let waitFor = concat waitFor' - blockBackends waitFor + runEnvM defaultEnv $ do + waiApp <- waiApplication serverState + let backs = zipWith (runBackend waiApp) options backends + waitFor' <- sequence backs + let waitFor = concat waitFor' + blockBackends waitFor -blockBackends :: [MVar ()] -> IO () +blockBackends :: [MVar ()] -> EnvM () blockBackends = mapM_ takeMVar -runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> IO [MVar ()] +runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> EnvM [MVar ()] runBackend app (Left (Just conf)) (BackendWithConfig b _ _) = b app conf runBackend _ (Left Nothing) (BackendWithConfig _ _ _) = return [] runBackend app (Right True) (BackendWithoutConfig b _ _) = b app diff --git a/app/WaiApp.hs b/app/WaiApp.hs index a9b4307..445b21e 100644 --- a/app/WaiApp.hs +++ b/app/WaiApp.hs @@ -8,9 +8,13 @@ import Network.Wai.Handler.WebSockets import Network.Wai import Network.HTTP.Types import Control.Concurrent.MVar +import Control.Monad.Reader.Class +import Environment -waiApplication :: MVar WSA.ServerState -> Application -waiApplication serverState = websocketsOr WS.defaultConnectionOptions (WSA.application serverState) clientServer +waiApplication :: MVar WSA.ServerState -> EnvM Application +waiApplication serverState = do + app <- WSA.application serverState + return $ websocketsOr WS.defaultConnectionOptions app clientServer -- this should serve the webclient see Network.Wai.responseFile clientServer :: Application diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index adb5af5..a0434be 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -2,11 +2,14 @@ module WebSocketApp (newServerState, ServerState, application) where --- Maybe strict MVar?? but then we need NFData instenaces for TickLeiste +import Environment +import Control.Monad.IO.Class import Control.Arrow (first, second) -import Control.Concurrent.MVar -import Control.Exception +import UnliftIO.MVar +import UnliftIO.Exception +import Control.Monad.IO.Unlift import Control.Monad +import Control.Monad.Reader.Class import Data.Aeson import qualified Data.Aeson.TickLeiste as TL import qualified Data.ByteString as B @@ -50,31 +53,43 @@ type ServerState = M.Map SessionId (MVar SessionState) newServerState :: ServerState newServerState = M.empty -application :: MVar ServerState -> WS.ServerApp -application ssMV pending = do +-- shift the PendingConnection parameter outside of EnvM +application :: MVar ServerState -> EnvM WS.ServerApp +application mvar = do + r <- ask + return (runEnvM r . application' mvar) + + +-- Unlifted WS.withPingThread +withPingThread :: WS.Connection -> Int -> EnvM () -> EnvM a -> EnvM a +withPingThread conn int rep action = withRunInIO $ \run -> WS.withPingThread conn int (run rep) (run action) + +application' :: MVar ServerState -> WS.PendingConnection -> EnvM () +application' ssMV pending = do -- maybe we want to check that the Path has a maximum length or something let requestPath = WS.requestPath $ WS.pendingRequest pending if B.null requestPath then do -- TODO reject Body should probably not empty... -- this may need a better logic - WS.rejectRequestWith pending WS.defaultRejectRequest + liftIO $ WS.rejectRequestWith pending WS.defaultRejectRequest else do - conn <- WS.acceptRequest pending - WS.withPingThread conn 30 (return ()) $ do - clientUUID <- U.nextRandom + conn <- liftIO $ WS.acceptRequest pending + withPingThread conn 30 (return ()) $ do + clientUUID <- liftIO U.nextRandom bracket (addClient requestPath (clientUUID, conn) ssMV) (const $ removeClient requestPath (clientUUID, conn) ssMV) (clientLogic conn) -clientLogic :: WS.Connection -> MVar SessionState -> IO () +clientLogic :: WS.Connection -> MVar SessionState -> EnvM () clientLogic conn sessionStateMVar = do - msg <- (WS.receiveData conn :: IO B.ByteString) + msg <- (liftIO $ WS.receiveData conn :: EnvM B.ByteString) maybe ( do - hPutStr stderr "Unable to parse JSON: " - hPrint stderr msg + --hPutStr stderr "Unable to parse JSON: " + --hPrint stderr msg + return () ) -- the next line is a bit ugly, maybe there is a better way? -- maybe refactor, so that the request Handler can choose to lock or not. -- TODO @@ -82,13 +97,13 @@ clientLogic conn sessionStateMVar = do (decodeStrict msg :: Maybe TL.JSONRequest) clientLogic conn sessionStateMVar -requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> IO SessionState +requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> EnvM SessionState requestHandler conn (tl, pl, cls, sem) (TL.SetPlayerTickR playerUUID tick) = do let tl' = TL.setPlayerTick playerUUID tick tl broadcastEvent (TL.SetPlayerTickE playerUUID tick) cls return (tl', pl, cls, sem) requestHandler conn (tl, pl, cls, sem) (TL.AddPlayerTickR playerName tick) = do - playerUUID <- U.nextRandom + playerUUID <- liftIO U.nextRandom let tl' = TL.setPlayerTick playerUUID tick tl pl' = M.insert playerUUID playerName pl broadcastEvent (TL.AddPlayerTickE playerUUID playerName tick) cls @@ -117,11 +132,11 @@ requestHandler conn (tl, pl, cls, sem) (TL.RemovePlayerR playerUUID) = do broadcastEvent (TL.RemovePlayerE playerUUID) cls return (tl', pl', cls, sem) -broadcastEvent :: TL.JSONEvent -> [Client] -> IO () +broadcastEvent :: TL.JSONEvent -> [Client] -> EnvM () broadcastEvent event = mapM_ $ sendClientEvent event . snd -sendClientEvent :: TL.JSONEvent -> WS.Connection -> IO () -sendClientEvent event = flip WS.sendTextData $ encode event +sendClientEvent :: TL.JSONEvent -> WS.Connection -> EnvM () +sendClientEvent event = liftIO . flip WS.sendTextData ( encode event) -- if you find something better than this ugly stuff ... feel free tickLeisteListToPlayerList :: M.Map U.UUID T.Text -> [(TL.Tick, [U.UUID])] -> [(TL.Tick, [(U.UUID, T.Text)])] @@ -132,14 +147,14 @@ tickLeisteToPlayerList pl = tickLeisteListToPlayerList pl . TL.toList -- uff good luck reading that -- maybe it would be better to collect the UUID to Text map in a list and call M.fromList in the end? -playerNameListToTickLeisteList :: [(TL.Tick, [T.Text])] -> IO ([(TL.Tick, [U.UUID])], M.Map U.UUID T.Text) +playerNameListToTickLeisteList :: [(TL.Tick, [T.Text])] -> EnvM ([(TL.Tick, [U.UUID])], M.Map U.UUID T.Text) playerNameListToTickLeisteList = foldM ( \(tl, pl) (tick, plns) -> do (tl', pl') <- foldM ( \(tl, pl) playerName -> do - playerUUID <- U.nextRandom + playerUUID <- liftIO U.nextRandom let tl' = playerUUID : tl pl' = M.insert playerUUID playerName pl return (tl', pl') @@ -154,7 +169,7 @@ playerNameListToTickLeisteList = unknownPlayerName :: T.Text unknownPlayerName = "Unknown Player" -addClient :: SessionId -> Client -> MVar ServerState -> IO (MVar SessionState) +addClient :: SessionId -> Client -> MVar ServerState -> EnvM (MVar SessionState) addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState -> maybe ( do @@ -169,11 +184,11 @@ addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serve ) (serverState M.!? sessionId) -removeClient :: SessionId -> Client -> MVar ServerState -> IO () +removeClient :: SessionId -> Client -> MVar ServerState -> EnvM () removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState -> maybe ( do - hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG" + --hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG" return serverState ) ( \sessionStateMVar -> do