84 lines
2.5 KiB
Haskell
84 lines
2.5 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Session (
|
|
State(..)
|
|
, deleteGame
|
|
, initial
|
|
, 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 (delete, empty, insert)
|
|
import Hanafuda.KoiKoi (GameID, PlayerID)
|
|
import qualified Hanafuda.Message as Message (PublicGame)
|
|
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 :: 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
|
|
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
|
|
|
|
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}
|