135 lines
4.2 KiB
Haskell
135 lines
4.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
start
|
|
) where
|
|
|
|
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 ((!))
|
|
import qualified Data.Map as Map (empty, filter, lookup)
|
|
import Control.Monad.Reader (ReaderT, ask)
|
|
import Control.Monad.Trans (lift)
|
|
import Hanafuda.KoiKoi (Step(..))
|
|
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 Session (State(..), deleteGame, initial, storeID, storeGame)
|
|
|
|
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 :: State -> Message.T -> App State
|
|
|
|
answer New (Welcome {key}) = do
|
|
lift $ Session.storeID key
|
|
lift $ putStrLn "Stored"
|
|
return $ Connected {playerID = key, games = Map.empty}
|
|
|
|
answer state@(Connected {}) (Relay {from, message = Invitation {}}) =
|
|
send (Answer {accept = True, to = from}) >> return state
|
|
|
|
answer state@(Connected {playerID}) message@(Game {}) = do
|
|
case Message.step $ Message.public game of
|
|
Over -> deleteGame gameID state
|
|
_ -> do
|
|
if Message.playing (Message.public game) == playerID
|
|
then
|
|
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 state Pong = ping >> return state
|
|
|
|
answer state (Error {error}) = do
|
|
debug $ "Received error from server : " `append` pack error
|
|
return state
|
|
|
|
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 Ping connection)
|
|
where
|
|
setTimeout delay callback =
|
|
const () <$> (lift $ forkIO (threadDelay delay >> callback))
|
|
ms = 1000
|
|
s = 1000 * ms
|
|
|
|
start :: App ()
|
|
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 = receive >>= answer state >>= loop
|