Implement basic Automaton

hannah.cabal

@@ -29,6 +29,7 @@ executable hannah
                      , hanafuda
                      , hanafuda-APILanguage
                      , mtl
+                     , text
                      , websockets
   hs-source-dirs:      src
   default-language:    Haskell2010

src/AI.hs

@@ -2,7 +2,8 @@ module AI (
     move
   ) where
 
-import Hanafuda.KoiKoi (Game(..), Move(..), PlayerKey)
+import Hanafuda.KoiKoi (Move(..), PlayerKey)
+import Hanafuda.Message (PublicGame)
 
-move :: PlayerKey -> Game -> Move
+move :: PlayerKey -> PublicGame -> Move
 move = undefined

src/Automaton.hs

@@ -1,21 +1,23 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Automaton (
-      initialState
+    start
-    , start
   ) where
 
 import AI (move)
-import Network.WebSockets (Connection, receiveData, sendTextData)
+import Control.Concurrent (forkIO, threadDelay)
---import Data.Aeson
+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.ByteString.Lazy.Char8 (ByteString, pack, putStrLn)
+import Data.Text (Text)
 import Control.Concurrent (threadDelay)
 import Control.Monad.Reader (ReaderT, ask)
 import Control.Monad.State (StateT)
 import Control.Monad.Trans (lift)
-import Hanafuda.KoiKoi (Game(..), PlayerKey)
+import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerKey)
-import qualified Hanafuda.Message as Message (T(..), FromClient(..), Room)
+import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame, Room)
+import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
 
 data State =
@@ -27,61 +29,88 @@ data State =
   | LoggedIn {
         key :: PlayerKey
       , room :: Message.Room
-      , name :: String
+      , name :: Text
     }
   | Playing {
         key :: PlayerKey
       , room :: Message.Room
-      , name :: String
+      , name :: Text
-      , game :: Game
+      , game :: Message.PublicGame
     }
+  deriving Show
 
 type App a = ReaderT Connection IO a
 
+sendIO :: Message.FromClient -> Connection -> IO ()
+sendIO message connection = do
+  putStrLn $ ">" `append` encoded
+  sendTextData connection encoded
+  where
+    encoded = encode message
+
 send :: Message.FromClient -> App ()
-send = undefined
+send message =
+  ask >>= lift . sendIO message
 
 receive :: App Message.T
-receive = undefined
+receive = do
+  received <- ask >>= lift . receiveData
+  debug $ "<" `append` received
+  case eitherDecode' received of
+    Left errorMessage -> debug (pack errorMessage) >> receive
+    Right message -> return message
 
 debug :: ByteString -> App ()
 debug message = lift $ putStrLn message
 
 answer :: Message.T -> State -> App State
 answer welcome@(Message.Welcome {}) Initial = do
-  send $ Message.LogIn {name = "Hannah"}
+  send $ Message.LogIn {Message.name = "Hannah"}
   return $ Connected {
         key = Message.key welcome
       , room = Message.room welcome
     }
 
 answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key, room})
-  | from == key = return $ LoggedIn {key, room, name = Message.name}
+  | from == key = return $ LoggedIn {key, room, name}
 
 answer (Message.Relay {Message.message = Message.Invitation {}}) state@(LoggedIn {key, room, name}) = do
   send $ Message.Answer {Message.accept = True}
   return $ Playing {key, room, name, game = undefined}
 
-answer (Message.Relay {Message.message = Message.Invitation {}}) _ =
+answer (Message.Relay {Message.message = Message.Invitation {}}) state = do
-  send $ Message.Answer {Message.accept = False} >> return state
+  send $ Message.Answer {Message.accept = False}
+  return state
 
-answer game@(Message.Game {Message.game, Message.logs}) state@(Playing {key}) =
+answer (Message.Game {Message.game, Message.logs}) state@(Playing {key}) = do
-  if playing == key
+  if playing game == key
-  then send $ AI.move key game
+  then send $ Message.Play {Message.move = AI.move key game}
   else return ()
   return $ state {game}
 
---answer Pong =
+answer Message.Pong state = ping >> return state
 
-answer (Message.Error {Message.error}) state =
+answer (Message.Error {Message.error}) state = do
-  debug $ "Received error from server : " <> pack error >> return state
+  debug $ "Received error from server : " `append` pack error
-
-answer message state = do
-  debug $ "Unexpected message : " <> encode message <> " in state " <> show state
   return state
 
+answer message state = do
+  debug $ ByteString.concat [
+      "Unexpected message : ", encode message, " in state ", pack $ show state
+    ]
+  return state
+
+ping = do
+  connection <- ask
+  setTimeout (2*s) (sendIO Message.Ping connection)
+  where
+    setTimeout delay callback =
+      const () <$> (lift $ forkIO (threadDelay delay >> callback))
+    ms = 1000
+    s = 1000 * ms
+
 start :: App ()
-start = loop Initial
+start = ping >> loop Initial
   where
     loop state = do
       newMessage <- receive

src/Main.hs

@@ -4,11 +4,10 @@ import Network.WebSockets (ClientApp, runClient)
 import Control.Monad.Reader (runReaderT)
 import Control.Monad.State (runStateT)
 import Config (host, port, path)
-import Automaton (initialState, start)
+import Automaton (start)
 
 bot :: ClientApp ()
-bot connection =
+bot connection = runReaderT Automaton.start connection
-  fst <$> runReaderT Automaton.start connection
 
 main :: IO ()
 main =