From 1f8344d31c9c41e6c5090be0e27818921aef80c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Markus=20L=C3=A4ll?= Date: Thu, 25 Aug 2022 18:24:37 +0300 Subject: [PATCH 1/2] Export `fromShelleyBasedScript` from Cardano.Api --- cardano-api/src/Cardano/Api/Shelley.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 19ce7a4294e..c77df8331fb 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -111,6 +111,7 @@ module Cardano.Api.Shelley ProtocolParametersError(..), -- * Scripts + fromShelleyBasedScript, toShelleyScript, toShelleyMultiSig, fromShelleyMultiSig, From ac73752abb0fd95d05916844a27c5594630f8bc5 Mon Sep 17 00:00:00 2001 From: Robert 'Probie' Offner Date: Mon, 13 Feb 2023 22:44:40 +1100 Subject: [PATCH 2/2] Handle pipes Fixes https://github.com/input-output-hk/cardano-node/issues/4235 Co-authored-by: John Ky --- cardano-api/src/Cardano/Api.hs | 1 + .../src/Cardano/Api/SerialiseLedgerCddl.hs | 5 +- cardano-api/src/Cardano/Api/Utils.hs | 1 - cardano-cli/cardano-cli.cabal | 9 +- .../src/Cardano/CLI/Shelley/Run/Read.hs | 146 +++++++++++++++--- .../Cardano/CLI/Shelley/Run/Transaction.hs | 33 ++-- cardano-cli/test/Test/Cli/Pipes.hs | 100 ++++++++++++ cardano-cli/test/Test/OptParse.hs | 4 +- cardano-cli/test/cardano-cli-test.hs | 10 ++ cardano-testnet/cardano-testnet.cabal | 1 + 10 files changed, 271 insertions(+), 39 deletions(-) create mode 100644 cardano-cli/test/Test/Cli/Pipes.hs diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index a6357fa5cd6..aebc5cf2c64 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -510,6 +510,7 @@ module Cardano.Api ( -- single API. FromSomeTypeCDDL(..), readFileTextEnvelopeCddlAnyOf, + deserialiseFromTextEnvelopeCddlAnyOf, writeTxFileTextEnvelopeCddl, writeTxWitnessFileTextEnvelopeCddl, serialiseTxLedgerCddl, diff --git a/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs index 3eb8cfa764c..a91f7e2ddc1 100644 --- a/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs +++ b/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 @@ -34,7 +35,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 @@ -50,6 +50,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` @@ -317,6 +318,6 @@ readTextEnvelopeCddlFromFile readTextEnvelopeCddlFromFile path = runExceptT $ do bs <- handleIOExceptT (FileIOError path) $ - BS.readFile path + readFileBlocking path firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path) . hoistEither $ Aeson.eitherDecodeStrict' bs diff --git a/cardano-api/src/Cardano/Api/Utils.hs b/cardano-api/src/Cardano/Api/Utils.hs index 6d31ed26fea..b658e3e8602 100644 --- a/cardano-api/src/Cardano/Api/Utils.hs +++ b/cardano-api/src/Cardano/Api/Utils.hs @@ -131,4 +131,3 @@ renderEra (AnyCardanoEra AllegraEra) = "Allegra" renderEra (AnyCardanoEra MaryEra) = "Mary" renderEra (AnyCardanoEra AlonzoEra) = "Alonzo" renderEra (AnyCardanoEra BabbageEra) = "Babbage" - diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index c7db9a94f0c..3cbd4dd73a4 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -37,6 +37,10 @@ common maybe-unix if !os(windows) build-depends: unix +common maybe-bytestring + if !os(windows) + build-depends: bytestring + library import: project-config @@ -162,7 +166,7 @@ executable cardano-cli , transformers-except test-suite cardano-cli-test - import: project-config + import: project-config, maybe-unix, maybe-bytestring hs-source-dirs: test main-is: cardano-cli-test.hs @@ -201,6 +205,7 @@ test-suite cardano-cli-test Test.Cli.Pioneers.Exercise4 Test.Cli.Pioneers.Exercise5 Test.Cli.Pioneers.Exercise6 + Test.Cli.Pipes Test.Cli.Shelley.Run.Query Test.OptParse @@ -227,7 +232,7 @@ test-suite cardano-cli-golden , directory , exceptions , filepath - , hedgehog + , hedgehog ^>= 1.2 , hedgehog-extras , text , time diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs index 108f9d64a84..fb91b698cd3 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs @@ -53,19 +53,34 @@ module Cardano.CLI.Shelley.Run.Read , RequiredSignerError(..) , categoriseSomeWitness , readRequiredSigner + + -- * FileOrPipe + , FileOrPipe + , fileOrPipe + , fileOrPipePath + , fileOrPipeCache + , 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 +462,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 +478,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 @@ -484,21 +499,22 @@ renderCddlError (CddlErrorTextEnv textEnvErr cddlErr) = mconcat 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 @@ -521,7 +537,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 @@ -727,10 +744,10 @@ 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) @@ -738,3 +755,88 @@ readFileInAnyCardanoEra asThing = , 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 + +fileOrPipeCache :: FileOrPipe -> IO (Maybe LBS.ByteString) +fileOrPipeCache (FileOrPipe _ c) = readIORef c + +-- | 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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 363f4fdeebe..d37bc26888d 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -1070,7 +1070,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 <- @@ -1089,7 +1090,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 @@ -1137,15 +1139,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 @@ -1175,11 +1179,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 @@ -1322,7 +1327,8 @@ 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 @@ -1330,7 +1336,8 @@ runTxGetTxId txfile = do 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 @@ -1339,7 +1346,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 <- @@ -1351,7 +1359,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 @@ -1367,7 +1376,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 @@ -1418,7 +1428,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 diff --git a/cardano-cli/test/Test/Cli/Pipes.hs b/cardano-cli/test/Test/Cli/Pipes.hs new file mode 100644 index 00000000000..22583ba1168 --- /dev/null +++ b/cardano-cli/test/Test/Cli/Pipes.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Test.Cli.Pipes + ( tests + ) where + +#if !defined(mingw32_HOST_OS) +#define UNIX +#endif + +import Prelude + +#ifdef UNIX +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import System.IO (hClose, hFlush, hPutStr) +import System.Posix.IO (closeFd, createPipe, fdToHandle) + +import Cardano.CLI.Shelley.Run.Read +import Test.OptParse + +import Hedgehog (Property, discover, forAll, (===)) +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.File as H +import qualified Hedgehog.Gen as G +import Hedgehog.Internal.Property (failWith) +import qualified Hedgehog.Range as R +import System.FilePath (()) + +#else + +import Hedgehog (Property, discover, property, success) +#endif + +import qualified Hedgehog as H + +#ifdef UNIX + +prop_readFromPipe :: Property +prop_readFromPipe = H.withTests 10 . H.property . H.moduleWorkspace "tmp" $ \ws -> do + + s <- forAll $ G.string (R.linear 1 8192) G.ascii + + let testFile = ws "test-file" + + H.writeFile testFile s + + -- We first test that we can read a filepath + testFp <- noteInputFile testFile + testFileOrPipe <- liftIO $ fileOrPipe testFp + testBs <- liftIO $ readFileOrPipe testFileOrPipe + + if LBS.null testBs + then failWith Nothing + $ "readFileOrPipe failed to read file: " <> fileOrPipePath testFileOrPipe + else do + -- We now test that we can read from a pipe. + -- We first check that the IORef has Nothing + mContents <- liftIO $ fileOrPipeCache testFileOrPipe + case mContents of + Just{} -> failWith Nothing "readFileOrPipe has incorrectly populated its IORef with contents read from a filepath." + Nothing -> do + -- We can reuse testFileOrPipe because we know the cache (IORef) is empty + let txBodyStr = BSC.unpack $ LBS.toStrict testBs + fromPipeBs <- liftIO $ withPipe txBodyStr + if LBS.null fromPipeBs + then failWith Nothing "readFileOrPipe failed to read from a pipe" + else testBs === fromPipeBs + +-- | Create a pipe, write some String into it, read its contents and return the contents +withPipe :: String -> IO LBS.ByteString +withPipe contents = do + (readEnd, writeEnd) <- createPipe + + writeHandle <- fdToHandle writeEnd + + -- Write contents to pipe + hPutStr writeHandle contents + hFlush writeHandle + hClose writeHandle + pipe <- fileOrPipe $ "/dev/fd/" ++ show readEnd + + -- Read contents from pipe + readContents <- readFileOrPipe pipe + closeFd readEnd + pure readContents + +#else +prop_readFromPipe :: Property +prop_readFromPipe = property success +#endif + +-- ----------------------------------------------------------------------------- + +tests :: IO Bool +tests = + H.checkParallel $$discover diff --git a/cardano-cli/test/Test/OptParse.hs b/cardano-cli/test/Test/OptParse.hs index bf53850a92c..d3062118410 100644 --- a/cardano-cli/test/Test/OptParse.hs +++ b/cardano-cli/test/Test/OptParse.hs @@ -70,7 +70,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 diff --git a/cardano-cli/test/cardano-cli-test.hs b/cardano-cli/test/cardano-cli-test.hs index 12f7847bc00..4f23e5571b3 100644 --- a/cardano-cli/test/cardano-cli-test.hs +++ b/cardano-cli/test/cardano-cli-test.hs @@ -10,9 +10,12 @@ import qualified Test.Cli.Pioneers.Exercise1 import qualified Test.Cli.Pioneers.Exercise2 import qualified Test.Cli.Pioneers.Exercise3 import qualified Test.Cli.Pioneers.Exercise4 +import qualified Test.Cli.Pipes import qualified Test.Cli.Shelley.Run.Query import qualified Test.Config.Mainnet +import Hedgehog.Extras.Stock.OS (isWin32) + main :: IO () main = defaultMain @@ -21,6 +24,7 @@ main = , Test.Cli.ITN.tests , Test.Cli.JSON.tests , Test.Cli.MultiAssetParsing.tests + , ignoreOnWindows Test.Cli.Pipes.tests , Test.Cli.Pioneers.Exercise1.tests , Test.Cli.Pioneers.Exercise2.tests , Test.Cli.Pioneers.Exercise3.tests @@ -28,3 +32,9 @@ main = , Test.Cli.Shelley.Run.Query.tests , Test.Config.Mainnet.tests ] + +ignoreOnWindows :: IO Bool -> IO Bool +ignoreOnWindows test = + if isWin32 + then return True + else test diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 24126792346..41532258688 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -14,6 +14,7 @@ license-files: LICENSE NOTICE build-type: Simple + common project-config default-language: Haskell2010 build-depends: base >= 4.14 && < 4.17