Persistence with cookies

4 files changed, 157 insertions, 42 deletions

diff --git a/server/cafp.cabal b/server/cafp.cabal
index 0d6815c..89bd8a7 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -16,6 +16,7 @@ Library
   Hs-source-dirs:   lib
 
   Exposed-modules:
+    Cafp.CookieSocket
     Cafp.Game
     Cafp.Messages
     Cafp.Main.GenerateElmTypes
@@ -23,6 +24,7 @@ Library
 
   Build-depends:
     aeson                >= 1.4  && < 1.5,
+    async                >= 2.2  && < 2.3,
     base                 >= 4.9  && < 5,
     bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
@@ -33,7 +35,9 @@ Library
     scotty               >= 0.11 && < 0.12,
     stm                  >= 2.5  && < 2.6,
     text                 >= 1.2  && < 1.3,
+    time                 >= 1.9  && < 1.10,
     unordered-containers >= 0.2  && < 0.3,
+    uuid                 >= 1.3  && < 1.4,
     vector               >= 0.12 && < 0.13,
     vector-algorithms    >= 0.8  && < 0.9,
     vector-instances     >= 3.4  && < 3.5,
diff --git a/server/lib/Cafp/CookieSocket.hs b/server/lib/Cafp/CookieSocket.hs
new file mode 100644
index 0000000..5770a3b
--- /dev/null
+++ b/server/lib/Cafp/CookieSocket.hs
@@ -0,0 +1,86 @@
+-- | 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
index d4e1b4b..96b24dc 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -21,9 +21,9 @@ module Cafp.Game
 
 import           Cafp.Messages
 import           Control.Lens                 (Lens', at, iall, ifor_, imap, ix,
-                                               orOf, over, to, (%%=), (%=),
-                                               (%~), (&), (+=), (.=), (.~),
-                                               (^.), (^..), (^?), _1, _2, _3)
+                                               orOf, to, (%%=), (%=), (%~), (&),
+                                               (+=), (.=), (.~), (^.), (^..),
+                                               (^?), _1, _2, _3)
 import           Control.Lens.TH              (makeLenses, makePrisms)
 import           Control.Monad                (guard)
 import           Control.Monad.State          (State, execState, modify,
@@ -60,7 +60,8 @@ data Table
     deriving (Show)
 
 data Player = Player
-    { _playerName   :: !Text
+    { _playerId     :: !PlayerId
+    , _playerName   :: !Text
     , _playerHand   :: !(V.Vector WhiteCard)
     , _playerAdmin  :: !Bool
     , _playerPoints :: !Int
@@ -134,17 +135,23 @@ assignAdmin game
     -- No players
     | otherwise = game
 
-joinGame :: Game -> (PlayerId, Game)
-joinGame = runState $ do
-    pid <- gameNextPlayerId %%= (\x -> (x, x + 1))
-    let name = "Player " <> T.pack (show pid)
-    hand <- V.replicateM defaultHandSize popWhiteCard
-    gamePlayers %= HMS.insert pid (Player name hand False 0)
+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 pid
+    pure $ player ^. playerId
 
-leaveGame :: PlayerId -> Game -> Game
-leaveGame pid = assignAdmin . over gamePlayers (HMS.delete pid)
+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) =
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index 4b1bfe7..70e9a00 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -3,6 +3,7 @@ module Cafp.Main.Server
     ( main
     ) where
 
+import qualified Cafp.CookieSocket              as CookieSocket
 import           Cafp.Game
 import           Cafp.Messages
 import           Control.Concurrent.MVar        (MVar)
@@ -15,10 +16,11 @@ 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)
+import           Data.Maybe                     (fromMaybe, isNothing)
 import           Data.String                    (fromString)
 import qualified Data.Text                      as T
 import qualified Data.Text.Encoding             as T
@@ -33,8 +35,8 @@ import qualified System.IO                      as IO
 import           System.Random                  (StdGen, newStdGen)
 import qualified Web.Scotty                     as Scotty
 
-warning :: String -> IO ()
-warning = IO.hPutStrLn IO.stderr
+info :: String -> IO ()
+info = IO.hPutStrLn IO.stderr
 
 type RoomId = T.Text
 
@@ -46,8 +48,9 @@ data Room = Room
     }
 
 data Server = Server
