Send a message containing the final score at the end

src/Automaton.hs

@@ -16,20 +16,20 @@ import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers,
 
 type Vertex = Session.Status
 
-edges :: Vertex -> Message.FromClient -> App.T Vertex
+receive :: Vertex -> Message.FromClient -> App.T ()
 
-edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
+receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
   asks App.key >>= App.try . (Server.logIn login)
   >>= maybe
-   (Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
+   (Message.relay logIn Message.broadcast >> move (Session.LoggedIn True))
-   (withError $ Session.LoggedIn False)
+   sendError
 
-edges (Session.LoggedIn True) logOut@Message.LogOut = do
+receive (Session.LoggedIn True) logOut@Message.LogOut = do
   Message.relay logOut Message.broadcast
   asks App.key >>= App.update_ . Server.logOut
-  return (Session.LoggedIn False)
+  move (Session.LoggedIn False)
 
-edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
+receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
   session <- App.get to
   case Session.status session of
     Session.LoggedIn True -> do
@@ -37,10 +37,10 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
       App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
       Message.broadcast $ Message.update {Message.paired = [key, to]}
       (Message.relay invitation $ Message.sendTo [to])
-      return (Session.Waiting to)
+      move (Session.Waiting to)
-    _ -> Session.LoggedIn True `withError` "They just left"
+    _ -> sendError "They just left"
 
-edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
+receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
   session <- App.get to
   key <- asks App.key
   case Session.status session of
@@ -51,48 +51,49 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
           then do
             gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
             game <- Server.get gameKey <$> App.server
-            Message.notifyPlayers game []
+            Message.notifyPlayers (KoiKoi.On game) []
             return $ Session.Playing gameKey
           else do
             Message.broadcast $ Message.update {Message.alone = [key, to]}
             return $ Session.LoggedIn True
       App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
-      return newStatus
+      move newStatus
-    _ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
+    _ -> sendError "They're not waiting for your answer"
 
-edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
+receive (Session.Playing gameKey) played@(Message.Play {}) = do
   key <- asks App.key
   game <- Server.get gameKey <$> App.server
-  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key move game
+  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game
   case result of
-    Left message -> status `withError` message
+    Left message -> sendError message
     Right newGame ->
       case newGame of
-        KoiKoi.Over _ -> undefined
+        KoiKoi.Over _ ->
+          Message.notifyPlayers newGame logs
         KoiKoi.On on -> do
           App.update_ $ Server.update gameKey (const on)
-          Message.notifyPlayers on logs
+          Message.notifyPlayers newGame logs
-          return status
 
-edges state _ =
+receive state _ = sendError $ "Invalid message in state " ++ show state
-  state `withError` ("Invalid message in state " ++ show state)
 
-withError :: Vertex -> String -> App.T Vertex
+sendError :: String -> App.T ()
-withError vertex message = 
+sendError = Message.send . Message.Error
-  (Message.send $ Message.Error message) >> return vertex
 
-run :: App.T ()
+move :: Vertex -> App.T ()
-run = do
+move newStatus = do
-  message <- Message.get
-  status <- Session.status <$> App.current
-  newStatus <- edges status message
   key <- asks App.key
   App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
   App.debug $ show newStatus
-  run
+
+loop :: App.T ()
+loop = do
+  message <- Message.get
+  status <- Session.status <$> App.current
+  status `receive` message
+  loop
 
 start :: App.T ()
 start = do
   App.debug "Initial state"
   Message.Welcome <$> App.server <*> asks App.key >>= Message.send
-  run
+  loop

src/Game.hs

@@ -48,6 +48,11 @@ deriving instance Generic On
 deriving instance Generic Over
 deriving instance Generic View
 
+instance ToJSON On where
+  toEncoding = genericToEncoding JSON.defaultOptions
+instance ToJSON Over where
+  toEncoding = genericToEncoding JSON.defaultOptions
+
 instance FromJSON Hanafuda.Card
 instance ToJSON Hanafuda.Card
 
@@ -90,9 +95,7 @@ instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
   toJSON = toJSON1
   toEncoding = toEncoding1
 
-type T = Hanafuda.KoiKoi.On Player.Key
+type T = On
-
-instance ToJSON T
 
 type Key = Data.Key T
 
@@ -100,8 +103,9 @@ new :: Player.Key -> Player.Key -> IO T
 new p1 p2 = do
   Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear
 
-export :: Player.Key -> T -> Value
+export :: Player.Key -> View -> Value
-export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
+export _ (Hanafuda.KoiKoi.Over over) = toJSON over
+export key (Hanafuda.KoiKoi.On on) = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
   where
     Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
     maskOpponentsHand k player

src/Message.hs

@@ -23,11 +23,11 @@ import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Text (Text)
 import Control.Monad.Reader (asks, lift)
 import qualified Player (Key)
-import qualified Game (T, export)
+import qualified Game (View, export)
 import qualified Session (T(..))
 import qualified Server (T(..), get)
 import qualified App (Context(..), T, connection, debug, server)
-import qualified Hanafuda.KoiKoi as KoiKoi (Action, On(..), Move(..))
+import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), On(..), Over(..), Move(..))
 import GHC.Generics (Generic)
 
 data FromClient =
@@ -98,7 +98,10 @@ get =
 update :: T
 update = Update {alone = [], paired = []}
 
-notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
+notifyPlayers :: Game.View -> [KoiKoi.Action] -> App.T ()
-notifyPlayers game logs =
+notifyPlayers game@(KoiKoi.Over over) logs =
-  forM_ (keys $ KoiKoi.scores game) $ \k ->
+  forM_ (keys $ KoiKoi.finalScores over) $ \k ->
+    sendTo [k] $ Game {game = Game.export k game, logs}
+notifyPlayers game@(KoiKoi.On on) logs =
+  forM_ (keys $ KoiKoi.scores on) $ \k ->
     sendTo [k] $ Game {game = Game.export k game, logs}