diff options
Diffstat (limited to '')
| -rw-r--r-- | server/cafp.cabal | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 34 |
2 files changed, 20 insertions, 15 deletions
diff --git a/server/cafp.cabal b/server/cafp.cabal index 89bd8a7..a0eded7 100644 --- a/server/cafp.cabal +++ b/server/cafp.cabal @@ -28,6 +28,7 @@ Library base >= 4.9 && < 5, bytestring >= 0.10 && < 0.11, elm-bridge >= 0.5 && < 0.6, + fast-logger >= 3.0 && < 3.1, hashable >= 1.3 && < 1.4, lens >= 4.18 && < 4.19, mtl >= 2.2 && < 2.3, diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 70e9a00..28949ed 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -31,13 +31,10 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs import qualified Network.WebSockets as WS import System.Environment (getEnv) -import qualified System.IO as IO +import qualified System.Log.FastLogger as FL import System.Random (StdGen, newStdGen) import qualified Web.Scotty as Scotty -info :: String -> IO () -info = IO.hPutStrLn IO.stderr - type RoomId = T.Text type Sink = BL.ByteString -> IO () @@ -48,7 +45,8 @@ data Room = Room } data Server = Server - { serverCookieSocket :: CookieSocket.Handle Player + { serverLogger :: FL.FastLogger + , serverCookieSocket :: CookieSocket.Handle Player , serverCards :: Cards , serverRooms :: MVar (HMS.HashMap RoomId Room) } @@ -61,9 +59,9 @@ readCards = Cards parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines dropComment = T.strip . fst . T.break (== '#') -withServer :: (Server -> IO a) -> IO a -withServer f = CookieSocket.withHandle 5 $ \cs -> - f =<< Server cs <$> readCards <*> MVar.newMVar HMS.empty +withServer :: FL.FastLogger -> (Server -> IO a) -> IO a +withServer fl f = CookieSocket.withHandle 5 $ \cs -> do + f =<< Server fl cs <$> readCards <*> MVar.newMVar HMS.empty newRoom :: Server -> StdGen -> STM Room newRoom server gen = Room @@ -105,13 +103,13 @@ getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> Just room -> pure (rooms, room) Nothing -> do gen <- newStdGen - info $ "[" <> T.unpack roomId <> "] Created room" + serverLogger server $ "[" <> FL.toLogStr roomId <> "] Created room" room <- atomically $ newRoom server gen pure (HMS.insert roomId room rooms, room) deleteRoom :: Server -> RoomId -> IO () deleteRoom server roomId = do - info $ "[" <> T.unpack roomId <> "] Deleting room" + serverLogger server $ "[" <> FL.toLogStr roomId <> "] Deleting room" MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete roomId joinRoom :: Room -> Sink -> Maybe Player -> STM PlayerId @@ -147,13 +145,14 @@ wsApp server pc = case routePendingConnection pc of WS.withPingThread conn 30 (pure ()) $ bracket (do pid <- atomically $ joinRoom room sink mbRecovered - info $ "[" <> T.unpack roomId <> "] Player " <> show pid <> + serverLogger server $ "[" <> FL.toLogStr roomId <> + "] Player " <> FL.toLogStr pid <> if isNothing mbRecovered then " joined" else " rejoined" pure pid) (\pid -> do (roomEmpty, mbPlayer) <- atomically $ leaveRoom room pid - info $ "[" <> T.unpack roomId <> - "] Player " <> show pid <> " left" + serverLogger server $ "[" <> FL.toLogStr roomId <> + "] Player " <> FL.toLogStr pid <> " left" if roomEmpty then deleteRoom server roomId else do @@ -177,7 +176,8 @@ wsApp server pc = case routePendingConnection pc of processClientMessage playerId cm syncRoom room Nothing -> do - info $ "Could not decode client message: " ++ show msg + serverLogger server $ "Could not decode client message: " <> + FL.toLogStr (show msg) splitPath :: T.Text -> [T.Text] splitPath = filter (not . T.null) . T.split (== '/') @@ -200,7 +200,11 @@ main = do port <- read <$> getEnv "CAFP_PORT" base <- splitPath . T.pack <$> getEnv "CAFP_BASE" let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings - withServer $ \server -> do + timeCache <- FL.newTimeCache FL.simpleTimeFormat + FL.withTimedFastLogger timeCache + (FL.LogStderr FL.defaultBufSize) $ \tfl -> + let fl s = tfl (\time -> FL.toLogStr time <> " " <> s <> "\n") in + withServer fl $ \server -> do sapp <- scottyApp Warp.runSettings settings $ baseUrl base $ WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp |