Handle pipes

Fixes #4235

cardano-api/src/Cardano/Api.hs

@@ -488,8 +488,10 @@ module Cardano.Api (
     -- | Support for serialising values in the ledger's CDDL format.
     -- Note, this will be deprecated in the future in favour of a
     -- single API.
+    TextEnvelopeCddl(..),
     FromSomeTypeCDDL(..),
     readFileTextEnvelopeCddlAnyOf,
+    deserialiseFromTextEnvelopeCddlAnyOf,
     writeTxFileTextEnvelopeCddl,
     writeTxWitnessFileTextEnvelopeCddl,
     serialiseTxLedgerCddl,

cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs

@@ -15,6 +15,7 @@ module Cardano.Api.SerialiseLedgerCddl
   -- * Reading one of several transaction or
   -- key witness types
   , readFileTextEnvelopeCddlAnyOf
+  , deserialiseFromTextEnvelopeCddlAnyOf
 
   , writeTxFileTextEnvelopeCddl
   , writeTxWitnessFileTextEnvelopeCddl
@@ -36,7 +37,6 @@ import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder)
 import           Data.Bifunctor (first)
 import           Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.List as List
@@ -52,6 +52,7 @@ import           Cardano.Api.Error
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.Tx
+import           Cardano.Api.Utils
 
 
 -- Why have we gone this route? The serialization format of `TxBody era`
@@ -319,6 +320,6 @@ readTextEnvelopeCddlFromFile
 readTextEnvelopeCddlFromFile path =
   runExceptT $ do
     bs <- handleIOExceptT (FileIOError path) $
-            BS.readFile path
+            readFileBlocking path
     firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path)
       . hoistEither $ Aeson.eitherDecodeStrict' bs

cardano-api/src/Cardano/Api/Utils.hs

@@ -133,4 +133,3 @@ renderEra (AnyCardanoEra AllegraEra) = "Allegra"
 renderEra (AnyCardanoEra MaryEra)    = "Mary"
 renderEra (AnyCardanoEra AlonzoEra)  = "Alonzo"
 renderEra (AnyCardanoEra BabbageEra) = "Babbage"
-

cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs

@@ -53,19 +53,31 @@ module Cardano.CLI.Shelley.Run.Read
   , RequiredSignerError(..)
   , categoriseSomeWitness
   , readRequiredSigner
+
+  -- * FileOrPipe
+  , FileOrPipe
+  , fileOrPipe
+  , readFileOrPipe
   ) where
 
 import           Prelude
 
+import           Control.Exception (bracket)
+import           Control.Monad (unless)
 import           Control.Monad.Trans.Except (ExceptT (..), runExceptT)
-import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left)
+import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left, newExceptT)
 import qualified Data.Aeson as Aeson
 import           Data.Bifunctor (first)
+import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
+import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Data.List as List
 import qualified Data.Text as Text
 import           Data.Word
+import           GHC.IO.Handle (hClose, hIsSeekable)
+import           GHC.IO.Handle.FD (openFileBlocking)
+import           System.IO (IOMode (ReadMode))
 
 
 import           Cardano.Api
@@ -447,11 +459,11 @@ deserialiseScriptInAnyLang bs =
 
 newtype CddlTx = CddlTx {unCddlTx :: InAnyCardanoEra Tx} deriving (Show, Eq)
 
-readFileTx :: FilePath -> IO (Either CddlError (InAnyCardanoEra Tx))
-readFileTx fp = do
-  eAnyTx <- readFileInAnyCardanoEra AsTx fp
+readFileTx :: FileOrPipe -> IO (Either CddlError (InAnyCardanoEra Tx))
+readFileTx file = do
+  eAnyTx <- readFileInAnyCardanoEra AsTx file
   case eAnyTx of
-    Left e -> fmap unCddlTx <$> acceptTxCDDLSerialisation e
+    Left e -> fmap unCddlTx <$> acceptTxCDDLSerialisation file e
     Right tx -> return $ Right tx
 
 -- IncompleteCddlFormattedTx is an CDDL formatted tx or partial tx
@@ -463,11 +475,11 @@ data IncompleteTx
   = UnwitnessedCliFormattedTxBody (InAnyCardanoEra TxBody)
   | IncompleteCddlFormattedTx (InAnyCardanoEra Tx)
 
-readFileTxBody :: FilePath -> IO (Either CddlError IncompleteTx)
-readFileTxBody fp = do
-  eTxBody <- readFileInAnyCardanoEra AsTxBody fp
+readFileTxBody :: FileOrPipe -> IO (Either CddlError IncompleteTx)
+readFileTxBody file = do
+  eTxBody <- readFileInAnyCardanoEra AsTxBody file
   case eTxBody of
