Use latest changes in the lib to send a log of what happened during a turn

hanafuda-webapp.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hanafuda-webapp
-version:             0.2.0.1
+version:             0.2.1.0
 synopsis:            A webapp for the Haskell hanafuda library
 -- description:         
 homepage:            https://framagit.org/hanafuda

src/Automaton.hs

@@ -3,7 +3,9 @@ module Automaton (
     start
   ) where
 
+import Control.Monad.Except (runExceptT)
 import Control.Monad.Reader (asks, lift)
+import Control.Monad.Writer (runWriterT)
 import qualified Data (RW(..))
 import qualified Game (new, play)
 import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
@@ -49,7 +51,7 @@ 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 Nothing
+            Message.notifyPlayers game []
             return $ Session.Playing gameKey
           else do
             Message.broadcast $ Message.update {Message.alone = [key, to]}
@@ -61,14 +63,16 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
 edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
   key <- asks App.key
   game <- Server.get gameKey <$> App.server
-  newGame <- lift $ Game.play key move game
+  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key move game
-  case newGame of
+  case result of
-    KoiKoi.Error s -> status `withError` s
+    Left message -> status `withError` message
-    KoiKoi.Over _ -> undefined
+    Right newGame ->
-    KoiKoi.On on -> do
+      case newGame of
-      App.update_ $ Server.update gameKey (const on)
+        KoiKoi.Over _ -> undefined
-      Message.notifyPlayers on $ Just move
+        KoiKoi.On on -> do
-      return status
+          App.update_ $ Server.update gameKey (const on)
+          Message.notifyPlayers on logs
+          return status
 
 edges state _ =
   state `withError` ("Invalid message in state " ++ show state)

src/Game.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -14,6 +15,7 @@ module Game (
     , play
   ) where
 
+import Control.Monad.Except (throwError)
 import Data.Text (pack)
 import Data.Map (mapWithKey)
 import Data.HashMap.Strict (insert)
@@ -24,14 +26,16 @@ import qualified Data (Key)
 import qualified Player (Key)
 import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
 import qualified Hanafuda.Player (Player(..), Players(..))
-import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play)
+import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play)
 import GHC.Generics
 
 deriving instance Generic Hanafuda.Card
 deriving instance Generic Hanafuda.Flower
+deriving instance Generic Hanafuda.KoiKoi.Action
 deriving instance Generic Hanafuda.KoiKoi.Mode
 deriving instance Generic Hanafuda.KoiKoi.Move
 deriving instance Generic Hanafuda.KoiKoi.Yaku
+deriving instance Generic Hanafuda.KoiKoi.Source
 deriving instance Generic Hanafuda.KoiKoi.Step
 deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
 deriving instance Generic1 (Hanafuda.Player.Players Player.Key)
@@ -53,6 +57,8 @@ instance ToJSON Hanafuda.Pack where
   toJSON = toJSON . Hanafuda.cardsOfPack
   toEncoding = toEncoding . Hanafuda.cardsOfPack
 
+instance ToJSON Hanafuda.KoiKoi.Action
+
 instance ToJSON Hanafuda.KoiKoi.Mode
 
 instance FromJSON Hanafuda.KoiKoi.Move where
@@ -60,6 +66,11 @@ instance FromJSON Hanafuda.KoiKoi.Move where
 instance ToJSON Hanafuda.KoiKoi.Move where
   toEncoding = genericToEncoding JSON.singleLCField
 
+instance ToJSON Hanafuda.KoiKoi.Source
+
+instance ToJSON Hanafuda.KoiKoi.Step where
+  toEncoding = genericToEncoding JSON.defaultOptions
+
 instance ToJSON1 (Hanafuda.Player.Player Player.Key) where
   liftToEncoding = genericLiftToEncoding JSON.defaultOptions
 
@@ -72,9 +83,6 @@ instance ToJSON Hanafuda.KoiKoi.Yaku where
 instance ToJSONKey Hanafuda.KoiKoi.Yaku where
   toJSONKey = toJSONKeyText (pack . show)
 
-instance ToJSON Hanafuda.KoiKoi.Step where
-  toEncoding = genericToEncoding JSON.defaultOptions
-
 instance ToJSON1 (Hanafuda.Player.Players Player.Key) where
   liftToEncoding = genericLiftToEncoding JSON.defaultOptions
 
@@ -103,9 +111,8 @@ export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck o
         Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
       }
 
-play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO (Hanafuda.KoiKoi.Game Player.Key)
+play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key)
 play key move on
-  | Hanafuda.KoiKoi.playing on == key = do
+  | Hanafuda.KoiKoi.playing on == key =
-    newState <- Hanafuda.KoiKoi.play move on
+    Hanafuda.KoiKoi.play move on
-    return $ newState
+  | otherwise = throwError "Not your turn"
-  | otherwise = return $ Hanafuda.KoiKoi.Error "Not your turn"

src/Message.hs

@@ -27,7 +27,7 @@ import qualified Game (T, export)
 import qualified Session (T(..))
 import qualified Server (T(..), get)
 import qualified App (Context(..), T, connection, debug, server)
-import qualified Hanafuda.KoiKoi as KoiKoi (On(..), Move(..))
+import qualified Hanafuda.KoiKoi as KoiKoi (Action, On(..), Move(..))
 import GHC.Generics (Generic)
 
 data FromClient =
@@ -48,7 +48,7 @@ data T =
     Relay {from :: Player.Key, message :: FromClient}
   | Welcome {room :: Server.T, key :: Player.Key}
   | Update {alone :: [Player.Key], paired :: [Player.Key]}
-  | Game {game :: Value, played :: Maybe KoiKoi.Move}
+  | Game {game :: Value, logs :: [KoiKoi.Action]}
   | Pong
   | Error {error :: String}
   deriving (Generic)
@@ -98,7 +98,7 @@ get =
 update :: T
 update = Update {alone = [], paired = []}
 
-notifyPlayers :: Game.T -> Maybe KoiKoi.Move -> App.T ()
+notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
-notifyPlayers game played =
+notifyPlayers game logs =
   forM_ (keys $ KoiKoi.scores game) $ \k ->
-    sendTo [k] $ Game {game = Game.export k game, played}
+    sendTo [k] $ Game {game = Game.export k game, logs}