-    { serverCards :: Cards
-    , serverRooms :: MVar (HMS.HashMap RoomId Room)
+    { serverCookieSocket :: CookieSocket.Handle Player
+    , serverCards        :: Cards
+    , serverRooms        :: MVar (HMS.HashMap RoomId Room)
     }
 
 readCards :: IO Cards
@@ -58,14 +61,19 @@ readCards = Cards
     parseCards  = V.fromList . filter (not . T.null) . map dropComment . T.lines
     dropComment = T.strip . fst . T.break (== '#')
 
-newServer :: IO Server
-newServer = Server <$> readCards <*> MVar.newMVar HMS.empty
+withServer :: (Server -> IO a) -> IO a
+withServer f = CookieSocket.withHandle 5 $ \cs ->
+    f =<< Server cs <$> readCards <*> MVar.newMVar HMS.empty
 
 newRoom :: Server -> StdGen -> STM Room
 newRoom server gen = Room
     <$> (STM.newTVar $ newGame (serverCards server) 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
@@ -88,8 +96,8 @@ routePendingConnection :: WS.PendingConnection -> Maybe RoomId
 routePendingConnection pending =
     let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in
     case splitPath path of
-        ["rooms", roomId, "events"] -> Just roomId
-        _                           -> Nothing
+        ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r
+        _                                                     -> Nothing
 
 getOrCreateRoom :: Server -> RoomId -> IO Room
 getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms ->
@@ -97,27 +105,27 @@ getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms ->
         Just room -> pure (rooms, room)
         Nothing   -> do
             gen <- newStdGen
-            warning $ "[" <> T.unpack roomId <> "] Created room"
+            info $ "[" <> T.unpack roomId <> "] Created room"
             room <- atomically $ newRoom server gen
             pure (HMS.insert roomId room rooms, room)
 
 deleteRoom :: Server -> RoomId -> IO ()
 deleteRoom server roomId = do
-    warning $ "[" <> T.unpack roomId <> "] Deleting room"
+    info $ "[" <> T.unpack roomId <> "] Deleting room"
     MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete roomId
 
-joinRoom :: Room -> Sink -> STM PlayerId
-joinRoom room sink = do
-    pid <- STM.stateTVar (roomGame room) joinGame
+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
+leaveRoom :: Room -> PlayerId -> STM (Bool, Maybe Player)
 leaveRoom room pid = do
-    STM.modifyTVar' (roomGame room) $ leaveGame pid
+    player <- STM.stateTVar (roomGame room) $ leaveGame pid
     STM.stateTVar (roomSinks room) $ \sinks ->
         let sinks' = HMS.delete pid sinks in
-        (HMS.null sinks', sinks')
+        ((HMS.null sinks', player), sinks')
 
 syncRoom :: Room -> IO ()
 syncRoom room = do
@@ -126,7 +134,6 @@ syncRoom room = do
         <*> STM.readTVar (roomSinks room)
     for_ (HMS.toList sinks) $ \(pid, sink) -> do
         let view = gameViewForPlayer pid game
-        warning $ "New state: " ++ show view
         sink . Aeson.encode $ SyncGameView view
 
 wsApp :: Server -> WS.ServerApp
@@ -134,13 +141,25 @@ wsApp server pc = case routePendingConnection pc of
     Nothing -> WS.rejectRequest pc "Invalid URL"
     Just roomId -> do
         room <- getOrCreateRoom server roomId
-        conn <- WS.acceptRequest pc
+        (conn, secret, mbRecovered) <-
+            CookieSocket.acceptRequest (serverCookieSocket server) roomId pc
         let sink = WS.sendTextData conn
         WS.withPingThread conn 30 (pure ()) $ bracket
-            (atomically $ joinRoom room sink)
-            (\playerId -> do
-                roomEmpty <- atomically $ leaveRoom room playerId
-                if roomEmpty then deleteRoom server roomId else syncRoom room)
+            (do
+                pid <- atomically $ joinRoom room sink mbRecovered
+                info $ "[" <> T.unpack roomId <> "] Player " <> show 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"
+                if roomEmpty
+                    then deleteRoom server roomId
+                    else do
+                        for_ mbPlayer $ CookieSocket.persist
+                            (serverCookieSocket server) secret
+                        syncRoom room)
             (\playerId -> do
                 sink . Aeson.encode $ Welcome roomId
                 syncRoom room
@@ -153,13 +172,12 @@ wsApp server pc = case routePendingConnection pc of
         msg <- WS.receiveData conn
         case Aeson.decode msg of
             Just cm -> do
-                warning $ "Client: " ++ show cm
                 room <- getOrCreateRoom server roomId  -- TODO: only get?
                 atomically . STM.modifyTVar' (roomGame room) $
                     processClientMessage playerId cm
                 syncRoom room
             Nothing -> do
-                warning $ "Could not decode client message: " ++ show msg
+                info $ "Could not decode client message: " ++ show msg
 
 splitPath :: T.Text -> [T.Text]
 splitPath = filter (not . T.null) . T.split (== '/')
@@ -182,7 +200,7 @@ main = do
     port <- read <$> getEnv "CAFP_PORT"
     base <- splitPath . T.pack <$> getEnv "CAFP_BASE"
     let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings
-    server <- newServer
-    sapp <- scottyApp
-    Warp.runSettings settings $ baseUrl base $
-        WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
+    withServer $ \server -> do
+        sapp <- scottyApp
+        Warp.runSettings settings $ baseUrl base $
+            WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp