mirror of
https://github.com/digital-asset/daml.git
synced 2024-11-10 10:46:11 +03:00
Haskell ledger bindings (#1181)
* Bindings & tests for more ledger services * fix hardcoded package id in test * language-support/hs/bindings/examples/nim-console * make hlint happy * headers & format * README * increase timeouts; track location of GPRC Deadline Exceeded. * Update language-support/hs/bindings/examples/nim-console/README.md Co-Authored-By: Neil Mitchell <35463327+neil-da@users.noreply.github.com> * rename: Mes --> Logger, mes --> log, tagMes --> tagLog (etc) * replace isOpen with ==Open * Avoid fragile hardcoded PackageId in testcase
This commit is contained in:
nickchapman-da
GitHub
parent
69429f3a14
commit
8510e6afc5
@ -9,6 +9,7 @@ da_haskell_library(
|
||||
srcs = glob(["src/**/*.hs"]),
|
||||
hazel_deps = [
|
||||
"base",
|
||||
"bytestring",
|
||||
"text",
|
||||
"vector",
|
||||
"containers",
|
||||
@ -16,6 +17,9 @@ da_haskell_library(
|
||||
],
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
"//compiler/daml-lf-ast",
|
||||
"//compiler/daml-lf-proto",
|
||||
"//daml-lf/archive:daml_lf_haskell_proto",
|
||||
"//ledger-api/grpc-definitions:ledger-api-haskellpb",
|
||||
"//nix/third-party/gRPC-haskell:grpc-haskell",
|
||||
],
|
||||
@ -38,6 +42,27 @@ da_haskell_binary(
|
||||
],
|
||||
)
|
||||
|
||||
da_haskell_binary(
|
||||
name = "nim",
|
||||
srcs = glob(["examples/nim-console/src/*.hs"]),
|
||||
compiler_flags = [],
|
||||
hazel_deps = [
|
||||
"ansi-terminal",
|
||||
"base",
|
||||
"containers",
|
||||
"extra",
|
||||
"haskeline",
|
||||
"random",
|
||||
"text",
|
||||
"transformers",
|
||||
"uuid",
|
||||
],
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
"//language-support/hs/bindings:hs-ledger",
|
||||
],
|
||||
)
|
||||
|
||||
daml_compile(
|
||||
name = "quickstart",
|
||||
srcs = glob(["test/daml/quickstart/*.daml"]),
|
||||
@ -57,10 +82,11 @@ da_haskell_test(
|
||||
"directory",
|
||||
"extra",
|
||||
"process",
|
||||
"split",
|
||||
"tasty",
|
||||
"tasty-hunit",
|
||||
"text",
|
||||
"random",
|
||||
"uuid",
|
||||
],
|
||||
main_function = "DA.Ledger.Tests.main",
|
||||
src_strip_prefix = "test",
|
||||
|
||||
@ -25,12 +25,12 @@ main = do
|
||||
let lid = Ledger.identity h
|
||||
putStrLn $ "LedgerIdentity = " <> show lid
|
||||
|
||||
aliceTs <- Ledger.getTransactionStream h alice
|
||||
bobTs <- Ledger.getTransactionStream h bob
|
||||
aliceTs <- Ledger.transactions h alice
|
||||
bobTs <- Ledger.transactions h bob
|
||||
watch (show alice) aliceTs
|
||||
watch (show bob) bobTs
|
||||
|
||||
cs <- Ledger.getCompletionStream h myAid [alice,bob]
|
||||
cs <- Ledger.completions h myAid [alice,bob]
|
||||
watch "completions" cs
|
||||
|
||||
sleep 1
|
||||
@ -82,9 +82,9 @@ myAid = ApplicationId "<my-application>"
|
||||
randomCid :: IO CommandId
|
||||
randomCid = do fmap (CommandId . Text.pack . UUID.toString) randomIO
|
||||
|
||||
watch :: Show a => String -> ResponseStream a -> IO ()
|
||||
watch :: Show a => String -> Stream a -> IO ()
|
||||
watch tag rs = void $ forkIO $ loop (1::Int)
|
||||
where loop n = do
|
||||
x <- nextResponse rs
|
||||
x <- takeStream rs
|
||||
putStrLn $ tag <> "(" <> show n <> ") = " <> show x
|
||||
loop (n+1)
|
||||
|
||||
10
language-support/hs/bindings/examples/nim-console/README.md
Normal file
10
language-support/hs/bindings/examples/nim-console/README.md
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
# `nim-console`
|
||||
|
||||
Example of a ledger app written in Haskell, to demo the Haskell ledger bindings.
|
||||
|
||||
Currently the app is hooked up with a simulated ledger. Next step: hook up to real ledger!
|
||||
|
||||
## Build and Run
|
||||
|
||||
$ bazel run language-support/hs/bindings:nim
|
||||
@ -0,0 +1,62 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
-- Domain types (will originate in Daml model)
|
||||
|
||||
module Domain(Player(..),
|
||||
Offer(..),
|
||||
Game(..),
|
||||
Move(..),
|
||||
playersOfGame,
|
||||
playersOfOffer,
|
||||
legalMovesOfGame,
|
||||
initGame,
|
||||
playMove
|
||||
) where
|
||||
|
||||
import Data.List as List(splitAt)
|
||||
|
||||
data Player = Player 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)
|
||||
|
||||
data Move = Move { pileNum :: Int, howMany :: Int }
|
||||
deriving Show
|
||||
|
||||
playersOfGame :: Game -> [Player]
|
||||
playersOfGame Game{p1,p2} = [p1,p2]
|
||||
|
||||
playersOfOffer :: Offer -> [Player]
|
||||
playersOfOffer Offer{from,to} = from : to
|
||||
|
||||
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"
|
||||
@ -0,0 +1,49 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
module External(XCommand(..),
|
||||
XTrans(..),
|
||||
Xoid, genXoid,
|
||||
Xgid, genXgid,
|
||||
) where
|
||||
|
||||
import Domain
|
||||
|
||||
import qualified Data.UUID as UUID(toString)
|
||||
import System.Random (randomIO)
|
||||
|
||||
-- external commands
|
||||
|
||||
data XCommand
|
||||
= OfferGame Offer
|
||||
| AcceptOffer Player Xoid
|
||||
| MakeMove Player Xgid Move
|
||||
-- | ClaimWin Xgid -- TODO
|
||||
deriving Show
|
||||
|
||||
|
||||
-- external transitions
|
||||
|
||||
data XTrans
|
||||
= NewOffer { xoid :: Xoid, offer :: Offer }
|
||||
| OfferWithdrawn { xoid :: Xoid, offer :: Offer } -- because someone accepted
|
||||
| NewGame { xgid :: Xgid, game :: Game } -- replaces an offer
|
||||
| GameMove { oldXgid :: Xgid, newXgid :: Xgid, game :: Game }
|
||||
deriving Show
|
||||
|
||||
-- order id & game id
|
||||
|
||||
data Xoid = Xoid String
|
||||
deriving (Eq,Ord)
|
||||
instance Show Xoid where show (Xoid s) = s
|
||||
|
||||
data Xgid = Xgid String
|
||||
deriving (Eq,Ord)
|
||||
instance Show Xgid where show (Xgid s) = s
|
||||
|
||||
genXgid :: IO Xgid
|
||||
genXgid = do fmap (Xgid . UUID.toString) randomIO
|
||||
|
||||
genXoid :: IO Xoid
|
||||
genXoid = do fmap (Xoid . UUID.toString) randomIO
|
||||
188
language-support/hs/bindings/examples/nim-console/src/Local.hs
Normal file
188
language-support/hs/bindings/examples/nim-console/src/Local.hs
Normal file
@ -0,0 +1,188 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
module Local(State(..), Onum(..), Gnum(..), initState, applyTransPureSimple, applyTrans,
|
||||
LCommand(..), externCommand,lookForAnAction,
|
||||
OpenState, getOpenState,
|
||||
LTrans,
|
||||
) where
|
||||
|
||||
import Prelude hiding(id)
|
||||
import Control.Monad(when)
|
||||
import qualified Data.List as List(find,concatMap)
|
||||
import Data.List ((\\))
|
||||
import Data.Maybe(mapMaybe,listToMaybe)
|
||||
import qualified Data.Map.Strict as Map(toList,lookup,empty,adjust,insert,elems,keys)
|
||||
import Data.Map.Strict (Map)
|
||||
|
||||
import Domain
|
||||
import External
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- local command, map to X in context of state
|
||||
|
||||
data LCommand
|
||||
= OfferNewGameToAnyone
|
||||
| OfferGameL Player
|
||||
| AcceptOfferL Onum
|
||||
| MakeMoveL Gnum Move
|
||||
deriving Show
|
||||
|
||||
externCommand :: Player -> State -> LCommand -> Maybe XCommand
|
||||
externCommand who state@State{knownPlayers} = \case
|
||||
OfferNewGameToAnyone -> do
|
||||
return $ OfferGame (Offer {from = who, to = knownPlayers \\ [who] })
|
||||
OfferGameL player -> do
|
||||
return $ OfferGame (Offer {from = who, to = [player] }) --can play self!
|
||||
AcceptOfferL lid -> do
|
||||
xid <- externOid state lid
|
||||
return $ AcceptOffer who xid
|
||||
MakeMoveL lid move -> do
|
||||
xid <- externGid state lid
|
||||
return $ MakeMove who xid move
|
||||
|
||||
externOid :: State -> Onum -> Maybe Xoid
|
||||
externOid State{offers} low = (fmap fst . List.find (\(_,(l,_,status)) -> l==low && status == Open) . Map.toList) offers
|
||||
|
||||
externGid :: State -> Gnum -> Maybe Xgid
|
||||
externGid State{games} low = (fmap fst . List.find (\(_,(l,_,status)) -> l==low && status == Open) . Map.toList) games
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- local trans, for reporting what happing in terms of local oid/gid
|
||||
data LTrans
|
||||
= NewOfferL Onum Offer
|
||||
| OfferNowUnavailable Onum Offer
|
||||
| NewGameL Gnum Game
|
||||
| GameMoveL Gnum Game
|
||||
deriving Show
|
||||
|
||||
-- TODO: return list, then caller can make random choice!
|
||||
lookForAnAction :: State -> Maybe LCommand
|
||||
lookForAnAction State{whoami,offers,games} =
|
||||
listToMaybe $
|
||||
-- prefer to play a game move..
|
||||
mapMaybe
|
||||
(\(onum,offer,status) ->
|
||||
if whoami `elem` to offer && status == Open
|
||||
then Just $ AcceptOfferL onum
|
||||
else Nothing
|
||||
) (Map.elems offers)
|
||||
++
|
||||
-- otherwise accept any pending offer
|
||||
List.concatMap
|
||||
-- randomize move order here !
|
||||
(\(gnum,game,status) ->
|
||||
if whoami == p1 game && status == Open
|
||||
then map (MakeMoveL gnum) (legalMovesOfGame game)
|
||||
else []
|
||||
) (Map.elems games)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- local state, accumulates external transitions
|
||||
|
||||
data State = State {
|
||||
whoami :: Player,
|
||||
knownPlayers :: [Player],
|
||||
offers :: Map Xoid (Onum,Offer,Status),
|
||||
games :: Map Xgid (Gnum,Game,Status),
|
||||
|
||||
-- TODO: share the next number thing for offers and games
|
||||
-- when an offer is converted to a game, keep the number
|
||||
-- this mean a X-NewGame wil need to refernce the offer is comes from
|
||||
nextOfferId :: Onum,
|
||||
nextGameId :: Gnum
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Status = Open | Closed
|
||||
deriving (Eq,Show)
|
||||
|
||||
initState :: Player -> [Player] -> State
|
||||
initState whoami knownPlayers = State {
|
||||
whoami,
|
||||
knownPlayers, -- TODO: = [] when support Hello
|
||||
offers = Map.empty,
|
||||
games = Map.empty,
|
||||
nextOfferId = Onum 1,
|
||||
nextGameId = Gnum 1
|
||||
}
|
||||
|
||||
data Onum = Onum Int deriving (Show,Eq) -- local offer id
|
||||
data Gnum = Gnum Int deriving (Show,Eq) -- local game id
|
||||
|
||||
incOfferId :: Onum -> Onum
|
||||
incOfferId (Onum n) = Onum (n+1)
|
||||
|
||||
incGameId :: Gnum -> Gnum
|
||||
incGameId (Gnum n) = Gnum (n+1)
|
||||
|
||||
applyTransPureSimple :: State -> XTrans -> State
|
||||
applyTransPureSimple s xt = either error snd (applyTrans s xt)
|
||||
|
||||
applyTrans :: State -> XTrans -> Either String ([LTrans], State)
|
||||
applyTrans state0 = \case
|
||||
NewOffer{xoid,offer} -> do
|
||||
let State{offers,nextOfferId=onum} = state0
|
||||
when (xoid `elem` Map.keys offers) $ fail "new offer, dup id"
|
||||
return (
|
||||
[NewOfferL onum offer],
|
||||
state0 { offers = Map.insert xoid (onum,offer,Open) offers,
|
||||
nextOfferId = incOfferId onum })
|
||||
|
||||
OfferWithdrawn{xoid,offer} -> do
|
||||
let State{offers} = state0
|
||||
case Map.lookup xoid offers of
|
||||
Nothing -> fail "offer withdrawm, unknown id"
|
||||
Just (onum,_,_) ->
|
||||
return (
|
||||
[OfferNowUnavailable onum offer],
|
||||
state0 { offers = Map.adjust archive xoid offers })
|
||||
|
||||
NewGame {xgid,game} -> do
|
||||
let State{games,nextGameId=gnum} = state0
|
||||
when (xgid `elem` Map.keys games) $ fail "new game, dup id"
|
||||
return (
|
||||
[NewGameL gnum game],
|
||||
state0 { games = Map.insert xgid (gnum,game,Open) games,
|
||||
nextGameId = incGameId gnum })
|
||||
|
||||
GameMove {oldXgid,newXgid,game} -> do
|
||||
let State{games} = state0
|
||||
when (newXgid `elem` Map.keys games) $ fail "game move, dup new id"
|
||||
case Map.lookup oldXgid games of
|
||||
Nothing -> fail "game move, unknown old id"
|
||||
Just (gnum,_,_) -> return (
|
||||
[GameMoveL gnum game],
|
||||
state0 { games = Map.insert newXgid (gnum,game,Open) (Map.adjust archive oldXgid games) }
|
||||
)
|
||||
|
||||
where archive (k,v,_) = (k,v,Closed)
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Visualize local open state
|
||||
|
||||
data OpenState = OpenState {
|
||||
me :: Player,
|
||||
oOffers :: [(Onum,Offer)],
|
||||
oGames :: [(Gnum,Game)]
|
||||
}
|
||||
|
||||
instance Show OpenState where
|
||||
show OpenState{me,oOffers,oGames} = unlines (
|
||||
[show me] ++
|
||||
["- offers:"] ++
|
||||
map (\(id,offer) -> "- " <> show id <> " = " <> show offer) oOffers ++
|
||||
["- games:"] ++
|
||||
map (\(id,game) -> "- " <> show id <> " = " <> show game) oGames
|
||||
)
|
||||
|
||||
getOpenState :: State -> OpenState
|
||||
getOpenState State{whoami=me,offers,games} = OpenState{me,oOffers,oGames}
|
||||
-- TODO: sort the games and offers, by index number
|
||||
-- geerally just make this prettier
|
||||
-- also, maybe have a summary version, which can show when switch whoami
|
||||
where
|
||||
oOffers = (map (\(id,offer,_) -> (id,offer)) . filter (\(_,_,status) -> status == Open) . Map.elems) offers
|
||||
oGames = (map (\(id,game,_) -> (id,game)) . filter (\(_,_,status) -> status == Open) . Map.elems) games
|
||||
@ -0,0 +1,27 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
module Logging (Logger,noLog,tagLog,colourLog,plainLog,colourWrap) where
|
||||
|
||||
import System.Console.ANSI(
|
||||
setSGRCode, Color(..), SGR(SetColor), ConsoleLayer(Foreground), ColorIntensity(Vivid),)
|
||||
|
||||
type Logger = String -> IO ()
|
||||
|
||||
noLog :: Logger
|
||||
noLog _ = return ()
|
||||
|
||||
plainLog :: Logger
|
||||
plainLog = putStrLn
|
||||
|
||||
colourWrap :: Color -> String -> String
|
||||
colourWrap col s =
|
||||
setSGRCode [SetColor Foreground Vivid col] <> s <>
|
||||
setSGRCode [SetColor Foreground Vivid White]
|
||||
|
||||
colourLog :: Color -> Logger -> Logger
|
||||
colourLog col log s = log (colourWrap col s)
|
||||
|
||||
tagLog :: String -> Logger -> Logger
|
||||
tagLog tag log s = log (tag <> s)
|
||||
@ -0,0 +1,7 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module Main(main) where
|
||||
import qualified UI(main)
|
||||
main :: IO ()
|
||||
main = UI.main
|
||||
@ -0,0 +1,8 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module PastAndFuture(PastAndFuture(..)) where
|
||||
|
||||
import Stream
|
||||
|
||||
data PastAndFuture a = PF { past :: [a], future :: Stream a }
|
||||
@ -0,0 +1,137 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
-- Simulate a ledger
|
||||
-- Accepting commands, and feeding back the resultant transitions
|
||||
|
||||
module SimLedger(Handle, connect, sendCommand, getTrans) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad(when,filterM)
|
||||
import Data.List as List(filter)
|
||||
import qualified Data.Map.Strict as Map(lookup,empty,adjust,insert)
|
||||
import Data.Map.Strict (Map)
|
||||
import System.Time.Extra(sleep)
|
||||
|
||||
import Domain
|
||||
import External
|
||||
import Stream
|
||||
import PastAndFuture
|
||||
|
||||
data Client = Client { player :: Player, stream :: Stream XTrans }
|
||||
|
||||
newClient :: Player -> IO Client
|
||||
newClient player = do
|
||||
stream <- newStream
|
||||
return Client{player,stream}
|
||||
|
||||
sendToClient :: XTrans -> Client -> IO ()
|
||||
sendToClient xt Client{player,stream} = do
|
||||
when (canSeeTrans player xt) $ writeStream stream (Right xt)
|
||||
|
||||
isClientClosed :: Client -> IO Bool
|
||||
isClientClosed Client{stream} = do
|
||||
Stream.isClosed stream >>= \case
|
||||
Just _ -> return True
|
||||
Nothing -> return False
|
||||
|
||||
sendListToClients :: [XTrans] -> [Client] -> IO ()
|
||||
sendListToClients xts clients =
|
||||
mapM_ (\xt -> mapM_ (sendToClient xt) clients) xts
|
||||
|
||||
after :: Double -> IO () -> IO ()
|
||||
after n action = do
|
||||
_ <- forkIO (do sleep n; action)
|
||||
return ()
|
||||
|
||||
data Handle = LH {
|
||||
state :: MVar Ledger,
|
||||
history :: MVar [XTrans],
|
||||
watching :: MVar [Client]
|
||||
}
|
||||
|
||||
connect :: IO Handle
|
||||
connect = do
|
||||
state <- newMVar emptyLedger
|
||||
history <- newMVar []
|
||||
watching <- newMVar []
|
||||
return LH {state,history,watching}
|
||||
|
||||
sendCommand :: Handle -> XCommand -> IO (Maybe Rejection)
|
||||
sendCommand LH{state,watching,history} com = do
|
||||
ledger <- takeMVar state
|
||||
(ledger',rejOpt,xts) <- recordOnLedger ledger com
|
||||
putMVar state ledger'
|
||||
modifyMVar_ history (return . (reverse xts ++))
|
||||
clients <- takeMVar watching
|
||||
-- TODO: would be better to setup onClose handler
|
||||
clients' <- filterM (fmap not . isClientClosed) clients
|
||||
putMVar watching clients'
|
||||
-- delay to simulate the lag of a real ledger
|
||||
after 1.5 (sendListToClients xts clients')
|
||||
return rejOpt
|
||||
|
||||
getTrans :: Player -> Handle -> IO (PastAndFuture XTrans)
|
||||
getTrans player LH{watching,history} = do
|
||||
client@Client{stream=future} <- newClient player
|
||||
modifyMVar_ watching (return . (client:))
|
||||
past <- fmap (reverse . List.filter (canSeeTrans player)) $ readMVar history
|
||||
return PF{past, future}
|
||||
|
||||
canSeeTrans :: Player -> XTrans -> Bool
|
||||
canSeeTrans player xt = player `elem` playersOfTrans xt
|
||||
|
||||
playersOfTrans :: XTrans -> [Player]
|
||||
playersOfTrans = \case
|
||||
NewOffer {offer} -> playersOfOffer offer
|
||||
OfferWithdrawn{offer} -> playersOfOffer offer
|
||||
NewGame {game} -> playersOfGame game
|
||||
GameMove {game} -> playersOfGame game
|
||||
|
||||
data Ledger = Ledger (Map Xoid (Offer,Bool)) (Map Xgid (Game,Bool))
|
||||
|
||||
emptyLedger :: Ledger
|
||||
emptyLedger = Ledger Map.empty Map.empty
|
||||
|
||||
type Rejection = String
|
||||
|
||||
-- TODO: Better return type -- IO (Either Rejection (Ledger,[XTrans]))
|
||||
-- which makes clear than on rejection we chage nothing & generate no xtrans
|
||||
recordOnLedger :: Ledger -> XCommand -> IO (Ledger,Maybe Rejection,[XTrans])
|
||||
recordOnLedger ledger@(Ledger os gs) = \case
|
||||
|
||||
OfferGame offer -> do
|
||||
oid <- genXoid
|
||||
let os' = Map.insert oid (offer,True) os
|
||||
accept (Ledger os' gs) [NewOffer oid offer]
|
||||
|
||||
AcceptOffer acceptor oid ->
|
||||
case Map.lookup oid os of
|
||||
Nothing -> reject "no such oid"
|
||||
Just (_,False) -> reject "double accept"
|
||||
Just (offer,True) -> do
|
||||
let os' = Map.adjust archive oid os
|
||||
if acceptor `notElem` to offer then reject "not in offer to-list" else do
|
||||
xgid <- genXgid
|
||||
let game = initGame acceptor (from offer)
|
||||
let gs' = Map.insert xgid (game,True) gs
|
||||
accept (Ledger os' gs') [OfferWithdrawn oid offer, NewGame {xgid, game}]
|
||||
|
||||
MakeMove player gid move ->
|
||||
case Map.lookup gid gs of
|
||||
Nothing -> reject "no such gid"
|
||||
Just (_,False) -> reject "double play"
|
||||
Just (game,True) -> do
|
||||
if player /= p1 game then reject "not player1" else do
|
||||
gid' <- genXgid
|
||||
case playMove move game of
|
||||
Left reason -> reject reason
|
||||
Right game' -> do
|
||||
let gs' = Map.insert gid' (game',True) (Map.adjust archive gid gs)
|
||||
accept (Ledger os gs') [GameMove gid gid' game']
|
||||
|
||||
where
|
||||
accept l ts = return (l,Nothing,ts)
|
||||
reject reason = return (ledger,Just reason,[])
|
||||
archive (x,_) = (x,False)
|
||||
@ -0,0 +1,92 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
-- TODO: better name than "clients" for the onClose callbacks?
|
||||
|
||||
-- Streams which are closable at both ends.
|
||||
-- When closed (at the read-end), elements in flight are dropped, clients are notified
|
||||
-- When closure is requested at the write-end, elements in flight are processed. The stream becomes properly closed when the closure request reaches the read-end of the stream. Subsequent writes are dropped.
|
||||
|
||||
module Stream(Stream, newStream,
|
||||
Closed(..), onClose, closeStream,
|
||||
takeStream,
|
||||
writeStream,
|
||||
whenClosed, isClosed,
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
|
||||
newtype Stream a = Stream {status :: MVar (Either Closed (Open a))}
|
||||
|
||||
newtype Closed = Closed { reason :: String }
|
||||
|
||||
data Open a = Open {
|
||||
chan :: Chan (Either Closed a),
|
||||
clients :: MVar [Closed -> IO ()] -- notified on close
|
||||
}
|
||||
|
||||
-- Create a new open stream.
|
||||
newStream :: IO (Stream a)
|
||||
newStream = do
|
||||
chan <- newChan
|
||||
clients <- newMVar []
|
||||
status <- newMVar (Right (Open {chan,clients}))
|
||||
return Stream{status}
|
||||
|
||||
-- Set a callback for when a stream becomes closed.
|
||||
-- Called immediately if the stream is already closed.
|
||||
onClose :: Stream a -> (Closed -> IO ()) -> IO ()
|
||||
onClose Stream{status} f = do
|
||||
readMVar status >>= \case
|
||||
Left closed -> f closed -- already closed, call f now
|
||||
Right Open{clients} -> do
|
||||
modifyMVar_ clients (return . (f:))
|
||||
|
||||
-- Close stream now! Elements in flight are lost. Clients are notified.
|
||||
closeStream :: Stream a -> Closed -> IO ()
|
||||
closeStream Stream{status} closed = do
|
||||
takeMVar status >>= \case
|
||||
Left alreadyClosed -> putMVar status (Left alreadyClosed) -- do nothing
|
||||
Right Open{clients} -> do
|
||||
putMVar status (Left closed) -- now can't get new clients
|
||||
fs <- readMVar clients
|
||||
mapM_ (\f -> f closed) fs
|
||||
|
||||
-- Get the next element from a stream, or find the stream is closed.
|
||||
-- (Blocking until one of the above occurs)
|
||||
takeStream :: Stream a -> IO (Either Closed a)
|
||||
takeStream Stream{status} = do
|
||||
readMVar status >>= \case
|
||||
Left closed -> return (Left closed)
|
||||
Right Open{chan} -> do
|
||||
readChan chan >>= \case
|
||||
Right a -> return (Right a)
|
||||
Left closed -> do
|
||||
-- closed the stream, as requested by writer
|
||||
modifyMVar_ status (\_ -> return (Left closed))
|
||||
-- forward the closure request in case of multiple blocked readers
|
||||
writeChan chan (Left closed)
|
||||
return (Left closed)
|
||||
|
||||
-- Write an element onto the stream,
|
||||
-- Or write a closure-request which happens after elems in flight are processed.
|
||||
writeStream :: Stream a -> Either Closed a -> IO ()
|
||||
writeStream Stream{status} item = do
|
||||
readMVar status >>= \case
|
||||
Left _closed -> return () -- already closed, item dropped on floor
|
||||
Right Open{chan} -> writeChan chan item
|
||||
|
||||
-- Block until the stream is closed, which might be already
|
||||
whenClosed :: Stream a -> IO Closed
|
||||
whenClosed stream = do
|
||||
signal <- newEmptyMVar
|
||||
onClose stream (putMVar signal)
|
||||
takeMVar signal
|
||||
|
||||
-- Is the stream closed right now?
|
||||
isClosed :: Stream a -> IO (Maybe Closed)
|
||||
isClosed Stream{status} =
|
||||
readMVar status >>= \case
|
||||
Left closed -> return (Just closed)
|
||||
Right _ -> return Nothing
|
||||
240
language-support/hs/bindings/examples/nim-console/src/UI.hs
Normal file
240
language-support/hs/bindings/examples/nim-console/src/UI.hs
Normal file
@ -0,0 +1,240 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
module UI(main) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Foldable(forM_)
|
||||
import Prelude hiding (id)
|
||||
import System.Console.ANSI(Color(..))
|
||||
import qualified System.Console.Haskeline as HL (InputT,runInputT,getInputLine,defaultSettings,getExternalPrint)
|
||||
import Text.Read (readMaybe)
|
||||
import System.Time.Extra(sleep)
|
||||
|
||||
import Domain
|
||||
import Stream
|
||||
import PastAndFuture
|
||||
import External
|
||||
|
||||
import Local(State,LCommand,Onum(..),Gnum(..))
|
||||
import qualified Local
|
||||
|
||||
import qualified SimLedger as Ledger
|
||||
import SimLedger(Handle)
|
||||
|
||||
import Logging
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- players, colours
|
||||
|
||||
alice,bob,charles :: Player
|
||||
alice = Player "alice"
|
||||
bob = Player "bob"
|
||||
charles = Player "charles"
|
||||
|
||||
|
||||
message :: String -> IO ()
|
||||
message = colourLog Cyan plainLog
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- PlayerState
|
||||
|
||||
data PlayerState = PlayerState {
|
||||
player :: Player,
|
||||
sv :: MVar State,
|
||||
stream :: Stream XTrans
|
||||
}
|
||||
|
||||
makePlayerState :: Handle -> Logger -> Player -> IO PlayerState
|
||||
makePlayerState h xlog player = do
|
||||
-- TODO: handle knownPlayers by "Hello" contracts
|
||||
let knownPlayers = [alice,bob,charles] -- john *not* a known player
|
||||
let s = Local.initState player knownPlayers
|
||||
sv <- newMVar s
|
||||
stream <- manageUpdates h player (playerLog player xlog) sv
|
||||
return PlayerState{player,sv,stream}
|
||||
|
||||
|
||||
playerLog :: Player -> Logger -> Logger
|
||||
playerLog player log =
|
||||
tagLog ("(" <> show player <> ") ") $
|
||||
--colourLog (colourForPlayer player) log
|
||||
colourLog Blue log
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main
|
||||
|
||||
main :: IO ()
|
||||
main = HL.runInputT HL.defaultSettings $ do
|
||||
h <- lift Ledger.connect
|
||||
xlog <- HL.getExternalPrint
|
||||
let player = alice -- initial interactive player
|
||||
lift $ runBotFor h bob
|
||||
lift $ runBotFor h charles -- 2nd bot
|
||||
ps <- lift $ makePlayerState h xlog player
|
||||
readLoop h xlog ps
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- readLoop
|
||||
|
||||
promptPlayer :: Player -> String
|
||||
promptPlayer player =
|
||||
--colourWrap (colourForPlayer player) (show player <> "> ")
|
||||
colourWrap Green (show player <> "> ")
|
||||
|
||||
readLoop :: Handle -> Logger -> PlayerState -> HL.InputT IO ()
|
||||
readLoop h xlog ps = do
|
||||
let PlayerState{player} = ps
|
||||
lineOpt <- HL.getInputLine (promptPlayer player)
|
||||
case lineOpt of
|
||||
Nothing -> return ()
|
||||
Just line -> do
|
||||
ps' <- lift $ processLine h xlog ps line
|
||||
readLoop h xlog ps'
|
||||
|
||||
processLine :: Handle -> Logger -> PlayerState -> String -> IO PlayerState
|
||||
processLine h xlog ps line = do
|
||||
case parseWords (words line) of
|
||||
Nothing -> do
|
||||
message $ "failed to parse: " <> line
|
||||
return ps
|
||||
Just res -> runParsed h xlog ps res
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- parse console input line
|
||||
|
||||
data LQuery
|
||||
= ShowFullState --debug
|
||||
| ShowOpenState
|
||||
-- TODO: individual game state
|
||||
|
||||
data Parsed
|
||||
= Submit LCommand
|
||||
| Query LQuery
|
||||
| Become Player
|
||||
|
||||
parseWords :: [String] -> Maybe Parsed
|
||||
parseWords = \case
|
||||
["become",p] -> do
|
||||
return $ Become (Player p)
|
||||
["show"] ->
|
||||
return $ Query ShowOpenState
|
||||
["show","full"] ->
|
||||
return $ Query ShowFullState
|
||||
["offer"] ->
|
||||
return $ Submit Local.OfferNewGameToAnyone
|
||||
["offer",p] -> do
|
||||
return $ Submit $ Local.OfferGameL (Player p)
|
||||
["accept",o] -> do
|
||||
oid <- parseOnum o
|
||||
return $ Submit $ Local.AcceptOfferL oid
|
||||
["move",g,p,n] -> do
|
||||
gid <- parseGnum g
|
||||
pileNum <- readMaybe p
|
||||
howMany <- readMaybe n
|
||||
return $ Submit $ Local.MakeMoveL gid (Move {pileNum,howMany})
|
||||
_ ->
|
||||
Nothing
|
||||
|
||||
parseOnum :: String -> Maybe Onum
|
||||
parseOnum s = fmap Onum (readMaybe s)
|
||||
|
||||
parseGnum :: String -> Maybe Gnum
|
||||
parseGnum s = fmap Gnum (readMaybe s)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- run thhe parsed command
|
||||
|
||||
runParsed :: Handle -> Logger -> PlayerState -> Parsed -> IO PlayerState
|
||||
runParsed h xlog ps = \case
|
||||
Submit lc -> do
|
||||
runSubmit h message ps lc
|
||||
return ps
|
||||
Query lq -> do
|
||||
let PlayerState{sv} = ps
|
||||
s <- readMVar sv
|
||||
runLocalQuery s lq
|
||||
return ps
|
||||
Become player' -> do
|
||||
message $ "becoming: " <> show player'
|
||||
let PlayerState{stream} = ps
|
||||
closeStream stream (Closed "changing player")
|
||||
makePlayerState h xlog player'
|
||||
|
||||
runLocalQuery :: State -> LQuery -> IO ()
|
||||
runLocalQuery s = \case
|
||||
ShowFullState -> message (show s)
|
||||
ShowOpenState -> message (show (Local.getOpenState s))
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- runSubmit (used by runParsed and robot)
|
||||
|
||||
runSubmit :: Handle -> Logger -> PlayerState -> LCommand -> IO ()
|
||||
runSubmit h log ps lc = do
|
||||
--log $ "lc: " <> show lc
|
||||
let PlayerState{player,sv} = ps
|
||||
s <- readMVar sv
|
||||
case Local.externCommand player s lc of
|
||||
Nothing -> do
|
||||
log $ "bad local command: " <> show lc
|
||||
return ()
|
||||
Just xc -> do
|
||||
Ledger.sendCommand h xc >>= \case
|
||||
Nothing -> return ()
|
||||
Just rej -> do
|
||||
log $ "command rejected by ledger: " <> rej
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Manage updates in response to XTrans from the ledger
|
||||
|
||||
manageUpdates :: Handle -> Player -> Logger -> MVar State -> IO (Stream XTrans)
|
||||
manageUpdates h player log sv = do
|
||||
PF{past,future} <- Ledger.getTrans player h
|
||||
modifyMVar_ sv (\s -> return $ foldl Local.applyTransPureSimple s past)
|
||||
_ <- forkIO (updateX log sv future)
|
||||
return future
|
||||
|
||||
updateX :: Logger -> MVar State -> Stream XTrans -> IO ()
|
||||
updateX log sv stream = loop
|
||||
where
|
||||
loop = takeStream stream >>= \case
|
||||
Left Closed{} -> do
|
||||
log "transaction stream is closed"
|
||||
return () -- forked thread will terminate
|
||||
Right xt ->
|
||||
do applyX log sv xt; loop
|
||||
|
||||
applyX :: Logger -> MVar State -> XTrans -> IO ()
|
||||
applyX log sv xt = do
|
||||
s <- takeMVar sv
|
||||
--log $ "xt: " <> show xt
|
||||
(lts,s') <- either fail return (Local.applyTrans s xt)
|
||||
mapM_ (\lt -> log $ "lt: " <> show lt) lts -- TODO: improve message for "local trans"
|
||||
putMVar sv s'
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- robot
|
||||
|
||||
runBotFor :: Handle -> Player -> IO ()
|
||||
runBotFor h player = do
|
||||
ps <- makePlayerState h noLog player
|
||||
_tid <- forkIO (robot h noLog ps)
|
||||
return ()
|
||||
|
||||
|
||||
robot :: Handle -> Logger -> PlayerState -> IO ()
|
||||
robot h log ps = loop
|
||||
where
|
||||
loop = do
|
||||
sleep 2
|
||||
log "thinking..."
|
||||
let PlayerState{sv} = ps
|
||||
s <- readMVar sv
|
||||
forM_ (Local.lookForAnAction s) (runSubmit h noLog ps) -- quiet!
|
||||
loop
|
||||
@ -6,123 +6,148 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module DA.Ledger( -- WIP: High level interface to the Ledger API services
|
||||
module DA.Ledger.Types,
|
||||
Port(..),
|
||||
LedgerHandle,
|
||||
Party(..),
|
||||
LL_Transaction, -- TODO: remove
|
||||
ResponseStream,
|
||||
connect,
|
||||
identity,
|
||||
getTransactionStream,
|
||||
nextResponse,
|
||||
|
||||
-- services
|
||||
listPackages,
|
||||
getPackage, Package,
|
||||
transactions,
|
||||
completions,
|
||||
submitCommands,
|
||||
getCompletionStream,
|
||||
|
||||
module DA.Ledger.Types,
|
||||
LL_Transaction, -- TODO: remove when coded `raise' (LL->HL) operation on Transaction types
|
||||
|
||||
Port(..),
|
||||
|
||||
Stream, takeStream, getStreamContents,
|
||||
|
||||
LedgerHandle, connect, identity,
|
||||
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Fix (fix)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text.Lazy as Text
|
||||
import Data.Vector as Vector (fromList, toList)
|
||||
import Prelude hiding (log)
|
||||
|
||||
import DA.Ledger.Types
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (Exception,SomeException,catch,throwIO)
|
||||
import Control.Monad.Fix (fix)
|
||||
import qualified Data.Map as Map(empty,singleton)
|
||||
import qualified Data.Text.Lazy as Text(unpack)
|
||||
import qualified Data.Vector as Vector(toList,fromList)
|
||||
import DA.Ledger.Convert(lowerCommands)
|
||||
import DA.Ledger.LowLevel as LL hiding(Commands)
|
||||
|
||||
import qualified DA.Ledger.LowLevel as LL
|
||||
|
||||
import DA.Ledger.LowLevel(
|
||||
|
||||
ClientRequest(
|
||||
ClientReaderRequest,
|
||||
ClientNormalRequest
|
||||
),
|
||||
ClientResult(
|
||||
ClientErrorResponse,
|
||||
ClientReaderResponse,
|
||||
ClientNormalResponse
|
||||
),
|
||||
MetadataMap(..),
|
||||
GRPCMethodType(Normal,ServerStreaming),
|
||||
ClientConfig(..),
|
||||
Port(..),
|
||||
Host(..),
|
||||
|
||||
LedgerIdentityService(..),
|
||||
GetLedgerIdentityRequest(..),
|
||||
GetLedgerIdentityResponse(..),
|
||||
|
||||
TransactionService(..),
|
||||
GetTransactionsRequest(..),
|
||||
GetTransactionsResponse(..),
|
||||
|
||||
CommandSubmissionService(..),
|
||||
SubmitRequest(..),
|
||||
Empty(..),
|
||||
|
||||
CommandCompletionService(..),
|
||||
CompletionStreamRequest(..),
|
||||
CompletionStreamResponse(completionStreamResponseCompletions),
|
||||
|
||||
TransactionFilter(..),
|
||||
Filters(..),
|
||||
LedgerOffset(..),
|
||||
LedgerOffsetValue(..),
|
||||
LedgerOffset_LedgerBoundary(..),
|
||||
TraceContext,
|
||||
)
|
||||
import qualified Proto3.Suite(fromByteString)
|
||||
import qualified DA.Daml.LF.Ast as LF(Package)
|
||||
import qualified DA.Daml.LF.Proto3.Decode as Decode(decodePayload)
|
||||
|
||||
data LedgerHandle = LedgerHandle { port :: Port, lid :: LedgerId }
|
||||
|
||||
identity :: LedgerHandle -> LedgerId
|
||||
identity LedgerHandle{lid} = lid
|
||||
|
||||
|
||||
newtype ResponseStream a = ResponseStream { chan :: Chan a }
|
||||
|
||||
nextResponse :: ResponseStream a -> IO a
|
||||
nextResponse ResponseStream{chan} = readChan chan
|
||||
|
||||
connect :: Port -> IO LedgerHandle
|
||||
connect port = do
|
||||
connect port = wrapE "connect" $ do
|
||||
lid <- getLedgerIdentity port
|
||||
return $ LedgerHandle {port, lid}
|
||||
|
||||
|
||||
getLedgerIdentity :: Port -> IO LedgerId
|
||||
getLedgerIdentity port = do
|
||||
getLedgerIdentity port = wrapE "getLedgerIdentity" $ do
|
||||
let request = GetLedgerIdentityRequest noTrace
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
service <- LL.ledgerIdentityServiceClient client
|
||||
let LedgerIdentityService rpc = service
|
||||
response <- rpc (wrap (GetLedgerIdentityRequest noTrace))
|
||||
response <- rpc (ClientNormalRequest request timeout mdm)
|
||||
GetLedgerIdentityResponse text <- unwrap response
|
||||
return $ LedgerId text
|
||||
|
||||
listPackages :: LedgerHandle -> IO [PackageId]
|
||||
listPackages LedgerHandle{port,lid} = wrapE "listPackages" $ do
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
service <- LL.packageServiceClient client
|
||||
let PackageService rpc1 _ _ = service
|
||||
let request = ListPackagesRequest (unLedgerId lid) noTrace
|
||||
response <- rpc1 (ClientNormalRequest request timeout mdm)
|
||||
ListPackagesResponse xs <- unwrap response
|
||||
return $ map PackageId $ Vector.toList xs
|
||||
|
||||
data Package = Package LF.Package deriving Show
|
||||
|
||||
getPackage :: LedgerHandle -> PackageId -> IO Package
|
||||
getPackage LedgerHandle{port,lid} pid = wrapE "getPackage" $ do
|
||||
let request = GetPackageRequest (unLedgerId lid) (unPackageId pid) noTrace
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
service <- LL.packageServiceClient client
|
||||
let PackageService _ rpc2 _ = service
|
||||
response <- rpc2 (ClientNormalRequest request timeout mdm)
|
||||
GetPackageResponse _ bs _ <- unwrap response
|
||||
let ap = either (error . show) id (Proto3.Suite.fromByteString bs)
|
||||
case Decode.decodePayload ap of
|
||||
Left e -> fail (show e)
|
||||
Right package -> return (Package package)
|
||||
|
||||
submitCommands :: LedgerHandle -> Commands -> IO ()
|
||||
submitCommands h commands = do
|
||||
let request = wrap (SubmitRequest (Just (lowerCommands commands)) noTrace)
|
||||
let LedgerHandle{port} = h
|
||||
submitCommands LedgerHandle{port} commands = wrapE "submitCommands" $ do
|
||||
let request = SubmitRequest (Just (lowerCommands commands)) noTrace
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
service <- LL.commandSubmissionServiceClient client
|
||||
let CommandSubmissionService rpc = service
|
||||
response <- rpc request
|
||||
response <- rpc (ClientNormalRequest request timeout mdm)
|
||||
Empty{} <- unwrap response
|
||||
return ()
|
||||
|
||||
|
||||
wrap :: r -> ClientRequest 'Normal r a
|
||||
wrap r = ClientNormalRequest r timeout mdm
|
||||
where timeout = 3
|
||||
timeout :: Int -- Seconds
|
||||
timeout = 30 -- TODO: sensible default? user configuarable?
|
||||
|
||||
unwrap :: ClientResult 'Normal a -> IO a
|
||||
unwrap = \case
|
||||
ClientNormalResponse x _m1 _m2 _status _details -> return x
|
||||
ClientErrorResponse e -> fail (show e)
|
||||
|
||||
mdm :: MetadataMap
|
||||
mdm = MetadataMap Map.empty
|
||||
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Services with streaming responses
|
||||
|
||||
data Elem a = Elem a | Eend | Eerr String
|
||||
|
||||
deElem :: Elem a -> IO a
|
||||
deElem = \case
|
||||
Elem a -> return a
|
||||
Eend -> fail "readStream, end"
|
||||
Eerr s -> fail $ "readStream, err: " <> s
|
||||
|
||||
newtype Stream a = Stream { mv :: MVar (Elem a) }
|
||||
|
||||
newStream :: IO (Stream a)
|
||||
newStream = do
|
||||
mv <- newEmptyMVar
|
||||
return Stream{mv}
|
||||
|
||||
writeStream :: Stream a -> Elem a -> IO () -- internal use only
|
||||
writeStream Stream{mv} elem = putMVar mv elem
|
||||
|
||||
takeStream :: Stream a -> IO a
|
||||
takeStream Stream{mv} = takeMVar mv >>= deElem
|
||||
|
||||
data StreamState = SS -- TODO
|
||||
getStreamContents :: Stream a -> IO ([a],StreamState)
|
||||
getStreamContents Stream{mv} = do xs <- loop ; return (xs,SS)
|
||||
where
|
||||
loop = do
|
||||
tryTakeMVar mv >>= \case
|
||||
Nothing -> return []
|
||||
Just e -> do
|
||||
x <- deElem e
|
||||
xs <- loop
|
||||
return (x:xs)
|
||||
|
||||
-- wrap LL.Transaction to show summary
|
||||
newtype LL_Transaction = LL_Transaction { low :: LL.Transaction } --TODO: remove
|
||||
deriving Eq
|
||||
|
||||
instance Show LL_Transaction where
|
||||
show LL_Transaction{low} = _summary
|
||||
@ -131,45 +156,50 @@ instance Show LL_Transaction where
|
||||
_full = show low
|
||||
LL.Transaction{transactionTransactionId} = low
|
||||
|
||||
|
||||
-- TODO: return (HL) [Transaction]
|
||||
getTransactionStream :: LedgerHandle -> Party -> IO (ResponseStream LL_Transaction)
|
||||
getTransactionStream h party = do
|
||||
let tag = "getTransactionStream for " <> show party
|
||||
let LedgerHandle{port,lid} = h
|
||||
chan <- newChan
|
||||
transactions :: LedgerHandle -> Party -> IO (Stream LL_Transaction)
|
||||
transactions LedgerHandle{port,lid} party = wrapE "transactions" $ do
|
||||
stream <- newStream
|
||||
let request = mkGetTransactionsRequest lid offsetBegin Nothing (filterEverthingForParty party)
|
||||
forkIO_ tag $
|
||||
_ <- forkIO $ --TODO: dont use forkIO
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
rpcs <- LL.transactionServiceClient client
|
||||
let (TransactionService rpc1 _ _ _ _ _ _) = rpcs
|
||||
sendToChan request f chan rpc1
|
||||
return $ ResponseStream{chan}
|
||||
sendToStream request f stream rpc1
|
||||
return stream
|
||||
where f = map LL_Transaction . Vector.toList . getTransactionsResponseTransactions
|
||||
|
||||
|
||||
-- TODO: return (HL) [Completion]
|
||||
getCompletionStream :: LedgerHandle -> ApplicationId -> [Party] -> IO (ResponseStream LL.Completion)
|
||||
getCompletionStream h aid partys = do
|
||||
let tag = "getCompletionStream for " <> show (aid,partys)
|
||||
let LedgerHandle{port,lid} = h
|
||||
chan <- newChan
|
||||
completions :: LedgerHandle -> ApplicationId -> [Party] -> IO (Stream LL.Completion)
|
||||
completions LedgerHandle{port,lid} aid partys = wrapE "completions" $ do
|
||||
stream <- newStream
|
||||
let request = mkCompletionStreamRequest lid aid partys
|
||||
forkIO_ tag $
|
||||
_ <- forkIO $ --TODO: dont use forkIO
|
||||
LL.withGRPCClient (config port) $ \client -> do
|
||||
rpcs <- LL.commandCompletionServiceClient client
|
||||
let (CommandCompletionService rpc1 _) = rpcs
|
||||
sendToChan request (Vector.toList . completionStreamResponseCompletions) chan rpc1
|
||||
return $ ResponseStream{chan}
|
||||
sendToStream request (Vector.toList . completionStreamResponseCompletions) stream rpc1
|
||||
return stream
|
||||
|
||||
sendToChan :: a -> (b -> [c]) -> Chan c -> (ClientRequest 'ServerStreaming a b -> IO (ClientResult 'ServerStreaming b)) -> IO ()
|
||||
sendToChan request f chan rpc1 = do
|
||||
sendToStream :: a -> (b -> [c]) -> Stream c -> (ClientRequest 'ServerStreaming a b -> IO (ClientResult 'ServerStreaming b)) -> IO ()
|
||||
sendToStream request f stream rpc1 = do
|
||||
ClientReaderResponse _meta _code _details <- rpc1 $
|
||||
ClientReaderRequest request timeout mdm $ \ _mdm recv -> fix $
|
||||
ClientReaderRequest request timeout mdm $ \ _mdm recv -> fix $ -- TODO: whileM better?
|
||||
\again -> do
|
||||
either <- recv
|
||||
case either of
|
||||
Left e -> fail (show e)
|
||||
Right Nothing -> return ()
|
||||
Right (Just x) -> do writeList2Chan chan (f x); again
|
||||
Left e -> do
|
||||
writeStream stream (Eerr (show e)) -- notify reader of error
|
||||
return ()
|
||||
Right Nothing -> do
|
||||
writeStream stream Eend -- notify reader of end-of-stream
|
||||
return ()
|
||||
Right (Just x) ->
|
||||
do
|
||||
mapM_ (writeStream stream . Elem) (f x)
|
||||
again
|
||||
return ()
|
||||
-- After a minute, we stop collecting the events.
|
||||
-- But we ought to wait indefinitely.
|
||||
@ -183,9 +213,6 @@ config port =
|
||||
, clientSSLConfig = Nothing
|
||||
}
|
||||
|
||||
mdm :: MetadataMap
|
||||
mdm = MetadataMap Map.empty
|
||||
|
||||
|
||||
-- Low level data mapping for Request
|
||||
|
||||
@ -224,15 +251,8 @@ noTrace :: Maybe TraceContext
|
||||
noTrace = Nothing
|
||||
|
||||
|
||||
-- Misc / logging
|
||||
data LedgerApiException = LedgerApiException { tag :: String, underlying :: SomeException } deriving Show
|
||||
instance Exception LedgerApiException
|
||||
|
||||
forkIO_ :: String -> IO () -> IO ()
|
||||
forkIO_ tag m = do
|
||||
tid <- forkIO $ do m; log $ tag <> " is done"
|
||||
log $ "forking " <> tag <> " on " <> show tid
|
||||
return ()
|
||||
|
||||
log :: String -> IO ()
|
||||
log s = do
|
||||
tid <- myThreadId
|
||||
putStrLn $ "[" <> show tid <> "]: " ++ s
|
||||
wrapE :: String -> IO a -> IO a
|
||||
wrapE tag io = io `catch` \e -> throwIO (LedgerApiException {tag,underlying=e})
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
module DA.Ledger.LowLevel(module X) where -- Low level GRPC and Generated Haskell code
|
||||
|
||||
import Network.GRPC.HighLevel.Generated as X
|
||||
|
||||
import Proto3.Suite.Types as X
|
||||
|
||||
import Google.Protobuf.Empty as X
|
||||
@ -25,3 +26,5 @@ import Com.Digitalasset.Ledger.Api.V1.Transaction as X
|
||||
import Com.Digitalasset.Ledger.Api.V1.TransactionFilter as X
|
||||
import Com.Digitalasset.Ledger.Api.V1.TransactionService as X
|
||||
import Com.Digitalasset.Ledger.Api.V1.Value as X
|
||||
|
||||
import Da.DamlLf as X hiding (HashFunction,HashFunctionSHA256)
|
||||
|
||||
@ -73,6 +73,7 @@ data Command
|
||||
createArgs :: Record,
|
||||
choice :: Choice,
|
||||
choiceArg :: Value }
|
||||
deriving Show
|
||||
|
||||
-- completion.proto
|
||||
|
||||
@ -80,6 +81,7 @@ data Completion
|
||||
= Completion {
|
||||
cid :: CommandId,
|
||||
status :: Status }
|
||||
deriving Show
|
||||
|
||||
-- transaction.proto
|
||||
|
||||
@ -90,7 +92,7 @@ data WIP_Transaction
|
||||
wid :: Maybe WorkflowId,
|
||||
leTime :: Timestamp,
|
||||
events :: [Event],
|
||||
ofset :: AbsOffset }
|
||||
ofset :: AbsOffset } deriving Show
|
||||
|
||||
-- event.proto
|
||||
|
||||
@ -118,7 +120,7 @@ data Event
|
||||
acting :: [Party],
|
||||
consuming :: Bool,
|
||||
witness :: [Party],
|
||||
childEids :: [EventId] }
|
||||
childEids :: [EventId] } deriving Show
|
||||
|
||||
-- value.proto
|
||||
|
||||
@ -128,7 +130,7 @@ data Value
|
||||
| VContract ContractId
|
||||
| VList [Value]
|
||||
| VInt Int
|
||||
| VDecimal Text -- TODO: why not Int?
|
||||
| VDecimal Text -- TODO: Maybe use Haskell Decimal type
|
||||
| VString Text
|
||||
| VTimestamp MicroSecondsSinceEpoch
|
||||
| VParty Party
|
||||
@ -137,63 +139,66 @@ data Value
|
||||
| VDate DaysSinceEpoch
|
||||
| VOpt (Maybe Value)
|
||||
| VMap (Map Text Value)
|
||||
deriving Show
|
||||
|
||||
data Record
|
||||
= Record {
|
||||
rid :: Maybe Identifier,
|
||||
fields :: [RecordField] }
|
||||
fields :: [RecordField] } deriving Show
|
||||
|
||||
data RecordField
|
||||
= RecordField {
|
||||
label :: Text,
|
||||
value :: Value }
|
||||
value :: Value } deriving Show
|
||||
|
||||
data Variant
|
||||
= Variant {
|
||||
vid :: VariantId,
|
||||
constructor :: ConstructorId,
|
||||
value :: Value }
|
||||
value :: Value } deriving Show
|
||||
|
||||
data Identifier
|
||||
= Identifier {
|
||||
pid :: PackageId,
|
||||
mod :: ModuleName,
|
||||
ent :: EntityName }
|
||||
ent :: EntityName } deriving Show
|
||||
|
||||
newtype MicroSecondsSinceEpoch = MicroSecondsSinceEpoch Int
|
||||
newtype DaysSinceEpoch = DaysSinceEpoch Int
|
||||
newtype MicroSecondsSinceEpoch = MicroSecondsSinceEpoch Int deriving Show-- TODO: Int64?
|
||||
newtype DaysSinceEpoch = DaysSinceEpoch Int deriving Show
|
||||
|
||||
data Timestamp
|
||||
= Timestamp {
|
||||
seconds :: Integer,
|
||||
nanos :: Integer }
|
||||
seconds :: Integer, -- TODO: Int64?
|
||||
nanos :: Integer } deriving Show
|
||||
|
||||
data Status -- TODO: from standard google proto, determining success/failure
|
||||
data Status = Status-- TODO: from standard google proto, determining success/failure
|
||||
deriving Show
|
||||
|
||||
newtype TemplateId = TemplateId Identifier
|
||||
deriving Show
|
||||
|
||||
newtype LedgerId = LedgerId { unLedgerId :: Text } deriving Show
|
||||
|
||||
-- Text wrappers
|
||||
newtype TransactionId = TransactionId { unTransactionId :: Text }
|
||||
newtype EventId = EventId { unEventId :: Text }
|
||||
newtype ContractId = ContractId { unContractId :: Text }
|
||||
newtype WorkflowId = WorkflowId { unWorkflowId :: Text }
|
||||
newtype TransactionId = TransactionId { unTransactionId :: Text } deriving Show
|
||||
newtype EventId = EventId { unEventId :: Text } deriving Show
|
||||
newtype ContractId = ContractId { unContractId :: Text } deriving Show
|
||||
newtype WorkflowId = WorkflowId { unWorkflowId :: Text } deriving Show
|
||||
newtype ApplicationId = ApplicationId { unApplicationId :: Text } deriving Show
|
||||
newtype CommandId = CommandId { unCommandId :: Text }
|
||||
newtype PackageId = PackageId { unPackageId :: Text }
|
||||
newtype ConstructorId = ConstructorId { unConstructorId :: Text }
|
||||
newtype VariantId = VariantId { unVariantId :: Text }
|
||||
newtype CommandId = CommandId { unCommandId :: Text } deriving (Show,Eq)
|
||||
newtype PackageId = PackageId { unPackageId :: Text } deriving Show
|
||||
newtype ConstructorId = ConstructorId { unConstructorId :: Text } deriving Show
|
||||
newtype VariantId = VariantId { unVariantId :: Text } deriving Show
|
||||
|
||||
newtype Choice = Choice { unChoice :: Text }
|
||||
newtype Choice = Choice { unChoice :: Text } deriving Show
|
||||
|
||||
newtype Party = Party { unParty :: Text }
|
||||
instance Show Party where show = Text.unpack . unParty
|
||||
|
||||
newtype ModuleName = ModuleName { unModuleName :: Text }
|
||||
newtype EntityName = EntityName { unEntityName :: Text }
|
||||
newtype ModuleName = ModuleName { unModuleName :: Text } deriving Show
|
||||
newtype EntityName = EntityName { unEntityName :: Text } deriving Show
|
||||
|
||||
newtype AbsOffset = AbsOffset { unAbsOffset :: Text } -- TODO: why not an int?
|
||||
newtype AbsOffset = AbsOffset { unAbsOffset :: Text } deriving Show -- TODO: why not an int?
|
||||
|
||||
-- TODO: .proto message types now yet handled
|
||||
{-
|
||||
|
||||
@ -9,13 +9,12 @@ module DA.Ledger.Sandbox ( -- Run a sandbox for testing on a dynamically selecte
|
||||
withSandbox
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Exception (Exception, bracket, evaluate, onException, throw)
|
||||
import Control.Monad(when)
|
||||
import Control.Exception (bracket, evaluate, onException)
|
||||
import DA.Ledger (Port (..), unPort)
|
||||
import Data.List (isInfixOf)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.List.Extra(splitOn)
|
||||
import GHC.IO.Handle (Handle, hGetLine)
|
||||
import Prelude hiding (log)
|
||||
import System.IO (hFlush, stdout)
|
||||
import System.Process (CreateProcess (..), ProcessHandle, StdStream (CreatePipe), createProcess, getPid, interruptProcessGroupOf, proc, waitForProcess)
|
||||
import System.Time.Extra (Seconds, timeout)
|
||||
@ -42,16 +41,16 @@ startSandboxProcess spec = do
|
||||
create_group = True -- To avoid sending INT to ourself
|
||||
}
|
||||
pid <- getPid proh
|
||||
log $ "Sandbox process started, pid = " <> show pid
|
||||
trace $ "Sandbox process started, pid = " <> show pid
|
||||
return (proh,hOutOpt)
|
||||
|
||||
shutdownSandboxProcess :: ProcessHandle -> IO ()
|
||||
shutdownSandboxProcess proh = do
|
||||
pidOpt <- getPid proh
|
||||
log $ "Sending INT to sandbox process: " <> show pidOpt
|
||||
trace $ "Sending INT to sandbox process: " <> show pidOpt
|
||||
interruptProcessGroupOf proh
|
||||
x <- timeoutError 10 "Sandbox process didn't exit" (waitForProcess proh)
|
||||
log $ "Sandbox process exited with: " <> show x
|
||||
x <- timeoutError 30 "Sandbox process didn't exit" (waitForProcess proh)
|
||||
trace $ "Sandbox process exited with: " <> show x
|
||||
return ()
|
||||
|
||||
parsePortFromListeningLine :: String -> IO Port
|
||||
@ -70,7 +69,7 @@ getListeningLine :: Handle -> IO String
|
||||
getListeningLine h = loop where
|
||||
loop = do
|
||||
line <- hGetLine h
|
||||
when (interestingLineFromSandbox line) $ log $ "SANDBOX: " <> line
|
||||
when (interestingLineFromSandbox line) $ trace $ "SANDBOX: " <> line
|
||||
if "listening" `isInfixOf` line
|
||||
then return line
|
||||
else if "initialization error" `isInfixOf` line
|
||||
@ -80,18 +79,18 @@ getListeningLine h = loop where
|
||||
discoverListeningPort :: Maybe Handle -> IO Port
|
||||
discoverListeningPort hOpt = do
|
||||
Just h <- return hOpt
|
||||
log "Looking for sandbox listening port..."
|
||||
trace "Looking for sandbox listening port..."
|
||||
line <- getListeningLine h
|
||||
port <- parsePortFromListeningLine line
|
||||
`onException` log ("Failed to parse listening port from: " <> show line)
|
||||
log $ "Sandbox listening on port: " <> show (unPort port)
|
||||
`onException` trace ("Failed to parse listening port from: " <> show line)
|
||||
trace $ "Sandbox listening on port: " <> show (unPort port)
|
||||
return port
|
||||
|
||||
startSandbox :: SandboxSpec-> IO Sandbox
|
||||
startSandbox spec = do
|
||||
(proh,hOpt) <-startSandboxProcess spec
|
||||
port <-
|
||||
timeoutError 10 "Didn't discover sandbox port" (discoverListeningPort hOpt)
|
||||
timeoutError 30 "Didn't discover sandbox port" (discoverListeningPort hOpt)
|
||||
`onException` shutdownSandboxProcess proh
|
||||
return Sandbox { port, proh }
|
||||
|
||||
@ -100,21 +99,17 @@ shutdownSandbox Sandbox{proh} = do shutdownSandboxProcess proh
|
||||
|
||||
withSandbox :: SandboxSpec -> (Sandbox -> IO a) -> IO a
|
||||
withSandbox spec f =
|
||||
bracket (startSandbox spec)
|
||||
bracket (startSandbox spec) -- TODO: too long to backet over? (masks C-c ?)
|
||||
shutdownSandbox
|
||||
f
|
||||
|
||||
data Timeout = Timeout String deriving Show
|
||||
instance Exception Timeout
|
||||
|
||||
timeoutError :: Seconds -> String -> IO a -> IO a
|
||||
timeoutError n tag io =
|
||||
timeout n io >>= \case
|
||||
Just x -> return x
|
||||
Nothing -> do
|
||||
log $ "Timeout: " <> tag <> ", after " <> show n <> " seconds."
|
||||
throw (Timeout tag)
|
||||
fail $ "Timeout: " <> tag <> ", after " <> show n <> " seconds."
|
||||
|
||||
_log,log :: String -> IO ()
|
||||
_log s = do putStr ("\n["<>s<>"]"); hFlush stdout -- debugging
|
||||
log _ = return ()
|
||||
_trace,trace :: String -> IO ()
|
||||
_trace s = do putStr ("\n["<>s<>"]"); hFlush stdout -- debugging
|
||||
trace _ = return ()
|
||||
|
||||
@ -5,14 +5,30 @@
|
||||
|
||||
module DA.Ledger.Tests (main) where
|
||||
|
||||
import Control.Monad(unless)
|
||||
import Control.Exception (SomeException, try)
|
||||
import qualified DA.Ledger as Ledger
|
||||
import Data.List (isPrefixOf)
|
||||
import qualified Data.Text.Lazy as Text (unpack)
|
||||
import Prelude hiding (log)
|
||||
import DA.Ledger as Ledger
|
||||
import Data.List (isPrefixOf,isInfixOf)
|
||||
import qualified Data.Text.Lazy as Text (pack,unpack)
|
||||
import DA.Ledger.Sandbox as Sandbox(SandboxSpec (..), port, shutdownSandbox, withSandbox)
|
||||
import Test.Tasty as Tasty (TestTree, defaultMain, testGroup)
|
||||
import Test.Tasty.HUnit as Tasty (assertBool, assertFailure, testCase)
|
||||
import Test.Tasty.HUnit as Tasty (assertEqual, assertBool, assertFailure, testCase)
|
||||
import Data.Text.Lazy(Text)
|
||||
import qualified Data.UUID as UUID
|
||||
import System.Random(randomIO)
|
||||
|
||||
import qualified DA.Ledger.LowLevel as LL(Completion(..))
|
||||
|
||||
expectException :: IO a -> IO SomeException
|
||||
expectException io =
|
||||
try io >>= \case
|
||||
Right _ -> assertFailure "exception was expected"
|
||||
Left (e::SomeException) -> return e
|
||||
|
||||
assertExceptionTextContains :: SomeException -> String -> IO ()
|
||||
assertExceptionTextContains e frag =
|
||||
unless (frag `isInfixOf` show e) (assertFailure msg)
|
||||
where msg = "expected frag: " ++ frag ++ "\n contained in: " ++ show e
|
||||
|
||||
main :: IO ()
|
||||
main = Tasty.defaultMain tests
|
||||
@ -22,7 +38,13 @@ spec1 = SandboxSpec {dar}
|
||||
where dar = "language-support/hs/bindings/quickstart.dar"
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "Haskell Ledger Bindings" [t1,t2]
|
||||
tests = testGroup "Haskell Ledger Bindings" [
|
||||
t1, t2, t3,
|
||||
t4, t4_1,
|
||||
t5, t6
|
||||
-- we really need sandboxes shared between tests..
|
||||
--,t1,t1,t1,t1,t1,t1
|
||||
]
|
||||
|
||||
t1 :: Tasty.TestTree
|
||||
t1 = testCase "connect, ledgerid" $ do
|
||||
@ -31,14 +53,98 @@ t1 = testCase "connect, ledgerid" $ do
|
||||
let lid = Ledger.identity h
|
||||
let got = Text.unpack $ Ledger.unLedgerId lid
|
||||
assertBool "bad ledgerId" (looksLikeSandBoxLedgerId got)
|
||||
|
||||
looksLikeSandBoxLedgerId :: String -> Bool
|
||||
looksLikeSandBoxLedgerId s = "sandbox-" `isPrefixOf` s && length s == 44
|
||||
where looksLikeSandBoxLedgerId s =
|
||||
"sandbox-" `isPrefixOf` s && length s == 44
|
||||
|
||||
t2 :: Tasty.TestTree
|
||||
t2 = testCase "connect, sandbox dead -> exception" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
shutdownSandbox sandbox -- kill it here
|
||||
try (Ledger.connect (Sandbox.port sandbox)) >>= \case
|
||||
Left (_::SomeException) -> return ()
|
||||
Right _ -> assertFailure "an Exception was expected"
|
||||
e <- expectException (Ledger.connect (Sandbox.port sandbox))
|
||||
assertExceptionTextContains e "ClientIOError"
|
||||
|
||||
t3 :: Tasty.TestTree
|
||||
t3 = testCase "no transcations to start with" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
h <- Ledger.connect (Sandbox.port sandbox)
|
||||
stream <- Ledger.transactions h alice
|
||||
(ts,_) <- Ledger.getStreamContents stream
|
||||
assertEqual "#transactions" 0 (length ts)
|
||||
|
||||
t4 :: Tasty.TestTree
|
||||
t4 = testCase "submit bad package id" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
h <- Ledger.connect (Sandbox.port sandbox)
|
||||
e <- expectException (submitCommand h alice command)
|
||||
assertExceptionTextContains e "Couldn't find package"
|
||||
where command = createIOU pid alice "A-coin" 100
|
||||
pid = PackageId "xxxxxxxxxxxxxxxxxxxxxx"
|
||||
|
||||
t4_1 :: Tasty.TestTree
|
||||
t4_1 = testCase "submit good package id" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
h <- Ledger.connect (Sandbox.port sandbox)
|
||||
-- TODO: Use Ledger.getPackage to find the correct package with the "Iou" contract.
|
||||
[pid,_,_] <- Ledger.listPackages h -- for now assume it's in the 1st of the 3 listed packages.
|
||||
let command = createIOU pid alice "A-coin" 100
|
||||
completions <- Ledger.completions h myAid [alice]
|
||||
(cs1,_) <- Ledger.getStreamContents completions
|
||||
assertEqual "before submit 1" [] cs1
|
||||
cid1 <- submitCommand h alice command
|
||||
comp1 <- takeStream completions
|
||||
let LL.Completion{completionCommandId} = comp1
|
||||
let cid1' = CommandId completionCommandId
|
||||
assertEqual "submit1" cid1' cid1
|
||||
|
||||
t5 :: Tasty.TestTree
|
||||
t5 = testCase "package service, listPackages" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
h <- Ledger.connect (Sandbox.port sandbox)
|
||||
ids <- Ledger.listPackages h
|
||||
assertEqual "#packages" 3 (length ids)
|
||||
|
||||
t6 :: Tasty.TestTree -- WIP (Ledger.getPackage not working yet)
|
||||
t6 = testCase "package service, get Package" $ do
|
||||
withSandbox spec1 $ \sandbox -> do
|
||||
h <- Ledger.connect (Sandbox.port sandbox)
|
||||
ids <- Ledger.listPackages h
|
||||
ps <- mapM (Ledger.getPackage h) ids
|
||||
assertEqual "#packages" 3 (length ps)
|
||||
return ()
|
||||
|
||||
alice :: Ledger.Party
|
||||
alice = Ledger.Party "Alice"
|
||||
|
||||
createIOU :: PackageId -> Party -> Text -> Int -> Command
|
||||
createIOU quickstart party currency quantity = CreateCommand {tid,args}
|
||||
where
|
||||
tid = TemplateId (Identifier quickstart mod ent)
|
||||
-- TODO: use package-service to find package-id
|
||||
-- da run damlc inspect-dar target/quickstart.dar
|
||||
mod = ModuleName "Iou"
|
||||
ent = EntityName "Iou"
|
||||
args = Record Nothing [
|
||||
RecordField "issuer" (VParty party),
|
||||
RecordField "owner" (VParty party),
|
||||
RecordField "currency" (VString currency),
|
||||
RecordField "amount" (VDecimal $ Text.pack $ show quantity),
|
||||
RecordField "observers" (VList [])
|
||||
]
|
||||
|
||||
submitCommand :: LedgerHandle -> Party -> Command -> IO CommandId
|
||||
submitCommand h party com = do
|
||||
let lid = Ledger.identity h
|
||||
cid <- randomCid
|
||||
Ledger.submitCommands h
|
||||
(Commands {lid,wid,aid=myAid,cid,party,leTime,mrTime,coms=[com]})
|
||||
return cid
|
||||
where
|
||||
wid = Nothing
|
||||
leTime = Timestamp 0 0
|
||||
mrTime = Timestamp 5 0
|
||||
|
||||
myAid :: ApplicationId
|
||||
myAid = ApplicationId "<my-application>"
|
||||
|
||||
randomCid :: IO CommandId
|
||||
randomCid = do fmap (CommandId . Text.pack . UUID.toString) randomIO
|
||||
|
||||
Loading…
Reference in New Issue
Block a user