Implement games memory for Hannah

hannah.cabal

@@ -21,15 +21,19 @@ executable hannah
   other-modules:       AI
                      , Automaton
                      , Config
+                     , Session
   -- other-extensions:    
   build-depends:       aeson
                      , base >=4.9 && <4.13
                      , bytestring
                      , containers
+                     , directory
+                     , filepath
                      , hanafuda
-                     , hanafuda-APILanguage
+                     , hanafuda-protocol
                      , mtl
                      , text
                      , websockets
   hs-source-dirs:      src
+  ghc-options:         -Wall
   default-language:    Haskell2010

src/AI.hs

@@ -4,34 +4,41 @@ module AI (
   ) where
 
 import Data.List (sortOn)
-import Data.Map ((!))
+import Data.Map ((!), delete, findMin)
 import Data.Ord (Down(..))
-import Data.Set (Set, member)
+import Data.Set (member)
-import qualified Data.Set as Set (fromList, intersection, unions)
+import qualified Data.Set as Set (fromList)
 import Hanafuda (
       Card(..), Flower(..), Pack
     , cardsOf, cardsOfPack, contains, empty,flower, packOfCards, sameMonth, size, union
   )
-import Hanafuda.Player (Player(..), Players(..))
+import Hanafuda.KoiKoi (Move(..), PlayerID, Step(..))
-import Hanafuda.KoiKoi (GameBlueprint(..), Move(..), PlayerID, Step(..), Score)
+import Hanafuda.Message (PublicGame(..), PublicState(..), PublicPlayer)
-import Hanafuda.Message (PublicGame)
+import qualified Hanafuda.Message as Message (Coordinates(..))
 
 move :: PlayerID -> PublicGame -> Move
 
-move me (Game {step = ToPlay, month, players = Players p, river}) =
+move me (PublicGame {playerHand, public = PublicState {coordinates, step = ToPlay, players, river}}) =
-  case getAvailableCards myHand (cardsOfPack river) of
+  case getAvailableCards hand (cardsOfPack river) of
-    [] -> Play $ worstFor month (p ! (nextPlayer $ p ! me)) myHand
+    [] -> Play $ worstFor month opponent hand
     available ->
-      let riverCard = bestFor month (p ! me) available in
+      let riverCard = bestFor month (players ! me) available in
-      let matchingCards = cardsOfPack . sameMonth riverCard . hand $ p ! me in
+      let matchingCards = cardsOfPack . sameMonth riverCard $ playerHand in
-      capture (bestFor month (p ! me) matchingCards) riverCard river
+      capture (bestFor month (players ! me) matchingCards) riverCard river
   where
-    myHand = cardsOfPack . hand $ p ! me
+    month = Message.month $ coordinates
+    hand = cardsOfPack playerHand
+    opponent = snd . findMin $ delete me players
 
-move me (Game {step = Turned card, month, players = Players p, river}) =
+move me (PublicGame {public = PublicState {coordinates, step = Turned card, players, river}}) =
-  Choose . bestFor month (p ! me) . cardsOfPack $ sameMonth card river
+  Choose . bestFor month (players ! me) . cardsOfPack $ sameMonth card river
+  where
+    month = Message.month $ coordinates
 
-move me (Game {players = Players p}) = KoiKoi $ hand (p ! me) /= empty
+move _ (PublicGame {playerHand, public = PublicState {step = Scored}}) =
+  KoiKoi $ playerHand /= empty
+
+move _ _ = error "Nothing to play on ended game"
 
 capture :: Card -> Card -> Pack -> Move
 capture card caught river =
@@ -48,13 +55,13 @@ getAvailableCards hand =
 choose :: Ord a => (Card -> a) -> [Card] -> Card
 choose sortCriterion = head . sortOn sortCriterion
 
-bestFor :: Flower -> Player Score -> [Card] -> Card
+bestFor :: Flower -> PublicPlayer -> [Card] -> Card
 bestFor monthFlower player = choose (Down . rank monthFlower player)
 
-worstFor :: Flower -> Player Score -> [Card] -> Card
+worstFor :: Flower -> PublicPlayer -> [Card] -> Card
 worstFor monthFlower player = choose (rank monthFlower player)
 
-rank :: Flower -> Player Score -> Card -> Int
+rank :: Flower -> PublicPlayer -> Card -> Int
 rank monthFlower _ card
   | isTrueLight card = 5
   | card == RainMan = 2

src/Automaton.hs

@@ -4,38 +4,23 @@ module Automaton (
     start
   ) where
 
-import AI (move)
+import qualified AI (move)
 import Control.Concurrent (forkIO, threadDelay)
 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 (Map, empty)
+import Data.Map ((!))
-import Data.Text (Text)
+import qualified Data.Map as Map (empty, filter, lookup)
-import Control.Concurrent (threadDelay)
 import Control.Monad.Reader (ReaderT, ask)
-import Control.Monad.State (StateT)
 import Control.Monad.Trans (lift)
-import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerID, Step(..))
+import Hanafuda.KoiKoi (Step(..))
-import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame)
+import Hanafuda.Message (FromClient(..), T(..), orderCoordinates)
+import qualified Hanafuda.Message as Message (
+    Coordinates(..), FromClient, PublicGame(..), PublicState(..), T(..)
+  )
 import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
