tar-conduit 0.3.2.1 → 0.4.0
raw patch · 5 files changed
+307/−17 lines, 5 filesdep +mtl
Dependencies added: mtl
Files
- ChangeLog.md +9/−1
- src/Data/Conduit/Tar.hs +167/−11
- src/Data/Conduit/Tar/Types.hs +12/−0
- tar-conduit.cabal +5/−1
- tests/Spec.hs +114/−4
ChangeLog.md view
@@ -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-
src/Data/Conduit/Tar.hs view
@@ -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", <length>, <keyword>, <value>+--+-- If the record does not parse @(<keyword>, <value>)@, 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
src/Data/Conduit/Tar/Types.hs view
@@ -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
tar-conduit.cabal view
@@ -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
tests/Spec.hs view
@@ -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"