{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main where

import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types.Status (badRequest400)
import Network.WebSockets (defaultConnectionOptions)
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.Wai (responseLBS)
import qualified Config (listenPort)
import qualified Player (Login(..), T(..))
import qualified Server (logIn, logOut, disconnect)
import qualified Session (App, debug, get, player, serve, update)
import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send)

type Vertex = Session.App ()
type Edges = Message.FromClient -> Vertex

newVertex :: String -> Edges -> Vertex
newVertex name = do
  (Session.debug name >> catchPings >>=)
  where
    catchPings = Message.receive >>= pong
    pong Message.Ping = (Message.send Message.Pong >> catchPings)
    pong m = return m

enter :: Vertex
enter = do
  Session.debug "Initial state"
  Session.get id >>= (Message.send . Message.Welcome)
  connected

onErrorGoto :: Vertex -> String -> Session.App ()
onErrorGoto vertex message = 
  (Message.send $ Message.Error message) >> vertex

connected  :: Vertex
connected = newVertex "Connected" edges
  where
    edges logIn@(Message.LogIn login) =
       Session.update (Server.logIn login)
       >>= maybe
        (Message.relay logIn Message.broadcast >> loggedIn)
        (onErrorGoto connected)
    edges _ = Session.debug "Invalid message" >> connected

loggedIn :: Vertex
loggedIn = newVertex "Logged in" edges
  where
    edges logOut@Message.LogOut = do
      Message.relay logOut Message.broadcast
      Session.update Server.logOut
      >>= maybe
        connected
        (onErrorGoto loggedIn)
    edges _ = loggedIn

exit :: Vertex
exit = do
  leaving <- Player.login <$> Session.player
  _ <- Session.update Server.disconnect -- ignoring never-occuring error
  case leaving of
    Player.Login from -> Message.broadcast $
      Message.Relay {Message.from, Message.message = Message.LogOut}
    _ -> return ()

main :: IO ()
main = do
  app <- Session.serve enter exit
  run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
  where
    blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")