diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +# ChangeLog for tar-conduit + +## 0.4.0 - 2023-08-07 + +* `untarChunks` and `untar` now provide partial support for the pax interchange + format, by applying pax header blocks and certain keywords in pax extended + headers. Exposes `applyPaxChunkHeaders`. Also exposes `untarChunksRaw` and + `untarRaw`, which do not apply pax header blocks and extended headers. + ## 0.3.2.1 - 2023-06-25 * `unix-2.8` compatibility [#32](https://github.com/snoyberg/tar-conduit/pull/32) @@ -61,4 +70,3 @@ ## 0.1.0 - 2016-11-03 * Initial release - diff --git a/src/Data/Conduit/Tar.hs b/src/Data/Conduit/Tar.hs --- a/src/Data/Conduit/Tar.hs +++ b/src/Data/Conduit/Tar.hs @@ -13,6 +13,7 @@ tar , tarEntries , untar + , untarRaw , untarWithFinalizers , untarWithExceptions , restoreFile @@ -21,6 +22,8 @@ , restoreFileWithErrors -- ** Operate on Chunks , untarChunks + , untarChunksRaw + , applyPaxChunkHeaders , withEntry , withEntries , withFileInfo @@ -42,6 +45,7 @@ import Conduit as C import Control.Exception (assert, SomeException) import Control.Monad (unless, void) +import Control.Monad.State.Lazy (StateT, get, put) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -52,7 +56,9 @@ import qualified Data.ByteString.Short as SS import qualified Data.ByteString.Unsafe as BU import Data.Foldable (foldr') +import qualified Data.Map as Map import Data.Monoid ((<>), mempty) +import Data.Word (Word8) import Foreign.C.Types (CTime (..)) import Foreign.Storable import System.Directory (createDirectoryIfMissing, @@ -147,28 +153,47 @@ else getOctal off len parseOctal :: Integral i => ByteString -> i - parseOctal = S.foldl' (\t c -> t * 8 + fromIntegral (c - zero)) 0 + parseOctal = parseBase 8 . S.takeWhile (\c -> zero <= c && c <= seven) . S.dropWhile (== space) - space :: Integral i => i - space = 0x20 - zero = 48 seven = 55 +parseBase :: Integral i => i -> ByteString -> i +parseBase n = S.foldl' (\t c -> t * n + fromIntegral (c - zero)) 0 + +space :: Integral i => i +space = 0x20 -- UTF-8 ' ' + +zero :: Word8 +zero = 0x30 -- UTF-8 '0' + -- | Make sure we don't use more bytes than we can fit in the data type. fromHex :: forall a . (Storable a, Bits a, Integral a) => ByteString -> a fromHex str = S.foldl' (\ acc x -> (acc `shiftL` 8) .|. fromIntegral x) 0 $ S.drop (max 0 (S.length str - sizeOf (undefined :: a))) str - - --- | Convert a stream of raw bytes into a stream of 'TarChunk's. This stream can further be passed --- into `withFileInfo` or `withHeaders` functions. +-- | Convert a stream of raw bytes into a stream of 'TarChunk's, after applying +-- any pax header blocks and extended headers. This stream can further be passed +-- into 'withFileInfo' or 'withHeaders' functions. Only the \'comment\', +-- \'gid\', \'gname\', \'linkpath\', \'path\', \'size\', \'uid\' and \'uname\' +-- pax keywords are supported. For a component that produces unprocessed +-- 'TarChunk's, see 'untarChunksRaw'. -- -- @since 0.2.1 untarChunks :: Monad m => ConduitM ByteString TarChunk m () untarChunks = + untarChunksRaw + .| evalStateLC initialPaxState applyPaxChunkHeaders + +-- | Convert a stream of raw bytes into a stream of raw 'TarChunk's. This stream +-- can further be passed into `withFileInfo` or `withHeaders` functions. For a +-- component that further processes raw 'TarChunk's to apply pax header blocks +-- and extended headers, see 'untarChunk'. +-- +-- @since 0.3.3 +untarChunksRaw :: Monad m => ConduitM ByteString TarChunk m () +untarChunksRaw = loop 0 where loop !offset = assert (offset `mod` 512 == 0) $ do @@ -381,9 +406,10 @@ return Nothing _ -> return Nothing - - --- | Just like `withFileInfo`, but works directly on the stream of bytes. +-- | Just like 'withFileInfo', but works directly on the stream of bytes. +-- Applies pax header blocks and extended headers. However, only the +-- \'comment\', \'gid\', \'gname\', \'linkpath\', \'path\', \'size\', \'uid\' +-- and \'uname\' pax keywords are supported. -- -- @since 0.2.0 untar :: MonadThrow m @@ -391,6 +417,136 @@ -> ConduitM ByteString o m () untar inner = untarChunks .| withFileInfo inner +-- | Like 'untar' but does not apply pax header blocks and extended headers. +-- +-- @since 0.3.3 +untarRaw :: + MonadThrow m + => (FileInfo -> ConduitM ByteString o m ()) + -> ConduitM ByteString o m () +untarRaw inner = untarChunksRaw .| withFileInfo inner + +-- | Applies tar chunks that are pax header blocks and extended headers to the +-- tar chunks that follow. However, only the \'comment\', \'gid\', \'gname\', +-- \'linkpath\', \'path\', \'size\', \'uid\' and \'uname\' pax keywords are +-- supported. +applyPaxChunkHeaders :: + Monad m + => ConduitM TarChunk TarChunk (StateT PaxState m) () +applyPaxChunkHeaders = awaitForever $ \i -> do + state@(PaxState g x) <- lift get + let updateState f = do + p <- parsePax + lift $ put $ f p state + case i of + ChunkHeader h -> case headerLinkIndicator h of + -- 'g' typeflag unique to pax header block + 0x67 -> updateState updateGlobal + -- 'x' typeflag unique to pax header block + 0x78 -> updateState updateNext + -- All other typeflag + _ -> do + yield $ ChunkHeader $ applyPax (Map.union x g) h + lift $ put $ clearNext state + _ -> yield i + where + updateGlobal p (PaxState g x) = PaxState (Map.union p g) x + updateNext p (PaxState g _) = PaxState g p + clearNext = updateNext mempty + +-- | Only the \'comment\', \'gid\', \'gname\', \'linkpath\',\'path\', \'size\', +-- \'uid\' and \'uname\' pax keywords are supported. +applyPax :: PaxHeader -> Header -> Header +applyPax p h = + updateGid + $ updateGname + $ updateLinkpath + $ updatePath + $ updateSize + $ updateUid + $ updateUname h + where + update :: + ByteString + -> (ByteString -> Header -> Header) + -> (Header -> Header) + update k f = maybe id f (Map.lookup k p) + ifValueDecimal :: + Integral i + => (i -> Header -> Header) + -> ByteString + -> (Header -> Header) + ifValueDecimal f v = if S.all isDecimal v + then f (parseDecimal v) + else id + -- There is no 'updateComment' because comments are ignored. + updateGid = update "gid" $ ifValueDecimal $ \v h' -> h' + { headerGroupId = v } + updateGname = update "gname" $ \v h' -> h' { headerGroupName = toShort v } + updateLinkpath = + update "linkpath" $ \v h' -> h' { headerLinkName = toShort v } + updatePath = update "path" $ \v h' -> h' + { headerFileNameSuffix = toShort v, headerFileNamePrefix = mempty } + updateSize = update "size" $ ifValueDecimal $ \v h' -> h' + { headerPayloadSize = v } + updateUid = update "uid" $ ifValueDecimal $ \v h' -> h' + { headerOwnerId = v } + updateUname = update "uname" $ \v h' -> h' { headerOwnerName = toShort v } + +parsePax :: Monad m => ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader +parsePax = await >>= \case + Just (ChunkPayload _ b) -> pure $ paxParser b + _ -> pure mempty + +-- | A pax extended header comprises one or more records. If the pax extended +-- header is empty or does not parse, yields an empty 'Pax'. +paxParser :: ByteString -> PaxHeader +paxParser b + -- This is an error case. + | S.null b = mempty +paxParser b = paxParser' [] b + where + paxParser' :: [(ByteString, ByteString)] -> ByteString -> PaxHeader + paxParser' l b0 + | S.null b0 = Map.fromList l + paxParser' l b0 = + maybe mempty (\(pair, b1) -> paxParser' (pair:l) b1) (recordParser b0) + +-- | A record in a pax extended header has format: +-- +-- "%d %s=%s\n", , , +-- +-- If the record does not parse @(, )@, yields 'Nothing'. +recordParser :: ByteString -> Maybe ((ByteString, ByteString), ByteString) +recordParser b0 = do + let (nb, b1) = S.span isDecimal b0 + n <- toMaybe (not $ S.null nb) (parseDecimal nb) + b2 <- skip isSpace b1 + let (k, b3) = S.span (not . isEquals) b2 + b4 <- skip isEquals b3 + let (v, b5) = S.splitAt (n - S.length nb - S.length k - 3) b4 + b6 <- skip isNewline b5 + Just ((k, v), b6) + where + newline = 0x0a -- UTF-8 '\n' + equals = 0x3d -- UTF-8 '=' + toMaybe :: Bool -> a -> Maybe a + toMaybe False _ = Nothing + toMaybe True x = Just x + skip p b = do + (w, b') <- S.uncons b + if p w then Just b' else Nothing + isSpace = (space ==) + isEquals = (equals ==) + isNewline = (newline ==) + +parseDecimal :: Integral i => ByteString -> i +parseDecimal = parseBase 10 + +isDecimal :: Word8 -> Bool +isDecimal w = w >= zero && w <= nine + where + nine = 0x39 -- UTF-8 '9' -- | Just like `untar`, except that each `FileInfo` handling function can produce a finalizing -- action, all of which will be executed after the whole tarball has been processed in the opposite diff --git a/src/Data/Conduit/Tar/Types.hs b/src/Data/Conduit/Tar/Types.hs --- a/src/Data/Conduit/Tar/Types.hs +++ b/src/Data/Conduit/Tar/Types.hs @@ -5,6 +5,9 @@ -- | Module contains all the types necessary for tarball processing. module Data.Conduit.Tar.Types ( Header(..) + , PaxHeader + , PaxState (..) + , initialPaxState , TarChunk(..) , TarException(..) , TarCreateException(..) @@ -29,6 +32,7 @@ import Data.Word import System.Posix.Types import qualified Data.ByteString.Char8 as S8 +import Data.Map (Map) import Data.Text as T import Data.Text.Encoding as T import Data.Text.Encoding.Error as T @@ -114,7 +118,15 @@ } deriving Show +-- | Type synonym representing a pax extended header. +type PaxHeader = Map ByteString ByteString +-- | Type representing states (global, next file) given pax extended headers. +data PaxState = PaxState PaxHeader PaxHeader + +-- | The initial state before applying any pax extended headers. +initialPaxState :: PaxState +initialPaxState = PaxState mempty mempty data TarChunk = ChunkHeader Header diff --git a/tar-conduit.cabal b/tar-conduit.cabal --- a/tar-conduit.cabal +++ b/tar-conduit.cabal @@ -1,5 +1,5 @@ name: tar-conduit -version: 0.3.2.1 +version: 0.4.0 synopsis: Extract and create tar files using conduit for streaming description: Please see README.md. This is just filler to avoid warnings. homepage: https://github.com/snoyberg/tar-conduit#readme @@ -24,8 +24,10 @@ , bytestring , conduit , conduit-combinators >= 1.0.8.1 + , containers , directory , filepath + , mtl , safe-exceptions , text default-language: Haskell2010 @@ -54,6 +56,8 @@ , hspec , tar-conduit ghc-options: -O2 -threaded -rtsopts + if os(windows) + cpp-options: -DWINDOWS default-language: Haskell2010 test-suite space diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -10,6 +10,7 @@ import Control.Monad (void, when, zipWithM_) import Data.ByteString as S import Data.ByteString.Char8 as S8 +import Data.ByteString.Short (fromShort) import Data.Conduit.List import Data.Conduit.Tar import Data.Int @@ -38,10 +39,21 @@ let baseTmp = "tar-conduit-tests" isStack <- doesDirectoryExist ".stack-work" let testPaths = - ["src", "./tests", "README.md", "ChangeLog.md", "LICENSE"] ++ - if isStack - then [".stack-work"] - else [] + ["src", "README.md", "ChangeLog.md", "LICENSE"] +#ifndef WINDOWS + <> ["./tests"] + -- On Windows, the 'stack test' command results in error message: + -- + -- uncaught exception: IOException of type PermissionDenied + -- System.Win32File.read: permission denied (Permission denied) + -- + -- if '.stack-work' is included in the test paths. + <> [".stack-work" | isStack] +#else + -- The package does not support symlinks on Windows. See + -- Data.Conduit.Tar.Windows.getFileInfo. + <> ["./tests/files"] +#endif hspec $ do describe "tar/untar" $ do let tarUntarContent dir = @@ -74,6 +86,7 @@ collectContent (outDir Posix. "dir/subdir/") `shouldReturn` "Hello World\n" describe "ustar" ustarSpec describe "GNUtar" gnutarSpec + describe "pax" paxSpec describe "unsupported headers" $ do it "associated payload is discarded" $ do contents <- readGzipTarball "./tests/files/libpq-0.3.tar.gz" @@ -278,3 +291,100 @@ collectContent dir = runConduitRes $ sourceDirectoryDeep False dir .| mapMC (\fp -> runConduit (sourceFileBS fp .| foldC)) .| foldC + +-- | This test uses untar to process a simple example in the pax interchange +-- format. +paxSpec :: Spec +paxSpec = do + it "untarChunksRaw, pax interchange format" $ do + res <- runConduitRes $ + paxExample + .| untarChunksRaw + .| processTarChunks + .| sinkList + pure res `shouldReturn` + [ "/pax-global-header" + , "payload: 19 comment=Example\n" + , "/pax-extended-header" + , "payload: 17 path=filepath\n" + , "original-dir/original-filepath" + , "payload: payload" + ] + it "untar, pax interchange format" $ do + res <- runConduitRes $ + paxExample + .| untar process + .| sinkList + pure res `shouldReturn` [("filepath", "payload")] + it "untarRaw, pax interchange format" $ do + res <- runConduitRes $ + paxExample + .| untarRaw process + .| sinkList + pure res `shouldReturn` [("original-dir/original-filepath", "payload")] + where + process fi = awaitForever $ \bs -> yield (filePath fi, bs) + processTarChunks = awaitForever $ \tc -> yield $ case tc of + ChunkHeader h -> fromShort $ + headerFileNamePrefix h <> "/" <> headerFileNameSuffix h + ChunkPayload _ bs -> "payload: " <> bs + ChunkException e -> "exception: " <> S8.pack (show e) + +-- | Produces a simple example in the pax interchange format. It has a pax +-- \'global\' header block providing a comment, a pax \'next\' header block +-- providing a path (@\"filepath\"@), and a normal file with filepath +-- @\"original-filepath\"@ and payload @\"payload\". +paxExample :: MonadThrow m => ConduitM a ByteString m () +paxExample = void $ + yieldMany + [ Left globalHeader + , Right globalPayload + , Left extendedHeader + , Right extendedPayload + , Left ustarHeader + , Right ustarPayload + ] + .| void tarEntries + where + defaultHeader :: FileOffset -> Header + defaultHeader offset = Header + { headerOffset = offset + , headerPayloadOffset = offset + 512 + , headerFileNameSuffix = mempty + , headerFileMode = 0o666 + , headerOwnerId = 0x0 + , headerGroupId = 0x0 + , headerPayloadSize = 0x0 + , headerTime = 0x0 + , headerLinkIndicator = 0x0 + , headerLinkName = mempty + , headerMagicVersion = "ustar" + , headerOwnerName = "root" + , headerGroupName = "root" + , headerDeviceMajor = 0x0 + , headerDeviceMinor = 0x0 + , headerFileNamePrefix = mempty + } + nextOffset :: Header -> FileOffset + nextOffset h = headerPayloadOffset h + ((headerPayloadSize h + 512) `div` 512) + globalHeader = (defaultHeader 0x0) + { headerFileNameSuffix = "pax-global-header" + , headerPayloadSize = fromIntegral $ S.length globalPayload + , headerLinkIndicator = 0x67 -- UTF-8 'g' + } + globalPayload = "19 comment=Example\n" + extendedHeader = (defaultHeader $ nextOffset globalHeader) + { headerFileNameSuffix = "pax-extended-header" + , headerPayloadSize = fromIntegral $ S.length extendedPayload + , headerLinkIndicator = 0x78 -- UTF-8 'x' + } + -- The path in the pax extended header should override the filepath + -- specified in the ustar header. + extendedPayload = "17 path=filepath\n" + ustarHeader = (defaultHeader $ nextOffset extendedHeader) + { headerFileNameSuffix = "original-filepath" + , headerPayloadSize = fromIntegral $ S.length ustarPayload + , headerLinkIndicator = 0x30 -- UTF-8 '0' + , headerFileNamePrefix = "original-dir" + } + ustarPayload = "payload"