aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/cafp.cabal1
-rw-r--r--server/lib/Cafp/Main/Server.hs34
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