120 lines
3.6 KiB
Haskell
120 lines
3.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
start
|
|
) where
|
|
|
|
import 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 Control.Monad.Reader (ReaderT, ask)
|
|
import Control.Monad.State (StateT)
|
|
import Control.Monad.Trans (lift)
|
|
import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerID, Step(..))
|
|
import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame)
|
|
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
|
|
|
|
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 message =
|
|
ask >>= lift . sendIO message
|
|
|
|
receive :: App Message.T
|
|
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 {Message.name = "Hannah"}
|
|
return $ Connected {key = Message.key welcome}
|
|
|
|
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}
|
|
return $ Playing {key, name, against = from}
|
|
|
|
answer (Message.Relay {Message.message = Message.Invitation {}}) state = do
|
|
send $ Message.Answer {Message.accept = False}
|
|
return 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
|
|
then send (Message.Play {Message.move = AI.move key game}) >> return state
|
|
else return state
|
|
|
|
answer (Message.Relay {Message.from, Message.message = Message.LogOut}) (Playing {key, name, against})
|
|
| from == against = send Message.Quit >> return (LoggedIn {key, name})
|
|
|
|
answer (Message.Relay {}) state = return state
|
|
|
|
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
|
|
debug $ ByteString.concat [
|
|
"Unexpected message : ", encode message, " in state ", pack $ show state
|
|
]
|
|
return state
|
|
|
|
ping = do
|
|
connection <- ask
|
|
setTimeout (20*s) (sendIO Message.Ping connection)
|
|
where
|
|
setTimeout delay callback =
|
|
const () <$> (lift $ forkIO (threadDelay delay >> callback))
|
|
ms = 1000
|
|
s = 1000 * ms
|
|
|
|
start :: App ()
|
|
start = ping >> loop Initial
|
|
where
|
|
loop state = do
|
|
newMessage <- receive
|
|
answer newMessage state >>= loop
|