-
Notifications
You must be signed in to change notification settings - Fork 44
/
Common.hs
68 lines (60 loc) · 2.55 KB
/
Common.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
module Language.Marlowe.Runtime.Web.Common
where
import Cardano.Api
( AsType(..)
, ShelleyWitnessSigningKey(..)
, TextEnvelope(..)
, TextEnvelopeType(..)
, deserialiseFromTextEnvelope
, serialiseToTextEnvelope
, signShelleyTransaction
)
import Cardano.Api.SerialiseTextEnvelope (TextEnvelopeDescr(..))
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (MonadIO(liftIO))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Language.Marlowe as V1
import Language.Marlowe.Runtime.Integration.Common
import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses(..))
import qualified Language.Marlowe.Runtime.Web as Web
import Language.Marlowe.Runtime.Web.Client (getContract, postContract, putContract)
import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO(toDTO))
import Servant.Client (ClientM)
createCloseContract :: Wallet -> ClientM Web.TxOutRef
createCloseContract Wallet{..}= do
let WalletAddresses{..} = addresses
let webChangeAddress = toDTO changeAddress
let webExtraAddresses = Set.map toDTO extraAddresses
let webCollataralUtxos = Set.map toDTO collateralUtxos
Web.CreateTxBody{txBody = createTxBody, ..} <- postContract
webChangeAddress
(Just webExtraAddresses)
(Just webCollataralUtxos)
Web.PostContractsRequest
{ metadata = mempty
, version = Web.V1
, roles = Nothing
, contract = V1.Close
, minUTxODeposit = 2_000_000
}
createTx <- liftIO $ signShelleyTransaction' createTxBody signingKeys
putContract contractId createTx
_ <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
pure contractId
signShelleyTransaction' :: Web.TextEnvelope -> [ShelleyWitnessSigningKey] -> IO Web.TextEnvelope
signShelleyTransaction' Web.TextEnvelope{..} wits = do
let te = TextEnvelope { teType = TextEnvelopeType (T.unpack teType), teDescription = TextEnvelopeDescr (T.unpack teDescription), teRawCBOR = Web.unBase16 teCborHex }
txBody <- case deserialiseFromTextEnvelope (AsTxBody AsBabbage) te of
Left err -> fail $ show err
Right a -> pure a
pure case serialiseToTextEnvelope Nothing $ signShelleyTransaction txBody wits of
TextEnvelope (TextEnvelopeType ty) _ bytes -> Web.TextEnvelope (T.pack ty) "" $ Web.Base16 bytes
waitUntilConfirmed :: MonadIO m => (a -> Web.TxStatus) -> m a -> m a
waitUntilConfirmed getStatus getResource = do
resource <- getResource
case getStatus resource of
Web.Confirmed -> pure resource
_ -> do
liftIO $ threadDelay 1000
waitUntilConfirmed getStatus getResource