aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-08-13 19:19:22 +0200
committerJasper Van der Jeugt2020-08-13 19:19:22 +0200
commit8d5c0405565ad4afd976efd1262b3224efd6ee2f (patch)
tree8d24ecb97212d54943d104ed95f1fda4dea7c1fd /server/lib/Cafp/Main
parenta39fe7ff759a552c64a060f0d98a0d4e8a577b01 (diff)
cafp -> uplcg
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs22
-rw-r--r--server/lib/Cafp/Main/Server.hs214
2 files changed, 0 insertions, 236 deletions
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
deleted file mode 100644
index ccf19e8..0000000
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Cafp.Main.GenerateElmTypes
- ( main
- ) where
-
-import Cafp.Messages
-import Data.Proxy
-import Elm.Module
-
-main :: IO ()
-main = putStrLn $ makeElmModule "Messages"
- [ DefineElm (Proxy :: Proxy BlackCard)
- , DefineElm (Proxy :: Proxy WhiteCard)
- , DefineElm (Proxy :: Proxy Cards)
- , DefineElm (Proxy :: Proxy PlayerView)
- , DefineElm (Proxy :: Proxy VotedView)
- , DefineElm (Proxy :: Proxy TableView)
- , DefineElm (Proxy :: Proxy GameView)
- , DefineElm (Proxy :: Proxy ServerMessage)
- , DefineElm (Proxy :: Proxy ClientMessage)
- ]
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