cafp -> uplcg

5 files changed, 741 insertions, 0 deletions

diff --git a/server/lib/Uplcg/CookieSocket.hs b/server/lib/Uplcg/CookieSocket.hs
new file mode 100644
index 0000000..7efb8b2
--- /dev/null
+++ b/server/lib/Uplcg/CookieSocket.hs
@@ -0,0 +1,86 @@
+-- | Allows websockets to reconnect and recover state by storing a cookie client
+-- side.
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+module Uplcg.CookieSocket
+    ( Handle
+    , withHandle
+    , CookieName
+    , acceptRequest
+    , persist
+    ) where
+
+import           Control.Concurrent       (threadDelay)
+import qualified Control.Concurrent.Async as Async
+import           Control.Concurrent.MVar  (MVar)
+import qualified Control.Concurrent.MVar  as MVar
+import           Control.Monad            (forever, guard)
+import           Data.Hashable            (Hashable)
+import           Data.HashMap.Strict      (HashMap)
+import qualified Data.HashMap.Strict      as HMS
+import           Data.Maybe               (listToMaybe)
+import qualified Data.Text                as T
+import qualified Data.Text.Encoding       as T
+import qualified Data.Time                as Time
+import           Data.UUID                (UUID)
+import qualified Data.UUID                as UUID
+import qualified Data.UUID.V4             as UUID.V4
+import qualified Network.WebSockets       as WS
+
+type CookieName = T.Text
+
+newtype Secret = Secret UUID deriving (Eq, Hashable)
+
+data Handle v = Handle
+    { hMinutes :: Int  -- Minutes after which expiry happens
+    , hStore   :: MVar (HashMap Secret (Time.UTCTime, v))
+    }
+
+withHandle :: Int -> (Handle v -> IO a) -> IO a
+withHandle minutes f = do
+    store <- MVar.newMVar HMS.empty
+    Async.withAsync (reaper store) $ \_ -> f $ Handle minutes store
+  where
+    -- This is really shitty and we should probably do something with
+    -- monotonic time.
+    reaper store = forever $ do
+        threadDelay $ minutes * 60 * 1000 * 1000
+        now <- Time.getCurrentTime
+        MVar.modifyMVar_ store $ pure . HMS.filter ((> now) . fst)
+
+parseCookie :: CookieName -> WS.PendingConnection -> Maybe T.Text
+parseCookie name pc = listToMaybe $ do
+    (header, values) <- WS.requestHeaders $ WS.pendingRequest pc
+    guard $ header == "Cookie"
+    part <- T.split (== ';') $ T.decodeUtf8 values
+    let (key, val) = T.break (== '=') part
+    guard $ T.strip key == name
+    guard $ "=" `T.isPrefixOf` val
+    pure . T.strip $ T.drop 1 val
+
+makeCookie :: CookieName -> T.Text -> WS.Headers
+makeCookie name val = [("Set-Cookie", T.encodeUtf8 $ name <> "=" <> val)]
+
+acceptRequest
+    :: Handle a -> CookieName -> WS.PendingConnection
+    -> IO (WS.Connection, Secret, Maybe a)
+acceptRequest h name pc = case parseCookie name pc >>= UUID.fromText of
+    Just uuid -> do
+        conn <- WS.acceptRequest pc
+        store <- MVar.readMVar (hStore h)
+        pure (conn, Secret uuid, snd <$> HMS.lookup (Secret uuid) store)
+    Nothing -> do
+        uuid <- UUID.V4.nextRandom
+        conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest
+            { WS.acceptHeaders =
+                makeCookie name (UUID.toText uuid) <>
+                WS.acceptHeaders WS.defaultAcceptRequest
+            }
+        pure (conn, Secret uuid, Nothing)
+
+persist :: Handle a -> Secret -> a -> IO ()
+persist h key x = MVar.modifyMVar_ (hStore h) $ \store -> do
+    expiry <- Time.addUTCTime diffTime <$> Time.getCurrentTime
+    pure $ HMS.insert key (expiry, x) store
+  where
+    diffTime = fromIntegral (60 * hMinutes h)
diff --git a/server/lib/Uplcg/Game.hs b/server/lib/Uplcg/Game.hs
new file mode 100644
index 0000000..02e40cb
--- /dev/null
+++ b/server/lib/Uplcg/Game.hs
@@ -0,0 +1,332 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Uplcg.Game
+    ( PlayerId
+    , Table (..)
+    , Player (..)
+    , Game (..)
+    , gameLog, gameCards, gamePlayers, gameNextPlayerId
+
+    , newGame
+    , joinGame
+    , leaveGame
+
+    , processClientMessage
+
+    , gameViewForPlayer
+    ) where
+
+import           Uplcg.Messages
+import           Control.Lens                 (Lens', at, iall, ifor_, imap, ix,
+                                               orOf, to, (%%=), (%=), (%~), (&),
+                                               (+=), (.=), (.~), (^.), (^..),
+                                               (^?), _1, _2, _3)
+import           Control.Lens.TH              (makeLenses, makePrisms)
+import           Control.Monad                (guard)
+import           Control.Monad.State          (State, execState, modify,
+                                               runState, state)
+import           Data.Bifunctor               (first)
+import           Data.Foldable                (for_)
+import qualified Data.HashMap.Strict          as HMS
+import           Data.List                    (sort)
+import           Data.Maybe                   (fromMaybe)
+import           Data.Ord                     (Down (..), comparing)
+import           Data.Text                    (Text)
+import qualified Data.Text                    as T
+import qualified Data.Vector                  as V
+import qualified Data.Vector.Algorithms.Merge as V
+import           Data.Vector.Instances        ()
+import           System.Random                (StdGen)
+import           VectorShuffling.Immutable    (shuffle)
+
+type PlayerId = Int
+
+type Proposal = V.Vector WhiteCard
+
+data Table
+    = TableProposing
+        !BlackCard
+        !(HMS.HashMap PlayerId Proposal)
+    | TableVoting
+        !BlackCard
+        !(V.Vector (Proposal, [PlayerId]))
+        !(HMS.HashMap PlayerId Int)
+    | TableTally
+        !BlackCard
+        !(V.Vector VotedView)
+    deriving (Show)
+
+data Player = Player
+    { _playerId     :: !PlayerId
+    , _playerName   :: !Text
+    , _playerHand   :: !(V.Vector WhiteCard)
+    , _playerAdmin  :: !Bool
+    , _playerPoints :: !Int
+    } deriving (Show)
+
+data Game = Game
+    { _gameCards        :: !Cards
+    , _gameSeed         :: !StdGen
+    , _gameLog          :: ![Text]
+    , _gameBlack        :: ![BlackCard]
+    , _gameWhite        :: ![WhiteCard]
+    , _gamePlayers      :: !(HMS.HashMap PlayerId Player)
+    , _gameTable        :: !Table
+    , _gameNextPlayerId :: !Int
+    } deriving (Show)
+
+makePrisms ''Table
+makeLenses ''Player
+makeLenses ''Game
+
+popCard
+    :: (Cards -> V.Vector t) -> (Int -> c) -> Lens' Game [c]
+    -> State Game c
+popCard getDeck mk queue = state $ \game -> case game ^. queue of
+    (x : xs) -> (x, game & queue .~ xs)
+    []        ->
+        let deck = game ^. gameCards . to getDeck
+            idxs = V.imap (\i _ -> mk i) deck
+            (cs, seed) = first V.toList $ shuffle idxs (game ^. gameSeed) in
+        case cs of
+            []     -> error "popCard: Cards are empty"
+            x : xs -> (x, game & queue .~ xs & gameSeed .~ seed)
+
+popBlackCard :: State Game BlackCard
+popBlackCard = popCard cardsBlack BlackCard gameBlack
+
+popWhiteCard :: State Game WhiteCard
+popWhiteCard = popCard cardsWhite WhiteCard gameWhite
+
+newGame :: Cards -> StdGen -> Game
+newGame cards gen = flip execState state0 $ do
+    black <- popBlackCard
+    gameTable .= TableProposing black HMS.empty
+  where
+    state0 = Game
+        { _gameCards        = cards
+        , _gameSeed         = gen
+        , _gameLog          = []
+        , _gameBlack        = []
+        , _gameWhite        = []
+        , _gamePlayers      = HMS.empty
+        , _gameTable        = TableProposing (BlackCard 0) HMS.empty
+        , _gameNextPlayerId = 1
+        }
+
+defaultHandSize :: Int
+defaultHandSize = 8
+
+drawNewWhiteCards :: Game -> Game
+drawNewWhiteCards game = flip execState game $ do
+    ifor_ (game ^. gamePlayers) $ \pid player -> do
+        let num = defaultHandSize - V.length (player ^. playerHand)
+        new <- V.replicateM num popWhiteCard
+        gamePlayers . ix pid . playerHand %= (<> new)
+
+assignAdmin :: Game -> Game
+assignAdmin game
+    -- Admin already assigned.
+    | orOf (gamePlayers . traverse . playerAdmin) game = game
+    -- Assign to first player
+    | (p1 : _) <- sort (game ^. gamePlayers . to HMS.keys) =
+        game & gamePlayers . ix p1 . playerAdmin .~ True
+    -- No players
+    | otherwise = game
+
+joinGame :: Maybe Player -> Game -> (PlayerId, Game)
+joinGame mbPlayer = runState $ do
+    player <- case mbPlayer of
+        Nothing -> do
+            pid <- gameNextPlayerId %%= (\x -> (x, x + 1))
+            let name = "Player " <> T.pack (show pid)
+            hand <- V.replicateM defaultHandSize popWhiteCard
+            pure $ Player pid name hand False 0
+        Just p -> pure $ p & playerAdmin .~ False
+    gamePlayers %= HMS.insert (player ^. playerId) player
+    modify assignAdmin
+    pure $ player ^. playerId
+
+leaveGame :: PlayerId -> Game -> (Maybe Player, Game)
+leaveGame pid game = case game ^? gamePlayers . ix pid of
+    Nothing -> (Nothing, game)
+    Just p  -> (Just p, assignAdmin $ game & gamePlayers %~ HMS.delete pid)
+
+blackCardBlanks :: Cards -> BlackCard -> Int
+blackCardBlanks cards (BlackCard c) =
+    maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c
+
+maximaOn :: Ord o => (a -> o) -> [a] -> [a]
+maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs
+  where
+    go best _         []       = reverse best
+    go best bestScore (x : xs) =
+        let score = f x in
+        case compare score bestScore of
+            LT -> go best bestScore xs
+            EQ -> go (x : best) bestScore xs
+            GT -> go [x] score xs
+
+tallyVotes
+    :: Game
+    -> (V.Vector (Proposal, [PlayerId]))
+    -> (HMS.HashMap PlayerId Int)
+    -> (V.Vector VotedView, [PlayerId])
+tallyVotes game shuffled votes =
+    let counts :: HMS.HashMap Int Int  -- Index, votes received.
+        counts = HMS.fromListWith (+) [(idx, 1) | (_, idx) <- HMS.toList votes]
+        best = map fst . maximaOn snd $ HMS.toList counts in
+    ( byScore $ V.imap (\i (proposal, players) -> VotedView
+        { votedProposal = proposal
+        , votedScore    = fromMaybe 0 $ HMS.lookup i counts
+        , votedWinners  = V.fromList $ do
+            guard $ i `elem` best
+            p <- players
+            game ^.. gamePlayers . ix p . playerName
+        })
+        shuffled
+    , [player | idx <- best, player <- snd $ shuffled V.! idx]
+    )
+  where
+    byScore = V.modify $ V.sortBy . comparing $ Down . votedScore
+
+-- | Create nice messages about the winners in the logs.
+votedMessages :: Cards -> BlackCard -> V.Vector VotedView -> [T.Text]
+votedMessages cards (BlackCard black) voteds = do
+    voted <- V.toList voteds
+    guard $ V.length (votedWinners voted) > 0
+    pure $
+        T.intercalate ", " (V.toList $ votedWinners voted) <> " won with " <>
+        cardsBlack cards V.! black <> " | " <>
+        T.intercalate " / "
+            [ cardsWhite cards V.! i
+            | WhiteCard i <- V.toList $ votedProposal voted
+            ]
+
+stepGame :: Bool -> Game -> Game
+stepGame skip game = case game ^. gameTable of
+    TableProposing black proposals
+        -- Everyone has proposed.
+        | skip || iall (const . (`HMS.member` proposals)) (game ^. gamePlayers) ->
+            let proposalsMap = HMS.fromListWith (++) $ do
+                    (pid, proposal) <- HMS.toList proposals
+                    pure (proposal, [pid])
+                (shuffled, seed) = shuffle
+                    (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in
+            -- There's a recursive call because in some one-player cases we
+            -- skip the voting process entirely.
+            stepGame False $ game
+                & gameSeed .~ seed
+                & gameTable .~ TableVoting black shuffled HMS.empty
+                & gamePlayers %~ imap (\pid player ->
+                    let used = fromMaybe V.empty $ HMS.lookup pid proposals in
+                    player & playerHand %~ V.filter (not . (`V.elem` used)))
+        | otherwise -> game
+
+    TableVoting black shuffled votes
+        -- Everyone has voted.
+        | skip || iall hasVoted (game ^. gamePlayers) ->
+            let (voted, wins) = tallyVotes game shuffled votes in
+            flip execState game $ do
+            for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1
+            gameTable .= TableTally black voted
+            gameLog %= (votedMessages (game ^. gameCards) black voted ++)
+        | otherwise -> game
+      where
+        hasVoted pid _ = HMS.member pid votes ||
+            -- The person cannot vote for anything since all the proposals
+            -- are theirs.  This can happen when the game starts out with a
+            -- single person.
+            V.all (\(_, pids) -> pid `elem` pids) shuffled
+
+    TableTally _ _ -> game
+
+processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
+processClientMessage pid msg game = case msg of
+    ChangeMyName name
+        | T.length name > 32 -> game
+        | otherwise -> game & gamePlayers . ix pid . playerName .~ name
+
+    ProposeWhiteCards cs
+        -- Bad card(s) proposed, i.e. not in hand of player.
+        | any (not . (`elem` hand)) cs -> game
+        -- Proposal already made.
+        | Just _ <- game ^? gameTable . _TableProposing . _2 . ix pid -> game
+        -- Not enough cards submitted.
+        | Just b <- game ^? gameTable . _TableProposing . _1
+        , blackCardBlanks (game ^. gameCards) b /= length cs -> game
+        -- All good.
+        | otherwise -> stepGame False $
+            game & gameTable . _TableProposing . _2 . at pid .~ Just cs
+
+    SubmitVote i -> case game ^. gameTable of
+        TableProposing _ _ -> game
+        TableTally _ _ -> game
+        TableVoting _ shuffled votes
+            -- Vote out of bounds.
+            | i < 0 || i >= V.length shuffled -> game
+            -- Already voted.
+            | pid `HMS.member` votes -> game
+            -- Can't vote for self.
+            | pid `elem` snd (shuffled V.! i) -> game
+            -- Ok vote.
+            | otherwise -> stepGame False $ game
+                & gameTable . _TableVoting . _3 . at pid .~ Just i
+
+    AdminConfirmTally
+        | TableTally _ _ <- game ^. gameTable, admin ->
+            flip execState game $ do
+            black <- popBlackCard
+            gameTable .= TableProposing black HMS.empty
+            modify drawNewWhiteCards
+        | otherwise -> game
+
+    AdminSkipProposals
+        | TableProposing _ _ <- game ^. gameTable, admin -> stepGame True $
+            game & gameLog %~ ("Admin skipped proposals" :)
+        | otherwise -> game
+
+    AdminSkipVotes
+        | TableVoting _ _ _ <- game ^. gameTable, admin -> stepGame True $
+            game & gameLog %~ ("Admin skipped votes" :)
+        | otherwise -> game
+  where
+    hand  = game ^.. gamePlayers . ix pid . playerHand . traverse
+    admin = fromMaybe False $ game ^? gamePlayers . ix pid . playerAdmin
+
+gameViewForPlayer :: PlayerId -> Game -> GameView
+gameViewForPlayer self game =
+    let playerView pid player = PlayerView
+            { playerViewName = player ^. playerName
+            , playerViewAdmin = player ^. playerAdmin
+            , playerViewReady = case game ^. gameTable of
+                TableProposing _ proposals -> HMS.member pid proposals
+                TableVoting _ _ votes      -> HMS.member pid votes
+                TableTally _ _             -> False
+            , playerViewPoints = player ^. playerPoints
+            }
+
+        table = case game ^. gameTable of
+            TableProposing black proposals ->
+                Proposing black . fromMaybe V.empty $ HMS.lookup self proposals
+            TableVoting black shuffled votes -> Voting
+                black
+                (fst <$> shuffled)
+                (V.findIndex ((self `elem`) . snd) shuffled)
+                (HMS.lookup self votes)
+            TableTally black voted -> Tally black voted in
+    GameView
+        { gameViewPlayers = V.fromList . map snd . HMS.toList
+            . HMS.delete self . imap playerView $ game ^. gamePlayers
+        , gameViewMe      = maybe dummy (playerView self) $
+            game ^? gamePlayers . ix self
+        , gameViewTable   = table
+        , gameViewHand    = fromMaybe V.empty $
+            game ^? gamePlayers . ix self . playerHand
+        }
+
+  where
+    dummy = PlayerView "" False False 0
diff --git a/server/lib/Uplcg/Main/GenerateElmTypes.hs b/server/lib/Uplcg/Main/GenerateElmTypes.hs
new file mode 100644
index 0000000..bc2481c
--- /dev/null
+++ b/server/lib/Uplcg/Main/GenerateElmTypes.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Uplcg.Main.GenerateElmTypes
+    ( main
+    ) where
+
+import           Uplcg.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/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
new file mode 100644
index 0000000..a2914ab
--- /dev/null
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -0,0 +1,214 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Uplcg.Main.Server
+    ( main
+    ) where
+
+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 Uplcg.CookieSocket             as CookieSocket
+import           Uplcg.Game
+import           Uplcg.Messages
+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 "UPLCG_HOSTNAME"
+    port <- read <$> getEnv "UPLCG_PORT"
+    base <- splitPath . T.pack <$> getEnv "UPLCG_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
diff --git a/server/lib/Uplcg/Messages.hs b/server/lib/Uplcg/Messages.hs
new file mode 100644
index 0000000..b1627e9
--- /dev/null
+++ b/server/lib/Uplcg/Messages.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Uplcg.Messages
+    ( BlackCard (..)
+    , WhiteCard (..)
+    , Cards (..)
+    , PlayerView (..)
+    , VotedView (..)
+    , TableView (..)
+    , GameView (..)
+    , ServerMessage (..)
+    , ClientMessage (..)
+    ) where
+
+import           Data.Hashable (Hashable)
+import           Data.Text     (Text)
+import           Data.Vector   (Vector)
+import           Elm.Derive
+import           GHC.Generics  (Generic)
+
+data BlackCard = BlackCard Int deriving (Eq, Generic, Show)
+
+instance Hashable BlackCard
+
+data WhiteCard = WhiteCard Int deriving (Eq, Generic, Show)
+
+instance Hashable WhiteCard
+
+data Cards = Cards
+    { cardsBlack :: !(Vector Text)
+    , cardsWhite :: !(Vector Text)
+    } deriving (Show)
+
+data PlayerView = PlayerView
+    { playerViewName   :: !Text
+    , playerViewAdmin  :: !Bool
+    , playerViewReady  :: !Bool
+    , playerViewPoints :: !Int
+    } deriving (Show)
+
+data VotedView = VotedView
+    { votedProposal :: !(Vector WhiteCard)
+    , votedScore    :: !Int
+    , votedWinners  :: !(Vector Text)
+    } deriving (Show)
+
+data TableView
+    = Proposing !BlackCard !(Vector WhiteCard)
+    | Voting
+        !BlackCard
+        !(Vector (Vector WhiteCard))  -- ^ Proposals to vote for
+        !(Maybe Int)                  -- ^ My proposal
+        !(Maybe Int)                  -- ^ My vote
+    | Tally !BlackCard !(Vector VotedView)
+    deriving (Show)
+
+data GameView = GameView
+    { gameViewPlayers :: !(Vector PlayerView)
+    , gameViewMe      :: !PlayerView
+    , gameViewTable   :: !TableView
+    , gameViewHand    :: !(Vector WhiteCard)
+    } deriving (Show)
+
+data ServerMessage
+    = Welcome !Text
+    | SyncCards !Cards
+    | SyncGameView !GameView
+    deriving (Show)
+
+data ClientMessage
+    = ChangeMyName !Text
+    | ProposeWhiteCards !(Vector WhiteCard)
+    | SubmitVote !Int
+    | AdminSkipProposals
+    | AdminSkipVotes
+    | AdminConfirmTally
+    deriving (Show)
+
+deriveBoth defaultOptions ''BlackCard
+deriveBoth defaultOptions ''WhiteCard
+deriveBoth (defaultOptionsDropLower 5) ''Cards
+deriveBoth (defaultOptionsDropLower 10) ''PlayerView
+deriveBoth (defaultOptionsDropLower 5) ''VotedView
+deriveBoth defaultOptions ''TableView
+deriveBoth (defaultOptionsDropLower 8) ''GameView
+deriveBoth defaultOptions ''ServerMessage
+deriveBoth defaultOptions ''ClientMessage