Taking the existing flow from Main into a separate Automaton module

hanafudapi.cabal

@@ -21,7 +21,8 @@ source-repository head
 
 executable hanafudapi
   main-is:             Main.hs
-  other-modules:       Config
+  other-modules:       Automaton
+                     , Config
                      , Message
                      , Game
                      , JSON

src/Automaton.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Automaton (
+    start
+  ) where
+
+import Control.Monad.Reader (asks)
+import qualified Player (Session(..), Status(..))
+import qualified Server (logIn, logOut, setStatus)
+import qualified Session (App, T(..), current, debug, get, server, try, update)
+import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo)
+
+type Vertex = Player.Status
+
+edges :: Vertex -> Message.FromClient -> Session.App Vertex
+
+edges (Player.LoggedIn False) logIn@(Message.LogIn login) =
+  asks Session.key >>= Session.try . (Server.logIn login)
+  >>= maybe
+   (Message.relay logIn Message.broadcast >> return (Player.LoggedIn True))
+   (withError $ Player.LoggedIn False)
+
+edges (Player.LoggedIn True) logOut@Message.LogOut = do
+  Message.relay logOut Message.broadcast
+  asks Session.key >>= Session.update . Server.logOut
+  return (Player.LoggedIn False)
+
+edges (Player.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
+  session <- Session.get to
+  case Player.status session of
+    Player.LoggedIn True -> do
+      key <- asks Session.key
+      Session.update (Server.setStatus (Player.Answering key) to)
+      (Message.relay invitation $ Message.sendTo (to, session))
+      return (Player.Waiting to)
+    _ -> Player.LoggedIn True `withError` "They just left"
+
+edges (Player.Answering to) message@(Message.Answer {Message.accept}) = do
+  session <- Session.get to
+  key <- asks Session.key
+  case Player.status session of
+    Player.Waiting for | for == key -> do
+      Message.relay message $ Message.sendTo (to, session)
+      if accept
+        then Session.debug "Yeah ! Let's start a game" >> return (Player.LoggedIn True)
+        else Session.debug "Oh, they said no" >> return (Player.LoggedIn True)
+    _ -> (Player.LoggedIn True) `withError` "They're not waiting for your answer"
+
+edges state _ =
+  state `withError` ("Invalid message in state " ++ show state)
+
+withError :: Vertex -> String -> Session.App Vertex
+withError vertex message = 
+  (Message.send $ Message.Error message) >> return vertex
+
+run :: Session.App ()
+run = do
+  message <- Message.get
+  status <- Player.status <$> Session.current
+  newStatus <- edges status message
+  Server.setStatus newStatus <$> asks Session.key >>= Session.update
+  Session.debug $ show newStatus
+  run
+
+start :: Session.App ()
+start = do
+  Session.debug "Initial state"
+  Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
+  run

src/Main.hs

@@ -4,87 +4,39 @@ module Main where
 
 import Network.Wai.Handler.Warp (run)
 import Network.HTTP.Types.Status (badRequest400)
-import Network.WebSockets (defaultConnectionOptions)
+import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
 import Network.Wai.Handler.WebSockets (websocketsOr)
 import Network.Wai (responseLBS)
-import Control.Monad.Reader (asks)
+import Control.Monad.Reader (ReaderT(..), asks)
+import Control.Concurrent (newMVar, modifyMVar)
+import Control.Exception (finally)
 import qualified Config (listenPort)
-import qualified Player (Session(..), Status(..))
+import qualified Player (openSession)
-import qualified Server (logIn, logOut, disconnect, setStatus)
+import qualified Server (disconnect, join, new)
-import qualified Session (App, T(..), current, debug, get, serve, server, try, update)
+import qualified Session (App, T(..), update)
-import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send, sendTo)
+import qualified Message (FromClient(..), broadcast, relay)
+import qualified Automaton (start)
 
