hannah/src/Automaton.hs

{-# 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(..), PlayerKey)
import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame, Room)
import Network.WebSockets (Connection, receiveData, sendTextData)
import Prelude hiding (error, putStrLn)

data State =
    Initial
  | Connected {
        key :: PlayerKey
      , room :: Message.Room
    }
  | LoggedIn {
        key :: PlayerKey
      , room :: Message.Room
      , name :: Text
    }
  | Playing {
        key :: PlayerKey
      , room :: Message.Room
      , 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 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
      , 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}

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 {}}) state = do
  send $ Message.Answer {Message.accept = False}
  return state

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 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 (2*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