-    Left e -> fmap (IncompleteCddlFormattedTx . unCddlTx) <$> acceptTxCDDLSerialisation e
+    Left e -> fmap (IncompleteCddlFormattedTx . unCddlTx) <$> acceptTxCDDLSerialisation file e
     Right txBody -> return $ Right $ UnwitnessedCliFormattedTxBody txBody
 
 data CddlError = CddlErrorTextEnv
@@ -483,21 +495,22 @@ renderCddlError (CddlErrorTextEnv textEnvErr cddlErr) =
 renderCddlError (CddlIOError e) = Text.pack $ displayError e
 
 acceptTxCDDLSerialisation
-  :: FileError TextEnvelopeError
+  :: FileOrPipe
+  -> FileError TextEnvelopeError
   -> IO (Either CddlError CddlTx)
-acceptTxCDDLSerialisation err =
+acceptTxCDDLSerialisation file err =
   case err of
-   e@(FileError fp (TextEnvelopeDecodeError _)) ->
-      first (CddlErrorTextEnv e) <$> readCddlTx fp
-   e@(FileError fp (TextEnvelopeAesonDecodeError _)) ->
-      first (CddlErrorTextEnv e) <$> readCddlTx fp
-   e@(FileError fp (TextEnvelopeTypeError _ _)) ->
-      first (CddlErrorTextEnv e) <$> readCddlTx fp
+   e@(FileError _ (TextEnvelopeDecodeError _)) ->
+      first (CddlErrorTextEnv e) <$> readCddlTx file
+   e@(FileError _ (TextEnvelopeAesonDecodeError _)) ->
+      first (CddlErrorTextEnv e) <$> readCddlTx file
+   e@(FileError _ (TextEnvelopeTypeError _ _)) ->
+      first (CddlErrorTextEnv e) <$> readCddlTx file
    e@FileErrorTempFile{} -> return . Left $ CddlIOError e
    e@FileIOError{} -> return . Left $ CddlIOError e
 
-readCddlTx :: FilePath -> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
-readCddlTx = readFileTextEnvelopeCddlAnyOf teTypes
+readCddlTx :: FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
+readCddlTx = readFileOrPipeTextEnvelopeCddlAnyOf teTypes
  where
     teTypes = [ FromCDDLTx "Witnessed Tx ByronEra" CddlTx
               , FromCDDLTx "Witnessed Tx ShelleyEra" CddlTx
@@ -520,7 +533,8 @@ newtype CddlWitness = CddlWitness { unCddlWitness :: InAnyCardanoEra KeyWitness}
 readFileTxKeyWitness :: FilePath
                 -> IO (Either CddlWitnessError (InAnyCardanoEra KeyWitness))
 readFileTxKeyWitness fp = do
-  eWitness <- readFileInAnyCardanoEra AsKeyWitness fp
+  file <- fileOrPipe fp
+  eWitness <- readFileInAnyCardanoEra AsKeyWitness file
   case eWitness of
     Left e -> fmap unCddlWitness <$> acceptKeyWitnessCDDLSerialisation e
     Right keyWit -> return $ Right keyWit
@@ -726,14 +740,83 @@ readFileInAnyCardanoEra
      , HasTextEnvelope (thing BabbageEra)
      )
   => (forall era. AsType era -> AsType (thing era))
-  -> FilePath
+  -> FileOrPipe
   -> IO (Either (FileError TextEnvelopeError) (InAnyCardanoEra thing))
 readFileInAnyCardanoEra asThing =
- readFileTextEnvelopeAnyOf
+ readFileOrPipeTextEnvelopeAnyOf
    [ FromSomeType (asThing AsByronEra)   (InAnyCardanoEra ByronEra)
    , FromSomeType (asThing AsShelleyEra) (InAnyCardanoEra ShelleyEra)
    , FromSomeType (asThing AsAllegraEra) (InAnyCardanoEra AllegraEra)
    , FromSomeType (asThing AsMaryEra)    (InAnyCardanoEra MaryEra)
    , FromSomeType (asThing AsAlonzoEra)  (InAnyCardanoEra AlonzoEra)
    , FromSomeType (asThing AsBabbageEra) (InAnyCardanoEra BabbageEra)
    ]
