wrapped everything in the EnvM Monad, the logging might commence

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