Simplify the client/server protocol, add client messages used in game initialization

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

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
   }

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

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

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

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)