+
+-- | We need a type for handling files that may be actually be things like pipes
+data FileOrPipe = FileOrPipe FilePath (IORef (Maybe LBS.ByteString))
+
+instance Show FileOrPipe where
+    show (FileOrPipe fp _) = show fp
+
+fileOrPipe :: FilePath -> IO FileOrPipe
+fileOrPipe fp = FileOrPipe fp <$> newIORef Nothing
+
+fileOrPipePath :: FileOrPipe -> FilePath
+fileOrPipePath (FileOrPipe fp _) = fp
+
+readFileOrPipe :: FileOrPipe -> IO LBS.ByteString
+readFileOrPipe (FileOrPipe fp cacheRef) = do
+    cached <- readIORef cacheRef
+    case cached of
+      Just dat -> pure dat
+      Nothing -> bracket
+        (openFileBlocking fp ReadMode)
+        hClose
+        (\handle -> do
+          -- An arbitrary block size.
+          let blockSize = 4096
+          let go acc = do
+                next <- BS.hGet handle blockSize
+                if BS.null next
+                then pure acc
+                else go (acc <> Builder.byteString next)
+          contents <- go mempty
+          let dat = Builder.toLazyByteString contents
+          -- If our file is not seekable, it's likely a pipe, so we need to
+          -- save the result for subsequent calls
+          seekable <- hIsSeekable handle
+          unless seekable (writeIORef cacheRef (Just dat))
+          pure dat)
+
+readFileOrPipeTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
+                          -> FileOrPipe
+                          -> IO (Either (FileError TextEnvelopeError) b)
+readFileOrPipeTextEnvelopeAnyOf types file = do
+    let path = fileOrPipePath file
+    runExceptT $ do
+      content <- handleIOExceptT (FileIOError path) $ readFileOrPipe file
+      firstExceptT (FileError path) $ hoistEither $ do
+        te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecode' content
+        deserialiseFromTextEnvelopeAnyOf types te
+
+readFileOrPipeTextEnvelopeCddlAnyOf
+  :: [FromSomeTypeCDDL TextEnvelopeCddl b]
+  -> FileOrPipe
+  -> IO (Either (FileError TextEnvelopeCddlError) b)
+readFileOrPipeTextEnvelopeCddlAnyOf types file = do
+  let path = fileOrPipePath file
+  runExceptT $ do
+    te <- newExceptT $ readTextEnvelopeCddlFromFileOrPipe file
+    firstExceptT (FileError path) $ hoistEither $ do
+      deserialiseFromTextEnvelopeCddlAnyOf types te
+
+readTextEnvelopeCddlFromFileOrPipe
+  :: FileOrPipe
+  -> IO (Either (FileError TextEnvelopeCddlError) TextEnvelopeCddl)
+readTextEnvelopeCddlFromFileOrPipe file = do
+  let path = fileOrPipePath file
+  runExceptT $ do
+    bs <- handleIOExceptT (FileIOError path) $
+            readFileOrPipe file
+    firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path)
+      . hoistEither $ Aeson.eitherDecode' bs

cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs

@@ -209,7 +209,7 @@ renderShelleyTxCmdError err =
     ShelleyTxCmdScriptWitnessError e -> renderScriptWitnessError e
     ShelleyTxCmdScriptDataError e -> renderScriptDataError e
     ShelleyTxCmdProtocolParamsError e -> renderProtocolParamsError e
-    ShelleyTxCmdCddlError _ -> error "TODO"
+    ShelleyTxCmdCddlError e -> error $ show $ renderCddlError e
     ShelleyTxCmdCddlWitnessError _ -> error "TODO"
     ShelleyTxCmdRequiredSignerError _ -> error ""
     -- Validation errors
@@ -983,7 +983,8 @@ runTxSign txOrTxBody witSigningData mnw (TxFile outTxFile) = do
   let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeWitness sks
 
   case txOrTxBody of
-    (InputTxFile (TxFile inputTxFile)) -> do
+    (InputTxFile (TxFile inputTxFilePath)) -> do
+      inputTxFile <- liftIO $ fileOrPipe inputTxFilePath
       anyTx <- firstExceptT ShelleyTxCmdCddlError . newExceptT $ readFileTx inputTxFile
 
       InAnyShelleyBasedEra _era tx <-
@@ -1002,7 +1003,8 @@ runTxSign txOrTxBody witSigningData mnw (TxFile outTxFile) = do
       firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
         writeTxFileTextEnvelopeCddl outTxFile signedTx
 
-    (InputTxBodyFile (TxBodyFile txbodyFile)) -> do
+    (InputTxBodyFile (TxBodyFile txbodyFilePath)) -> do
+      txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
       unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                        $ readFileTxBody txbodyFile
 
@@ -1050,15 +1052,17 @@ runTxSubmit
   -> NetworkId
   -> FilePath
   -> ExceptT ShelleyTxCmdError IO ()
-runTxSubmit (AnyConsensusModeParams cModeParams) network txFile = do
+runTxSubmit (AnyConsensusModeParams cModeParams) network txFilePath = do
+
     SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError
                              $ newExceptT readEnvSocketPath
 
+    txFile <- liftIO $ fileOrPipe txFilePath
     InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                                 $ readFileTx txFile
     let cMode = AnyConsensusMode $ consensusModeOnly cModeParams
     eraInMode <- hoistMaybe
