diff --git a/src/Automaton.hs b/src/Automaton.hs index 27f19a4..3c4084a 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Automaton ( run ) where @@ -5,15 +7,32 @@ module Automaton ( import Control.Monad.State (get, put) import Control.Monad.IO.Class (liftIO) import Data.Aeson (encode) -import Data.ByteString.Lazy.Char8 (ByteString, putStrLn) +import Data.ByteString.Lazy.Char8 (ByteString, putStrLn, unpack) import Prelude hiding (log, putStrLn) -import Game (Game) +import Character (Character(..)) +import Game (Game(..), InitProcess(..), State(..), stub) import Message (Connected, receive, send) import qualified Message.Client as Client (Message(..)) import qualified Message.Server as Server (Message(..)) edges :: Game -> Client.Message -> Connected Game -edges = undefined + +edges (Game {state = Start}) Client.NewGame = return $ Game.stub { + state = Initializing Name + } + +edges (Game {state = Start}) (Client.Resume {Client.game}) = return game + +edges (Game {state = Initializing Name, character}) (Client.Initialize {Client.step = Name, Client.value}) = return $ Game { + character = character { name = value } + , state = Initializing Skin + } + +edges game message = do + let errorMessage = "inacceptable message " <> encode message <> " in this context" + send (Server.Error $ unpack errorMessage) + log errorMessage + return game log :: ByteString -> Connected () log line = @@ -26,5 +45,5 @@ run = do newGame <- edges game message log $ encode newGame put newGame - send $ Server.Update newGame + send $ Server.Game newGame run diff --git a/src/Game.hs b/src/Game.hs index 6a51676..2e79528 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} module Game ( Game(..) + , InitProcess(..) + , State(..) , stub ) where @@ -29,7 +31,7 @@ instance ToJSON Turn where instance FromJSON Turn where parseJSON = genericParseJSON defaultOptions -data InitProcess = Name | Gender | OpponentsName deriving (Generic) +data InitProcess = Gender | Name | Skin deriving (Generic) instance ToJSON InitProcess where toEncoding = genericToEncoding defaultOptions @@ -43,7 +45,9 @@ data State = , opponent :: Character , turn :: Turn } - | Initializing InitProcess deriving (Generic) + | Initializing InitProcess + | Start + deriving (Generic) instance ToJSON State where toEncoding = genericToEncoding defaultOptions @@ -63,5 +67,5 @@ instance FromJSON Game where stub :: Game stub = Game { character = Character.stub - , state = Initializing Name + , state = Start } diff --git a/src/Main.hs b/src/Main.hs index bb2c156..6b69f70 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,28 +8,18 @@ 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 Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions, forkPingThread) 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 + forkPingThread connection 20 + runReaderT (evalStateT Automaton.run Game.stub) connection main :: IO () main = do diff --git a/src/Message.hs b/src/Message.hs index fab3596..c568928 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -14,7 +14,7 @@ import Game (Game) import qualified Message.Client as Client (Message) import qualified Message.Server as Server (Message(..)) -type Connected a = ReaderT Connection (StateT Game IO) a +type Connected a = StateT Game (ReaderT Connection IO) a send :: (MonadReader Connection t, MonadIO t) => Server.Message -> t () send message = do diff --git a/src/Message/Client.hs b/src/Message/Client.hs index 2b46902..2f59a67 100644 --- a/src/Message/Client.hs +++ b/src/Message/Client.hs @@ -3,15 +3,22 @@ module Message.Client ( Message(..) ) where -import Data.Aeson (FromJSON(..), genericParseJSON, defaultOptions) -import Game (Game) +import Data.Aeson (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding, defaultOptions) +import Game (Game, InitProcess(..)) import GHC.Generics (Generic) data Message = NewGame + | Initialize { + step :: InitProcess + , value :: String + } | Resume { game :: Game } deriving (Generic) +instance ToJSON Message where + toEncoding = genericToEncoding defaultOptions + instance FromJSON Message where parseJSON = genericParseJSON defaultOptions diff --git a/src/Message/Server.hs b/src/Message/Server.hs index dbe57c9..d5b6b7b 100644 --- a/src/Message/Server.hs +++ b/src/Message/Server.hs @@ -8,12 +8,7 @@ import Game (Game) import GHC.Generics (Generic) data Message = - Init { - game :: Game - } - | Update { - game :: Game - } + Game Game | Error { error :: String } deriving (Generic)