diff --git a/src/Automaton.hs b/src/Automaton.hs index 9809e68..142fec3 100644 --- a/src/Automaton.hs +++ b/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 -> - let xGameID = Message.gameID . Message.coordinates $ Message.public game in - return $ state {games = Map.delete xGameID games} - _ -> + Over -> deleteGame gameID state + _ -> do if Message.playing (Message.public game) == playerID then - send (Play {move = AI.move playerID game, onGame = game}) >> return state - else return state + send (Play {move = AI.move playerID game, onGame = game}) + 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} diff --git a/src/Session.hs b/src/Session.hs index 683c98e..430bf10 100644 --- a/src/Session.hs +++ b/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 - then do - playerID <- read <$> readFile stateFile - return $ Connected {playerID, games = Map.empty} - else return New + runExceptT (if fileExists then loadFile else stateFileMissing) + >>= either (warn New) return + where + stateFileMissing = throwError $ "State file missing : " ++ stateFile + loadFile = do + playerID <- ExceptT $ readEither <$> readFile stateFile + Connected playerID <$> liftIO loadGames -store :: PlayerID -> IO () -store = writeFile stateFile . show +storeID :: Show a => a -> IO () +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}