Skip to content

Commit 5ddc05d

Browse files
bladyjokerbladyjoker
committed
Implemented TxBuilder.createGcFsTx method
1 parent 80cd716 commit 5ddc05d

File tree

6 files changed

+176
-77
lines changed

6 files changed

+176
-77
lines changed

‎coop-pab/app/Coop/Cli/TxBuilderGrpc.hs

Lines changed: 81 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
module Coop.Cli.TxBuilderGrpc (txBuilderService, TxBuilderGrpcOpts (..)) where
22

3-
import Control.Lens ((&), (.~), (^.))
3+
import Control.Lens (makeLenses, (&), (.~), (^.))
44
import Network.GRPC.HTTP2.Encoding as Encoding (
55
gzip,
66
uncompressed,
@@ -22,42 +22,51 @@ import BotPlutusInterface.Config (loadPABConfig)
2222
import BotPlutusInterface.Files (txFileName)
2323
import BotPlutusInterface.Types (PABConfig, RawTx (_cborHex), pcOwnPubKeyHash, pcTxFileDir)
2424
import Cardano.Proto.Aux (ProtoCardano (toCardano))
25-
import Coop.Pab (runMintFsTx)
25+
import Coop.Pab (runGcFsTx, runMintFsTx)
2626
import Coop.Pab.Aux (runBpi)
2727
import Coop.Types (CoopDeployment)
2828
import Data.Aeson (decodeFileStrict)
2929
import Data.Maybe (fromMaybe)
3030
import Data.ProtoLens (Message (defMessage))
3131
import Data.Text (Text, unpack)
32+
import Data.Text qualified as Text
3233
import GHC.Exts (fromString)
3334
import Ledger (PaymentPubKeyHash (PaymentPubKeyHash), TxId)
3435
import Proto.Plutus_Fields (cborBase16)
35-
import Proto.TxBuilderService_Fields (alreadyPublished, mintFsSuccess, mintFsTx, msg, otherErr, submitter)
36+
import Proto.TxBuilderService_Fields (alreadyPublished, gcFsTx, info, mintFsSuccess, mintFsTx, msg, otherErr, submitter, success)
3637
import Proto.TxBuilderService_Fields qualified as Proto.TxBuilderService
3738
import System.Directory (doesFileExist, makeAbsolute)
3839
import System.FilePath ((</>))
3940

4041
data TxBuilderGrpcOpts = TxBuilderGrpcOpts
41-
{ tbgo'pabConfig :: FilePath
42-
, tbgo'coopDeploymentFile :: FilePath
43-
, tbgo'authWallets :: [PubKeyHash]
44-
, tbgo'fee :: (PubKeyHash, AssetClass, Integer)
45-
, tbgo'grpcAddress :: String
46-
, tbgo'grpcPort :: Int
47-
, tbgo'tlsCertFile :: FilePath
48-
, tbgo'tlsKeyFile :: FilePath
42+
{ _pabConfig :: FilePath
43+
, _coopDeploymentFile :: FilePath
44+
, _authWallets :: [PubKeyHash]
45+
, _fee :: (PubKeyHash, AssetClass, Integer)
46+
, _grpcAddress :: String
47+
, _grpcPort :: Int
48+
, _tlsCertFile :: FilePath
49+
, _tlsKeyFile :: FilePath
50+
, _mintFsTxValidityMinutes :: Integer
4951
}
5052
deriving stock (Show, Eq)
5153

54+
makeLenses ''TxBuilderGrpcOpts
55+
5256
txBuilderService :: TxBuilderGrpcOpts -> IO ()
5357
txBuilderService opts = do
54-
coopDeployment <- fromMaybe (error "txBuilderService: Must have a CoopDeployment file in JSON") <$> decodeFileStrict @CoopDeployment (tbgo'coopDeploymentFile opts)
55-
pabConf <- either (\err -> error $ "txBuilderService: Must have a PABConfig file in Config format: " <> err) id <$> loadPABConfig (tbgo'pabConfig opts)
58+
coopDeployment <- fromMaybe (error "txBuilderService: Must have a CoopDeployment file in JSON") <$> decodeFileStrict @CoopDeployment (opts ^. coopDeploymentFile)
59+
pabConf <- either (\err -> error $ "txBuilderService: Must have a PABConfig file in Config format: " <> err) id <$> loadPABConfig (opts ^. pabConfig)
5660

57-
let (feeCollector, feeAc, feeQ) = tbgo'fee opts
61+
let (feeCollector, feeAc, feeQ) = opts ^. fee
5862
feeValue = assetClassValue feeAc feeQ
59-
authenticators = PaymentPubKeyHash <$> tbgo'authWallets opts
60-
runMintFsTxOnReq = runMintFsTx coopDeployment authenticators (feeValue, PaymentPubKeyHash feeCollector)
63+
authenticators = PaymentPubKeyHash <$> opts ^. authWallets
64+
runMintFsTxOnReq =
65+
runMintFsTx
66+
coopDeployment
67+
authenticators
68+
(feeValue, PaymentPubKeyHash feeCollector)
69+
(False, opts ^. mintFsTxValidityMinutes)
6170

6271
handleCreateMintFsTx :: Server.UnaryHandler IO CreateMintFsTxReq CreateMintFsTxResp
6372
handleCreateMintFsTx _ req = do
@@ -78,8 +87,12 @@ txBuilderService opts = do
7887
)
7988
( \txId -> do
8089
mayRawTx <- readSignedTx pabConf txId
81-
maybe
82-
(return $ defMessage & Proto.TxBuilderService.error . otherErr . msg .~ "Unable to authenticate transaction")
90+
either
91+
( \err ->
92+
return $
93+
defMessage
94+
& Proto.TxBuilderService.error . otherErr . msg .~ ("Failed creating mint-fact-statement-tx: " <> err)
95+
)
8396
( \rawTx ->
8497
return $
8598
defMessage
@@ -92,6 +105,50 @@ txBuilderService opts = do
92105
)
93106
errOrAcs
94107

108+
runGcFsTxOnReq =
109+
runGcFsTx
110+
coopDeployment
111+
False
112+
113+
handleCreateGcFsTx :: Server.UnaryHandler IO CreateGcFsTxReq CreateGcFsTxResp
114+
handleCreateGcFsTx _ req = do
115+
sub <- toCardano (req ^. submitter)
116+
(_, errOrAcs) <-
117+
runBpi @Text
118+
pabConf
119+
{ pcOwnPubKeyHash = sub
120+
}
121+
(runGcFsTxOnReq req)
122+
either
123+
(\err -> return $ defMessage & Proto.TxBuilderService.error . otherErr . msg .~ err)
124+
( \(mayTxId, info') -> do
125+
maybe
126+
( return $
127+
defMessage
128+
& Proto.TxBuilderService.error . otherErr . msg .~ "Failed creating a gc-fact-statement-tx"
129+
& info .~ info'
130+
)
131+
( \txId -> do
132+
mayRawTx <- readSignedTx pabConf txId
133+
either
134+
( \err ->
135+
return $
136+
defMessage
137+
& Proto.TxBuilderService.error . otherErr . msg .~ ("Failed creating a gc-fact-statement-tx: " <> err)
138+
& info .~ info'
139+
)
140+
( \rawTx ->
141+
return $
142+
defMessage
143+
& success . gcFsTx . cborBase16 .~ rawTx
144+
& info .~ info'
145+
)
146+
mayRawTx
147+
)
148+
mayTxId
149+
)
150+
errOrAcs
151+
95152
routes :: [ServiceHandler]
96153
routes =
97154
[ Server.unary (RPC :: RPC TxBuilder "createMintFsTx") handleCreateMintFsTx
@@ -100,8 +157,8 @@ txBuilderService opts = do
100157

101158
runServer
102159
routes
103-
(fromString $ tbgo'grpcAddress opts, tbgo'grpcPort opts)
104-
(tbgo'tlsCertFile opts, tbgo'tlsKeyFile opts)
160+
(fromString $ opts ^. grpcAddress, opts ^. grpcPort)
161+
(opts ^. tlsCertFile, opts ^. tlsKeyFile)
105162

106163
runServer :: [ServiceHandler] -> (Warp.HostPreference, Int) -> (FilePath, FilePath) -> IO ()
107164
runServer routes (h, p) (certFile, keyFile) = do
@@ -117,13 +174,7 @@ runServer routes (h, p) (certFile, keyFile) = do
117174
, Encoding.gzip
118175
]
119176

120-
handleCreateGcFsTx :: Server.UnaryHandler IO CreateGcFsTxReq CreateGcFsTxResp
121-
handleCreateGcFsTx _ _ =
122-
return $
123-
defMessage
124-
& Proto.TxBuilderService.error . otherErr . msg .~ "Finally"
125-
126-
readSignedTx :: PABConfig -> TxId -> IO (Maybe Text)
177+
readSignedTx :: PABConfig -> TxId -> IO (Either Text Text)
127178
readSignedTx pabConf txId = do
128179
txFolderPath <- makeAbsolute (unpack . pcTxFileDir $ pabConf)
129180
let path :: FilePath
@@ -134,11 +185,9 @@ readSignedTx pabConf txId = do
134185
mayRawTx <- decodeFileStrict @RawTx path
135186
maybe
136187
( do
137-
print $ "Must have a properly formatter RawTx in Json at " <> path
138-
return Nothing
188+
return . Left . Text.pack $ "Must have a properly formatter RawTx in Json at " <> path
139189
)
140-
(return . Just . _cborHex)
190+
(return . Right . _cborHex)
141191
mayRawTx
142192
else do
143-
print $ "Must find signed transaction file at " <> path
144-
return Nothing
193+
return . Left . Text.pack $ "Must find signed transaction file at " <> path

‎coop-pab/app/Main.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -268,6 +268,14 @@ txBuilderGrpcOpts =
268268
<> value ".coop-pab-cli/key.pem"
269269
<> showDefault
270270
)
271+
<*> option
272+
auto
273+
( long "mint-fs-tx-validity-minutes"
274+
<> metavar "MINT_VALIDITY_MINUTES"
275+
<> help "mint-fact-statement-tx validity range setting validityRange = <now, now + minutes>"
276+
<> value 10
277+
<> showDefault
278+
)
271279

272280
optionsP :: Parser Command
273281
optionsP =

‎coop-pab/build.nix

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -110,11 +110,11 @@ let
110110
};
111111

112112
shellHook = ''
113+
${shellHook}
113114
export LC_CTYPE=C.UTF-8
114115
export LC_ALL=C.UTF-8
115116
export LANG=C.UTF-8
116117
source ${./aux.sh}
117-
${shellHook}
118118
'';
119119

120120
};

‎coop-pab/src/Coop/Pab.hs

Lines changed: 32 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -20,12 +20,12 @@ import Cardano.Proto.Aux (
2020
ProtoCardano (fromCardano, toCardano),
2121
)
2222
import Control.Lens ((&), (.~), (^.))
23-
import Control.Monad (guard, void, when)
23+
import Control.Monad (guard, when)
2424
import Coop.Pab.Aux (Trx (Trx), currencyValue, datumFromTxOut, datumFromTxOutOrFail, deplAuthCs, deplAuthMp, deplCertCs, deplCertVAddress, deplFsCs, deplFsVAddress, deplFsVHash, findOutsAt, findOutsAt', findOutsAtHolding', findOutsAtHoldingCurrency, findOutsAtHoldingCurrency', hasCurrency, hashTxInputs, interval', minUtxoAdaValue, mkMintOneShotTrx, submitTrx, submitTrx', toDatum, toRedeemer)
2525
import Coop.Types (AuthBatchId, AuthDeployment (AuthDeployment, ad'authMp, ad'authorityAc, ad'certMp, ad'certV), AuthMpParams (AuthMpParams), AuthMpRedeemer (AuthMpBurn, AuthMpMint), AuthParams (AuthParams, ap'authTokenCs, ap'certTokenCs), CertDatum (CertDatum, cert'id, cert'validity), CertMpParams (CertMpParams), CertMpRedeemer (CertMpBurn, CertMpMint), CoopDeployment (CoopDeployment, cd'auth, cd'fsMp, cd'fsV), CoopPlutus (cp'fsV, cp'mkAuthMp, cp'mkCertMp, cp'mkFsMp, cp'mkOneShotMp), CoopState (CoopState), FactStatementId, FsDatum (FsDatum, fd'fsId, fs'gcAfter, fs'submitter), FsMpParams (FsMpParams), FsMpRedeemer (FsMpBurn, FsMpMint), cp'certV)
2626
import Data.Bool (bool)
2727
import Data.Foldable (toList)
28-
import Data.List (nub)
28+
import Data.List (nub, partition)
2929
import Data.Map (Map)
3030
import Data.Map qualified as Map
3131
import Data.Maybe (catMaybes)
@@ -60,9 +60,9 @@ import Plutus.V2.Ledger.Api (
6060
toData,
6161
)
6262
import PlutusTx (toBuiltinData)
63-
import PlutusTx.Prelude (Group (inv))
64-
import Proto.TxBuilderService (CreateMintFsTxReq, MintFsSuccess'FsIdAndTxOutRef)
65-
import Proto.TxBuilderService_Fields (factStatementId, factStatementUtxo, factStatements, fs, fsId, gcAfter, submitter)
63+
import PlutusTx.Prelude (Group (inv), fromBuiltin)
64+
import Proto.TxBuilderService (CreateGcFsTxReq, CreateMintFsTxReq, GcFsInfo, MintFsSuccess'FsIdAndTxOutRef)
65+
import Proto.TxBuilderService_Fields (factStatementId, factStatementUtxo, factStatements, fs, fsId, fsIds, gcAfter, notFoundFsIds, obsoleteFsIds, submitter, validFsIds)
6666
import Safe.Foldable (maximumMay)
6767
import Test.Plutip.Internal.BotPlutusInterface.Setup ()
6868
import Test.Plutip.Internal.LocalCluster ()
@@ -653,33 +653,47 @@ mkMintFsTrx coopDeployment now minutes publishingSpec (feeVal, feeCollectorPpkh)
653653
bpiConstraints = mustValidateInFixed (interval' (Finite now) (Finite txValidUntil))
654654
in Trx lookups constraints bpiConstraints
655655

656-
runGcFsTx :: CoopDeployment -> PaymentPubKeyHash -> Contract w s Text ()
657-
runGcFsTx coopDeployment self = do
656+
runGcFsTx :: CoopDeployment -> Bool -> CreateGcFsTxReq -> Contract w s Text (Maybe TxId, GcFsInfo)
657+
runGcFsTx coopDeployment submit req = do
658+
when (null $ req ^. fsIds) (throwError "Must have at least one Fact Statement ID to process")
659+
660+
self <- PaymentPubKeyHash <$> toCardanoC (req ^. submitter)
658661
fsOuts <- findOutsAtHoldingCurrency (deplFsVAddress coopDeployment) (deplFsCs coopDeployment)
659-
(start, _) <- currentNodeClientTimeRange
660662
fsOutsWithDatum <-
661663
traverse
662664
( \out@(_, ciOut) -> do
663665
mayDat <- datumFromTxOut @FsDatum ciOut
664666
maybe
665-
(throwError "Must parse FsDatum")
667+
(throwError "Must parse legitimate FsDatum from @FsV UTxO")
666668
(\d -> return (out, d))
667669
mayDat
668670
)
669671
(Map.toList fsOuts)
670-
let submitterFsOutsWithDatum =
672+
673+
(start, _) <- currentNodeClientTimeRange
674+
let mine =
671675
[ (out, fsDat)
672676
| (out, fsDat) <- fsOutsWithDatum
673677
, fs'submitter fsDat == unPaymentPubKeyHash self
674-
, Finite start > fs'gcAfter fsDat
675678
]
676-
let mintGcTrx =
677-
mkGcFsTrx
678-
coopDeployment
679-
self
680-
submitterFsOutsWithDatum
681-
start
682-
void $ submitTrx @Void mintGcTrx
679+
(mineFoundReqIds, missingReqIds) = partition (\(_, fsDat) -> (fromBuiltin . getLedgerBytes . fd'fsId $ fsDat) `elem` (req ^. fsIds)) mine
680+
(mineFoundObsolete, mineFoundStillValid) = partition (\(_, fsDat) -> Finite start > fs'gcAfter fsDat) mineFoundReqIds
681+
let info :: GcFsInfo
682+
info =
683+
defMessage
684+
& obsoleteFsIds .~ (fromBuiltin . getLedgerBytes . fd'fsId . snd <$> mineFoundObsolete)
685+
& notFoundFsIds .~ (fromBuiltin . getLedgerBytes . fd'fsId . snd <$> missingReqIds)
686+
& validFsIds .~ (fromBuiltin . getLedgerBytes . fd'fsId . snd <$> mineFoundStillValid)
687+
688+
let mintGcTrx = mkGcFsTrx coopDeployment self mineFoundObsolete start
689+
if null mineFoundObsolete
690+
then return (Nothing, info)
691+
else do
692+
txId <-
693+
if submit
694+
then submitTrx @Void mintGcTrx
695+
else submitTrx' @Void mintGcTrx
696+
return (Just txId, info)
683697

684698
mkGcFsTrx :: CoopDeployment -> PaymentPubKeyHash -> [((TxOutRef, ChainIndexTxOut), FsDatum)] -> POSIXTime -> Trx i o a
685699
mkGcFsTrx coopDeployment submitterPkh fsOutsWithDatum now = do

‎coop-pab/test/Main.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ import Plutus.Contract (currentNodeClientTimeRange, logInfo, ownFirstPaymentPubK
2828
import Plutus.Script.Utils.V2.Address (mkValidatorAddress)
2929
import Plutus.V2.Ledger.Api (Extended (Finite, NegInf, PosInf), POSIXTime, fromData, toBuiltin, toData)
3030
import Plutus.V2.Ledger.Api qualified as AssocMap
31-
import Proto.TxBuilderService_Fields (factStatements, fs, fsId, gcAfter, submitter)
31+
import Proto.TxBuilderService_Fields (factStatements, fs, fsId, fsIds, gcAfter, submitter)
3232
import Test.Plutip.Config (PlutipConfig (extraConfig))
3333
import Test.Plutip.Contract (assertExecutionWith, initAda, withCollateral, withContract, withContractAs)
3434
import Test.Plutip.Internal.Cluster.Extra.Types (ExtraConfig (ExtraConfig))
@@ -413,7 +413,12 @@ tests coopPlutus =
413413
( \[_god, _aa, _certR, _authWallet, _feeWallet] -> do
414414
self <- ownFirstPaymentPubKeyHash
415415
logInfo @String $ "Running as submitterWallet " <> show self
416-
runGcFsTx coopDeployment self
416+
self' <- fromCardano (unPaymentPubKeyHash self)
417+
let req =
418+
defMessage
419+
& fsIds .~ ["fsIdA", "fsIdB", "fsIdC", "fsIdD", "fsIdE"]
420+
& submitter .~ self'
421+
_ <- runGcFsTx coopDeployment True req
417422
outs <- findOutsAtHoldingCurrency (deplFsVAddress coopDeployment) (deplFsCs coopDeployment)
418423
return (length outs)
419424
)

0 commit comments

Comments
 (0)