Implement games memory for Hannah

src/Automaton.hs

@@ -10,7 +10,7 @@ import Data.Aeson (encode, eitherDecode')
 import Data.ByteString.Lazy.Char8 (ByteString, append, pack, putStrLn)
 import qualified Data.ByteString.Lazy.Char8 as ByteString (concat)
 import Data.Map ((!))
-import qualified Data.Map as Map (delete, empty, lookup)
+import qualified Data.Map as Map (empty, filter, lookup)
 import Control.Monad.Reader (ReaderT, ask)
 import Control.Monad.Trans (lift)
 import Hanafuda.KoiKoi (Step(..))
@@ -20,7 +20,7 @@ import qualified Hanafuda.Message as Message (
   )
 import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
-import Session (State(..), initial, store)
+import Session (State(..), deleteGame, initial, storeID, storeGame)
 
 type App a = ReaderT Connection IO a
 
@@ -49,30 +49,25 @@ debug message = lift $ putStrLn message
 answer :: State -> Message.T -> App State
 
 answer New (Welcome {key}) = do
-  lift $ Session.store key
+  lift $ Session.storeID key
   lift $ putStrLn "Stored"
   return $ Connected {playerID = key, games = Map.empty}
 
-{-
-answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key})
-  | from == key = return $ LoggedIn {key, name}
--}
-
 answer state@(Connected {}) (Relay {from, message = Invitation {}}) =
   send (Answer {accept = True, to = from}) >> return state
 
-answer state@(Connected {playerID, games}) message@(Game {}) = do
+answer state@(Connected {playerID}) message@(Game {}) = do
   case Message.step $ Message.public game of
-    Over ->
+    Over -> deleteGame gameID state
-      let xGameID = Message.gameID . Message.coordinates $ Message.public game in
+    _ -> do
-      return $ state {games = Map.delete xGameID games}
-    _ ->
       if Message.playing (Message.public game) == playerID
       then
-        send (Play {move = AI.move playerID game, onGame = game}) >> return state
+        send (Play {move = AI.move playerID game, onGame = game})
-      else return state
+      else return ()
+      storeGame gameID game state
   where
     game = Message.state message
+    gameID = Message.gameID . Message.coordinates $ Message.public game
 
 answer state Pong = ping >> return state
 
@@ -80,6 +75,13 @@ answer state (Error {error}) = do
   debug $ "Received error from server : " `append` pack error
   return state
 
+answer state@(Connected {playerID, games}) (LogIn {from}) =
+  (mapM_ sync . Map.filter isAgainst $ Message.public <$> games) >> return state
+  where
+    isAgainst publicState = Message.nextPlayer publicState ! playerID == from
+    sync publicState =
+      send $ Sync {latestKnown = Message.coordinates $ publicState, to = from}
+
 answer state@(Connected {games}) (Relay {from, message = Sync {latestKnown}}) =
   case Map.lookup gameID games of
     Nothing -> send $ Yield {onGameID = gameID, to = from}

src/Session.hs

@@ -1,38 +1,83 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Session (
       State(..)
+    , deleteGame
     , initial
-    , store
+    , storeID
+    , storeGame
   ) where
 
 import Config (libDir)
+import Control.Monad (foldM)
+import Control.Monad.Except (MonadError(..), ExceptT(..), runExceptT)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Aeson (encodeFile, eitherDecodeFileStrict')
 import Data.Map (Map)
-import qualified Data.Map as Map (empty)
+import qualified Data.Map as Map (delete, empty, insert)
 import Hanafuda.KoiKoi (GameID, PlayerID)
 import qualified Hanafuda.Message as Message (PublicGame)
-import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.Directory (
+    createDirectoryIfMissing, doesFileExist, listDirectory, removeFile
+  )
 import System.FilePath ((</>))
+import System.IO (stderr, hPutStrLn)
+import Text.Read (readEither)
 
+type Games = Map GameID Message.PublicGame
 data State =
     New
   | Connected {
         playerID :: PlayerID
-      , games :: Map GameID Message.PublicGame
+      , games :: Games
     }
   deriving Show
 
 stateFile :: FilePath
 stateFile = libDir </> "state"
 
+gamesDir :: FilePath
+gamesDir = libDir </> "games"
+
+warn :: a -> String -> IO a
+warn defaultValue errorMessage =
+  hPutStrLn stderr errorMessage >> return defaultValue
+
 initial :: IO State
 initial = do
   createDirectoryIfMissing True libDir
   fileExists <- doesFileExist stateFile
-  if fileExists
+  runExceptT (if fileExists then loadFile else stateFileMissing)
-  then do
+  >>= either (warn New) return
-    playerID <- read <$> readFile stateFile
+  where
-    return $ Connected {playerID, games = Map.empty}
+    stateFileMissing = throwError $ "State file missing : " ++ stateFile
-  else return New
+    loadFile = do
+      playerID <- ExceptT $ readEither <$> readFile stateFile
+      Connected playerID <$> liftIO loadGames
 
-store :: PlayerID -> IO ()
+storeID :: Show a => a -> IO ()
-store = writeFile stateFile . show
+storeID = writeFile stateFile . show
+
+loadGames :: IO Games
+loadGames = do
+  createDirectoryIfMissing True gamesDir
+  listDirectory gamesDir >>= foldM loadGame Map.empty
+
+loadGame :: Games -> FilePath -> IO Games
+loadGame tmpGames fileName =
+  runExceptT exceptLoad >>= either (warn tmpGames) return
+  where
+    exceptLoad = do
+      gameID <- ExceptT . return $ readEither fileName
+      publicGame <- ExceptT . eitherDecodeFileStrict' $ gamesDir </> fileName
+      return $ Map.insert gameID publicGame tmpGames
+
+storeGame :: MonadIO m => GameID -> Message.PublicGame -> State -> m State
+storeGame gameID publicGame state = do
+  liftIO $ createDirectoryIfMissing True gamesDir
+           >> encodeFile (gamesDir </> show gameID) publicGame
+  return $ state {games = Map.insert gameID publicGame $ games state}
+
+deleteGame :: MonadIO m => GameID -> State -> m State
+deleteGame gameID state = do
+  liftIO $ removeFile (gamesDir </> show gameID)
+  return $ state {games = Map.delete gameID $ games state}