From be9fdb162c53adba2698a71138a61bdd2ff97bc5 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 12 Jun 2023 18:44:31 +0100 Subject: [PATCH 1/9] Accommodate ouroboros-consensus API changes --- cabal.project | 4 +- cardano-api/cardano-api.cabal | 44 +++++++++---------- .../internal/Cardano/Api/LedgerState.hs | 10 +++-- cardano-api/internal/Cardano/Api/Orphans.hs | 1 - cardano-api/internal/Cardano/Api/Protocol.hs | 11 +++-- flake.lock | 12 ++--- 6 files changed, 44 insertions(+), 38 deletions(-) diff --git a/cabal.project b/cabal.project index 9a69e8d9ff..0f7a5ba7a8 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2023-07-02T00:00:00Z - , cardano-haskell-packages 2023-07-02T00:00:00Z + , hackage.haskell.org 2023-07-03T00:00:00Z + , cardano-haskell-packages 2023-07-07T22:30:00Z packages: cardano-api diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 731930f09a..6909251bf1 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -126,17 +126,17 @@ library internal , cardano-crypto-class >= 2.1.1 , cardano-crypto-wrapper ^>= 1.5 , cardano-data >= 1.0 - , cardano-ledger-alonzo >= 1.3 - , cardano-ledger-allegra >= 1.2 - , cardano-ledger-api >= 1.2.0.1 - , cardano-ledger-babbage >= 1.3 + , cardano-ledger-alonzo >= 1.3.1.1 + , cardano-ledger-allegra >= 1.2.0.2 + , cardano-ledger-api >= 1.3 + , cardano-ledger-babbage >= 1.4.0.1 , cardano-ledger-binary - , cardano-ledger-byron >= 1.0.0.1 - , cardano-ledger-conway >= 1.3 - , cardano-ledger-core >= 1.3 - , cardano-ledger-mary >= 1.1 - , cardano-ledger-shelley >= 1.3 - , cardano-protocol-tpraos >= 1.0.3.1 + , cardano-ledger-byron >= 1.0.0.2 + , cardano-ledger-conway >= 1.5 + , cardano-ledger-core >= 1.4 + , cardano-ledger-mary >= 1.3.0.2 + , cardano-ledger-shelley >= 1.4.1.0 + , cardano-protocol-tpraos >= 1.0.3.3 , cardano-slotting >= 0.1 , cardano-strict-containers >= 0.1 , cborg @@ -153,9 +153,9 @@ library internal , mtl , network , optparse-applicative-fork - , ouroboros-consensus >= 0.7 - , ouroboros-consensus-cardano >= 0.6 - , ouroboros-consensus-diffusion >= 0.6 + , ouroboros-consensus >= 0.9 + , ouroboros-consensus-cardano >= 0.7 + , ouroboros-consensus-diffusion >= 0.7 , ouroboros-consensus-protocol >= 0.5 , ouroboros-network , ouroboros-network-api @@ -170,7 +170,7 @@ library internal , serialise , small-steps ^>= 1.0 , stm - , text + , text >= 2.0 , time , transformers , transformers-except ^>= 0.1.3 @@ -228,11 +228,11 @@ library gen , cardano-binary >= 1.6 && < 1.8 , cardano-crypto-class ^>= 2.1 , cardano-crypto-test ^>= 1.5 - , cardano-ledger-alonzo >= 1.3 + , cardano-ledger-alonzo >= 1.3.1.1 , cardano-ledger-alonzo-test , cardano-ledger-byron-test >= 1.5 - , cardano-ledger-core >= 1.3 - , cardano-ledger-shelley >= 1.3 + , cardano-ledger-core >= 1.4 + , cardano-ledger-shelley >= 1.4.1.0 , containers , hedgehog >= 1.1 , text @@ -252,8 +252,8 @@ test-suite cardano-api-test , cardano-crypto-class ^>= 2.1 , cardano-crypto-test ^>= 1.5 , cardano-crypto-tests ^>= 2.1 - , cardano-ledger-api >= 1.2.0.1 - , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.2 + , cardano-ledger-api >= 1.3 + , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.4 , containers , hedgehog >= 1.1 , hedgehog-quickcheck @@ -298,10 +298,10 @@ test-suite cardano-api-golden , cardano-crypto-class , cardano-data >= 1.0 , cardano-ledger-alonzo - , cardano-ledger-api >= 1.2.0.1 - , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.2 + , cardano-ledger-api >= 1.3 + , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.4 , cardano-ledger-shelley - , cardano-ledger-shelley-test >= 1.2 + , cardano-ledger-shelley-test >= 1.2.0.1 , cardano-slotting ^>= 0.1 , containers , errors diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 223b250c7c..a315216545 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -134,6 +134,7 @@ import qualified Cardano.Slotting.EpochInfo.API as Slot import Cardano.Slotting.Slot (WithOrigin (At, Origin)) import qualified Cardano.Slotting.Slot as Slot import qualified Ouroboros.Consensus.Block.Abstract as Consensus +import Ouroboros.Consensus.Block.Forging (BlockForging) import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron import qualified Ouroboros.Consensus.Byron.Ledger.Ledger as Byron import qualified Ouroboros.Consensus.Cardano as Consensus @@ -772,7 +773,7 @@ genesisConfigToEnv ] | otherwise -> let - topLevelConfig = Consensus.pInfoConfig (mkProtocolInfoCardano genCfg) + topLevelConfig = Consensus.pInfoConfig $ fst $ mkProtocolInfoCardano genCfg in Right $ Env { envLedgerConfig = Consensus.topLevelConfigLedger topLevelConfig @@ -912,7 +913,7 @@ readByteString fp cfgType = ExceptT $ initLedgerStateVar :: GenesisConfig -> LedgerState initLedgerStateVar genesisConfig = LedgerState - { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger protocolInfo + { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo } where protocolInfo = mkProtocolInfoCardano genesisConfig @@ -989,10 +990,11 @@ type NodeConfigFile = File NodeConfig mkProtocolInfoCardano :: GenesisConfig -> - Consensus.ProtocolInfo - IO + (Consensus.ProtocolInfo (HFC.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto)) + , IO [BlockForging IO (HFC.HardForkBlock + (Consensus.CardanoEras Consensus.StandardCrypto))]) mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesis alonzoGenesis conwayGenesis) = Consensus.protocolInfoCardano Consensus.ProtocolParamsByron diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index acb2a818d1..d62e48e1a4 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -16,7 +16,6 @@ import Data.Aeson (ToJSON (..), object, pairs, (.=)) import qualified Data.Aeson as Aeson import Data.Data (Data) - deriving instance Data DecoderError deriving instance Data CBOR.DeserialiseFailure deriving instance Data Bech32.DecodingError diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs index 51426d78b6..66f1346555 100644 --- a/cardano-api/internal/Cardano/Api/Protocol.hs +++ b/cardano-api/internal/Cardano/Api/Protocol.hs @@ -17,6 +17,9 @@ module Cardano.Api.Protocol import Cardano.Api.Modes +import Data.Bifunctor (bimap) + +import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Cardano import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC) @@ -35,7 +38,7 @@ import Ouroboros.Consensus.Util.IOLike (IOLike) class (RunNode blk, IOLike m) => Protocol m blk where data ProtocolInfoArgs m blk - protocolInfo :: ProtocolInfoArgs m blk -> ProtocolInfo m blk + protocolInfo :: ProtocolInfoArgs m blk -> (ProtocolInfo blk, m [BlockForging m blk]) -- | Node client support for each consensus protocol. -- @@ -50,7 +53,9 @@ class RunNode blk => ProtocolClient blk where -- | Run PBFT against the Byron ledger instance IOLike m => Protocol m ByronBlockHFC where data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron - protocolInfo (ProtocolInfoArgsByron params) = inject $ protocolInfoByron params + protocolInfo (ProtocolInfoArgsByron params) = ( inject $ protocolInfoByron params + , pure . map inject $ blockForgingByron params + ) instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where data ProtocolInfoArgs m (CardanoBlock StandardCrypto) = @@ -123,7 +128,7 @@ instance ( IOLike m (ProtocolParamsShelleyBased StandardShelley) (ProtocolParamsShelley StandardCrypto) protocolInfo (ProtocolInfoArgsShelley paramsShelleyBased paramsShelley) = - inject $ protocolInfoShelley paramsShelleyBased paramsShelley + bimap inject (fmap $ map inject) $ protocolInfoShelley paramsShelleyBased paramsShelley instance Consensus.LedgerSupportsProtocol (Consensus.ShelleyBlock diff --git a/flake.lock b/flake.lock index 41d21ba202..6f152dfc79 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1688471493, - "narHash": "sha256-QeO03eNW5ZmgUS4ebSvygnWHAcSpRGz3e8UCS5Yb5i4=", + "lastModified": 1688739041, + "narHash": "sha256-1ji5gb5c7e/dMvwMIGjNfkDF1AOCMVdiFrSN+xUQpzw=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "892494f936926f63962d3066b4cfc4270a6bc12d", + "rev": "ba9bfea00fa468dc4c18de2ab0b7d3c7cb4a35ef", "type": "github" }, "original": { @@ -221,11 +221,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1688516853, - "narHash": "sha256-BR7kmt/vblCHJUZyszWV2SDI786HmqBCZCnM37RfFd8=", + "lastModified": 1688603318, + "narHash": "sha256-rXEPjf6pecyl0mIpK6xk3Vp/lKxWiCUfw6PMU+7utjY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "6aa31b7e500039788e62ee028fbc04d461424c02", + "rev": "a5604f20c9446451d4f1fd3ad4c160240069833a", "type": "github" }, "original": { From dd477ca87512c25f47746c0d352891f08975ee54 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 13 Jun 2023 16:09:28 +0100 Subject: [PATCH 2/9] ProtocolInfoArgs does not use 'm' type variable --- cardano-api/internal/Cardano/Api/Protocol.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs index 66f1346555..43a89a6393 100644 --- a/cardano-api/internal/Cardano/Api/Protocol.hs +++ b/cardano-api/internal/Cardano/Api/Protocol.hs @@ -37,8 +37,8 @@ import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) import Ouroboros.Consensus.Util.IOLike (IOLike) class (RunNode blk, IOLike m) => Protocol m blk where - data ProtocolInfoArgs m blk - protocolInfo :: ProtocolInfoArgs m blk -> (ProtocolInfo blk, m [BlockForging m blk]) + data ProtocolInfoArgs blk + protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk]) -- | Node client support for each consensus protocol. -- @@ -52,13 +52,13 @@ class RunNode blk => ProtocolClient blk where -- | Run PBFT against the Byron ledger instance IOLike m => Protocol m ByronBlockHFC where - data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron + data ProtocolInfoArgs ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron protocolInfo (ProtocolInfoArgsByron params) = ( inject $ protocolInfoByron params , pure . map inject $ blockForgingByron params ) instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where - data ProtocolInfoArgs m (CardanoBlock StandardCrypto) = + data ProtocolInfoArgs (CardanoBlock StandardCrypto) = ProtocolInfoArgsCardano ProtocolParamsByron (ProtocolParamsShelleyBased StandardShelley) @@ -124,7 +124,7 @@ instance ( IOLike m (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) ) => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) where - data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) = ProtocolInfoArgsShelley + data ProtocolInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) = ProtocolInfoArgsShelley (ProtocolParamsShelleyBased StandardShelley) (ProtocolParamsShelley StandardCrypto) protocolInfo (ProtocolInfoArgsShelley paramsShelleyBased paramsShelley) = From 28b14c7f7b139b9639fdd24ca64f3bc1b1842c01 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 13 Jun 2023 17:04:33 +0100 Subject: [PATCH 3/9] Added SomeBlockType and reflBlockType --- cardano-api/internal/Cardano/Api/Protocol.hs | 16 ++++++++++++++++ cardano-api/src/Cardano/Api.hs | 2 ++ 2 files changed, 18 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs index 43a89a6393..6bff874831 100644 --- a/cardano-api/internal/Cardano/Api/Protocol.hs +++ b/cardano-api/internal/Cardano/Api/Protocol.hs @@ -6,9 +6,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Protocol ( BlockType(..) + , SomeBlockType (..) + , reflBlockType , Protocol(..) , ProtocolInfoArgs(..) , ProtocolClient(..) @@ -36,6 +39,8 @@ import Ouroboros.Consensus.Shelley.Node.Praos import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) import Ouroboros.Consensus.Util.IOLike (IOLike) +import Type.Reflection ((:~:) (..)) + class (RunNode blk, IOLike m) => Protocol m blk where data ProtocolInfoArgs blk protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk]) @@ -147,3 +152,14 @@ data BlockType blk where deriving instance Eq (BlockType blk) deriving instance Show (BlockType blk) +reflBlockType :: BlockType blk -> BlockType blk' -> Maybe (blk :~: blk') +reflBlockType ByronBlockType ByronBlockType = Just Refl +reflBlockType ShelleyBlockType ShelleyBlockType = Just Refl +reflBlockType CardanoBlockType CardanoBlockType = Just Refl +reflBlockType _ _ = Nothing + + +data SomeBlockType where + SomeBlockType :: BlockType blk -> SomeBlockType + +deriving instance Show SomeBlockType diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 3dfc25ba85..38c9cb4f02 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -707,6 +707,8 @@ module Cardano.Api ( -- ** Protocol related types BlockType(..), + SomeBlockType (..), + reflBlockType, Protocol(..), ProtocolInfoArgs(..), From f49418551eec57673dfe809bae83592d30dffd38 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 21 Jun 2023 15:52:26 +0100 Subject: [PATCH 4/9] Added FileDoesNotExistError constructor Improves the error situation when dealing with file paths. Before all IO related errors where wrapped around the constructor FileIOError. Now the existence of the file is checked and if it does not exist a FileDoesNotExistError is thrown. Added `fileIOExceptT` function that abstracts away this existence check, so we can get read of all the FileIOError wraps. --- cardano-api/internal/Cardano/Api/Error.hs | 24 ++++++++++++++++++- cardano-api/internal/Cardano/Api/IO.hs | 8 +++---- .../internal/Cardano/Api/IO/Compat/Posix.hs | 6 ++--- cardano-api/internal/Cardano/Api/Keys/Read.hs | 14 +++-------- cardano-api/internal/Cardano/Api/Protocol.hs | 4 ++-- .../internal/Cardano/Api/SerialiseJSON.hs | 4 ++-- .../Cardano/Api/SerialiseLedgerCddl.hs | 7 +++--- .../Cardano/Api/SerialiseTextEnvelope.hs | 9 ++++--- 8 files changed, 44 insertions(+), 32 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Error.hs b/cardano-api/internal/Cardano/Api/Error.hs index 437ad14c4e..a139fa4626 100644 --- a/cardano-api/internal/Cardano/Api/Error.hs +++ b/cardano-api/internal/Cardano/Api/Error.hs @@ -9,11 +9,21 @@ module Cardano.Api.Error , throwErrorAsException , ErrorAsException(..) , FileError(..) + , fileIOExceptT ) where import Control.Exception (Exception (..), IOException, throwIO) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except.Extra (handleIOExceptT) +import System.Directory (doesFileExist) import System.IO (Handle) - +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except.Extra (handleIOExceptT) +import Control.Monad.IO.Class (MonadIO) +import System.Directory (doesFileExist) +import Control.Monad.Except (throwError) class Show e => Error e where @@ -46,6 +56,7 @@ data FileError e = FileError FilePath e FilePath -- ^ Temporary path Handle + | FileDoesNotExistError FilePath | FileIOError FilePath IOException deriving (Show, Eq, Functor) @@ -54,6 +65,8 @@ instance Error e => Error (FileError e) where "Error creating temporary file at: " ++ tempPath ++ "/n" ++ "Target path: " ++ targetPath ++ "/n" ++ "Handle: " ++ show h + displayError (FileDoesNotExistError path) = + "Error file not found at: " ++ path displayError (FileIOError path ioe) = path ++ ": " ++ displayException ioe displayError (FileError path e) = @@ -62,3 +75,12 @@ instance Error e => Error (FileError e) where instance Error IOException where displayError = show +fileIOExceptT :: MonadIO m + => FilePath + -> (FilePath -> IO s) + -> ExceptT (FileError e) m s +fileIOExceptT fp readFile' = do + fileExists <- handleIOExceptT (FileIOError fp) $ doesFileExist fp + if fileExists then handleIOExceptT (FileIOError fp) $ readFile' fp + else throwError (FileDoesNotExistError fp) + diff --git a/cardano-api/internal/Cardano/Api/IO.hs b/cardano-api/internal/Cardano/Api/IO.hs index f466527fd1..6bfbc835c1 100644 --- a/cardano-api/internal/Cardano/Api/IO.hs +++ b/cardano-api/internal/Cardano/Api/IO.hs @@ -34,7 +34,7 @@ module Cardano.Api.IO , writeSecrets ) where -import Cardano.Api.Error (FileError (..)) +import Cardano.Api.Error (FileError (..), fileIOExceptT) import Cardano.Api.IO.Base import Cardano.Api.IO.Compat @@ -54,21 +54,21 @@ readByteStringFile :: () => File content In -> m (Either (FileError e) ByteString) readByteStringFile fp = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ BS.readFile (unFile fp) + fileIOExceptT (unFile fp) BS.readFile readLazyByteStringFile :: () => MonadIO m => File content In -> m (Either (FileError e) LBS.ByteString) readLazyByteStringFile fp = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ LBS.readFile (unFile fp) + fileIOExceptT (unFile fp) LBS.readFile readTextFile :: () => MonadIO m => File content In -> m (Either (FileError e) Text) readTextFile fp = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ Text.readFile (unFile fp) + fileIOExceptT (unFile fp) Text.readFile writeByteStringFile :: () => MonadIO m diff --git a/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs b/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs index f845c530bb..3387eb5d34 100644 --- a/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs +++ b/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs @@ -17,14 +17,14 @@ module Cardano.Api.IO.Compat.Posix #ifdef UNIX -import Cardano.Api.Error (FileError (..)) +import Cardano.Api.Error (FileError (..), fileIOExceptT) import Cardano.Api.IO.Base import Control.Exception (IOException, bracket, bracketOnError, try) import Control.Monad (forM_, when) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class -import Control.Monad.Trans.Except.Extra (handleIOExceptT, left) +import Control.Monad.Trans.Except.Extra (left) import qualified Data.ByteString as BS import System.Directory () import System.FilePath (()) @@ -62,7 +62,7 @@ handleFileForWritingWithOwnerPermissionImpl path f = do bracket (fdToHandle fd) IO.hClose - (runExceptT . handleIOExceptT (FileIOError path) . f) + (runExceptT . fileIOExceptT path . const . f) writeSecretsImpl :: FilePath -> [Char] -> [Char] -> (a -> BS.ByteString) -> [a] -> IO () writeSecretsImpl outDir prefix suffix secretOp xs = diff --git a/cardano-api/internal/Cardano/Api/Keys/Read.hs b/cardano-api/internal/Cardano/Api/Keys/Read.hs index 8eac1a8221..8b3728b7e9 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Read.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Read.hs @@ -18,9 +18,8 @@ import Cardano.Api.SerialiseBech32 import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.Utils -import Control.Exception +import Control.Monad.Except (runExceptT) import Data.Bifunctor -import Data.ByteString as BS import Data.List.NonEmpty (NonEmpty) -- | Read a cryptographic key from a file. @@ -33,14 +32,11 @@ readKeyFile -> FilePath -> IO (Either (FileError InputDecodeError) a) readKeyFile asType acceptedFormats path = do - eContent <- fmap Right (readFileBlocking path) `catches` [Handler handler] + eContent <- runExceptT $ fileIOExceptT path readFileBlocking case eContent of Left e -> return $ Left e Right content -> return . first (FileError path) $ deserialiseInput asType acceptedFormats content - where - handler :: IOException -> IO (Either (FileError InputDecodeError) BS.ByteString) - handler e = return . Left $ FileIOError path e -- | Read a cryptographic key from a file. -- @@ -65,12 +61,8 @@ readKeyFileAnyOf -> File content In -> IO (Either (FileError InputDecodeError) b) readKeyFileAnyOf bech32Types textEnvTypes path = do - eContent <- fmap Right (readFileBlocking (unFile path)) `catches` [Handler handler] + eContent <- runExceptT $ fileIOExceptT (unFile path) readFileBlocking case eContent of Left e -> return $ Left e Right content -> return . first (FileError (unFile path)) $ deserialiseInputAnyOf bech32Types textEnvTypes content - where - handler :: IOException -> IO (Either (FileError InputDecodeError) BS.ByteString) - handler e = return . Left $ FileIOError (unFile path) e - diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs index 6bff874831..7d08e30712 100644 --- a/cardano-api/internal/Cardano/Api/Protocol.hs +++ b/cardano-api/internal/Cardano/Api/Protocol.hs @@ -20,8 +20,6 @@ module Cardano.Api.Protocol import Cardano.Api.Modes -import Data.Bifunctor (bimap) - import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Cardano import Ouroboros.Consensus.Cardano.Block @@ -39,6 +37,8 @@ import Ouroboros.Consensus.Shelley.Node.Praos import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) import Ouroboros.Consensus.Util.IOLike (IOLike) +import Data.Bifunctor (bimap) + import Type.Reflection ((:~:) (..)) class (RunNode blk, IOLike m) => Protocol m blk where diff --git a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs index ec30dff6fa..f47f895a5f 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs @@ -19,7 +19,7 @@ import Cardano.Api.Error import Cardano.Api.HasTypeProxy import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither) +import Control.Monad.Trans.Except.Extra (handleIOExceptT, firstExceptT, hoistEither) import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty) @@ -56,7 +56,7 @@ readFileJSON :: FromJSON a -> IO (Either (FileError JsonDecodeError) a) readFileJSON ttoken path = runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ BS.readFile path + content <- fileIOExceptT path BS.readFile firstExceptT (FileError path) $ hoistEither $ deserialiseFromJSON ttoken content diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 53c096176f..fc7e5ccf9f 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -41,8 +41,8 @@ import Cardano.Api.Utils import Cardano.Ledger.Binary (DecoderError) import qualified Cardano.Ledger.Binary as CBOR -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, - newExceptT, runExceptT) +import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, newExceptT, + runExceptT) import Data.Aeson import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) @@ -328,7 +328,6 @@ readTextEnvelopeCddlFromFile -> IO (Either (FileError TextEnvelopeCddlError) TextEnvelopeCddl) readTextEnvelopeCddlFromFile path = runExceptT $ do - bs <- handleIOExceptT (FileIOError path) $ - readFileBlocking path + bs <- fileIOExceptT path readFileBlocking firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path) . hoistEither $ Aeson.eitherDecodeStrict' bs diff --git a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index a7f0bbc5f8..54c38217ff 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs @@ -46,7 +46,7 @@ import Cardano.Binary (DecoderError) import Control.Monad (unless) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither) +import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) @@ -234,7 +234,7 @@ readFileTextEnvelope :: HasTextEnvelope a -> IO (Either (FileError TextEnvelopeError) a) readFileTextEnvelope ttoken path = runExceptT $ do - content <- handleIOExceptT (FileIOError (unFile path)) $ readFileBlocking (unFile path) + content <- fileIOExceptT (unFile path) readFileBlocking firstExceptT (FileError (unFile path)) $ hoistEither $ do te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content deserialiseFromTextEnvelope ttoken te @@ -245,7 +245,7 @@ readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b] -> IO (Either (FileError TextEnvelopeError) b) readFileTextEnvelopeAnyOf types path = runExceptT $ do - content <- handleIOExceptT (FileIOError (unFile path)) $ readFileBlocking (unFile path) + content <- fileIOExceptT (unFile path) readFileBlocking firstExceptT (FileError (unFile path)) $ hoistEither $ do te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content deserialiseFromTextEnvelopeAnyOf types te @@ -255,8 +255,7 @@ readTextEnvelopeFromFile :: FilePath -> IO (Either (FileError TextEnvelopeError) TextEnvelope) readTextEnvelopeFromFile path = runExceptT $ do - bs <- handleIOExceptT (FileIOError path) $ - readFileBlocking path + bs <- fileIOExceptT path readFileBlocking firstExceptT (FileError path . TextEnvelopeAesonDecodeError) . hoistEither $ Aeson.eitherDecodeStrict' bs From 4ebc58b5742d35a71532ad6323783b66b987e896 Mon Sep 17 00:00:00 2001 From: Samuel Leathers Date: Thu, 6 Jul 2023 00:58:35 -0400 Subject: [PATCH 5/9] cardano-ledger-conway: renames for 1.5.0.0 (cherry picked from commit 8de46eaa85827d693054327cc65283263f671db0) --- .../Cardano/Api/Governance/Actions/VotingProcedure.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 3bc02fdf0e..35e4503948 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -103,10 +103,10 @@ data VoteChoice | Abst -- ^ Abstain deriving (Show, Eq) -toVoterRole :: VoterType -> Gov.VoterRole -toVoterRole CC = Gov.ConstitutionalCommittee -toVoterRole DR = Gov.DRep -toVoterRole SP = Gov.SPO +toVoterRole :: VoterType -> Gov.Voter +toVoterRole CC = Gov.CommitteeVoter +toVoterRole DR = Gov.DRepVoter +toVoterRole SP = Gov.StakePoolVoter toVote :: VoteChoice -> Gov.Vote toVote No = Gov.VoteNo @@ -157,8 +157,7 @@ createVotingProcedure sbe vChoice vt (GovernanceActionIdentifier govActId) (Voti obtainEraCryptoConstraints sbe $ Vote $ Gov.VotingProcedure { Gov.vProcGovActionId = govActId - , Gov.vProcRole = toVoterRole vt - , Gov.vProcRoleKeyHash = govWitnessCredential + , Gov.vProcVoter = toVoterRole vt , Gov.vProcVote = toVote vChoice , Gov.vProcAnchor = SNothing -- TODO: Conway } From 066c6def9dd373bfabe70382b8700b44d0cfb9ab Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Tue, 4 Jul 2023 19:23:55 +0530 Subject: [PATCH 6/9] Query: add constitution hash ledger query (cherry picked from commit 4cd2216d8f5e338973de6bde13f7f2d940417e74) --- cardano-api/internal/Cardano/Api/Query.hs | 16 ++++++++++++++++ cardano-api/internal/Cardano/Api/Query/Expr.hs | 8 ++++++++ cardano-api/src/Cardano/Api.hs | 1 + 3 files changed, 25 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 0b2e1fb190..90bbdc56c9 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -94,6 +94,9 @@ import Cardano.Api.Value import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update import Cardano.Ledger.Binary +import Cardano.Ledger.SafeHash (SafeHash) +import Data.ByteString (ByteString) +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (Crypto) @@ -294,6 +297,10 @@ data QueryInShelleyBasedEra era result where :: Set StakeCredential -> QueryInShelleyBasedEra era (Map StakeCredential Lovelace) + QueryConstitutionHash + :: QueryInShelleyBasedEra era (Maybe (SafeHash (EraCrypto era) ByteString)) + + instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where nodeToClientVersionOf QueryEpoch = NodeToClientV_9 nodeToClientVersionOf QueryGenesisParameters = NodeToClientV_9 @@ -311,6 +318,7 @@ instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where nodeToClientVersionOf (QueryPoolDistribution _) = NodeToClientV_14 nodeToClientVersionOf (QueryStakeSnapshot _) = NodeToClientV_14 nodeToClientVersionOf (QueryStakeDelegDeposits _) = NodeToClientV_15 + nodeToClientVersionOf QueryConstitutionHash = NodeToClientV_15 deriving instance Show (QueryInShelleyBasedEra era result) @@ -623,6 +631,9 @@ toConsensusQueryShelleyBased toConsensusQueryShelleyBased erainmode QueryEpoch = Some (consensusQueryInEraInMode erainmode Consensus.GetEpochNo) +toConsensusQueryShelleyBased erainmode QueryConstitutionHash = + Some (consensusQueryInEraInMode erainmode Consensus.GetConstitutionHash) + toConsensusQueryShelleyBased erainmode QueryGenesisParameters = Some (consensusQueryInEraInMode erainmode Consensus.GetGenesisConfig) @@ -861,6 +872,11 @@ fromConsensusQueryResultShelleyBased _ QueryEpoch q' epoch = Consensus.GetEpochNo -> epoch _ -> fromConsensusQueryResultMismatch +fromConsensusQueryResultShelleyBased _ QueryConstitutionHash q' mCHash = + case q' of + Consensus.GetConstitutionHash -> mCHash + _ -> fromConsensusQueryResultMismatch + fromConsensusQueryResultShelleyBased _ QueryGenesisParameters q' r' = case q' of Consensus.GetGenesisConfig -> fromShelleyGenesis diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 8b6d072247..1252f66ad2 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -7,6 +7,7 @@ module Cardano.Api.Query.Expr , queryCurrentEra , queryDebugLedgerState , queryEpoch + , queryConstitutionHash , queryEraHistory , queryGenesisParameters , queryPoolDistribution @@ -126,6 +127,13 @@ queryProtocolParameters :: () queryProtocolParameters eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters +queryConstitutionHash :: () + => EraInMode era mode + -> ShelleyBasedEra era + -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto era) ByteString)))) +queryConstitutionHash eraInMode sbe = + queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitutionHash + queryProtocolParametersUpdate :: () => EraInMode era mode -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 38c9cb4f02..6065140cff 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -875,6 +875,7 @@ module Cardano.Api ( queryCurrentEra, queryDebugLedgerState, queryEpoch, + queryConstitutionHash, queryEraHistory, queryGenesisParameters, queryPoolDistribution, From 7198fcb1af8f0fcf5d19ded35ab6e8852c857f09 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 7 Jul 2023 11:50:23 +0200 Subject: [PATCH 7/9] Fix import errors --- cardano-api/internal/Cardano/Api/Query/Expr.hs | 3 +++ cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 1252f66ad2..3e0888739e 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -41,10 +41,13 @@ import Cardano.Api.ProtocolParameters import Cardano.Api.Query import Cardano.Api.Value +import Cardano.Ledger.Api +import Cardano.Ledger.SafeHash import Cardano.Slotting.Slot import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.ByteString import Data.Map (Map) import Data.Set (Set) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index fc7e5ccf9f..7a6c194e89 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -41,8 +41,8 @@ import Cardano.Api.Utils import Cardano.Ledger.Binary (DecoderError) import qualified Cardano.Ledger.Binary as CBOR -import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, newExceptT, - runExceptT) +import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, + newExceptT, runExceptT) import Data.Aeson import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) From 8b8c9fd733fe6d348a0ffc8f99c3f1e4f27e389c Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 7 Jul 2023 13:00:24 +0200 Subject: [PATCH 8/9] Fix Cardano.Api.Query type errors --- cardano-api/internal/Cardano/Api/Query.hs | 8 ++++---- cardano-api/internal/Cardano/Api/Query/Expr.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 90bbdc56c9..ee74012a0d 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -94,12 +94,11 @@ import Cardano.Api.Value import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update import Cardano.Ledger.Binary -import Cardano.Ledger.SafeHash (SafeHash) -import Data.ByteString (ByteString) -import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.SafeHash (SafeHash) import qualified Cardano.Ledger.Shelley.API as Shelley import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.LedgerState as Shelley @@ -131,6 +130,7 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Parser) import Data.Bifunctor (bimap, first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS import Data.Either.Combinators (rightToMaybe) import qualified Data.HashMap.Strict as HMS @@ -298,7 +298,7 @@ data QueryInShelleyBasedEra era result where -> QueryInShelleyBasedEra era (Map StakeCredential Lovelace) QueryConstitutionHash - :: QueryInShelleyBasedEra era (Maybe (SafeHash (EraCrypto era) ByteString)) + :: QueryInShelleyBasedEra era (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) ByteString)) instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 3e0888739e..4835c13704 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -133,7 +133,7 @@ queryProtocolParameters eraInMode sbe = queryConstitutionHash :: () => EraInMode era mode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto era) ByteString)))) + -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) ByteString)))) queryConstitutionHash eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitutionHash From 511ea889d439e02a5c084418b44a4ddacf32686f Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 7 Jul 2023 14:22:03 +0200 Subject: [PATCH 9/9] Parameterize VoteType on the era and include the respective voting credentials Remove voting credential parameter from createVotingProcedure --- cardano-api/internal/Cardano/Api/Error.hs | 5 - .../Api/Governance/Actions/VotingProcedure.hs | 35 ++--- .../internal/Cardano/Api/Keys/Shelley.hs | 120 ++++++++++++++++++ .../internal/Cardano/Api/SerialiseJSON.hs | 2 +- 4 files changed, 141 insertions(+), 21 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Error.hs b/cardano-api/internal/Cardano/Api/Error.hs index a139fa4626..c153a675df 100644 --- a/cardano-api/internal/Cardano/Api/Error.hs +++ b/cardano-api/internal/Cardano/Api/Error.hs @@ -19,11 +19,6 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (handleIOExceptT) import System.Directory (doesFileExist) import System.IO (Handle) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Except.Extra (handleIOExceptT) -import Control.Monad.IO.Class (MonadIO) -import System.Directory (doesFileExist) -import Control.Monad.Except (throwError) class Show e => Error e where diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 35e4503948..5db9068068 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -15,6 +15,7 @@ module Cardano.Api.Governance.Actions.VotingProcedure where import Cardano.Api.Address import Cardano.Api.Eras import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Shelley import Cardano.Api.Script import Cardano.Api.SerialiseCBOR (FromCBOR (fromCBOR), SerialiseAsCBOR (..), ToCBOR (toCBOR)) @@ -30,7 +31,8 @@ import qualified Cardano.Ledger.Conway.Governance as Gov import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as Shelley import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Keys +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys (HasKeyRole (..), KeyRole (Voting)) import qualified Cardano.Ledger.TxIn as Ledger import Data.ByteString.Lazy (ByteString) @@ -88,13 +90,13 @@ makeGoveranceActionIdentifier sbe txin = , Gov.gaidGovActionIx = Gov.GovernanceActionIx txix } --- toVotingCredential :: _ -> Ledger.Credential 'Voting (EraCrypto ledgerera) --- toVotingCredential = undefined -data VoterType - = CC -- ^ Constitutional committee - | DR -- ^ Delegated representative - | SP -- ^ Stake pool operator +-- TODO: Conway era - These should be the different keys corresponding to the CC and DRs. +-- We can then derive the StakeCredentials from them. +data VoterType era + = CC (VotingCredential era) -- ^ Constitutional committee + | DR (VotingCredential era)-- ^ Delegated representative + | SP (Hash StakePoolKey) -- ^ Stake pool operator deriving (Show, Eq) data VoteChoice @@ -103,10 +105,14 @@ data VoteChoice | Abst -- ^ Abstain deriving (Show, Eq) -toVoterRole :: VoterType -> Gov.Voter -toVoterRole CC = Gov.CommitteeVoter -toVoterRole DR = Gov.DRepVoter -toVoterRole SP = Gov.StakePoolVoter +toVoterRole + :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + => ShelleyBasedEra era + -> VoterType era + -> Gov.Voter (Shelley.EraCrypto (ShelleyLedgerEra era)) +toVoterRole _ (CC (VotingCredential cred)) = Gov.CommitteeVoter $ coerceKeyRole cred -- TODO: Conway era - Alexey realllllyyy doesn't like this. We need to fix it. +toVoterRole _ (DR (VotingCredential cred)) = Gov.DRepVoter cred +toVoterRole _ (SP (StakePoolKeyHash kh)) = Gov.StakePoolVoter kh toVote :: VoteChoice -> Gov.Vote toVote No = Gov.VoteNo @@ -149,15 +155,14 @@ deriving instance Eq (VotingCredential crypto) createVotingProcedure :: ShelleyBasedEra era -> VoteChoice - -> VoterType + -> VoterType era -> GovernanceActionIdentifier (ShelleyLedgerEra era) - -> VotingCredential era -- ^ Governance witness credential (ledger checks that you are allowed to vote) -> Vote era -createVotingProcedure sbe vChoice vt (GovernanceActionIdentifier govActId) (VotingCredential govWitnessCredential) = +createVotingProcedure sbe vChoice vt (GovernanceActionIdentifier govActId) = obtainEraCryptoConstraints sbe $ Vote $ Gov.VotingProcedure { Gov.vProcGovActionId = govActId - , Gov.vProcVoter = toVoterRole vt + , Gov.vProcVoter = toVoterRole sbe vt , Gov.vProcVote = toVote vChoice , Gov.vProcAnchor = SNothing -- TODO: Conway } diff --git a/cardano-api/internal/Cardano/Api/Keys/Shelley.hs b/cardano-api/internal/Cardano/Api/Keys/Shelley.hs index 91f42a912b..63a8bf922d 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Shelley.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Shelley.hs @@ -20,6 +20,7 @@ module Cardano.Api.Keys.Shelley ( CommitteeColdKey, CommitteeHotKey, DRepKey, + CommitteeKey, PaymentKey, PaymentExtendedKey, StakeKey, @@ -1584,3 +1585,122 @@ instance HasTextEnvelope (SigningKey DRepKey) where where proxy :: Proxy (Shelley.DSIGN StandardCrypto) proxy = Proxy + +-- +-- Committee keys +-- + +data CommitteeKey + +instance HasTypeProxy CommitteeKey where + data AsType CommitteeKey = AsCommitteeKey + proxyToAsType _ = AsCommitteeKey + +instance Key CommitteeKey where + + newtype VerificationKey CommitteeKey = + CommitteeVerificationKey (Shelley.VKey {- TODO cip-1694: replace with Shelley.Committee -} Shelley.CommitteeHotKey StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey CommitteeKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + newtype SigningKey CommitteeKey = + CommitteeSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey CommitteeKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + deterministicSigningKey :: AsType CommitteeKey -> Crypto.Seed -> SigningKey CommitteeKey + deterministicSigningKey AsCommitteeKey seed = + CommitteeSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType CommitteeKey -> Word + deterministicSigningKeySeedSize AsCommitteeKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey CommitteeKey -> VerificationKey CommitteeKey + getVerificationKey (CommitteeSigningKey sk) = + CommitteeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey CommitteeKey -> Hash CommitteeKey + verificationKeyHash (CommitteeVerificationKey vkey) = + CommitteeKeyHash (Shelley.hashKey vkey) + +instance SerialiseAsRawBytes (VerificationKey CommitteeKey) where + serialiseToRawBytes (CommitteeVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk + + deserialiseFromRawBytes (AsVerificationKey AsCommitteeKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey CommitteeKey") $ + CommitteeVerificationKey . Shelley.VKey <$> + Crypto.rawDeserialiseVerKeyDSIGN bs + +instance SerialiseAsRawBytes (SigningKey CommitteeKey) where + serialiseToRawBytes (CommitteeSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + + deserialiseFromRawBytes (AsSigningKey AsCommitteeKey) bs = + maybe + (Left (SerialiseAsRawBytesError "Unable to deserialise SigningKey CommitteeKey")) + (Right . CommitteeSigningKey) + (Crypto.rawDeserialiseSignKeyDSIGN bs) + +instance SerialiseAsBech32 (VerificationKey CommitteeKey) where + bech32PrefixFor _ = "drep_vk" + bech32PrefixesPermitted _ = ["drep_vk"] + +instance SerialiseAsBech32 (SigningKey CommitteeKey) where + bech32PrefixFor _ = "drep_sk" + bech32PrefixesPermitted _ = ["drep_sk"] + +newtype instance Hash CommitteeKey = + CommitteeKeyHash { unCommitteeKeyHash :: Shelley.KeyHash {- TODO cip-1694: replace with Shelley.Committee -} Shelley.CommitteeHotKey StandardCrypto } + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash CommitteeKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash CommitteeKey) + deriving anyclass SerialiseAsCBOR + +instance SerialiseAsRawBytes (Hash CommitteeKey) where + serialiseToRawBytes (CommitteeKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh + + deserialiseFromRawBytes (AsHash AsCommitteeKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash CommitteeKey") + (CommitteeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) + +instance SerialiseAsBech32 (Hash CommitteeKey) where + bech32PrefixFor _ = "drep" + bech32PrefixesPermitted _ = ["drep"] + +instance ToJSON (Hash CommitteeKey) where + toJSON = toJSON . serialiseToBech32 + +instance ToJSONKey (Hash CommitteeKey) where + toJSONKey = toJSONKeyText serialiseToBech32 + +instance FromJSON (Hash CommitteeKey) where + parseJSON = withText "CommitteeId" $ \str -> + case deserialiseFromBech32 (AsHash AsCommitteeKey) str of + Left err -> + fail $ "Error deserialising Hash CommitteeKey: " <> Text.unpack str <> + " Error: " <> displayError err + Right h -> pure h + +instance HasTextEnvelope (VerificationKey CommitteeKey) where + textEnvelopeType _ = "CommitteeVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + +instance HasTextEnvelope (SigningKey CommitteeKey) where + textEnvelopeType _ = "CommitteeSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy diff --git a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs index f47f895a5f..08e9a0394e 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs @@ -19,7 +19,7 @@ import Cardano.Api.Error import Cardano.Api.HasTypeProxy import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Except.Extra (handleIOExceptT, firstExceptT, hoistEither) +import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither) import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty)