Skip to content

Commit fd20a84

Browse files
ffakenzffakenz
committed
sketch of publish Hydra scripts
1 parent 7ec4a6f commit fd20a84

File tree

2 files changed

+191
-91
lines changed

2 files changed

+191
-91
lines changed

‎hydra-node/hydra-node.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -112,6 +112,7 @@ library
112112
, cardano-ledger-shelley
113113
, cardano-slotting
114114
, cardano-strict-containers
115+
, cborg
115116
, conduit
116117
, containers
117118
, contra-tracer
@@ -146,6 +147,7 @@ library
146147
, quickcheck-arbitrary-adt
147148
, quickcheck-instances
148149
, resourcet
150+
, safe-money
149151
, serialise
150152
, stm
151153
, text

‎hydra-node/src/Hydra/Chain/Blockfrost/Client.hs

+189-91
Original file line numberDiff line numberDiff line change
@@ -7,107 +7,205 @@ import Blockfrost.Client (
77
runBlockfrost,
88
)
99
import Blockfrost.Client qualified as Blockfrost
10+
import Codec.CBOR.Encoding qualified as CBOR
11+
import Codec.CBOR.Write (toLazyByteString)
12+
import Data.ByteString.Lazy qualified as BL
13+
import Data.Time.Clock.POSIX
14+
import Hydra.Cardano.Api hiding (fromNetworkMagic)
15+
1016
import Cardano.Api.UTxO qualified as UTxO
11-
import Control.Concurrent.Class.MonadSTM (
12-
MonadSTM (readTVarIO),
13-
newTVarIO,
14-
writeTVar,
15-
)
16-
import Hydra.Cardano.Api (
17-
ChainPoint (..),
18-
HasTypeProxy (..),
19-
Hash,
20-
Key (..),
21-
NetworkId (..),
22-
NetworkMagic (..),
23-
PaymentKey,
24-
SerialiseAsCBOR (..),
25-
ShelleyWitnessSigningKey (WitnessPaymentKey),
26-
SigningKey,
27-
SlotNo (..),
28-
SocketPath,
29-
Tx,
30-
TxId,
31-
TxIn (..),
32-
TxIx (..),
33-
UTxO,
34-
WitCtx (..),
35-
examplePlutusScriptAlwaysFails,
36-
getTxBody,
37-
getTxId,
38-
makeShelleyKeyWitness,
39-
makeSignedTransaction,
40-
mkScriptAddress,
41-
mkScriptRef,
42-
mkTxOutAutoBalance,
43-
mkVkAddress,
44-
selectLovelace,
45-
serialiseToRawBytes,
46-
throwErrorAsException,
47-
txOutValue,
48-
pattern TxOutDatumNone,
49-
)
50-
import Hydra.Cardano.Api.Prelude (
51-
BlockHeader (..),
52-
)
53-
import Hydra.Chain.CardanoClient (
54-
QueryPoint (..),
55-
awaitTransaction,
56-
buildTransaction,
57-
queryProtocolParameters,
58-
queryUTxOByTxIn,
59-
queryUTxOFor,
60-
submitTransaction,
61-
)
17+
import Data.Set qualified as Set
18+
import Hydra.Cardano.Api.Prelude (StakePoolKey)
6219
import Hydra.Contract.Head qualified as Head
6320
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
64-
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..), newScriptRegistry)
21+
import Money qualified
6522

