diff --git a/hannah.cabal b/hannah.cabal index cbc3966..f8b9360 100644 --- a/hannah.cabal +++ b/hannah.cabal @@ -29,6 +29,7 @@ executable hannah , hanafuda , hanafuda-APILanguage , mtl + , text , websockets hs-source-dirs: src default-language: Haskell2010 diff --git a/src/AI.hs b/src/AI.hs index 5335beb..57831cc 100644 --- a/src/AI.hs +++ b/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 diff --git a/src/Automaton.hs b/src/Automaton.hs index ab8b99a..5036239 100644 --- a/src/Automaton.hs +++ b/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 Data.Aeson +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.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 qualified Hanafuda.Message as Message (T(..), FromClient(..), Room) +import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerKey) +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 - , game :: Game + , name :: Text + , 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 {}}) _ = - send $ Message.Answer {Message.accept = False} >> return state +answer (Message.Relay {Message.message = Message.Invitation {}}) state = do + send $ Message.Answer {Message.accept = False} + return state -answer game@(Message.Game {Message.game, Message.logs}) state@(Playing {key}) = - if playing == key - then send $ AI.move key game +answer (Message.Game {Message.game, Message.logs}) state@(Playing {key}) = do + if playing game == key + 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 = - debug $ "Received error from server : " <> pack error >> return state - -answer message state = do - debug $ "Unexpected message : " <> encode message <> " in state " <> show state +answer (Message.Error {Message.error}) state = do + debug $ "Received error from server : " `append` pack error 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 diff --git a/src/Main.hs b/src/Main.hs index 0d40875..92238a4 100644 --- a/src/Main.hs +++ b/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 = - fst <$> runReaderT Automaton.start connection +bot connection = runReaderT Automaton.start connection main :: IO () main =