cafp -> uplcg

5 files changed, 0 insertions, 741 deletions

diff --git a/server/lib/Cafp/CookieSocket.hs b/server/lib/Cafp/CookieSocket.hs
deleted file mode 100644
index 5770a3b..0000000
--- a/server/lib/Cafp/CookieSocket.hs
+++ /dev/null
@@ -1,86 +0,0 @@
--- | Allows websockets to reconnect and recover state by storing a cookie client
--- side.
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings          #-}
-module Cafp.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/Cafp/Game.hs b/server/lib/Cafp/Game.hs
deleted file mode 100644
index 9ed3cc1..0000000
--- a/server/lib/Cafp/Game.hs
+++ /dev/null
@@ -1,332 +0,0 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types        #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-module Cafp.Game
-    ( PlayerId
-    , Table (..)
-    , Player (..)
-    , Game (..)
-    , gameLog, gameCards, gamePlayers, gameNextPlayerId
-
-    , newGame
-    , joinGame
-    , leaveGame
-
-    , processClientMessage
-
-    , gameViewForPlayer
-    ) where
-
-import           Cafp.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/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
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
deleted file mode 100644
index 5066447..0000000
--- a/server/lib/Cafp/Messages.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{-# LANGUAGE DeriveGeneric   #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Cafp.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