/
Client.hs
272 lines (247 loc) · 9.44 KB
/
Client.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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE GADTs #-}
module Language.Marlowe.Runtime.Web.Client
( Page(..)
, getContract
, getContracts
, getTransaction
, getTransactions
, getWithdrawal
, getWithdrawals
, healthcheck
, postContract
, postContractCreateTx
, postTransaction
, postTransactionCreateTx
, postWithdrawal
, postWithdrawalCreateTx
, putContract
, putTransaction
, putWithdrawal
) where
import Control.Monad.Error.Class (MonadError(catchError))
import Control.Monad.IO.Class (liftIO)
import Data.Functor (void)
import Data.Maybe (fromJust)
import Data.Proxy (Proxy(..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.Marlowe.Runtime.Web.API
(API, GetContractsResponse, GetTransactionsResponse, GetWithdrawalsResponse, ListObject(..), api, retractLink)
import Language.Marlowe.Runtime.Web.Types
import Servant (ResponseHeader(..), getResponse, lookupResponseHeader, type (:<|>)((:<|>)))
import Servant.Client (Client, ClientM)
import qualified Servant.Client as Servant
import Servant.Pagination (ExtractRange(extractRange), HasPagination(..), PutRange(..), Range, Ranges)
client :: Client ClientM API
client = Servant.client api
data Page field resource = Page
{ totalCount :: Int
, nextRange :: Maybe (Range field (RangeType resource field))
, items :: [resource]
}
deriving (Eq, Show)
healthcheck :: ClientM Bool
healthcheck = do
let _ :<|> _ :<|> healthcheck' = client
(True <$ healthcheck') `catchError` const (pure False)
getContracts
:: Maybe (Set PolicyId)
-> Maybe (Set Text)
-> Maybe (Range "contractId" TxOutRef)
-> ClientM (Page "contractId" ContractHeader)
getContracts roleCurrencies tags range = do
let contractsClient :<|> _ = client
let getContracts' :<|> _ = contractsClient
response <- getContracts' (foldMap Set.toList roleCurrencies) (foldMap Set.toList tags)
$ putRange <$> range
totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response
nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response
let ListObject items = getResponse response
pure Page
{ totalCount
, nextRange = extractRangeSingleton @GetContractsResponse <$> nextRanges
, items = retractLink @"contract" . retractLink @"transactions" <$> items
}
postContract
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> PostContractsRequest
-> ClientM (CreateTxEnvelope CardanoTxBody)
postContract changeAddress otherAddresses collateralUtxos request = do
let (_ :<|> (postContractCreateTxBody' :<|> _) :<|> _) :<|> _ = client
response <- postContractCreateTxBody'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
postContractCreateTx
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> PostContractsRequest
-> ClientM (CreateTxEnvelope CardanoTx)
postContractCreateTx changeAddress otherAddresses collateralUtxos request = do
let (_ :<|> (_ :<|> postContractCreateTx') :<|> _) :<|> _ = client
response <- postContractCreateTx'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
getContract :: TxOutRef -> ClientM ContractState
getContract contractId = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let getContract' :<|> _ = contractApi contractId
retractLink <$> getContract'
putContract :: TxOutRef -> TextEnvelope -> ClientM ()
putContract contractId tx = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let _ :<|> putContract' :<|> _ = contractApi contractId
void $ putContract' tx
getWithdrawals
:: Maybe (Set PolicyId)
-> Maybe (Range "withdrawalId" TxId)
-> ClientM (Page "withdrawalId" WithdrawalHeader)
getWithdrawals roleCurrencies range = do
let _ :<|> withdrawalsClient :<|> _ = client
let getWithdrawals' :<|> _ = withdrawalsClient
response <- getWithdrawals' (foldMap Set.toList roleCurrencies) $ putRange <$> range
totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response
nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response
let ListObject items = getResponse response
pure Page
{ totalCount
, nextRange = extractRangeSingleton @GetWithdrawalsResponse <$> nextRanges
, items = retractLink @"withdrawal" <$> items
}
postWithdrawal
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> PostWithdrawalsRequest
-> ClientM (WithdrawTxEnvelope CardanoTxBody)
postWithdrawal changeAddress otherAddresses collateralUtxos request = do
let _ :<|> withdrawalsClient :<|> _ = client
let _ :<|> (postWithdrawal' :<|> _) :<|> _ = withdrawalsClient
response <- postWithdrawal'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
postWithdrawalCreateTx
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> PostWithdrawalsRequest
-> ClientM (WithdrawTxEnvelope CardanoTx)
postWithdrawalCreateTx changeAddress otherAddresses collateralUtxos request = do
let _ :<|> withdrawalsClient :<|> _ = client
let _ :<|> (_ :<|> postWithdrawalCreateTx') :<|> _ = withdrawalsClient
response <- postWithdrawalCreateTx'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
getWithdrawal :: TxId -> ClientM Withdrawal
getWithdrawal withdrawalId = do
let _ :<|> withdrawalsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = withdrawalsClient
let getWithdrawal' :<|> _ = contractApi withdrawalId
getWithdrawal'
putWithdrawal :: TxId -> TextEnvelope -> ClientM ()
putWithdrawal withdrawalId tx = do
let _ :<|> withdrawalsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = withdrawalsClient
let _ :<|> putWithdrawal' = contractApi withdrawalId
void $ putWithdrawal' tx
getTransactions
:: TxOutRef
-> Maybe (Range "transactionId" TxId)
-> ClientM (Page "transactionId" TxHeader)
getTransactions contractId range = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let _ :<|> _ :<|> _ :<|> getTransactions' :<|> _ = contractApi contractId
response <- getTransactions' $ putRange <$> range
totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response
nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response
let ListObject items = getResponse response
pure Page
{ totalCount
, nextRange = extractRangeSingleton @GetTransactionsResponse <$> nextRanges
, items = retractLink <$> items
}
postTransaction
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> TxOutRef
-> PostTransactionsRequest
-> ClientM (ApplyInputsTxEnvelope CardanoTxBody)
postTransaction changeAddress otherAddresses collateralUtxos contractId request = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let _ :<|> _ :<|> _ :<|> _ :<|> (postTransaction' :<|> _) :<|> _ = contractApi contractId
response <- postTransaction'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
postTransactionCreateTx
:: Address
-> Maybe (Set Address)
-> Maybe (Set TxOutRef)
-> TxOutRef
-> PostTransactionsRequest
-> ClientM (ApplyInputsTxEnvelope CardanoTx)
postTransactionCreateTx changeAddress otherAddresses collateralUtxos contractId request = do
let (_ :<|> _ :<|> contractApi) :<|> _ = client
let _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> postTransactionCreateTx') :<|> _ = contractApi contractId
response <- postTransactionCreateTx'
request
changeAddress
(setToCommaList <$> otherAddresses)
(setToCommaList <$> collateralUtxos)
pure $ retractLink response
getTransaction :: TxOutRef -> TxId -> ClientM Tx
getTransaction contractId transactionId = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId
let getTransaction' :<|> _ = transactionApi transactionId
retractLink . retractLink <$> getTransaction'
putTransaction :: TxOutRef -> TxId -> TextEnvelope -> ClientM ()
putTransaction contractId transactionId tx = do
let contractsClient :<|> _ = client
let _ :<|> _ :<|> contractApi = contractsClient
let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId
let _ :<|> putTransaction' = transactionApi transactionId
void $ putTransaction' tx
setToCommaList :: Set a -> CommaList a
setToCommaList = CommaList . Set.toList
reqHeaderValue :: forall name a. KnownSymbol name => ResponseHeader name a -> ClientM a
reqHeaderValue = \case
Header a -> pure a
UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name)
MissingHeader -> liftIO $ fail $ "Required header missing " <> symbolVal (Proxy @name)
headerValue :: forall name a. KnownSymbol name => ResponseHeader name a -> ClientM (Maybe a)
headerValue = \case
Header a -> pure $ Just a
UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name)
MissingHeader -> pure Nothing
extractRangeSingleton
:: HasPagination resource field
=> Ranges '[field] resource
-> Range field (RangeType resource field)
extractRangeSingleton = fromJust . extractRange