Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Handle pipes
Fixes #4235
  • Loading branch information
LudvikGalois committed Nov 22, 2022
1 parent d15ff2b commit b8282f9
Show file tree
Hide file tree
Showing 6 changed files with 145 additions and 37 deletions.
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api.hs
Expand Up @@ -501,6 +501,7 @@ module Cardano.Api (
-- single API.
FromSomeTypeCDDL(..),
readFileTextEnvelopeCddlAnyOf,
deserialiseFromTextEnvelopeCddlAnyOf,
writeTxFileTextEnvelopeCddl,
writeTxWitnessFileTextEnvelopeCddl,
serialiseTxLedgerCddl,
Expand Down
5 changes: 3 additions & 2 deletions cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs
Expand Up @@ -15,6 +15,7 @@ module Cardano.Api.SerialiseLedgerCddl
-- * Reading one of several transaction or
-- key witness types
, readFileTextEnvelopeCddlAnyOf
, deserialiseFromTextEnvelopeCddlAnyOf

, writeTxFileTextEnvelopeCddl
, writeTxWitnessFileTextEnvelopeCddl
Expand All @@ -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
Expand All @@ -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`
Expand Down Expand Up @@ -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
1 change: 0 additions & 1 deletion cardano-api/src/Cardano/Api/Utils.hs
Expand Up @@ -133,4 +133,3 @@ renderEra (AnyCardanoEra AllegraEra) = "Allegra"
renderEra (AnyCardanoEra MaryEra) = "Mary"
renderEra (AnyCardanoEra AlonzoEra) = "Alonzo"
renderEra (AnyCardanoEra BabbageEra) = "Babbage"

138 changes: 116 additions & 22 deletions cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs
Expand Up @@ -52,19 +52,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
Expand Down Expand Up @@ -446,11 +458,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
Expand All @@ -462,11 +474,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
Expand All @@ -483,21 +495,22 @@ instance Error CddlError where
displayError (CddlIOError e) = 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
Expand All @@ -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
Expand Down Expand Up @@ -742,14 +756,94 @@ 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. Currently the CLI makes no guarantee that a "file" will only
-- be read once. This is a problem for a user who who expects to be able to pass
-- a pipe. To handle this, we have a type for representing either files or pipes
-- where the contents will be saved in memory if what we're reading is a pipe (so
-- it can be re-read later). Unfortunately this means we can't easily stream data
-- from pipes, but at present that's not an issue.
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

-- | Get the path backing a FileOrPipe. This should primarily be used when
-- generating error messages for a user. A user should not call directly
-- call a function like readFile on the result of this function
fileOrPipePath :: FileOrPipe -> FilePath
fileOrPipePath (FileOrPipe fp _) = fp

-- | Get the contents of a file or pipe. This function reads the entire
-- contents of the file or pipe, and is blocking.
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
33 changes: 22 additions & 11 deletions cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs
Expand Up @@ -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 <-
Expand All @@ -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

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 <-
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 3 additions & 1 deletion cardano-cli/test/Test/OptParse.hs
Expand Up @@ -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
Expand Down

0 comments on commit b8282f9

Please sign in to comment.