Implement games memory for Hannah

This commit is contained in:
Tissevert 2020-01-31 09:15:19 +01:00
parent 22c15bd30e
commit bf4daa5a77
2 changed files with 73 additions and 26 deletions

View File

@ -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}

View File

@ -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}