diff --git a/cabal.project b/cabal.project index 9a69e8d9ff..bdbfadba07 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-06T13:00:00Z packages: cardano-api diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e43f84efaa..76ea4dfa4a 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -153,7 +153,7 @@ library internal , mtl , network , optparse-applicative-fork - , ouroboros-consensus >= 0.7 + , ouroboros-consensus >= 0.9 , ouroboros-consensus-cardano >= 0.6 , ouroboros-consensus-diffusion >= 0.6 , ouroboros-consensus-protocol >= 0.5 diff --git a/cardano-api/internal/Cardano/Api/Error.hs b/cardano-api/internal/Cardano/Api/Error.hs index 437ad14c4e..c153a675df 100644 --- a/cardano-api/internal/Cardano/Api/Error.hs +++ b/cardano-api/internal/Cardano/Api/Error.hs @@ -9,12 +9,17 @@ 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) - class Show e => Error e where displayError :: e -> String @@ -46,6 +51,7 @@ data FileError e = FileError FilePath e FilePath -- ^ Temporary path Handle + | FileDoesNotExistError FilePath | FileIOError FilePath IOException deriving (Show, Eq, Functor) @@ -54,6 +60,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 +70,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/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..7d08e30712 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(..) @@ -17,6 +20,7 @@ module Cardano.Api.Protocol import Cardano.Api.Modes +import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Cardano import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC) @@ -33,9 +37,13 @@ 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 - data ProtocolInfoArgs m blk - protocolInfo :: ProtocolInfoArgs m blk -> ProtocolInfo m blk + data ProtocolInfoArgs blk + protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk]) -- | Node client support for each consensus protocol. -- @@ -49,11 +57,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 - protocolInfo (ProtocolInfoArgsByron params) = inject $ protocolInfoByron params + 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) @@ -119,11 +129,11 @@ 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) = - inject $ protocolInfoShelley paramsShelleyBased paramsShelley + bimap inject (fmap $ map inject) $ protocolInfoShelley paramsShelleyBased paramsShelley instance Consensus.LedgerSupportsProtocol (Consensus.ShelleyBlock @@ -142,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/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 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(..), diff --git a/flake.lock b/flake.lock index 41d21ba202..1cf917554b 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1688471493, - "narHash": "sha256-QeO03eNW5ZmgUS4ebSvygnWHAcSpRGz3e8UCS5Yb5i4=", + "lastModified": 1688653741, + "narHash": "sha256-SMmTrFDxqmvulpfA+CJyhNzY0IsgvUcUPMBByqqYukg=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "892494f936926f63962d3066b4cfc4270a6bc12d", + "rev": "d522070c385b5ded2c1091d0c167e5b095383dba", "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": {