Allow reading/writing text envelopes from pipes

Previously the functions to read text envelopes used `readFile` from Data.ByteString. Unfortunately, that doesn't work with pipes, so we've switched to a function that does. Additionally, on unix based systems, we've changed how writing to an owned file works. Previously a new file was created (and since we created it, we must own it) and then copied into place. Unfortunately this doesn't work with symlinks, fifos, unix sockets or anything else that isn't a "normal" file. What we do now is grab the file descriptor, call fchown on it, which sets us as the owner (or errors out if we can't do that), and then write to the file.
IntersectMBO · Aug 25, 2022 · ec5063c · ec5063c
1 parent e36c1a7
commit ec5063c
Show file tree

Hide file tree

Showing 3 changed files with 75 additions and 10 deletions.
diff --git a/cardano-api/ChangeLog.md b/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
 

diff --git a/cardano-api/src/Cardano/Api/SerialiseTextEnvelope.hs b/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
 

diff --git a/cardano-api/src/Cardano/Api/Utils.hs b/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)