nim-console Ledger App (#1342)

* Use closable Stream in Haskell ledger bindings * move PastAndFuture abstraction into ledger interface code * distinguish past/future transactions in return of Ledger.getTransactionsPF * first cut: nim-console running against a ledger * remove flaky failing test
digital-asset · May 23, 2019 · 7ee7931 · 7ee7931
1 parent 91057be
commit 7ee7931
Show file tree

Hide file tree

Showing 26 changed files with 1,192 additions and 818 deletions.
diff --git a/language-support/hs/bindings/BUILD.bazel b/language-support/hs/bindings/BUILD.bazel
@@ -10,10 +10,11 @@ da_haskell_library(
     hazel_deps = [
         "base",
         "bytestring",
-        "text",
-        "vector",
         "containers",
         "proto3-suite",
+        "text",
+        "time",
+        "vector",
     ],
     visibility = ["//visibility:public"],
     deps = [
@@ -25,21 +26,10 @@ da_haskell_library(
     ],
 )
 
-da_haskell_binary(
-    name = "play",
-    srcs = ["examples/Play.hs"],
-    compiler_flags = [],
-    hazel_deps = [
-        "base",
-        "extra",
-        "random",
-        "text",
-        "uuid",
-    ],
-    visibility = ["//visibility:public"],
-    deps = [
-        "//language-support/hs/bindings:hs-ledger",
-    ],
+daml_compile(
+    name = "Nim",
+    srcs = glob(["examples/nim-console/daml/*.daml"]),
+    main_src = "examples/nim-console/daml/Nim.daml",
 )
 
 da_haskell_binary(
@@ -54,6 +44,7 @@ da_haskell_binary(
         "haskeline",
         "random",
         "text",
+        "time",
         "transformers",
         "uuid",
     ],
@@ -82,10 +73,11 @@ da_haskell_test(
         "directory",
         "extra",
         "process",
+        "random",
         "tasty",
         "tasty-hunit",
         "text",
-        "random",
+        "time",
         "uuid",
     ],
     main_function = "DA.Ledger.Tests.main",

diff --git a/language-support/hs/bindings/examples/Play.hs b/language-support/hs/bindings/examples/Play.hs
diff --git a/language-support/hs/bindings/examples/nim-console/README.md b/language-support/hs/bindings/examples/nim-console/README.md
@@ -1,10 +1,48 @@
 
 # `nim-console`
 
-Example of a ledger app written in Haskell, to demo the Haskell ledger bindings.
+Example ledger App, written in Haskell, which runs a multi-player game-server for Nim.
+The ledger maintains the game state, and encodes the rules of Nim. See: `daml/Nim.daml`.
+Players connect to the ledger using `nim-console`.
 
-Currently the app is hooked up with a simulated ledger. Next step: hook up to real ledger!
+The state of a game of Nim consists of 3 piles of matchsticks, initially containing 7, 5 and 3 sticks respectively. On your turn, you must take 1,2, or 3 matchsticks from a single pile. Turns alternate. The player who takes the final match is the loser.
 
-## Build and Run
+## Build
+
+    $ bazel build language-support/hs/bindings/...
+
+## Start a sandbox ledger running the Nim game server
+
+    $ daml sandbox bazel-out/k8-fastbuild/bin/language-support/hs/bindings/Nim.dar
+
+## Start a nim-console (as default player Alice)
 
     $ bazel run language-support/hs/bindings:nim
+
+## (Optional) Start more consoles for other players in different terminals
+
+    $ bazel run language-support/hs/bindings:nim -- Bob
+    $ bazel run language-support/hs/bindings:nim -- Charles
+
+## Play as Alice
+
+    Alice> offer Bob
+    Alice> offer Charles Dave
+    Alice> show
+
+## Start a robot to play as Bob
+
+    $ bazel run language-support/hs/bindings:nim -- --robot Bob
+
+## Quit and restart Alice's console. State is recovered from the ledger.
+
+    Alice> move 1 2 3
+    Alice> show
+    Alice> <Ctr-C>
+    $ bazel run language-support/hs/bindings:nim
+    Alice> show
+
+## Play as Dave against Alice
+
+    $ bazel run language-support/hs/bindings:nim -- Dave
+    Dave> accept 1
diff --git a/language-support/hs/bindings/examples/nim-console/daml/Nim.daml b/language-support/hs/bindings/examples/nim-console/daml/Nim.daml
@@ -0,0 +1,66 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+
+module Nim where
+
+import DA.List as List(splitAt)
+
+template GameOffer
+    with
+        offerer : Party
+        offerees : [Party]
+    where
+        signatory offerer
+        observer offerees
+        choice GameOffer_Accept : ContractId GameInProgress with acceptor : Party
+            controller acceptor
+            do
+                if not (acceptor `elem` offerees)
+                    then error "acceptor not an offeree"
+                    else create GameInProgress { game = Game {player1 = offerer,
+                                                              player2 = acceptor,
+                                                              piles = initPiles } }
+
+template GameInProgress
+    with
+        game : Game
+    where
+        ensure sum game.piles >= 0
+        signatory game.player1, game.player2
+        controller game.player1 can
+            Game_Take : ContractId GameInProgress with move : Move do
+                case playMove move game of
+                    Left m -> error m
+                    Right game' -> create this with game = game'
+
+data Game = Game {
+    player1 : Party,
+    player2 : Party,
+    piles : [Int]
+    } deriving (Eq,Show)
+
+initPiles = [7,5,3]
+
+initGameState : Party -> Party -> Game
+initGameState player1 player2 = Game { player1, player2, piles = initPiles }
+
+data Move = Move { pileNum : Int, howMany : Int } deriving (Eq,Show)
+
+type RejectionMessage = String
+
+playMove : Move -> Game -> Either RejectionMessage Game
+playMove Move{pileNum,howMany} Game{player1,player2,piles} =
+    if pileNum < 1 || pileNum > length piles then Left "no such pile" else
+    case List.splitAt (pileNum - 1) piles of
+        (xs,selected::ys)
+            | howMany < 1 -> Left "must take at least 1"
+            | howMany > 3 -> Left "may only take 1,2 or 3"
+            | selected < howMany -> Left "not that many in pile"
+            | otherwise ->
+              Right $ Game { player1 = player2,
+                             player2 = player1,
+                             piles = xs ++ [selected - howMany] ++ ys }
+        _ ->
+            Left "failed to split, should never happen"
diff --git a/language-support/hs/bindings/examples/nim-console/src/Domain.hs b/language-support/hs/bindings/examples/nim-console/src/Domain.hs
@@ -1,62 +1,72 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE OverloadedStrings #-}
 
--- Domain types (will originate in Daml model)
+-- Nim domain types. These should be derived automatically from the Daml model.
 
-module Domain(Player(..),
+module Domain(Player(..), partyOfPlayer,
               Offer(..),
               Game(..),
               Move(..),
-              playersOfGame,
-              playersOfOffer,
-              legalMovesOfGame,
-              initGame,
-              playMove
+              legalMovesOfGame, -- for Robot
              ) where
 
-import Data.List as List(splitAt)
-
-data Player = Player String
-    deriving (Eq,Ord)
+import DA.Ledger.Types
+import DA.Ledger.Valuable(Valuable(..))
+import qualified Data.Text.Lazy as Text
 
+data Player = Player { unPlayer :: String } deriving (Eq,Ord)
 instance Show Player where show (Player s) = s
 
-data Offer = Offer { from :: Player, to :: [Player] }
-    deriving (Show)
-
-data Game = Game { p1 :: Player, p2 :: Player, piles :: [Int] }
-    deriving (Show)
+partyOfPlayer :: Player -> Party
+partyOfPlayer = Party . Text.pack . unPlayer
 
-data Move = Move { pileNum :: Int, howMany :: Int }
-    deriving Show
+instance Valuable Player where
+    toValue = toValue . Party . Text.pack . unPlayer
+    fromValue = fmap (Player . Text.unpack . unParty) . fromValue
 
-playersOfGame :: Game -> [Player]
-playersOfGame Game{p1,p2} = [p1,p2]
+data Offer = Offer { from :: Player, to :: [Player] }
+    deriving (Show)
 
-playersOfOffer :: Offer -> [Player]
-playersOfOffer Offer{from,to} = from : to
+instance Valuable Offer where
+    toValue Offer{from,to} = VList [toValue from, toValue to]
+    fromValue = \case
+        VList [v1,v2] -> do
+            from <- fromValue v1
+            to <- fromValue v2
+            return Offer{from,to}
+        _ -> Nothing
+
+data Game = Game { p1 :: Player, p2 :: Player, piles :: [Int] } deriving (Show)
+
+instance Valuable Game where
+    toValue Game{} = undefined -- we never send games to the ledger
+    fromValue = \case
+        VList[VRecord Record{fields=[
+                                    RecordField{value=v1},
+                                    RecordField{value=v2},
+                                    RecordField{value=v3}]
+                            }] -> do
+            p1 <- fromValue v1
+            p2 <- fromValue v2
+            piles <- fromValue v3
+            return Game{p1,p2,piles}
+        _ ->
+            Nothing
+
+data Move = Move { pileNum :: Int, howMany :: Int } deriving Show
+
+instance Valuable Move where
+    toValue Move{pileNum,howMany} =
+        VRecord(Record{rid=Nothing,
+                       fields=[
+                              RecordField{label = "", value = toValue pileNum},
+                              RecordField{label = "", value = toValue howMany}]})
+    fromValue = undefined -- we never receive moves from the ledger
 
 legalMovesOfGame :: Game -> [Move]
 legalMovesOfGame Game{piles} = do
     (pileNum,remaining) <- zip [1..] piles
     howMany <- [1..min 3 remaining]
     return $ Move {pileNum,howMany}
-
-initGame :: Player -> Player -> Game
-initGame p1 p2 = Game {p1, p2, piles = standardInitPiles}
-
-standardInitPiles :: [Int]
-standardInitPiles = [7,5,3]
-
-type Rejection = String
-
-playMove :: Move -> Game -> Either Rejection Game
-playMove Move{pileNum,howMany} Game{p1,p2,piles} =
-    case List.splitAt (pileNum - 1) piles of
-        (xs,selected:ys)
-            | howMany > 3 -> Left "may only take 1,2 or 3"
-            | selected < howMany -> Left "not that many in pile"
-            | otherwise -> Right $ Game { p1 = p2, p2 = p1, piles = xs ++ [selected - howMany] ++ ys }
-
-        _ -> Left"no such pile"