30 lines
979 B
Haskell
30 lines
979 B
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, forkPingThread)
|
|
import qualified Automaton (run)
|
|
import Config (listenPort)
|
|
import qualified Game (Game(..))
|
|
|
|
makeApp :: IO ServerApp
|
|
makeApp =
|
|
return $ \pending -> do
|
|
connection <- acceptRequest pending
|
|
putStrLn "New connection"
|
|
forkPingThread connection 20
|
|
runReaderT (evalStateT Automaton.run Game.Empty) connection
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- makeApp
|
|
Warp.run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|