From 8d5c0405565ad4afd976efd1262b3224efd6ee2f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 13 Aug 2020 19:19:22 +0200 Subject: cafp -> uplcg --- server/lib/Cafp/Main/Server.hs | 214 ----------------------------------------- 1 file changed, 214 deletions(-) delete mode 100644 server/lib/Cafp/Main/Server.hs (limited to 'server/lib/Cafp/Main/Server.hs') diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs deleted file mode 100644 index ba2425d..0000000 --- a/server/lib/Cafp/Main/Server.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Cafp.Main.Server - ( main - ) where - -import qualified Cafp.CookieSocket as CookieSocket -import Cafp.Game -import Cafp.Messages -import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as MVar -import Control.Concurrent.STM (STM, TVar, atomically) -import qualified Control.Concurrent.STM as STM -import Control.Exception (bracket) -import Control.Lens ((^.), (&), (.~)) -import Control.Monad (forever, when) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Char (isAlphaNum) -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HMS -import qualified Data.List as L -import Data.Maybe (fromMaybe, isNothing) -import Data.String (fromString) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Vector as V -import qualified Network.Wai as Wai -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.Log.FastLogger as FL -import System.Random (StdGen, newStdGen) -import qualified Web.Scotty as Scotty - -type RoomId = T.Text - -type Sink = BL.ByteString -> IO () - -data Room = Room - { roomId :: RoomId - , roomGame :: TVar Game - , roomSinks :: TVar (HMS.HashMap PlayerId Sink) - } - -data Server = Server - { serverLogger :: FL.FastLogger - , serverCookieSocket :: CookieSocket.Handle Player - , serverCards :: Cards - , serverRooms :: MVar (HMS.HashMap RoomId Room) - } - -readCards :: IO Cards -readCards = Cards - <$> fmap parseCards (T.readFile "assets/black.txt") - <*> fmap parseCards (T.readFile "assets/white.txt") - where - parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines - dropComment = T.strip . fst . T.break (== '#') - -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 :: RoomId -> Cards -> StdGen -> STM Room -newRoom rid cards gen = Room rid - <$> STM.newTVar (newGame cards gen) - <*> STM.newTVar HMS.empty - -parseRoomId :: T.Text -> Either String T.Text -parseRoomId txt - | T.all isAlphaNum txt && T.length txt >= 6 = Right txt - | otherwise = Left "Bad room name" - -scottyApp :: IO Wai.Application -scottyApp = Scotty.scottyApp $ do - Scotty.get "/rooms/:id/" $ do - rid <- Scotty.param "id" - when (T.length rid < 6) $ - Scotty.raise "Room ID should be at least 6 characters" - Scotty.setHeader "Content-Type" "text/html" - Scotty.file "assets/client.html" - - Scotty.get "/assets/client.js" $ do - Scotty.setHeader "Content-Type" "application/JavaScript" - Scotty.file "assets/client.js" - - Scotty.get "/assets/style.css" $ do - Scotty.setHeader "Content-Type" "text/css" - Scotty.file "assets/style.css" - -routePendingConnection :: WS.PendingConnection -> Maybe RoomId -routePendingConnection pending = - let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in - case splitPath path of - ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r - _ -> Nothing - -getOrCreateRoom :: Server -> RoomId -> IO Room -getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms -> - case HMS.lookup rid rooms of - Just room -> pure (rooms, room) - Nothing -> do - gen <- newStdGen - serverLogger server $ "[" <> FL.toLogStr rid <> "] Created room" - room <- atomically $ newRoom rid (serverCards server) gen - pure (HMS.insert rid room rooms, room) - -deleteRoom :: Server -> RoomId -> IO () -deleteRoom server rid = do - serverLogger server $ "[" <> FL.toLogStr rid <> "] Deleting room" - MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete rid - -joinRoom :: Room -> Sink -> Maybe Player -> STM PlayerId -joinRoom room sink mbRecovered = do - pid <- STM.stateTVar (roomGame room) $ joinGame mbRecovered - STM.modifyTVar' (roomSinks room) $ HMS.insert pid sink - pure pid - -leaveRoom :: Room -> PlayerId -> STM (Bool, Maybe Player) -leaveRoom room pid = do - player <- STM.stateTVar (roomGame room) $ leaveGame pid - STM.stateTVar (roomSinks room) $ \sinks -> - let sinks' = HMS.delete pid sinks in - ((HMS.null sinks', player), sinks') - -syncRoom :: Server -> Room -> IO () -syncRoom server room = do - (game, sinks) <- atomically $ (,) - <$> STM.stateTVar (roomGame room) (\g -> (g, g & gameLog .~ [])) - <*> STM.readTVar (roomSinks room) - for_ (reverse $ game ^. gameLog) $ \msg -> - serverLogger server $ "[" <> FL.toLogStr (roomId room) <> "] " <> - FL.toLogStr msg - for_ (HMS.toList sinks) $ \(pid, sink) -> do - let view = gameViewForPlayer pid game - sink . Aeson.encode $ SyncGameView view - -wsApp :: Server -> WS.ServerApp -wsApp server pc = case routePendingConnection pc of - Nothing -> WS.rejectRequest pc "Invalid URL" - Just rid -> do - room <- getOrCreateRoom server rid - (conn, secret, mbRecovered) <- - CookieSocket.acceptRequest (serverCookieSocket server) rid pc - let sink = WS.sendTextData conn - WS.withPingThread conn 30 (pure ()) $ bracket - (do - pid <- atomically $ joinRoom room sink mbRecovered - serverLogger server $ "[" <> FL.toLogStr rid <> - "] Player " <> FL.toLogStr pid <> - if isNothing mbRecovered then " joined" else " rejoined" - pure pid) - (\pid -> do - (roomEmpty, mbPlayer) <- atomically $ leaveRoom room pid - serverLogger server $ "[" <> FL.toLogStr rid <> - "] Player " <> FL.toLogStr pid <> " left" - if roomEmpty - then deleteRoom server rid - else do - for_ mbPlayer $ CookieSocket.persist - (serverCookieSocket server) secret - syncRoom server room) - (\playerId -> do - sink . Aeson.encode $ Welcome rid - syncRoom server room - cards <- fmap (^. gameCards) . atomically . STM.readTVar $ - roomGame room - sink . Aeson.encode $ SyncCards cards - loop conn rid playerId) - where - loop conn rid playerId = forever $ do - msg <- WS.receiveData conn - case Aeson.decode msg of - Just cm -> do - room <- getOrCreateRoom server rid -- TODO: only get? - atomically . STM.modifyTVar' (roomGame room) $ - processClientMessage playerId cm - syncRoom server room - Nothing -> do - serverLogger server $ "Could not decode client message: " <> - FL.toLogStr (show msg) - -splitPath :: T.Text -> [T.Text] -splitPath = filter (not . T.null) . T.split (== '/') - -baseUrl :: [T.Text] -> Wai.Middleware -baseUrl prefix application = \req -> - case L.stripPrefix prefix (Wai.pathInfo req) of - Nothing -> application req - Just path -> application req - { Wai.pathInfo = path - , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) . - B.stripPrefix bs $ Wai.rawPathInfo req - } - where - bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix - -main :: IO () -main = do - host <- fromString <$> getEnv "CAFP_HOSTNAME" - port <- read <$> getEnv "CAFP_PORT" - base <- splitPath . T.pack <$> getEnv "CAFP_BASE" - let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings - 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 -- cgit v1.2.3