Adapt the automaton to the latest protocol changes in APILanguage; clean unused code (imports, declarations, various warnings)

src/AI.hs

@@ -6,14 +6,13 @@ module AI (
 import Data.List (sortOn)
 import Data.Map ((!), delete, findMin)
 import Data.Ord (Down(..))
-import Data.Set (Set, member)
-import qualified Data.Set as Set (fromList, intersection, unions)
+import Data.Set (member)
+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(..), Score)
+import Hanafuda.KoiKoi (Move(..), PlayerID, Step(..))
 import Hanafuda.Message (PublicGame(..), PublicState(..), PublicPlayer)
 
 move :: PlayerID -> PublicGame -> Move
@@ -32,9 +31,11 @@ move me (PublicGame {playerHand, public = PublicState {step = ToPlay, month, pla
 move me (PublicGame {public = PublicState {step = Turned card, month, players, river}}) =
   Choose . bestFor month (players ! me) . cardsOfPack $ sameMonth card river
 
-move me (PublicGame {playerHand, public = PublicState {step = Scored}}) =
+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 =
   if size (sameMonth card river) == 1

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.Text (Text)
-import Control.Concurrent (threadDelay)
+import Data.Map ((!))
+import qualified Data.Map as Map (delete, empty, member)
 import Control.Monad.Reader (ReaderT, ask)
-import Control.Monad.State (StateT)
 import Control.Monad.Trans (lift)
-import Hanafuda.KoiKoi (PlayerID, Step(..))
-import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame(..), PublicState(..))
+import Hanafuda.KoiKoi (Step(..))
+import Hanafuda.Message (T(..), FromClient(..))
+import qualified Hanafuda.Message as Message (
+    T(..), FromClient, PublicGame(..), PublicState(..)
+  )
 import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
-import System.Exit (exitSuccess)
-
-data State =
-    Initial
-  | Connected {
-        key :: PlayerID
-    }
-  | LoggedIn {
-        key :: PlayerID
-      , name :: Text
-    }
-  | Playing {
-        key :: PlayerID
-      , name :: Text
-      , against :: PlayerID
-    }
-  deriving Show
+import Session (State(..), initial, store)
 
 type App a = ReaderT Connection IO a
 
@@ -61,54 +46,58 @@ receive = do
 debug :: ByteString -> App ()
 debug message = lift $ putStrLn message
 
-answer :: Message.T -> State -> App State
-answer welcome@(Message.Welcome {}) Initial = do
-  send $ Message.LogIn {Message.name = "Hannah"}
-  return $ Connected {key = Message.key welcome}
+answer :: State -> Message.T -> App State
 
+answer New (Welcome {key}) = do
+  lift $ Session.store 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 (Message.Relay {Message.from, Message.message = Message.Invitation {}}) (LoggedIn {key, name}) = do
-  send $ Message.Answer {Message.accept = True, Message.to = from}
-  return $ Playing {key, name, against = from}
-
-answer (Message.Relay {Message.from, Message.message = Message.Invitation {}}) state = do
-  send $ Message.Answer {Message.accept = False, Message.to = from}
-  return state
-
-answer message@(Message.Game {Message.logs}) state@(Playing {key, name}) = do
-  case Message.step $ Message.public game of
-    Over -> send Message.Quit >> return (LoggedIn {key, name})
-    _ ->
-      if Message.playing (Message.public game) == key
-      then
-        send (Message.Play {Message.move = AI.move key game, Message.onGame = game})
+answer state@(Connected {games}) (Relay {from, message = Invitation {}}) =
+  -- policy : one game per player only
+  send (Answer {accept = not $ Map.member from games, to = from})
   >> return state
+
+answer state@(Connected {playerID, games}) message@(Game {}) = do
+  case Message.step $ Message.public game of
+    Over ->
+      let opponentID = Message.nextPlayer (Message.public game) ! playerID in
+      return $ state {games = Map.delete opponentID games}
+    _ ->
+      if Message.playing (Message.public game) == playerID
+      then
+        send (Play {move = AI.move playerID game, onGame = game}) >> return state
       else return state
   where
     game = Message.state message
 
-answer (Message.Relay {Message.from, Message.message = Message.LogOut}) (Playing {key, name, against})
-  | from == against = send Message.Quit >> return (LoggedIn {key, name})
+answer state Pong = ping >> return state
 
-answer (Message.Relay {}) state = return state
-
-answer Message.Pong state = ping >> return state
-
-answer (Message.Error {Message.error}) state = do
+answer state (Error {error}) = do
   debug $ "Received error from server : " `append` pack error
   return state
 
-answer message state = do
+{-
+ - Ignore
+ -}
+answer state@(Connected {}) (Okaeri {}) = 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))
@@ -116,8 +105,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
-      newMessage <- receive
-      answer newMessage state >>= loop
+    loop state = receive >>= answer state >>= loop

src/Config.hs

@@ -6,10 +6,10 @@ module Config (
   ) where
 
 host :: String
-host = "koikoi.menf.in"
+host = "koikoi.local"
 
 libDir :: FilePath
-libDir = "/var/lib/hannah"
+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)