Allow reading/writing text envelopes from pipes

cardano-api/ChangeLog.md

@@ -6,6 +6,10 @@
 
 - Append, not prepend change output when balancing a transaction ([PR 4343](https://github.com/input-output-hk/cardano-node/pull/4343))
 
+### Bugs
+
+- Allow reading text envelopes from pipes ([PR 4384](https://github.com/input-output-hk/cardano-node/pull/4384))
+
 ## 1.33.0 -- December 2021
 ## 1.32.1 -- November 2021
 

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

@@ -1,10 +1,15 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 
+#if !defined(mingw32_HOST_OS)
+#define UNIX
+#endif
+
 -- | TextEnvelope Serialisation
 --
 module Cardano.Api.SerialiseTextEnvelope
@@ -36,7 +41,6 @@ import           Prelude
 
 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
@@ -49,20 +53,31 @@ import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:
 import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder)
 
-import           Control.Exception (bracketOnError)
 import           Control.Monad (unless)
 import           Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither)
 
-import           System.Directory (removeFile, renameFile)
-import           System.FilePath (splitFileName, (<.>))
-import           System.IO (hClose, openTempFile)
 
 import           Cardano.Binary (DecoderError)
 
 import           Cardano.Api.Error
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.SerialiseCBOR
+import           Cardano.Api.Utils (readFileBlocking)
+
+#ifdef UNIX
+import           Control.Exception (IOException, bracket, bracketOnError, try)
+import           System.Directory ()
+import           System.Posix.Files (ownerModes, setFdOwnerAndGroup)
+import           System.Posix.IO (OpenMode (..), closeFd, openFd, fdToHandle, defaultFileFlags)
+import           System.Posix.User (getRealUserID)
+import           System.IO (hClose)
+#else
+import           Control.Exception (bracketOnError)
+import           System.Directory (removeFile, renameFile)
+import           System.FilePath (splitFileName, (<.>))
+import           System.IO (hClose, openTempFile)
+#endif
 
 
 -- ----------------------------------------------------------------------------
@@ -213,11 +228,36 @@ deserialiseFromTextEnvelopeAnyOf types te =
 
     matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken
 
-
 writeFileWithOwnerPermissions
   :: FilePath
   -> LBS.ByteString
   -> IO (Either (FileError ()) ())
+#ifdef UNIX
+-- On a unix based system, we grab a file descriptor and set ourselves as owner.
+-- Since we're holding the file descriptor at this point, we can be sure that
+-- what we're about to write to is owned by us if an error didn't occur.
+writeFileWithOwnerPermissions path a = do
+    user <- getRealUserID
+    ownedFile <- try $
+      -- We only close the FD on error here, otherwise we let it leak out, since
+      -- it will be immediately turned into a Handle (which will be closed when
+      -- the Handle is closed)
+      bracketOnError
+        (openFd path WriteOnly (Just ownerModes) defaultFileFlags)
+        closeFd
+        (\fd -> setFdOwnerAndGroup fd user (-1) >> pure fd)
+    case ownedFile of
+      Left (err :: IOException) -> do
+        pure $ Left $ FileIOError path err
+      Right fd -> do
+        bracket
+          (fdToHandle fd)
+          hClose
+          (\handle -> runExceptT $ handleIOExceptT (FileIOError path) $ LBS.hPut handle a)
+#else
+-- On something other than unix, we make a _new_ file, and since we created it,
+-- we must own it. We then place it at the target location. Unfortunately this
+-- won't work correctly with pseudo-files.
 writeFileWithOwnerPermissions targetPath a =
     bracketOnError
       (openTempFile targetDir $ targetFile <.> "tmp")
@@ -231,6 +271,7 @@ writeFileWithOwnerPermissions targetPath a =
           return $ Right ())
   where
     (targetDir, targetFile) = splitFileName targetPath
+#endif
 
 writeFileTextEnvelope :: HasTextEnvelope a
                       => FilePath
@@ -260,14 +301,13 @@ textEnvelopeToJSON :: HasTextEnvelope a =>  Maybe TextEnvelopeDescr -> a -> LBS.
 textEnvelopeToJSON mbDescr a  =
   encodePretty' textEnvelopeJSONConfig (serialiseToTextEnvelope mbDescr a) <> "\n"
 
-
 readFileTextEnvelope :: HasTextEnvelope a
                      => AsType a
                      -> FilePath
                      -> IO (Either (FileError TextEnvelopeError) a)
 readFileTextEnvelope ttoken path =
     runExceptT $ do
-      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
+      content <- handleIOExceptT (FileIOError path) $ readFileBlocking path
       firstExceptT (FileError path) $ hoistEither $ do
         te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content
         deserialiseFromTextEnvelope ttoken te
@@ -278,7 +318,7 @@ readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
                           -> IO (Either (FileError TextEnvelopeError) b)
 readFileTextEnvelopeAnyOf types path =
     runExceptT $ do
-      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
+      content <- handleIOExceptT (FileIOError path) $ readFileBlocking path
       firstExceptT (FileError path) $ hoistEither $ do
         te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content
         deserialiseFromTextEnvelopeAnyOf types te
@@ -289,7 +329,7 @@ readTextEnvelopeFromFile :: FilePath
 readTextEnvelopeFromFile path =
   runExceptT $ do
     bs <- handleIOExceptT (FileIOError path) $
-            BS.readFile path
+            readFileBlocking path
     firstExceptT (FileError path . TextEnvelopeAesonDecodeError)
       . hoistEither $ Aeson.eitherDecodeStrict' bs
 

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

@@ -16,24 +16,30 @@ module Cardano.Api.Utils
   , noInlineMaybeToStrictMaybe
   , note
   , parseFilePath
+  , readFileBlocking
   , runParsecParser
   , writeSecrets
   ) where
 
 import           Prelude
 
+import           Control.Exception (bracket)
 import           Control.Monad (forM_)
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Lazy as LBS
 import           Data.Maybe.Strict
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import           GHC.IO.Handle.FD (openFileBlocking)
 import qualified Text.Parsec as Parsec
 import qualified Text.Parsec.String as Parsec
 import qualified Text.ParserCombinators.Parsec.Error as Parsec
 import           Text.Printf (printf)
 import qualified Options.Applicative as Opt
 import           System.FilePath ((</>))
+import           System.IO (IOMode (ReadMode), hClose)
 #ifdef UNIX
 import           System.Posix.Files (ownerReadMode, setFileMode)
 #else
@@ -96,3 +102,18 @@ writeSecrets outDir prefix suffix secretOp xs =
 #else
     setPermissions filename (emptyPermissions {readable = True})
 #endif
+
+readFileBlocking :: FilePath -> IO BS.ByteString
+readFileBlocking path = bracket
+  (openFileBlocking path ReadMode)
+  hClose
+  (\fp -> do
+    -- An arbitrary block size.
+    let blockSize = 4096
+    let go acc = do
+          next <- BS.hGet fp blockSize
+          if BS.null next
+          then pure acc
+          else go (acc <> Builder.byteString next)
+    contents <- go mempty
+    pure $ LBS.toStrict $ Builder.toLazyByteString contents)