66-
publishHydraScripts' ::
67-
-- | Expected network discriminant.
68-
NetworkId ->
69-
-- | Path to the cardano-node's domain socket
70-
SocketPath ->
23+
data APIBlockfrostError
24+
= BlockfrostError Text
25+
| DecodeError Text
26+
deriving (Show, Exception)
27+
28+
runBlockfrostM ::
29+
(MonadIO m, MonadThrow m) =>
30+
Blockfrost.Project ->
31+
BlockfrostClientT IO a ->
32+
m a
33+
runBlockfrostM prj action = do
34+
result <- liftIO $ runBlockfrost prj action
35+
case result of
36+
Left err -> throwIO (BlockfrostError $ show err)
37+
Right val -> pure val
38+
39+
publishHydraScripts ::
40+
-- | The path where the Blockfrost project token hash is stored.
41+
FilePath ->
7142
-- | Keys assumed to hold funds to pay for the publishing transaction.
7243
SigningKey PaymentKey ->
7344
IO [TxId]
74-
publishHydraScripts' networkId socketPath sk = do
75-
pparams <- queryProtocolParameters networkId socketPath QueryTip
76-
forM scripts $ \script -> do
77-
utxo <- queryUTxOFor networkId socketPath QueryTip vk
78-
let output = mkScriptTxOut pparams <$> [mkScriptRef script]
79-
totalDeposit = sum (selectLovelace . txOutValue <$> output)
80-
someUTxO =
81-
maybe mempty UTxO.singleton $
82-
UTxO.find (\o -> selectLovelace (txOutValue o) > totalDeposit) utxo
83-
buildTransaction
84-
networkId
85-
socketPath
86-
changeAddress
87-
someUTxO
88-
[]
89-
output
90-
>>= \case
91-
Left e ->
92-
throwErrorAsException e
93-
Right x -> do
94-
let body = getTxBody x
95-
let tx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body
96-
submitTransaction networkId socketPath tx
97-
void $ awaitTransaction networkId socketPath tx
98-
return $ getTxId body
45+
publishHydraScripts projectPath sk = do
46+
prj <- Blockfrost.projectFromFile projectPath
47+
runBlockfrostM prj $ do
48+
pparams <- Blockfrost.getLatestEpochProtocolParams
49+
Blockfrost.Genesis
50+
{ _genesisNetworkMagic = networkMagic
51+
, _genesisSystemStart = systemStart
52+
} <-
53+
Blockfrost.getLedgerGenesis
54+
let address = Blockfrost.Address (vkAddress networkMagic)
55+
let networkId = fromNetworkMagic networkMagic
56+
let changeAddress = mkVkAddress networkId vk
57+
stakePools <- Blockfrost.listPools
58+
forM scripts $ \script -> do
59+
utxo <- Blockfrost.getAddressUtxos address
60+
liftIO $
61+
buildTx pparams networkId systemStart stakePools script changeAddress utxo
62+
>>= \case
63+
Left err ->
64+
liftIO $ throwErrorAsException err
65+
Right rawTx -> do
66+
let body = getTxBody rawTx
67+
tx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body
68+
-- REVIEW! double CBOR encoding
69+
txByteString :: BL.ByteString = toLazyByteString (CBOR.encodeBytes $ serialiseToCBOR tx)
70+
txCborString = Blockfrost.CBORString txByteString
71+
txHash <- Blockfrost.submitTx txCborString
72+
-- TODO! await transaction confirmed
73+
pure undefined
9974
where
10075
scripts = [initialValidatorScript, commitValidatorScript, Head.validatorScript]
76+
10177
vk = getVerificationKey sk
10278

