diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +## 0.1.0 - 2016-11-03 + + * Initial release + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Michael Snoyman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Conduit/Tar.hs b/src/Data/Conduit/Tar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Tar.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BangPatterns #-} +{-| This module is about stream-processing tar archives. It is currently +not very well tested. See the documentation of 'withEntries' for an usage sample. +-} +module Data.Conduit.Tar + ( -- * Basic functions + untar + , withEntry + , withEntries + -- * Helper functions + , headerFileType + , headerFilePath + -- * Types + , Header (..) + , TarChunk (..) + , TarException (..) + , Offset + , Size + , FileType (..) + ) where + +import Conduit +import Control.Exception (Exception, assert) +import Control.Monad (unless) +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Unsafe as BU +import System.Posix.Types (CMode) +import Data.Word (Word8) +import Data.Int (Int64) +import Data.ByteString.Short (ShortByteString, toShort, fromShort) +import Data.Monoid ((<>)) + +data Header = Header + { headerOffset :: !Offset + , headerPayloadOffset :: !Offset + , headerFileNameSuffix :: !ShortByteString + , headerFileMode :: !CMode + , headerOwnerId :: !Int + , headerGroupId :: !Int + , headerPayloadSize :: !Size + , headerTime :: !Int64 + , headerLinkIndicator :: !Word8 + , headerOwnerName :: !ShortByteString + , headerGroupName :: !ShortByteString + , headerDeviceMajor :: !Int + , headerDeviceMinor :: !Int + , headerFileNamePrefix :: !ShortByteString + } + deriving Show + +headerFilePath :: Header -> FilePath +headerFilePath h = S8.unpack $ fromShort + $ headerFileNamePrefix h <> headerFileNameSuffix h + +data FileType + = FTNormal + | FTHardLink + | FTSymbolicLink + | FTCharacterSpecial + | FTBlockSpecial + | FTDirectory + | FTFifo + | FTOther !Word8 + deriving (Show, Eq) + +headerFileType :: Header -> FileType +headerFileType h = + case headerLinkIndicator h of + 0 -> FTNormal + 48 -> FTNormal + 49 -> FTHardLink + 50 -> FTSymbolicLink + 51 -> FTCharacterSpecial + 52 -> FTBlockSpecial + 53 -> FTDirectory + 54 -> FTFifo + x -> FTOther x + +type Offset = Int +type Size = Int + +data TarChunk + = ChunkHeader Header + | ChunkPayload !Offset !ByteString + | ChunkException TarException + deriving Show + +-- | This the the exception type that is used in this module. +-- +-- More constructors are susceptible to be added without bumping the major +-- version of this module. +data TarException + = NoMoreHeaders + | UnexpectedPayload !Offset + | IncompleteHeader !Offset + | IncompletePayload !Offset !Size + | ShortTrailer !Offset + | BadTrailer !Offset + | InvalidHeader !Offset + | BadChecksum !Offset + deriving (Show, Typeable) +instance Exception TarException + +parseHeader :: Offset -> ByteString -> Either TarException Header +parseHeader offset bs = assert (S.length bs == 512) $ do + let checksumBytes = S.take 8 $ S.drop 148 bs + expectedChecksum = parseOctal checksumBytes + actualChecksum = bsum bs - bsum checksumBytes + 8 * 0x20 + unless (actualChecksum == expectedChecksum) (Left (BadChecksum offset)) + return Header + { headerOffset = offset + , headerPayloadOffset = offset + 512 + , headerFileNameSuffix = getShort 0 100 + , headerFileMode = getOctal 100 8 + , headerOwnerId = getOctal 108 8 + , headerGroupId = getOctal 116 8 + , headerPayloadSize = getOctal 124 12 + , headerTime = getOctal 136 12 + , headerLinkIndicator = BU.unsafeIndex bs 156 + , headerOwnerName = getShort 265 32 + , headerGroupName = getShort 297 32 + , headerDeviceMajor = getOctal 329 8 + , headerDeviceMinor = getOctal 337 8 + , headerFileNamePrefix = getShort 345 155 + } + where + bsum :: ByteString -> Int + bsum = S.foldl' (\c n -> c + fromIntegral n) 0 + + getShort off len = toShort $ S.takeWhile (/= 0) $ S.take len $ S.drop off bs + + getOctal off len = parseOctal $ S.take len $ S.drop off bs + + parseOctal :: Integral i => ByteString -> i + parseOctal = S.foldl' (\t c -> t * 8 + fromIntegral (c - zero)) 0 + . S.takeWhile (\c -> zero <= c && c <= seven) + + zero = 48 + seven = 55 + +untar :: Monad m => ConduitM ByteString TarChunk m () +untar = + loop 0 + where + loop !offset = assert (offset `mod` 512 == 0) $ do + bs <- takeCE 512 .| foldC + case S.length bs of + 0 -> return () + 512 | S.all (== 0) bs -> do + let offset' = offset + 512 + bs' <- takeCE 512 .| foldC + case () of + () + | S.length bs' /= 512 -> do + leftover bs' + yield $ ChunkException $ ShortTrailer offset' + | S.all (== 0) bs' -> return () + | otherwise -> do + leftover bs' + yield $ ChunkException $ BadTrailer offset' + 512 -> + case parseHeader offset bs of + Left e -> do + leftover bs + yield $ ChunkException e + Right h -> do + yield $ ChunkHeader h + offset' <- payloads (offset + 512) $ headerPayloadSize h + let expectedOffset = offset + 512 + headerPayloadSize h + + (case (512 - (headerPayloadSize h `mod` 512)) of + 512 -> 0 + x -> x) + assert (offset' == expectedOffset) (loop offset') + _ -> do + leftover bs + yield $ ChunkException $ IncompleteHeader offset + + payloads !offset 0 = do + let padding = + case offset `mod` 512 of + 0 -> 0 + x -> 512 - x + takeCE padding .| sinkNull + return $! offset + padding + payloads !offset !size = do + mbs <- await + case mbs of + Nothing -> do + yield $ ChunkException $ IncompletePayload offset size + return offset + Just bs -> do + let (x, y) = S.splitAt size bs + yield $ ChunkPayload offset x + let size' = size - S.length x + offset' = offset + S.length x + unless (S.null y) (leftover y) + payloads offset' size' + +-- | Process a single tar entry. See 'withEntries' for more details. +withEntry :: MonadThrow m + => (Header -> ConduitM ByteString o m r) + -> ConduitM TarChunk o m r +withEntry inner = do + mc <- await + case mc of + Nothing -> throwM NoMoreHeaders + Just (ChunkHeader h) -> payloads .| (inner h <* sinkNull) + Just x@(ChunkPayload offset _bs) -> do + leftover x + throwM $ UnexpectedPayload offset + Just (ChunkException e) -> throwM e + where + payloads = do + mx <- await + case mx of + Just (ChunkPayload _ bs) -> yield bs >> payloads + Just x@ChunkHeader{} -> leftover x + Just (ChunkException e) -> throwM e + Nothing -> return () + +{-| This function handles each entry of the tar archive according to the +behaviour of the function passed as first argument. + +Here is a full example function, that reads a compressed tar archive and for each entry that is a simple file, it prints its file path and SHA256 digest. Note that this function can throw exceptions! + +> import qualified Crypto.Hash.Conduit as CH +> import qualified Data.Conduit.Tar as CT +> +> import Conduit +> import Crypto.Hash (Digest, SHA256) +> import Control.Monad (when) +> import Data.Conduit.Zlib (ungzip) +> import Data.ByteString (ByteString) +> +> filedigests :: FilePath -> IO () +> filedigests fp = runConduitRes ( sourceFileBS fp -- read the raw file +> .| ungzip -- gunzip +> .| CT.untar -- decode the tar archive +> .| CT.withEntries hashentry -- process each file +> .| printC -- print the results +> ) +> where +> hashentry :: Monad m => CT.Header -> Conduit ByteString m (FilePath, Digest SHA256) +> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do +> hash <- CH.sinkHash +> yield (CT.headerFilePath hdr, hash) + +The @hashentry@ function handles a single entry, based on its first 'Header' argument. +In this example, a 'Consumer' is used to process the whole entry. + +Note that the benefits of stream processing are easily lost when working with a 'Consumer'. For example, the following implementation would have used an unbounded amount of memory: + +> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do +> content <- mconcat <$> sinkList +> yield (CT.headerFilePath hdr, hash content) +-} +withEntries :: MonadThrow m + => (Header -> ConduitM ByteString o m ()) + -> ConduitM TarChunk o m () +withEntries = peekForever . withEntry diff --git a/tar-conduit.cabal b/tar-conduit.cabal new file mode 100644 --- /dev/null +++ b/tar-conduit.cabal @@ -0,0 +1,37 @@ +name: tar-conduit +version: 0.1.0 +synopsis: Parse tar files using conduit for streaming +description: Please see README.md +homepage: https://github.com/snoyberg/tar-conduit#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com, bartavelle@gmail.com +category: Data Conduit +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Conduit.Tar + build-depends: base >= 4.7 && < 5 + , bytestring + , conduit-combinators >= 1.0.8.1 + default-language: Haskell2010 + +-- test-suite tar-conduit-test +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Spec.hs +-- build-depends: base +-- , hspec +-- , tar-conduit +-- , conduit-extra +-- , conduit-combinators +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N +-- default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/snoyberg/tar-conduit