hannah/src/Session.hs

{-# 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}