-                   (ShelleyTxCmdEraConsensusModeMismatch (Just txFile) cMode (AnyCardanoEra era))
+                   (ShelleyTxCmdEraConsensusModeMismatch (Just txFilePath) cMode (AnyCardanoEra era))
                    (toEraInMode era $ consensusModeOnly cModeParams)
     let txInMode = TxInMode tx eraInMode
         localNodeConnInfo = LocalNodeConnectInfo
@@ -1088,11 +1092,12 @@ runTxCalculateMinFee
   -> TxShelleyWitnessCount
   -> TxByronWitnessCount
   -> ExceptT ShelleyTxCmdError IO ()
-runTxCalculateMinFee (TxBodyFile txbodyFile) nw protocolParamsSourceSpec
+runTxCalculateMinFee (TxBodyFile txbodyFilePath) nw protocolParamsSourceSpec
                      (TxInCount nInputs) (TxOutCount nOutputs)
                      (TxShelleyWitnessCount nShelleyKeyWitnesses)
                      (TxByronWitnessCount nByronKeyWitnesses) = do
 
+    txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
     unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                      $ readFileTxBody txbodyFile
     pparams <- firstExceptT ShelleyTxCmdProtocolParamsError
@@ -1235,15 +1240,17 @@ runTxGetTxId :: InputTxBodyOrTxFile -> ExceptT ShelleyTxCmdError IO ()
 runTxGetTxId txfile = do
     InAnyCardanoEra _era txbody <-
       case txfile of
-        InputTxBodyFile (TxBodyFile txbodyFile) -> do
+        InputTxBodyFile (TxBodyFile txbodyFilePath) -> do
+          txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
           unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                            $ readFileTxBody txbodyFile
           case unwitnessed of
             UnwitnessedCliFormattedTxBody anyTxBody -> return anyTxBody
             IncompleteCddlFormattedTx (InAnyCardanoEra era tx) ->
               return (InAnyCardanoEra era (getTxBody tx))
 
-        InputTxFile (TxFile txFile) -> do
+        InputTxFile (TxFile txFilePath) -> do
+          txFile <- liftIO $ fileOrPipe txFilePath
           InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                                       $ readFileTx txFile
           return . InAnyCardanoEra era $ getTxBody tx
@@ -1252,7 +1259,8 @@ runTxGetTxId txfile = do
 
 runTxView :: InputTxBodyOrTxFile -> ExceptT ShelleyTxCmdError IO ()
 runTxView = \case
-  InputTxBodyFile (TxBodyFile txbodyFile) -> do
+  InputTxBodyFile (TxBodyFile txbodyFilePath) -> do
+    txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
     unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                      $ readFileTxBody txbodyFile
     InAnyCardanoEra era txbody <-
@@ -1264,7 +1272,8 @@ runTxView = \case
     -- In the case of a transaction body, we can simply call makeSignedTransaction []
     -- to get a transaction which allows us to reuse friendlyTxBS!
     liftIO $ BS.putStr $ friendlyTxBodyBS era txbody
-  InputTxFile (TxFile txFile) -> do
+  InputTxFile (TxFile txFilePath) -> do
+    txFile <- liftIO $ fileOrPipe txFilePath
     InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                                 $ readFileTx txFile
     liftIO $ BS.putStr $ friendlyTxBS era tx
@@ -1280,7 +1289,8 @@ runTxCreateWitness
   -> Maybe NetworkId
   -> OutputFile
   -> ExceptT ShelleyTxCmdError IO ()
-runTxCreateWitness (TxBodyFile txbodyFile) witSignData mbNw (OutputFile oFile) = do
+runTxCreateWitness (TxBodyFile txbodyFilePath) witSignData mbNw (OutputFile oFile) = do
+  txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
   unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                    $ readFileTxBody txbodyFile
   case unwitnessed of
@@ -1331,7 +1341,8 @@ runTxSignWitness
   -> [WitnessFile]
   -> OutputFile
   -> ExceptT ShelleyTxCmdError IO ()
-runTxSignWitness (TxBodyFile txbodyFile) witnessFiles (OutputFile oFp) = do
+runTxSignWitness (TxBodyFile txbodyFilePath) witnessFiles (OutputFile oFp) = do
+    txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
     unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
                      $ readFileTxBody txbodyFile
     case unwitnessed of

cardano-cli/test/Test/OptParse.hs

@@ -72,7 +72,9 @@ checkTxCddlFormat
   => FilePath -- ^ Reference/golden file
   -> FilePath -- ^ Newly created file
   -> m ()
-checkTxCddlFormat reference created = do
+checkTxCddlFormat referencePath createdPath = do
+  reference <- liftIO $ fileOrPipe referencePath
+  created <- liftIO $ fileOrPipe createdPath
   r <- liftIO $ readCddlTx reference
   c <- liftIO $ readCddlTx created
   r H.=== c