103-
changeAddress = mkVkAddress networkId vk
79+
vkAddress networkMagic = textAddrOf (fromNetworkMagic networkMagic) vk
80+
81+
-- TODO!
82+
buildTx ::
83+
Blockfrost.ProtocolParams ->
84+
NetworkId ->
85+
POSIXTime ->
86+
[Blockfrost.PoolId] ->
87+
PlutusScript ->
88+
-- | Change address to send
89+
AddressInEra ->
90+
[Blockfrost.AddressUtxo] ->
91+
IO (Either (TxBodyErrorAutoBalance Era) Tx)
92+
buildTx pparams networkId posixTime stakePools script changeAddress utxo = do
93+
pure $
94+
second (flip Tx [] . balancedTxBody) $
95+
makeTransactionBodyAutoBalance
96+
shelleyBasedEra
97+
systemStart
98+
undefined -- (toLedgerEpochInfo eraHistory)
99+
undefined -- (LedgerProtocolParameters pparams)
100+
(Set.fromList (toApiPoolId <$> stakePools))
101+
mempty
102+
mempty
103+
(UTxO.toApi utxoToSpend)
104+
bodyContent
105+
changeAddress
106+
Nothing
107+
where
108+
unspendableScriptAddress = mkScriptAddress networkId $ examplePlutusScriptAlwaysFails WitCtxTxIn
109+
-- FIXME! mkTxOutAutoBalance with minUTxOValue from pparams
110+
outputs = TxOut unspendableScriptAddress mempty TxOutDatumNone <$> [mkScriptRef script]
111+
utxo' = toApiUTxO utxo changeAddress
112+
totalDeposit = sum (selectLovelace . txOutValue <$> outputs)
113+
utxoToSpend = maybe mempty UTxO.singleton $ UTxO.find (\o -> selectLovelace (txOutValue o) > totalDeposit) utxo'
114+
systemStart = SystemStart $ posixSecondsToUTCTime posixTime
115+
collateral = mempty
116+
-- NOTE: 'makeTransactionBodyAutoBalance' overwrites this.
117+
dummyFeeForBalancing = TxFeeExplicit 0
118+
bodyContent =
119+
TxBodyContent
120+
(withWitness <$> toList (UTxO.inputSet utxoToSpend))
121+
(TxInsCollateral collateral)
122+
TxInsReferenceNone
123+
outputs
124+
TxTotalCollateralNone
125+
TxReturnCollateralNone
126+
dummyFeeForBalancing
127+
TxValidityNoLowerBound
128+
TxValidityNoUpperBound
129+
TxMetadataNone
130+
TxAuxScriptsNone
131+
TxExtraKeyWitnessesNone
132+
undefined -- (BuildTxWith $ Just $ LedgerProtocolParameters pparams)
133+
TxWithdrawalsNone
134+
TxCertificatesNone
135+
TxUpdateProposalNone
136+
TxMintValueNone
137+
TxScriptValidityNone
138+
Nothing
139+
Nothing
140+
Nothing
141+
Nothing
142+
143+
-- ** Extras
144+
145+
toApiPoolId :: Blockfrost.PoolId -> Hash StakePoolKey
146+
toApiPoolId (Blockfrost.PoolId textPoolId) =
147+
case deserialiseFromRawBytesHex (AsHash AsStakePoolKey) (encodeUtf8 textPoolId) of
148+
Left err -> error (show err)
149+
Right pool -> pool
150+
151+
toApiUTxO :: [Blockfrost.AddressUtxo] -> AddressInEra -> UTxO' (TxOut CtxUTxO)
152+
toApiUTxO utxos addr = UTxO.fromPairs (toEntry <$> utxos)
153+
where
154+
toEntry :: Blockfrost.AddressUtxo -> (TxIn, TxOut CtxUTxO)
155+
toEntry utxo = (toApiTxIn utxo, toApiTxOut utxo addr)
156+
157+
toApiTxIn :: Blockfrost.AddressUtxo -> TxIn
158+
toApiTxIn Blockfrost.AddressUtxo{_addressUtxoTxHash = Blockfrost.TxHash{unTxHash}, _addressUtxoOutputIndex} =
159+
case deserialiseFromRawBytesHex AsTxId (encodeUtf8 unTxHash) of
160+
Left err -> error (show err)
161+
Right txId -> TxIn txId (TxIx (fromIntegral _addressUtxoOutputIndex))
162+
163+
-- REVIEW! TxOutDatumNone and ReferenceScriptNone
164+
toApiTxOut :: Blockfrost.AddressUtxo -> AddressInEra -> TxOut CtxUTxO
165+
toApiTxOut Blockfrost.AddressUtxo{_addressUtxoAmount} addr =
166+
TxOut addr (toApiValue _addressUtxoAmount) TxOutDatumNone ReferenceScriptNone
167+
168+
toApiPolicyId :: Text -> PolicyId
169+
toApiPolicyId pid =
170+
case deserialiseFromRawBytesHex AsPolicyId (encodeUtf8 pid) of
171+
Left err -> error (show err)
172+
Right p -> p
173+
174+
toApiAssetName :: Text -> AssetName
175+
toApiAssetName = AssetName . encodeUtf8
176+
177+
toApiValue :: [Blockfrost.Amount] -> Value
178+
toApiValue = foldMap convertAmount
179+
where
180+
convertAmount (Blockfrost.AdaAmount lovelaces) =
181+
fromList
182+
[
183+
( AdaAssetId
184+
, Quantity (toInteger lovelaces)
185+
)
186+
]
187+
convertAmount (Blockfrost.AssetAmount money) =
188+
let currency = Money.someDiscreteCurrency money
189+
in fromList
190+
[
191+
( AssetId
192+
(toApiPolicyId currency)
193+
(toApiAssetName currency)
194+
, Quantity (Money.someDiscreteAmount money)
195+
)
196+
]
197+
198+
-- ** Helpers
199+
200+
unwrapAddress :: AddressInEra -> Text
201+
unwrapAddress = \case
202+
ShelleyAddressInEra addr -> serialiseToBech32 addr
203+
ByronAddressInEra{} -> error "Byron."
104204

105-
mkScriptTxOut pparams =
106-
mkTxOutAutoBalance
107-
pparams
108-
unspendableScriptAddress
109-
mempty
110-
TxOutDatumNone
205+
textAddrOf :: NetworkId -> VerificationKey PaymentKey -> Text
206+
textAddrOf networkId vk = unwrapAddress (mkVkAddress @Era networkId vk)
111207

112-
unspendableScriptAddress =
113-
mkScriptAddress networkId $ examplePlutusScriptAlwaysFails WitCtxTxIn
208+
fromNetworkMagic :: Integer -> NetworkId
209+
fromNetworkMagic = \case
210+
0 -> Mainnet
211+
magicNbr -> Testnet (NetworkMagic (fromInteger magicNbr))

0 commit comments

Comments
 (0)