haskell-ledger-bindings, test connect against sandbox (#1023)

* haskell-ledger-bindings, test connect with sandbox

* use System.Time.Extra.timeout instead of rolling own

* fix module name to match hierachical path

* increase timeout to 10s, fix macOS CI?

* delete-trailing-whitespace

* dont specify daml version for daml_compile rule

* unalign module imports

* replace xxx with undefined

language-support/hs/bindings/BUILD.bazel

@@ -1,7 +1,8 @@
 # Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 # SPDX-License-Identifier: Apache-2.0
 
-load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library")
+load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library", "da_haskell_test")
+load("//rules_daml:daml.bzl", "daml_compile")
 
 da_haskell_library(
     name = "hs-ledger",
@@ -36,3 +37,35 @@ da_haskell_binary(
         "//language-support/hs/bindings:hs-ledger",
     ],
 )
+
+daml_compile(
+    name = "quickstart",
+    srcs = glob(["test/daml/quickstart/*.daml"]),
+    main_src = "test/daml/quickstart/Main.daml",
+)
+
+da_haskell_test(
+    name = "test",
+    srcs = glob(["test/**/*.hs"]),
+    data = [
+        ":quickstart.dar",
+        "//ledger/sandbox:sandbox-binary",
+    ],
+    hazel_deps = [
+        "async",
+        "base",
+        "directory",
+        "extra",
+        "process",
+        "split",
+        "tasty",
+        "tasty-hunit",
+        "text",
+    ],
+    main_function = "DA.Ledger.Tests.main",
+    src_strip_prefix = "test",
+    visibility = ["//visibility:public"],
+    deps = [
+        "//language-support/hs/bindings:hs-ledger",
+    ],
+)

language-support/hs/bindings/examples/Play.hs

@@ -5,16 +5,16 @@
 
 module Main(main) where
 
-import           Control.Concurrent
-import           Control.Monad      (void)
-import           Data.Text.Lazy     (Text)
-import qualified Data.Text.Lazy     as Text
+import Control.Concurrent
+import Control.Monad (void)
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as Text
 
-import           Data.UUID          as UUID
-import           System.Random
-import           System.Time.Extra  (sleep)
+import Data.UUID as UUID
+import System.Random
+import System.Time.Extra (sleep)
 
-import           DA.Ledger          as Ledger
+import DA.Ledger as Ledger
 
 main :: IO ()
 main = do
@@ -60,9 +60,9 @@ createIOU 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 
+        -- da run damlc inspect-dar target/quickstart.dar
         quickstart = PackageId "d2738d858a282364bc66e9c0843ab77e4970769905df03f00934c6716771c972"
-        mod = ModuleName "Iou" 
+        mod = ModuleName "Iou"
         ent = EntityName "Iou"
         args = Record Nothing [
             RecordField "issuer" (VParty party),
@@ -75,7 +75,7 @@ createIOU party currency quantity = CreateCommand {tid,args}
 alice,bob :: Party
 alice = Party "Alice"
 bob = Party "Bob"
-    
+
 myAid :: ApplicationId
 myAid = ApplicationId "<my-application>"
 

language-support/hs/bindings/src/DA/Ledger.hs

@@ -20,12 +20,12 @@ module DA.Ledger( -- WIP: High level interface to the Ledger API services
     getCompletionStream,
     ) 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 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 DA.Ledger.Convert(lowerCommands)

language-support/hs/bindings/src/DA/Ledger/Convert.hs

@@ -6,14 +6,11 @@
 -- Convert between HL Ledger.Types and the LL types generated from .proto files
 module DA.Ledger.Convert (lowerCommands) where
 
-import           Data.Maybe         (fromMaybe)
-import           Data.Vector        as Vector (fromList)
+import Data.Maybe (fromMaybe)
+import Data.Vector as Vector (fromList)
 
 import qualified DA.Ledger.LowLevel as LL
-import           DA.Ledger.Types
-
-xxx :: a -- TODO: not finished while any instances of "xxx" of "_" remain in this file
-xxx = undefined
+import DA.Ledger.Types
 
 lowerCommands :: Commands -> LL.Commands
 lowerCommands = \case
@@ -34,7 +31,7 @@ lowerCommand = \case
         LL.Command $ Just $ LL.CommandCommandCreate $ LL.CreateCommand {
         createCommandTemplateId = Just (lowerTemplateId tid),
         createCommandCreateArguments = Just (lowerRecord args)}
-        
+
     ExerciseCommand{tid,cid,choice,arg} ->
         LL.Command $ Just $ LL.CommandCommandExercise $ LL.ExerciseCommand {
         exerciseCommandTemplateId = Just (lowerTemplateId tid),
@@ -72,19 +69,19 @@ lowerTimestamp = \case
 lowerValue :: Value -> LL.Value
 lowerValue = \case -- TODO: more cases here
     VRecord r -> LL.Value $ Just $ LL.ValueSumRecord $ lowerRecord r
-    VVariant _ -> xxx
-    VContract _ -> xxx
+    VVariant _ -> undefined
+    VContract _ -> undefined
     VList vs -> LL.Value $ Just $ LL.ValueSumList $ LL.List $ Vector.fromList $ map lowerValue vs
     VInt i -> LL.Value $ Just $ LL.ValueSumInt64 $ fromIntegral i
     VDecimal s -> LL.Value $ Just $ LL.ValueSumDecimal s
     VString s -> LL.Value $ Just $ LL.ValueSumText s
-    VTimestamp _ -> xxx
+    VTimestamp _ -> undefined
     VParty p -> LL.Value $ Just $ LL.ValueSumParty $ unParty p
-    VBool _ -> xxx
-    VUnit -> xxx
-    VDate _ -> xxx
-    VOpt _ -> xxx
-    VMap _ -> xxx
+    VBool _ -> undefined
+    VUnit -> undefined
+    VDate _ -> undefined
+    VOpt _ -> undefined
+    VMap _ -> undefined
 
 lowerRecord :: Record -> LL.Record
 lowerRecord = \case

language-support/hs/bindings/src/DA/Ledger/LowLevel.hs

@@ -3,25 +3,25 @@
 
 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 Network.GRPC.HighLevel.Generated as X
+import Proto3.Suite.Types as X
 
-import           Google.Protobuf.Empty                                     as X
-import           Google.Protobuf.Timestamp                                 as X
+import Google.Protobuf.Empty as X
+import Google.Protobuf.Timestamp as X
 
-import           Com.Digitalasset.Ledger.Api.V1.ActiveContractsService     as X
-import           Com.Digitalasset.Ledger.Api.V1.CommandCompletionService   as X
-import           Com.Digitalasset.Ledger.Api.V1.Commands                   as X
-import           Com.Digitalasset.Ledger.Api.V1.CommandService             as X
-import           Com.Digitalasset.Ledger.Api.V1.CommandSubmissionService   as X
-import           Com.Digitalasset.Ledger.Api.V1.Completion                 as X
-import           Com.Digitalasset.Ledger.Api.V1.Event                      as X
-import           Com.Digitalasset.Ledger.Api.V1.LedgerConfigurationService as X
-import           Com.Digitalasset.Ledger.Api.V1.LedgerIdentityService      as X
-import           Com.Digitalasset.Ledger.Api.V1.LedgerOffset               as X
-import           Com.Digitalasset.Ledger.Api.V1.PackageService             as X
-import           Com.Digitalasset.Ledger.Api.V1.TraceContext               as X
-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 Com.Digitalasset.Ledger.Api.V1.ActiveContractsService as X
+import Com.Digitalasset.Ledger.Api.V1.CommandCompletionService as X
+import Com.Digitalasset.Ledger.Api.V1.Commands as X
+import Com.Digitalasset.Ledger.Api.V1.CommandService as X
+import Com.Digitalasset.Ledger.Api.V1.CommandSubmissionService as X
+import Com.Digitalasset.Ledger.Api.V1.Completion as X
+import Com.Digitalasset.Ledger.Api.V1.Event as X
+import Com.Digitalasset.Ledger.Api.V1.LedgerConfigurationService as X
+import Com.Digitalasset.Ledger.Api.V1.LedgerIdentityService as X
+import Com.Digitalasset.Ledger.Api.V1.LedgerOffset as X
+import Com.Digitalasset.Ledger.Api.V1.PackageService as X
+import Com.Digitalasset.Ledger.Api.V1.TraceContext as X
+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

language-support/hs/bindings/src/DA/Ledger/Types.hs

@@ -39,8 +39,8 @@ module DA.Ledger.Types( -- High Level types for communication over Ledger API
 
     ) where
 
-import           Data.Map       (Map)
-import           Data.Text.Lazy (Text)
+import Data.Map (Map)
+import Data.Text.Lazy (Text)
 import qualified Data.Text.Lazy as Text
 
 -- TODO: deriving Show everywhere?

language-support/hs/bindings/test/DA/Ledger/Sandbox.hs

@@ -0,0 +1,120 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module DA.Ledger.Sandbox ( -- Run a sandbox for testing on a dynamically selected port
+    SandboxSpec(..),
+    Sandbox(port),
+    startSandbox,
+    shutdownSandbox,
+    withSandbox
+    ) where
+
+import Control.Monad (when)
+import Control.Exception (Exception, bracket, evaluate, onException, throw)
+import DA.Ledger (Port (..), unPort)
+import Data.List (isInfixOf)
+import Data.List.Split (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)
+
+data SandboxSpec = SandboxSpec {dar :: String}
+
+data Sandbox = Sandbox { port :: Port, proh :: ProcessHandle }
+
+selectedPort :: Int
+selectedPort = 0 --dynamic port selection
+
+sandboxProcess :: SandboxSpec -> CreateProcess
+sandboxProcess SandboxSpec{dar} =
+    proc binary [ dar, "--port", show selectedPort]
+    where
+        binary = "ledger/sandbox/sandbox-binary"
+
+startSandboxProcess :: SandboxSpec -> IO (ProcessHandle,Maybe Handle)
+startSandboxProcess spec = do
+    (_,hOutOpt,_,proh) <-
+        createProcess (sandboxProcess spec) {
+        std_out = CreatePipe,
+        std_err = CreatePipe, -- Question: ought the pipe to be drained?
+        create_group = True  -- To avoid sending INT to ourself
+        }
+    pid <- getPid proh
+    log $ "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
+    interruptProcessGroupOf proh
+    x <- timeoutError 10 "Sandbox process didn't exit" (waitForProcess proh)
+    log $ "Sandbox process exited with: " <> show x
+    return ()
+
+parsePortFromListeningLine :: String -> IO Port
+parsePortFromListeningLine line = do
+    [_,portNumStr] <- return (splitOn ":" line)
+    num <- evaluate (read portNumStr)
+    return (Port num)
+
+interestingLineFromSandbox :: String -> Bool
+interestingLineFromSandbox line =
+    any (`isInfixOf` line)
+    [--"listening",
+     "error", "Address already in use", "java.net.BindException"]
+
+getListeningLine :: Handle -> IO String
+getListeningLine h = loop where
+    loop = do
+        line <- hGetLine h
+        when (interestingLineFromSandbox line) $ log $ "SANDBOX: " <> line
+        if "listening" `isInfixOf` line
+            then return line
+            else if "initialization error" `isInfixOf` line
+                 then error line
+                 else loop
+
+discoverListeningPort :: Maybe Handle -> IO Port
+discoverListeningPort hOpt = do
+    Just h <- return hOpt
+    log "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)
+    return port
+
+startSandbox :: SandboxSpec-> IO Sandbox
+startSandbox spec = do
+    (proh,hOpt) <-startSandboxProcess spec
+    port <-
+        timeoutError 10 "Didn't discover sandbox port" (discoverListeningPort hOpt)
+        `onException` shutdownSandboxProcess proh
+    return Sandbox { port, proh }
+
+shutdownSandbox :: Sandbox -> IO ()
+shutdownSandbox Sandbox{proh} = do shutdownSandboxProcess proh
+
+withSandbox :: SandboxSpec -> (Sandbox -> IO a) -> IO a
+withSandbox spec f =
+    bracket (startSandbox spec)
+    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)
+
+_log,log :: String -> IO ()
+_log s = do putStr ("\n["<>s<>"]"); hFlush stdout -- debugging
+log _ = return ()

language-support/hs/bindings/test/DA/Ledger/Tests.hs

@@ -0,0 +1,44 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module DA.Ledger.Tests (main) where
+
+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.Sandbox as Sandbox(SandboxSpec (..), port, shutdownSandbox, withSandbox)
+import Test.Tasty as Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit as Tasty (assertBool, assertFailure, testCase)
+
+main :: IO ()
+main = Tasty.defaultMain tests
+
+spec1 :: SandboxSpec
+spec1 = SandboxSpec {dar}
+    where dar = "language-support/hs/bindings/quickstart.dar"
+
+tests :: TestTree
+tests = testGroup "Haskell Ledger Bindings" [t1,t2]
+
+t1 :: Tasty.TestTree
+t1 = testCase "connect, ledgerid" $ do
+    withSandbox spec1 $ \sandbox -> do
+        h <- Ledger.connect (Sandbox.port sandbox)
+        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
+
+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"

language-support/hs/bindings/test/daml/quickstart/Iou.daml

@@ -0,0 +1,86 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+module Iou where
+
+type IouId = ContractId Iou
+
+template Iou
+  with
+    issuer : Party
+    owner : Party
+    currency : Text
+    amount : Decimal
+    observers : [Party]
+  where
+    ensure amount > 0.0
+
+    signatory issuer, owner
+
+    observer observers
+
+    controller owner can
+
+      -- Split the IOU by dividing the amount.
+      Iou_Split : (IouId, IouId)
+         with
+          splitAmount: Decimal
+        do
+          let restAmount = amount - splitAmount
+          splitCid <- create this with amount = splitAmount
+          restCid <- create this with amount = restAmount
+          return (splitCid, restCid)
+
+      -- Merge two IOUs by aggregating their amounts.
+      Iou_Merge : IouId
+        with
+          otherCid: IouId
+        do
+          otherIou <- fetch otherCid
+          -- Check the two IOU's are compatible
+          assert (
+            currency == otherIou.currency &&
+            owner == otherIou.owner &&
+            issuer == otherIou.issuer
+            )
+          -- Retire the old Iou
+          archive otherCid
+          -- Return the merged Iou
+          create this with amount = amount + otherIou.amount
+
+      Iou_Transfer : ContractId IouTransfer
+        with
+          newOwner : Party
+        do create IouTransfer with iou = this; newOwner
+
+      Iou_AddObserver : IouId
+        with
+          newObserver : Party
+        do create this with observers = newObserver :: observers
+
+      Iou_RemoveObserver : IouId
+        with
+          oldObserver : Party
+        do create this with observers = filter (/= oldObserver) observers
+
+template IouTransfer
+  with
+    iou : Iou
+    newOwner : Party
+  where
+    signatory iou.issuer, iou.owner
+
+    controller iou.owner can
+      IouTransfer_Cancel : IouId
+        do create iou
+
+    controller newOwner can
+      IouTransfer_Reject : IouId
+        do create iou
+
+      IouTransfer_Accept : IouId
+        do
+          create iou with
+            owner = newOwner
+            observers = []

language-support/hs/bindings/test/daml/quickstart/IouTrade.daml

@@ -0,0 +1,49 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+module IouTrade where
+
+import DA.Assert
+
+import Iou
+
+template IouTrade
+  with
+    buyer : Party
+    seller : Party
+    baseIouCid : IouId
+    baseIssuer : Party
+    baseCurrency : Text
+    baseAmount : Decimal
+    quoteIssuer : Party
+    quoteCurrency : Text
+    quoteAmount : Decimal
+  where
+    signatory buyer
+
+    controller seller can
+      IouTrade_Accept : (IouId, IouId)
+        with
+          quoteIouCid : IouId
+        do
+          baseIou <- fetch baseIouCid
+          baseIssuer === baseIou.issuer
+          baseCurrency === baseIou.currency
+          baseAmount === baseIou.amount
+          buyer === baseIou.owner
+          quoteIou <- fetch quoteIouCid
+          quoteIssuer === quoteIou.issuer
+          quoteCurrency === quoteIou.currency
+          quoteAmount === quoteIou.amount
+          seller === quoteIou.owner
+          quoteIouTransferId <- exercise quoteIouCid Iou_Transfer with
+            newOwner = buyer
+          quoteIouCid <- exercise quoteIouTransferId IouTransfer_Accept
+          baseIouTransferId <- exercise baseIouCid Iou_Transfer with
+            newOwner = seller
+          baseIouCid <- exercise baseIouTransferId IouTransfer_Accept
+          return (quoteIouCid, baseIouCid)
+
+      TradeProposal_Reject : ()
+        do return ()

language-support/hs/bindings/test/daml/quickstart/Main.daml

@@ -0,0 +1,39 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+module Main where
+
+import Iou
+import IouTrade()
+
+setup = scenario do
+  alice <- getParty "Alice"
+  bob <- getParty "Bob"
+  usBank <- getParty "USD_Bank"
+  eurBank <- getParty "EUR_Bank"
+
+  -- Banks issue Iou transfers
+  iouTransferAliceCid <- submit eurBank do
+    iouCid <- create Iou with
+      issuer = eurBank
+      owner = eurBank
+      currency = "EUR"
+      amount = 100.0
+      observers = []
+    exercise iouCid Iou_Transfer with newOwner = alice
+
+  iouTransferBobCid <- submit usBank do
+    iouCid <- create Iou with
+      issuer = usBank
+      owner = usBank
+      currency = "USD"
+      amount = 110.0
+      observers = []
+    exercise iouCid Iou_Transfer with newOwner = bob
+
+  -- Bob and Alice accept
+  submit alice do
+    exercise iouTransferAliceCid IouTransfer_Accept
+  submit bob do
+    exercise iouTransferBobCid IouTransfer_Accept

language-support/hs/examples/ex-haskell-grpc-arithmetic/ArithmeticClient.hs

@@ -5,8 +5,8 @@
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-import           Arithmetic
-import           Network.GRPC.HighLevel.Generated
+import Arithmetic
+import Network.GRPC.HighLevel.Generated
 
 clientConfig :: ClientConfig
 clientConfig = ClientConfig { clientServerHost = "localhost"