Introduce FileDoesNotExistError and bump to ouroboros-consensus 0.8

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

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

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)
+

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

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 =

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
-

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

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

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

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
 

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

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
 

cardano-api/src/Cardano/Api.hs

@@ -707,6 +707,8 @@ module Cardano.Api (
 
     -- ** Protocol related types
     BlockType(..),
+    SomeBlockType (..),
+    reflBlockType,
     Protocol(..),
     ProtocolInfoArgs(..),