wrapped everything in the EnvM Monad, the logging might commence

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
+  BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String
-  | BackendWithoutConfig (Wai.Application -> IO [MVar ()]) String String
+  | BackendWithoutConfig (Wai.Application -> EnvM [MVar ()]) String String
 
 backends :: [Backend]
 backends =

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 :: Wai.Application -> FilePath -> EnvM [MVar ()]
-forkHttpBackend app configFile = forkWithConfigs (backend app) httpConfigsCodec configFile
+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 :: Wai.Application -> HttpConfiguration -> EnvM ()
-backend app config = HTTP.runSettings (httpToWarpConfig config) app
+backend app config = liftIO $ HTTP.runSettings (httpToWarpConfig config) app
 #endif

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 :: Wai.Application -> FilePath -> EnvM [MVar ()]
-forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile
+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 :: Wai.Application -> HttpsConfiguration -> EnvM ()
-backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app
+backend app conf = liftIO $ HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app
 #endif

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 UnliftIO.MVar
-import Control.Concurrent
+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 ())

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
+  runEnvM defaultEnv $ do
-  waitFor' <- sequence backs
+    waiApp <-  waiApplication serverState
-  let waitFor = concat waitFor'
+    let backs = zipWith (runBackend waiApp) options backends
-  blockBackends waitFor
+    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

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 :: MVar WSA.ServerState -> EnvM Application
-waiApplication serverState = websocketsOr WS.defaultConnectionOptions (WSA.application serverState) clientServer
+waiApplication serverState = do
+  app <- WSA.application serverState
+  return $ websocketsOr WS.defaultConnectionOptions app clientServer
 
 -- this should serve the webclient see Network.Wai.responseFile
 clientServer :: Application

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 UnliftIO.MVar
-import Control.Exception
+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
+-- shift the PendingConnection parameter outside of EnvM
-application ssMV pending = do
+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
+      conn <- liftIO $ WS.acceptRequest pending
-      WS.withPingThread conn 30 (return ()) $ do
+      withPingThread conn 30 (return ()) $ do
-        clientUUID <- U.nextRandom
+        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: "
+        --hPutStr stderr "Unable to parse JSON: "
-        hPrint stderr msg
+        --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 :: TL.JSONEvent -> WS.Connection -> EnvM ()
-sendClientEvent event = flip WS.sendTextData $ encode event
+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