40 lines
1.4 KiB
Haskell
40 lines
1.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Main where
|
|
|
|
import Control.Monad.Reader (runReaderT)
|
|
import Control.Monad.State (evalStateT)
|
|
import Network.HTTP.Types.Status (badRequest400)
|
|
import Network.Wai (responseLBS)
|
|
import qualified Network.Wai.Handler.Warp as Warp (run)
|
|
import Network.Wai.Handler.WebSockets (websocketsOr)
|
|
import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
|
|
import qualified Automaton (run)
|
|
import Config (listenPort)
|
|
import qualified Game (stub)
|
|
import Message (receive, send)
|
|
import qualified Message.Client as Client (Message(..))
|
|
import qualified Message.Server as Server (Message(..))
|
|
|
|
makeApp :: IO ServerApp
|
|
makeApp =
|
|
return $ \pending -> do
|
|
connection <- acceptRequest pending
|
|
putStrLn "New connection"
|
|
message <- runReaderT receive connection
|
|
game <- case message of
|
|
Client.NewGame -> do
|
|
let newGame = Game.stub
|
|
runReaderT (send (Server.Init newGame)) connection
|
|
putStrLn "New game"
|
|
return newGame
|
|
Client.Resume {Client.game} -> putStrLn "Loading game" >> return game
|
|
evalStateT (runReaderT Automaton.run connection) game
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- makeApp
|
|
Warp.run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|