-import System.Exit (exitSuccess)
+import Session (State(..), deleteGame, initial, storeID, storeGame)
-
-data State =
-    Initial
-  | Connected {
-        key :: PlayerID
-    }
-  | LoggedIn {
-        key :: PlayerID
-      , name :: Text
-    }
-  | Playing {
-        key :: PlayerID
-      , name :: Text
-      , against :: PlayerID
-    }
-  deriving Show
 
 type App a = ReaderT Connection IO a
 
@@ -61,50 +46,76 @@ receive = do
 debug :: ByteString -> App ()
 debug message = lift $ putStrLn message
 
-answer :: Message.T -> State -> App State
+answer :: State -> Message.T -> App State
-answer welcome@(Message.Welcome {}) Initial = do
-  send $ Message.LogIn {Message.name = "Hannah"}
-  return $ Connected {key = Message.key welcome}
 
-answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key})
+answer New (Welcome {key}) = do
-  | from == key = return $ LoggedIn {key, name}
+  lift $ Session.storeID key
+  lift $ putStrLn "Stored"
+  return $ Connected {playerID = key, games = Map.empty}
 
-answer (Message.Relay {Message.from, Message.message = Message.Invitation {}}) (LoggedIn {key, name}) = do
+answer state@(Connected {}) (Relay {from, message = Invitation {}}) =
-  send $ Message.Answer {Message.accept = True}
+  send (Answer {accept = True, to = from}) >> return state
-  return $ Playing {key, name, against = from}
 
-answer (Message.Relay {Message.message = Message.Invitation {}}) state = do
+answer state@(Connected {playerID}) message@(Game {}) = do
-  send $ Message.Answer {Message.accept = False}
+  case Message.step $ Message.public game of
-  return state
+    Over -> deleteGame gameID state
-
-answer (Message.Game {Message.game, Message.logs}) state@(Playing {key, name}) = do
-  case step game of
-    Over -> send Message.Quit >> return (LoggedIn {key, name})
     _ -> do
-      if playing game == key
+      if Message.playing (Message.public game) == playerID
-      then send (Message.Play {Message.move = AI.move key game}) >> return state
+      then
-      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 (Message.Relay {Message.from, Message.message = Message.LogOut}) (Playing {key, name, against})
+answer state Pong = ping >> return state
-  | from == against = send Message.Quit >> return (LoggedIn {key, name})
 
-answer (Message.Relay {}) state = return state
+answer state (Error {error}) = do
-
-answer Message.Pong state = ping >> return state
-
-answer (Message.Error {Message.error}) state = do
   debug $ "Received error from server : " `append` pack error
   return state
 
-answer message state = do
+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}
+    Just game ->
+      let latestKnownHere = Message.coordinates $ Message.public game in
+      case orderCoordinates latestKnown latestKnownHere of
+        Just LT -> send $ Share {gameSave = game}
+        Just GT -> send $ Yield {onGameID = gameID, to = from}
+        _ -> return ()
+  >> return state
+  where
+    gameID = Message.gameID latestKnown
+
+answer state@(Connected {games}) (Relay {message = Yield {onGameID}}) =
+  send (Share {gameSave = games ! onGameID}) >> return state
+
+{-
+ - Ignore
+ -}
+answer state@(Connected {}) (Okaeri {}) = return state
+answer state (LogIn {}) = return state
+answer state (LogOut {}) = return state
+answer state (Relay {}) = return state
+
+answer state message = do
   debug $ ByteString.concat [
       "Unexpected message : ", encode message, " in state ", pack $ show state
     ]
   return state
 
+ping :: App ()
 ping = do
   connection <- ask
-  setTimeout (20*s) (sendIO Message.Ping connection)
+  setTimeout (20*s) (sendIO Ping connection)
   where
     setTimeout delay callback =
       const () <$> (lift $ forkIO (threadDelay delay >> callback))
@@ -112,8 +123,12 @@ ping = do
     s = 1000 * ms
 
 start :: App ()
-start = ping >> loop Initial
+start = do
+  ping
+  initialState <- lift Session.initial
+  case initialState of
+    New -> send $ Hello {name = "Hannah"}
+    Connected {playerID} -> send $ Tadaima {myID = playerID, name = "Hannah"}
+  loop initialState
   where
-    loop state = do
+    loop state = receive >>= answer state >>= loop
-      newMessage <- receive
-      answer newMessage state >>= loop

src/Config.hs

@@ -1,11 +1,15 @@
 module Config (
       host
+    , libDir
     , path
     , port
   ) where
 
 host :: String
-host = "koikoi.menf.in"
+host = "koikoi.local"
+
+libDir :: FilePath
+libDir = "/home/alice/Documents/Atelier/hanafuda/hannah/lib"
 
 path :: String
 path = "/play/"

src/Main.hs

@@ -2,7 +2,6 @@ module Main where
 
 import Network.WebSockets (ClientApp, runClient)
 import Control.Monad.Reader (runReaderT)
-import Control.Monad.State (runStateT)
 import Config (host, port, path)
 import Automaton (start)
 

src/Session.hs

@@ -0,0 +1,83 @@
+{-# 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}