diff --git a/app/Logging.hs b/app/Logging.hs new file mode 100644 index 0000000..b1f7ed2 --- /dev/null +++ b/app/Logging.hs @@ -0,0 +1,25 @@ +module Logging(logError, logWarning, logDebug, logInfo) where + +import Colog.Core.Severity +import qualified Colog as Log +import qualified Data.Text as T +--this module contains our own specialication of logger functionality, +--this is usually a bad idea, but as the apis force us to write +--plain IO actions anyway (run..., bracket, modifyMVar, ...) we +--we are forced to make logging an IO action and can't parametrize +--over the Monad. If we already do that we can write our own small +--helper to wrap our specialcase in IO. + + +logError :: Log.LogAction IO Log.Message -> T.Text -> IO () +logError logAction = (Log.usingLoggerT logAction) . Log.logError + +logWarning :: Log.LogAction IO Log.Message -> T.Text -> IO () +logWarning logAction = (Log.usingLoggerT logAction) . Log.logWarning + +logDebug :: Log.LogAction IO Log.Message -> T.Text -> IO () +logDebug logAction = (Log.usingLoggerT logAction) . Log.logDebug + +logInfo :: Log.LogAction IO Log.Message -> T.Text -> IO () +logInfo logAction = (Log.usingLoggerT logAction) . Log.logInfo + diff --git a/app/Main.hs b/app/Main.hs index 00c8593..f649474 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,7 @@ module Main where import Control.Concurrent.MVar import WaiApp +import qualified Colog as Log #ifdef HTTP_SUPPORT import qualified Network.Wai.Handler.Warp as HTTP @@ -28,11 +29,14 @@ import qualified Network.Wai.Handler.FastCGI as FastCGI import qualified Network.Wai.Handler.CGI as CGI #endif +logAction :: Log.LogAction IO Log.Message +logAction = undefined + main :: IO () main = do serverState <- newMVar newServerState #ifdef HTTP_SUPPORT - HTTP.runSettings HTTP.defaultSettings $ waiApplication serverState + HTTP.runSettings HTTP.defaultSettings $ waiApplication logAction serverState #endif #ifdef HTTPS_SUPPORT HTTPS.runTLS HTTPS.defaultTlsSettings HTTP.defaultSettings $ waiApplication serverState diff --git a/app/WaiApp.hs b/app/WaiApp.hs index a9b4307..fbf02c1 100644 --- a/app/WaiApp.hs +++ b/app/WaiApp.hs @@ -8,9 +8,10 @@ import Network.Wai.Handler.WebSockets import Network.Wai import Network.HTTP.Types import Control.Concurrent.MVar +import qualified Colog as Log -waiApplication :: MVar WSA.ServerState -> Application -waiApplication serverState = websocketsOr WS.defaultConnectionOptions (WSA.application serverState) clientServer +waiApplication :: Log.LogAction IO Log.Message ->MVar WSA.ServerState -> Application +waiApplication logAction serverState = websocketsOr WS.defaultConnectionOptions (WSA.application logAction serverState) clientServer -- this should serve the webclient see Network.Wai.responseFile clientServer :: Application diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index dce3f37..196968a 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -11,14 +11,18 @@ import Data.Aeson import qualified Data.Aeson.TickLeiste as TL import qualified Data.ByteString as B import qualified Data.Map.Strict as M -import Data.Maybe (maybe) +import Data.Maybe (maybe) -- should be replaced by either +import Data.Either (either) import qualified Data.Text as T import qualified Data.TickLeiste as TL import qualified Data.UUID as U import qualified Data.UUID.V4 as U import qualified Network.WebSockets as WS import System.IO +import Control.Monad.IO.Class (liftIO, MonadIO) +import qualified Colog as Log hiding (logError,logWarning,logInfo,logDebug) +import qualified Logging as Log ---------------------------------------------------------------------------------- ------------------------ NEVER USE putMVar OR takeMVar --------------------------- ---------------------------------------------------------------------------------- @@ -50,8 +54,8 @@ type ServerState = M.Map SessionId (MVar SessionState) newServerState :: ServerState newServerState = M.empty -application :: MVar ServerState -> WS.ServerApp -application ssMV pending = do +application :: Log.LogAction IO Log.Message -> MVar ServerState -> WS.ServerApp +application logAction 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 @@ -66,20 +70,19 @@ application ssMV pending = do bracket (addClient requestPath (clientUUID, conn) ssMV) (const $ removeClient requestPath (clientUUID, conn) ssMV) - (clientLogic conn) + (clientLogic logAction conn) -clientLogic :: WS.Connection -> MVar SessionState -> IO () -clientLogic conn sessionStateMVar = do +clientLogic :: Log.LogAction IO Log.Message -> WS.Connection -> MVar SessionState -> IO () +clientLogic logAction conn sessionStateMVar = do msg <- (WS.receiveData conn :: IO B.ByteString) - maybe - ( do - hPutStr stderr "Unable to parse JSON: " - hPrint stderr msg + either + ( \fmsg -> do + Log.logError logAction $ T.pack fmsg ) -- the next line is a bit ugly, maybe there is a better way? (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler conn sessionState request)) - (decodeStrict msg :: Maybe TL.JSONRequest) - clientLogic conn sessionStateMVar + (eitherDecodeStrict msg :: Either String TL.JSONRequest) + clientLogic logAction conn sessionStateMVar requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> IO SessionState requestHandler conn (tl, pl, cls, sem) (TL.SetPlayerTickR playerUUID tick) = do diff --git a/package.yaml b/package.yaml index 3385bde..31bdac5 100644 --- a/package.yaml +++ b/package.yaml @@ -50,6 +50,8 @@ dependencies: - wai - wai-websockets - http-types +- co-log +- co-log-core when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 22b02d7..2ee15b6 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -46,6 +46,7 @@ flag https executable tickLeisteServer main-is: Main.hs other-modules: + Logging WaiApp WebSocketApp Paths_tickLeisteServer @@ -58,6 +59,8 @@ executable tickLeisteServer aeson , base >=4.7 && <5 , bytestring + , co-log + , co-log-core , containers , http-types , text @@ -104,6 +107,8 @@ test-suite tickLeisteServer-test aeson , base >=4.7 && <5 , bytestring + , co-log + , co-log-core , containers , http-types , text