Update GHC and change MonadUtxoQuery interface (j-mueller#185)

* Update GHC from 9.6.5 to 9.6.6 * Modify MonadUtxoQuery interface so that we also return the resolved datum of each TxOut * Remove duplicate Convex.Query.MonadUtxoQuery
albertodvp · Jul 19, 2024 · e1f4359 · e1f4359
1 parent ed0c7dc
commit e1f4359
Show file tree

Hide file tree

Showing 14 changed files with 118 additions and 113 deletions.
diff --git a/.github/workflows/ci-linux.yaml b/.github/workflows/ci-linux.yaml
@@ -5,7 +5,7 @@ on:
     tags: [ "*.*.*" ]
   pull_request:
 
-concurrency: 
+concurrency:
   group: ${{ github.ref }}
   cancel-in-progress: true
 
@@ -26,8 +26,8 @@ jobs:
       - uses: haskell-actions/setup@v2
         id: cabal-setup
         with:
-          ghc-version: '9.6.5'
-          cabal-version: '3.10.1.0'
+          ghc-version: '9.6.6'
+          cabal-version: '3.10.3.0'
 
       - uses: actions/checkout@v4
 

diff --git a/.github/workflows/gh-pages.yaml b/.github/workflows/gh-pages.yaml
@@ -23,8 +23,8 @@ jobs:
       - uses: haskell-actions/setup@v2
         id: cabal-setup
         with:
-          ghc-version: '9.6.5'
-          cabal-version: '3.10.1.0'
+          ghc-version: '9.6.6'
+          cabal-version: '3.10.3.0'
 
       - uses: actions/checkout@v4
 
@@ -67,4 +67,4 @@ jobs:
     steps:
       - name: Deploy to GitHub Pages
         id: deployment
-        uses: actions/deploy-pages@v2 # or the latest "vX.X.X" version tag for this action
+        uses: actions/deploy-pages@v2 # or the latest "vX.X.X" version tag for this action
diff --git a/README.md b/README.md
@@ -18,8 +18,8 @@ The `main` branch uses the following versions of its major dependencies:
 |--|--|
 |`cardano-node`|[9.0.0](https://chap.intersectmbo.org/package/cardano-node-9.0.0/)|
 |`cardano-api`|[9.0.0](https://chap.intersectmbo.org/package/cardano-api-9.0.0.0/)|
-|`ghc`|9.6.5|
-|`cabal`|3.10.1.0|
+|`ghc`|9.6.6|
+|`cabal`|3.10.3.0|
 
 Support for `ghc-8.10.7` and `cardano-node-1.35.4` will be maintained for a little while in the [`node-1.35.4`](https://github.com/j-mueller/sc-tools/tree/node-1.35.4) branch.
 
@@ -118,7 +118,7 @@ foldClient' ::
   PipelinedLedgerStateClient
 ```
 
-This lets you deal with rollbacks explicitly, by giving you a summary of type `w` of all the data that has been rolled back. 
+This lets you deal with rollbacks explicitly, by giving you a summary of type `w` of all the data that has been rolled back.
 
 ## Goals
 

diff --git a/cabal.project b/cabal.project
@@ -13,7 +13,7 @@ repository cardano-haskell-packages
     c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56
     d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee
 
-with-compiler: ghc-9.6.5
+with-compiler: ghc-9.6.6
 index-state:
   , hackage.haskell.org 2024-07-05T00:00:00Z
   , cardano-haskell-packages 2024-07-05T00:00:00Z

diff --git a/fix-stylish-haskell.sh b/fix-stylish-haskell.sh
@@ -1,3 +1,3 @@
-#! /bin/bash
+#!/usr/bin/env bash
 
-fdfind --extension hs --exclude 'dist-newstyle/*' --exclude 'dist/*' --exclude '.stack-work/*' --exec bash -c "~/.cabal/bin/stylish-haskell -i {} || true"
+fd --extension hs --exclude 'dist-newstyle/*' --exclude 'dist/*' --exclude '.stack-work/*' --exec bash -c "stylish-haskell -i {} || true"
diff --git a/flake.lock b/flake.lock
diff --git a/flake.nix b/flake.nix
@@ -2,12 +2,19 @@
   description = "sc-tools";
   inputs = {
     flake-parts.url = "github:hercules-ci/flake-parts";
-    haskellNix.url = "github:input-output-hk/haskell.nix";
     nixpkgs.follows = "haskellNix/nixpkgs-unstable";
+    hackage = {
+      url = "github:input-output-hk/hackage.nix";
+      flake = false;
+    };
     CHaP = {
       url = "github:intersectmbo/cardano-haskell-packages?ref=repo";
       flake = false;
     };
+    haskellNix = {
+      url = "github:input-output-hk/haskell.nix";
+      inputs.hackage.follows = "hackage";
+    };
     iohk-nix.url = "github:input-output-hk/iohk-nix";
   };
   outputs = inputs@{ nixpkgs, haskellNix, flake-parts, CHaP, iohk-nix, ... }:
@@ -21,15 +28,19 @@
             iohk-nix.overlays.haskell-nix-crypto
             (final: prev: {
               sc-tools = final.haskell-nix.cabalProject' {
-                compiler-nix-name = "ghc965";
+                compiler-nix-name = "ghc966";
                 src = lib.cleanSource ./.;
                 shell = {
                   withHoogle = true;
+                  buildInputs = with pkgs; [
+                    fd
+                  ];
                   tools = {
                     cabal = "latest";
                     haskell-language-server = "latest";
                     ghcide = "latest";
                     ghcid = "latest";
+                    stylish-haskell = "latest";
                   };
                 };
                 inputMap = { "https://chap.intersectmbo.org/" = CHaP; };
@@ -43,6 +54,15 @@
           devShells = flake.devShells;
         };
     };
+  nixConfig = {
+    extra-substituters = [
+      "https://cache.iog.io"
+    ];
+    extra-trusted-public-keys = [
+      "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ="
+    ];
+    allow-import-from-derivation = true;
+  };
 }
 
 
diff --git a/src/base/lib/Convex/Class.hs b/src/base/lib/Convex/Class.hs
@@ -277,8 +277,11 @@ control over the capabilities they require.
 --   NOTE: There are currently no implementations of this class in sc-tools.
 class Monad m => MonadUtxoQuery m where
   -- | Given a set of payment credentials, retrieve all UTxOs associated with
-  -- those payment credentials according to the current indexed blockchain state.
-  utxosByPaymentCredentials :: Set PaymentCredential -> m (UtxoSet C.CtxUTxO ())
+  -- those payment credentials according to the current indexed blockchain
+  -- state. Each UTXO also possibly has the resolved datum (meaning that if we
+  -- only have the datum hash, the implementation should try and resolve it to
+  -- the actual datum).
+  utxosByPaymentCredentials :: Set PaymentCredential -> m (UtxoSet C.CtxUTxO (Maybe C.HashableScriptData))
 
 instance MonadUtxoQuery m => MonadUtxoQuery (ResultT m) where
   utxosByPaymentCredentials = lift . utxosByPaymentCredentials
@@ -301,8 +304,11 @@ instance MonadUtxoQuery m => MonadUtxoQuery (MonadBlockchainCardanoNodeT e m) wh
 instance MonadUtxoQuery m => MonadUtxoQuery (MonadLogIgnoreT m) where
   utxosByPaymentCredentials = lift . utxosByPaymentCredentials
 
+instance MonadUtxoQuery m => MonadUtxoQuery (PropertyM m) where
+  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
+
 -- | Given a single payment credential, find the UTxOs with that credential
-utxosByPaymentCredential :: MonadUtxoQuery m => PaymentCredential -> m (UtxoSet C.CtxUTxO ())
+utxosByPaymentCredential :: MonadUtxoQuery m => PaymentCredential -> m (UtxoSet C.CtxUTxO (Maybe C.HashableScriptData))
 utxosByPaymentCredential = utxosByPaymentCredentials . Set.singleton
 
 {- Note [MonadDatumQuery design]

diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal
@@ -79,6 +79,7 @@ test-suite convex-coin-selection-test
     tasty-quickcheck,
     QuickCheck,
     lens,
+    cardano-ledger-api,
     cardano-ledger-alonzo,
     cardano-ledger-babbage,
     cardano-ledger-shelley,

diff --git a/src/coin-selection/lib/Convex/CoinSelection/Class.hs b/src/coin-selection/lib/Convex/CoinSelection/Class.hs
@@ -28,13 +28,13 @@ import           Convex.BuildTx                   (TxBuilder)
 import           Convex.CardanoApi.Lenses         (emptyTxOut)
 import           Convex.Class                     (MonadBlockchain (..),
                                                    MonadDatumQuery (queryDatumFromHash),
-                                                   MonadMockchain (..))
+                                                   MonadMockchain (..),
+                                                   MonadUtxoQuery (utxosByPaymentCredentials))
 import           Convex.CoinSelection             (BalanceTxError,
                                                    ChangeOutputPosition,
                                                    TxBalancingMessage)
 import qualified Convex.CoinSelection
 import           Convex.MonadLog                  (MonadLog, MonadLogIgnoreT)
-import           Convex.Query                     (MonadUtxoQuery (utxosByPaymentCredentials))
 import           Convex.Utxos                     (BalanceChanges (..),
                                                    UtxoSet (..))
 
@@ -59,7 +59,7 @@ class Monad m => MonadBalance m where
     AddressInEra BabbageEra ->
 
     -- | Set of UTxOs that can be used to supply missing funds
-    UtxoSet C.CtxUTxO () ->
+    UtxoSet C.CtxUTxO a ->
 
     -- | The unbalanced transaction body
     TxBuilder ->

diff --git a/src/coin-selection/lib/Convex/Query.hs b/src/coin-selection/lib/Convex/Query.hs
@@ -8,8 +8,6 @@
 queries that we need for building transactions
 -}
 module Convex.Query(
-  MonadUtxoQuery(..),
-  utxosByPaymentCredential,
   balanceTx,
 
   -- * Tx balancing for operator
@@ -27,82 +25,38 @@ module Convex.Query(
   runWalletAPIQueryT
 ) where
 
-import           Cardano.Api                        (BabbageEra, BalancedTxBody,
-                                                     PaymentCredential (..))
-import qualified Cardano.Api                        as C
-import           Control.Monad.Except               (MonadError)
-import           Control.Monad.IO.Class             (MonadIO (..))
-import           Control.Monad.Reader               (ReaderT, ask, runReaderT)
-import           Control.Monad.Trans.Class          (MonadTrans (..))
-import           Control.Monad.Trans.Except         (ExceptT, runExceptT)
-import           Control.Monad.Trans.Except.Result  (ResultT)
-import qualified Control.Monad.Trans.State          as StrictState
-import qualified Control.Monad.Trans.State.Strict   as LazyState
-import           Control.Tracer                     (Tracer, natTracer)
-import           Convex.BuildTx                     (TxBuilder)
-import           Convex.Class                       (MonadBlockchain (..),
-                                                     MonadBlockchainCardanoNodeT)
-import           Convex.CoinSelection               (BalanceTxError,
-                                                     ChangeOutputPosition,
-                                                     TxBalancingMessage)
+import           Cardano.Api                (BabbageEra, BalancedTxBody,
+                                             PaymentCredential (..))
+import qualified Cardano.Api                as C
+import           Control.Monad.Except       (MonadError)
+import           Control.Monad.IO.Class     (MonadIO (..))
+import           Control.Monad.Reader       (ReaderT, ask, runReaderT)
+import           Control.Monad.Trans.Class  (MonadTrans (..))
+import           Control.Monad.Trans.Except (runExceptT)
+import           Control.Tracer             (Tracer, natTracer)
+import           Convex.BuildTx             (TxBuilder)
+import           Convex.Class               (MonadBlockchain (..),
+                                             MonadUtxoQuery (utxosByPaymentCredentials),
+                                             utxosByPaymentCredential)
+import           Convex.CoinSelection       (BalanceTxError,
+                                             ChangeOutputPosition,
+                                             TxBalancingMessage)
 import qualified Convex.CoinSelection
-import           Convex.MockChain                   (MockchainT, utxoSet)
-import           Convex.MonadLog                    (MonadLog, MonadLogIgnoreT)
-import           Convex.NodeClient.WaitForTxnClient (MonadBlockchainWaitingT (..))
-import           Convex.Utils                       (liftEither, liftResult)
-import           Convex.Utxos                       (BalanceChanges,
-                                                     UtxoSet (_utxos),
-                                                     fromUtxoTx,
-                                                     onlyCredentials)
-import qualified Convex.Wallet.API                  as Wallet.API
-import           Convex.Wallet.Operator             (Operator (..), Signing,
-                                                     operatorPaymentCredential,
-                                                     returnOutputFor,
-                                                     signTxOperator)
-import           Data.Aeson                         (FromJSON, ToJSON)
-import           Data.Functor                       (($>))
-import qualified Data.Map                           as Map
-import           Data.Maybe                         (listToMaybe)
-import           Data.Set                           (Set)
-import qualified Data.Set                           as Set
-import           GHC.Generics                       (Generic)
-import           Servant.Client                     (ClientEnv)
-import           Test.QuickCheck.Monadic            (PropertyM)
-
-class Monad m => MonadUtxoQuery m where
-  utxosByPaymentCredentials :: Set PaymentCredential -> m (UtxoSet C.CtxUTxO ())
-
-utxosByPaymentCredential :: MonadUtxoQuery m => PaymentCredential -> m (UtxoSet C.CtxUTxO ())
-utxosByPaymentCredential = utxosByPaymentCredentials . Set.singleton
-
-instance Monad m => MonadUtxoQuery (MockchainT m) where
-  utxosByPaymentCredentials cred = onlyCredentials cred <$> utxoSet
-
-instance MonadUtxoQuery m => MonadUtxoQuery (ResultT m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (ExceptT e m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (ReaderT e m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (StrictState.StateT s m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (LazyState.StateT s m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (MonadBlockchainCardanoNodeT e m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (MonadLogIgnoreT m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-instance MonadUtxoQuery m => MonadUtxoQuery (PropertyM m) where
-  utxosByPaymentCredentials = lift . utxosByPaymentCredentials
-
-deriving newtype instance MonadUtxoQuery m => MonadUtxoQuery (MonadBlockchainWaitingT m)
+import           Convex.MonadLog            (MonadLog)
+import           Convex.Utils               (liftEither, liftResult)
+import           Convex.Utxos               (BalanceChanges, UtxoSet (_utxos),
+                                             fromUtxoTx, onlyCredentials)
+import qualified Convex.Wallet.API          as Wallet.API
+import           Convex.Wallet.Operator     (Operator (..), Signing,
+                                             operatorPaymentCredential,
+                                             returnOutputFor, signTxOperator)
+import           Data.Aeson                 (FromJSON, ToJSON)
+import           Data.Functor               (($>))
+import qualified Data.Map                   as Map
+import           Data.Maybe                 (listToMaybe)
+import qualified Data.Set                   as Set
+import           GHC.Generics               (Generic)
+import           Servant.Client             (ClientEnv)
 
 {-| Balance the transaction body using the UTxOs locked by the payment credentials,
 returning any unused funds to the given return output
@@ -134,7 +88,7 @@ instance MonadIO m => MonadUtxoQuery (WalletAPIQueryT m) where
         let msg = "WalletAPI: Error when calling remote server: " <> show err
         liftIO (putStrLn msg)
         error msg
-      Right x  -> pure (onlyCredentials credentials $ fromUtxoTx x)
+      Right x  -> pure (onlyCredentials credentials $ fromUtxoTx $ fmap (const Nothing) x)
 
 deriving newtype instance MonadError e m => MonadError e (WalletAPIQueryT m)
 
@@ -196,7 +150,7 @@ operatorUtxos :: MonadUtxoQuery m => Operator k -> m [(C.TxIn, C.InAnyCardanoEra
 operatorUtxos = fmap (Map.toList . fmap fst . _utxos) . utxosByPaymentCredential . operatorPaymentCredential
 
 {-| Select a single UTxO that is controlled by the operator. |-}
-selectOperatorUTxO :: MonadUtxoQuery m => Operator k -> m (Maybe (C.TxIn, C.InAnyCardanoEra (C.TxOut (C.CtxUTxO))))
+selectOperatorUTxO :: MonadUtxoQuery m => Operator k -> m (Maybe (C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxUTxO)))
 selectOperatorUTxO operator = fmap listToMaybe (operatorUtxos operator)
 
 -- | Failures during txn balancing and submission