-type Vertex = Session.App ()
+exit :: 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"
-  Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
-  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) =
-       asks Session.key >>= Session.try . (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
-      asks Session.key >>= Session.update . Server.logOut
-      connected
-    edges invitation@(Message.Invitation {Message.to}) = do
-      session <- Session.get to
-      case Player.status session of
-        Player.LoggedIn True -> do
-          key <- asks Session.key
-          Session.update (Server.setStatus (Player.Waiting to) key)
-          Session.update (Server.setStatus (Player.Answering key) to)
-          (Message.relay invitation $ Message.sendTo (to, session))
-          loggedIn
-        _ -> onErrorGoto loggedIn "They just left"
-    edges (Message.Answer {Message.accept}) = do
-      current <- Session.current
-      case Player.status current of
-        Player.Answering to -> do
-          session <- Session.get to
-          key <- asks Session.key
-          case Player.status session of
-            Player.Waiting for | for == key ->
-              if accept
-                then Session.debug "Yeah ! Let's start a game" >> loggedIn
-                else Session.debug "Oh they said no" >> loggedIn
-            _ -> onErrorGoto loggedIn "They're not waiting for your answer"
-        _ -> onErrorGoto loggedIn "You haven't been invited yet"
-    edges _ = loggedIn
-
-exit :: Vertex
 exit = do
   asks Session.key >>= Session.update . Server.disconnect
   Message.relay Message.LogOut Message.broadcast
 
+serverApp :: Session.App () -> Session.App () -> IO ServerApp
+serverApp onEnter onExit = do
+  mServer <- newMVar Server.new
+  return $ \pending -> do
+    key <- acceptRequest pending
+                 >>= return . Player.openSession
+                 >>= modifyMVar mServer . Server.join
+    let session = Session.T {Session.mServer, Session.key}
+    finally
+      (runReaderT onEnter session)
+      (runReaderT onExit session)
+
 main :: IO ()
 main = do
-  app <- Session.serve enter exit
+  app <- serverApp Automaton.start exit
   run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
   where
     blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")

src/Message.hs

@@ -4,6 +4,7 @@ module Message (
       FromClient(..)
     , T(..)
     , broadcast
+    , get
     , receive
     , relay
     , send
@@ -77,3 +78,10 @@ receive = do
   case eitherDecode' received of
     Left errorMessage -> send (Message.Error errorMessage) >> receive
     Right clientMessage -> return clientMessage
+
+get :: Session.App Message.FromClient
+get =
+  receive >>= pong
+  where
+    pong Ping = send Pong >> get
+    pong m = return m

src/Player.hs

@@ -35,7 +35,7 @@ data Status =
     LoggedIn Bool
   | Answering Key
   | Waiting Key
-  deriving (Generic)
+  deriving (Show, Generic)
 
 data Session = Session {
       connection :: Connection

src/Session.hs

@@ -6,19 +6,17 @@ module Session (
     , debug
     , get
     , current
-    , serve
     , server
     , try
     , update
   ) where
 
 import Data.Map ((!))
-import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVar)
+import Control.Concurrent (MVar, modifyMVar_, putMVar, readMVar, takeMVar)
-import Control.Exception (finally)
 import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
-import Network.WebSockets (Connection, ServerApp, acceptRequest)
+import Network.WebSockets (Connection)
-import qualified Player (Key, Session(..), openSession)
+import qualified Player (Key, Session(..))
-import qualified Server (T(..), join, new)
+import qualified Server (T(..))
 
 data T = T {
       mServer :: MVar Server.T
@@ -54,17 +52,8 @@ try f = do
     Left message -> putMVar mServer currentValue >> return (Just message)
     Right updated -> putMVar mServer updated >> return Nothing
 
+{- Not using the previous to minimize the duration mServer gets locked -}
 update :: (Server.T -> Server.T) -> App ()
-update f = try (Right . f) >> return ()
+update f = do
-
+  T {mServer} <- ask
-serve :: App () -> App () -> IO ServerApp
+  lift $ modifyMVar_ mServer (return . f)
-serve onEnter onExit = do
-  mServer <- newMVar Server.new
-  return $ \pending -> do
-    key <- acceptRequest pending
-                 >>= return . Player.openSession
-                 >>= modifyMVar mServer . Server.join
-    finally
-      (runReaderT onEnter $ T {mServer, key})
-      (runReaderT onExit $ T {mServer, key})
-