hannah/src/Automaton.hs

{-# 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