/
Workflow.hs
207 lines (169 loc) · 8.61 KB
/
Workflow.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Spec.PAB.Workflow where
import Cardano.Wallet.Mock.Client (createWallet)
import Cardano.Wallet.Mock.Types (wiPubKeyHash, wiWallet)
import Control.Concurrent.Async (async)
import Control.Monad (guard, join, void)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Coerce (coerce)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import qualified Data.Text as Text
import qualified Language.Marlowe.Client as Marlowe
import Language.Marlowe.Semantics (Action (..), Case (..), Contract (..), MarloweParams, Party (..),
Payee (..), Value (..))
import qualified Language.Marlowe.Semantics as Marlowe
import Language.Marlowe.Util (ada)
import Ledger (PubKeyHash, Slot)
import qualified Ledger.Value as Val
import MarloweContract (MarloweContract (..))
import Network.HTTP.Client (defaultManagerSettings, newManager)
import qualified Network.WebSockets as WS
import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin
import Plutus.PAB.Webserver.Client (InstanceClient (..), PabClient (..), pabClient)
import Plutus.PAB.Webserver.Types (ContractActivationArgs (..), InstanceStatusToClient (..))
import qualified PlutusTx.AssocMap as AssocMap
import Servant.Client (BaseUrl (..), ClientEnv, ClientM, mkClientEnv, runClientM)
import Test.Tasty
import Test.Tasty.HUnit
import Wallet.Types (ContractInstanceId (..), EndpointDescription (..))
import Network.Socket (withSocketsDo)
import qualified Cardano.Wallet.Mock.Types as Wallet.Types
import Control.Concurrent (threadDelay)
import Data.Aeson (decode)
import Data.ByteString.Builder (toLazyByteString)
import Data.Default (def)
import Data.Text.Encoding (encodeUtf8Builder)
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import Plutus.Contract.Effects (aeDescription)
import Plutus.PAB.App (StorageBackend (..))
import Plutus.PAB.Run (runWithOpts)
import Plutus.PAB.Run.Command (ConfigCommand (Migrate), allServices)
import Plutus.PAB.Run.CommandParser (AppOpts (..))
import qualified Plutus.PAB.Types as PAB.Types
startPab :: PAB.Types.Config -> IO ()
startPab pabConfig = do
let handler = Builtin.handleBuiltin @MarloweContract
opts = AppOpts
{ minLogLevel = Nothing
, logConfigPath = Nothing
, configPath = Nothing
, runEkgServer = False
, storageBackend = BeamSqliteBackend
, cmd = allServices
}
let mc = Just pabConfig
-- First, migrate.
void . async $ runWithOpts handler mc (opts {cmd = Migrate})
sleep 10
-- Then, spin up the services.
void . async $ runWithOpts handler mc opts
sleep 5
sleep :: Int -> IO ()
sleep n = threadDelay $ n * 1_000_000
waitForState :: (Aeson.Value -> Maybe a) -> (InstanceStatusToClient -> Maybe a)
waitForState f = g
where
g (NewObservableState v) = f v
g _ = Nothing
waitForEndpoint :: String -> (InstanceStatusToClient -> Maybe ())
waitForEndpoint ep = g
where
g (NewActiveEndpoints eps) = guard (any (\aep -> coerce (aeDescription aep) == ep) eps) >> Just ()
g _ = Nothing
runWebSocket :: BaseUrl -> ContractInstanceId -> (InstanceStatusToClient -> Maybe a) -> IO a
runWebSocket (BaseUrl _ host port _) cid f = do
let url = "/ws/" <> contractInstanceToString cid
withSocketsDo
$ WS.runClient host port (Text.unpack url)
$ \conn ->
let go = WS.receiveData conn >>= \msg ->
case join (f <$> decodeFromText msg) of
Just a -> pure a
Nothing -> go
in go
contractInstanceToString :: ContractInstanceId -> Text.Text
contractInstanceToString = Text.pack . show . unContractInstanceId
marloweCompanionFollowerContractExample :: IO ()
marloweCompanionFollowerContractExample = do
manager <- newManager defaultManagerSettings
let pabConfig = def { PAB.Types.pabWebserverConfig = def { PAB.Types.endpointTimeout = Just 30 } }
apiUrl = PAB.Types.baseUrl (PAB.Types.pabWebserverConfig pabConfig)
apiClientEnv = mkClientEnv manager apiUrl
walletUrl = coerce $ Wallet.Types.baseUrl (PAB.Types.walletServerConfig pabConfig)
walletClientEnv = mkClientEnv manager walletUrl
PabClient{activateContract, instanceClient} = pabClient @MarloweContract @Integer
-- This depends on the PabClient `instanceClient` route.
callEndpointOnInstance :: Aeson.ToJSON a => ContractInstanceId -> String -> a -> ClientM ()
callEndpointOnInstance cid ep args =
let call = callInstanceEndpoint . instanceClient $ cid
in call ep $ Aeson.toJSON args
run :: ClientEnv -> ClientM a -> IO a
run env ca = do
ea <- runClientM ca env
case ea of
Left e -> error $ show e
Right a -> pure a
runApi = run apiClientEnv
runWallet = run walletClientEnv
runWs = runWebSocket apiUrl
startPab pabConfig
walletInfo <- runWallet createWallet
let wallet = wiWallet walletInfo
hash = wiPubKeyHash walletInfo
args = createArgs hash hash
companionContractId <- runApi $ activateContract $ ContractActivationArgs { caID = WalletCompanion, caWallet = Just wallet }
marloweContractId <- runApi $ activateContract $ ContractActivationArgs { caID = MarloweApp, caWallet = Just wallet }
sleep 2
runApi $ callEndpointOnInstance marloweContractId "create" args
followerId <- runApi $ activateContract $ ContractActivationArgs { caID = MarloweFollower, caWallet = Just wallet }
sleep 2
mp <- runWs companionContractId $ waitForState extractMarloweParams
runWs followerId $ waitForEndpoint "follow"
runApi $ callEndpointOnInstance followerId "follow" mp
-- TODO Waits indefinitely because we don't reconstruct the history
-- for a given address since using the new chain index.
-- Uncomment once the correct changes are made.
-- _ <- runWs followerId $ waitForState extractFollowState
-- We're happy if the above call completes.
pure ()
createArgs :: PubKeyHash -> PubKeyHash -> (UUID, AssocMap.Map Val.TokenName PubKeyHash, Marlowe.Contract)
createArgs investor issuer = (UUID.nil, tokenNames, zcb) where
tokenNames = AssocMap.fromList [("Lender", investor), ("Borrower", issuer)]
issuerAcc = Role "Borrower"
investorAcc = Role "Lender"
zcb = When
[ Case
(Deposit issuerAcc issuerAcc ada (Constant 850))
(Pay issuerAcc (Account investorAcc) ada (Constant 850)
(When
[ Case (Deposit issuerAcc investorAcc ada (Constant 1000)) Close
] (26936589 :: Slot) Close
)
)
]
(26936589 :: Slot) Close
decodeFromText :: Aeson.FromJSON a => Text.Text -> Maybe a
decodeFromText = decode . toLazyByteString . encodeUtf8Builder
extractMarloweParams :: Aeson.Value -> Maybe MarloweParams
extractMarloweParams vl = do
(Marlowe.CompanionState s) <- either (const Nothing) Just (Aeson.parseEither Aeson.parseJSON vl)
(params, _) <- listToMaybe $ Map.toList s
pure params
extractFollowState :: Aeson.Value -> Maybe Marlowe.ContractHistory
extractFollowState vl = do
s <- either (const Nothing) Just (Aeson.parseEither Aeson.parseJSON vl)
guard (not $ Marlowe.isEmpty s)
pure s
tests :: TestTree
tests = testGroup "Marlowe Workflow tests"
[ testCase "Marlowe Follower/Companion contract scenario can be completed" $ do
marloweCompanionFollowerContractExample
]