{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-| 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
      tar
    , tarEntries
    , untar
    , untarRaw
    , untarWithFinalizers
    , untarWithExceptions
    , restoreFile
    , restoreFileInto
    , restoreFileIntoLenient
    , restoreFileWithErrors
    -- ** Operate on Chunks
    , untarChunks
    , untarChunksRaw
    , applyPaxChunkHeaders
    , withEntry
    , withEntries
    , withFileInfo
      -- * Helper functions
    , headerFileType
    , headerFilePath
      -- ** Creation
    , tarFilePath
    , filePathConduit
      -- * Directly on files
    , createTarball
    , writeTarball
    , extractTarball
    , extractTarballLenient
      -- * Types
    , module Data.Conduit.Tar.Types
    ) where

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
import           Data.ByteString.Builder
import qualified Data.ByteString.Char8    as S8
import qualified Data.ByteString.Lazy     as SL
import           Data.ByteString.Short    (ShortByteString, fromShort, toShort)
import qualified Data.ByteString.Short    as SS
import qualified Data.ByteString.Unsafe   as BU
import           Data.Foldable            (foldr')
import qualified Data.Map                 as Map
#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid              ((<>))
#endif
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid              (mempty)
#endif
import           Data.Word                (Word8)
import           Foreign.C.Types          (CTime (..))
import           Foreign.Storable
import           System.Directory         (createDirectoryIfMissing,
                                           getCurrentDirectory)
import           System.FilePath
import           System.IO

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative      ((<*))
#endif

import           Data.Conduit.Tar.Types
#ifdef WINDOWS
import           Data.Conduit.Tar.Windows
#else
import           Data.Conduit.Tar.Unix
#endif


headerFilePathBS :: Header -> S.ByteString
headerFilePathBS :: Header -> ByteString
headerFilePathBS Header {Word8
EpochTime
DeviceID
GroupID
CMode
FileOffset
UserID
ShortByteString
headerOffset :: FileOffset
headerPayloadOffset :: FileOffset
headerFileNameSuffix :: ShortByteString
headerFileMode :: CMode
headerOwnerId :: UserID
headerGroupId :: GroupID
headerPayloadSize :: FileOffset
headerTime :: EpochTime
headerLinkIndicator :: Word8
headerLinkName :: ShortByteString
headerMagicVersion :: ShortByteString
headerOwnerName :: ShortByteString
headerGroupName :: ShortByteString
headerDeviceMajor :: DeviceID
headerDeviceMinor :: DeviceID
headerFileNamePrefix :: ShortByteString
headerFileNamePrefix :: Header -> ShortByteString
headerDeviceMinor :: Header -> DeviceID
headerDeviceMajor :: Header -> DeviceID
headerGroupName :: Header -> ShortByteString
headerOwnerName :: Header -> ShortByteString
headerMagicVersion :: Header -> ShortByteString
headerLinkName :: Header -> ShortByteString
headerLinkIndicator :: Header -> Word8
headerTime :: Header -> EpochTime
headerPayloadSize :: Header -> FileOffset
headerGroupId :: Header -> GroupID
headerOwnerId :: Header -> UserID
headerFileMode :: Header -> CMode
headerFileNameSuffix :: Header -> ShortByteString
headerPayloadOffset :: Header -> FileOffset
headerOffset :: Header -> FileOffset
..} =
    if ShortByteString -> Bool
SS.null ShortByteString
headerFileNamePrefix
        then ShortByteString -> ByteString
fromShort ShortByteString
headerFileNameSuffix
        else [ByteString] -> ByteString
S.concat
                 [ShortByteString -> ByteString
fromShort ShortByteString
headerFileNamePrefix, ByteString
pathSeparatorS, ShortByteString -> ByteString
fromShort ShortByteString
headerFileNameSuffix]

-- | Construct a `FilePath` from `headerFileNamePrefix` and `headerFileNameSuffix`.
--
-- @since 0.1.0
headerFilePath :: Header -> FilePath
headerFilePath :: Header -> FilePath
headerFilePath = ByteString -> FilePath
decodeFilePath (ByteString -> FilePath)
-> (Header -> ByteString) -> Header -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> ByteString
headerFilePathBS

-- | Get Header file type.
--
-- @since 0.1.0
headerFileType :: Header -> FileType
headerFileType :: Header -> FileType
headerFileType Header
h =
    case Header -> Word8
headerLinkIndicator Header
h of
        Word8
0  -> FileType
FTNormal
        Word8
48 -> FileType
FTNormal
        Word8
49 -> ByteString -> FileType
FTHardLink (ShortByteString -> ByteString
fromShort (Header -> ShortByteString
headerLinkName Header
h))
        Word8
50 -> ByteString -> FileType
FTSymbolicLink (ShortByteString -> ByteString
fromShort (Header -> ShortByteString
headerLinkName Header
h))
        Word8
51 -> FileType
FTCharacterSpecial
        Word8
52 -> FileType
FTBlockSpecial
        Word8
53 -> FileType
FTDirectory
        Word8
54 -> FileType
FTFifo
        Word8
x  -> Word8 -> FileType
FTOther Word8
x

parseHeader :: FileOffset -> ByteString -> Either TarException Header
parseHeader :: FileOffset -> ByteString -> Either TarException Header
parseHeader FileOffset
offset ByteString
bs = do
    Bool -> Either TarException () -> Either TarException ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
512) (Either TarException () -> Either TarException ())
-> Either TarException () -> Either TarException ()
forall a b. (a -> b) -> a -> b
$ TarException -> Either TarException ()
forall a b. a -> Either a b
Left (TarException -> Either TarException ())
-> TarException -> Either TarException ()
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
IncompleteHeader FileOffset
offset
    let checksumBytes :: ByteString
checksumBytes = Int -> ByteString -> ByteString
BU.unsafeTake Int
8 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeDrop Int
148 ByteString
bs
        expectedChecksum :: Int
expectedChecksum = ByteString -> Int
forall i. Integral i => ByteString -> i
parseOctal ByteString
checksumBytes
        actualChecksum :: Int
actualChecksum = ByteString -> Int
bsum ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
bsum ByteString
checksumBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall i. Integral i => i
space
        magicVersion :: ShortByteString
magicVersion = ByteString -> ShortByteString
toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeTake Int
8 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeDrop Int
257 ByteString
bs
        getNumber :: (Storable a, Bits a, Integral a) => Int -> Int -> a
        getNumber :: forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber = if ShortByteString
magicVersion ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString
gnuTarMagicVersion then Int -> Int -> a
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getHexOctal else Int -> Int -> a
forall a. Integral a => Int -> Int -> a
getOctal

    Bool -> Either TarException () -> Either TarException ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
actualChecksum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedChecksum) (TarException -> Either TarException ()
forall a b. a -> Either a b
Left (FileOffset -> TarException
BadChecksum FileOffset
offset))
    Header -> Either TarException Header
forall a. a -> Either TarException a
forall (m :: * -> *) a. Monad m => a -> m a
return Header
        { headerOffset :: FileOffset
headerOffset         = FileOffset
offset
        , headerPayloadOffset :: FileOffset
headerPayloadOffset  = FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
512
        , headerFileNameSuffix :: ShortByteString
headerFileNameSuffix = Int -> Int -> ShortByteString
getShort Int
0 Int
100
        , headerFileMode :: CMode
headerFileMode       = Int -> Int -> CMode
forall a. Integral a => Int -> Int -> a
getOctal Int
100 Int
8
        , headerOwnerId :: UserID
headerOwnerId        = Int -> Int -> UserID
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
108 Int
8
        , headerGroupId :: GroupID
headerGroupId        = Int -> Int -> GroupID
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
116 Int
8
        , headerPayloadSize :: FileOffset
headerPayloadSize    = Int -> Int -> FileOffset
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
124 Int
12
        , headerTime :: EpochTime
headerTime           = Int64 -> EpochTime
CTime (Int64 -> EpochTime) -> Int64 -> EpochTime
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int64
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
136 Int
12
        , headerLinkIndicator :: Word8
headerLinkIndicator  = ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
156
        , headerLinkName :: ShortByteString
headerLinkName       = Int -> Int -> ShortByteString
getShort Int
157 Int
100
        , headerMagicVersion :: ShortByteString
headerMagicVersion   = ShortByteString
magicVersion
        , headerOwnerName :: ShortByteString
headerOwnerName      = Int -> Int -> ShortByteString
getShort Int
265 Int
32
        , headerGroupName :: ShortByteString
headerGroupName      = Int -> Int -> ShortByteString
getShort Int
297 Int
32
        , headerDeviceMajor :: DeviceID
headerDeviceMajor    = Int -> Int -> DeviceID
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
329 Int
8
        , headerDeviceMinor :: DeviceID
headerDeviceMinor    = Int -> Int -> DeviceID
forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getNumber Int
337 Int
8
        , headerFileNamePrefix :: ShortByteString
headerFileNamePrefix = Int -> Int -> ShortByteString
getShort Int
345 Int
155
        }
  where
    bsum :: ByteString -> Int
    bsum :: ByteString -> Int
bsum = (Int -> Word8 -> Int) -> Int -> ByteString -> Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' (\Int
c Word8
n -> Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Int
0

    getShort :: Int -> Int -> ShortByteString
getShort Int
off Int
len = ByteString -> ShortByteString
toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeTake Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeDrop Int
off ByteString
bs

    getOctal :: Integral a => Int -> Int -> a
    getOctal :: forall a. Integral a => Int -> Int -> a
getOctal Int
off Int
len = ByteString -> a
forall i. Integral i => ByteString -> i
parseOctal (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeTake Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeDrop Int
off ByteString
bs

    -- | Depending on the first bit of the first byte in the range either choose direct
    -- hex representation, or classic octal string view.
    getHexOctal :: (Storable a, Bits a, Integral a) => Int -> Int -> a
    getHexOctal :: forall a. (Storable a, Bits a, Integral a) => Int -> Int -> a
getHexOctal Int
off Int
len = if ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
off Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x80 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80
                          then ByteString -> a
forall a. (Storable a, Bits a, Integral a) => ByteString -> a
fromHex (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeTake Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BU.unsafeDrop Int
off ByteString
bs
                          else Int -> Int -> a
forall a. Integral a => Int -> Int -> a
getOctal Int
off Int
len

    parseOctal :: Integral i => ByteString -> i
    parseOctal :: forall i. Integral i => ByteString -> i
parseOctal = i -> ByteString -> i
forall i. Integral i => i -> ByteString -> i
parseBase i
8
               (ByteString -> i) -> (ByteString -> ByteString) -> ByteString -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (\Word8
c -> Word8
zero Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
seven)
               (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
forall i. Integral i => i
space)

    seven :: Word8
seven = Word8
55

parseBase :: Integral i => i -> ByteString -> i
parseBase :: forall i. Integral i => i -> ByteString -> i
parseBase i
n = (i -> Word8 -> i) -> i -> ByteString -> i
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' (\i
t Word8
c -> i
t i -> i -> i
forall a. Num a => a -> a -> a
* i
n i -> i -> i
forall a. Num a => a -> a -> a
+ Word8 -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
zero)) i
0

space :: Integral i => i
space :: forall i. Integral i => i
space = i
0x20 -- UTF-8 ' '

zero :: Word8
zero :: Word8
zero = Word8
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 :: forall a. (Storable a, Bits a, Integral a) => ByteString -> a
fromHex ByteString
str = (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' (\ a
acc Word8
x -> (a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x) a
0 (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$
              Int -> ByteString -> ByteString
S.drop (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (ByteString -> Int
S.length ByteString
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))) ByteString
str

-- | 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 :: forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
untarChunks =
       ConduitM ByteString TarChunk m ()
forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
untarChunksRaw
    ConduitM ByteString TarChunk m ()
-> ConduitT TarChunk TarChunk m ()
-> ConduitM ByteString TarChunk m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| PaxState
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
-> ConduitT TarChunk TarChunk m ()
forall (m :: * -> *) s i o r.
Monad m =>
s -> ConduitT i o (StateT s m) r -> ConduitT i o m r
evalStateLC PaxState
initialPaxState ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall (m :: * -> *).
Monad m =>
ConduitM TarChunk TarChunk (StateT PaxState m) ()
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 :: forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
untarChunksRaw =
    FileOffset -> ConduitT ByteString TarChunk m ()
forall {m :: * -> *}.
Monad m =>
FileOffset -> ConduitT ByteString TarChunk m ()
loop FileOffset
0
  where
    loop :: FileOffset -> ConduitT ByteString TarChunk m ()
loop !FileOffset
offset = Bool
-> ConduitT ByteString TarChunk m ()
-> ConduitT ByteString TarChunk m ()
forall a. HasCallStack => Bool -> a -> a
assert (FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
512 FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
== FileOffset
0) (ConduitT ByteString TarChunk m ()
 -> ConduitT ByteString TarChunk m ())
-> ConduitT ByteString TarChunk m ()
-> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ do
        bs <- Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE Int
Index ByteString
512 ConduitT ByteString ByteString m ()
-> ConduitT ByteString TarChunk m ByteString
-> ConduitT ByteString TarChunk m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString TarChunk m ByteString
forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
        case S.length bs of
            Int
0 -> () -> ConduitT ByteString TarChunk m ()
forall a. a -> ConduitT ByteString TarChunk m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Int
512 | (Word8 -> Bool) -> ByteString -> Bool
S.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bs -> do
                let offset' :: FileOffset
offset' = FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
512
                bs' <- Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE Int
Index ByteString
512 ConduitT ByteString ByteString m ()
-> ConduitT ByteString TarChunk m ByteString
-> ConduitT ByteString TarChunk m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString TarChunk m ByteString
forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
                case () of
                    ()
                        | ByteString -> Int
S.length ByteString
bs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
512 -> do
                            ByteString -> ConduitT ByteString TarChunk m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs'
                            TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ TarException -> TarChunk
ChunkException (TarException -> TarChunk) -> TarException -> TarChunk
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
ShortTrailer FileOffset
offset'
                        | (Word8 -> Bool) -> ByteString -> Bool
S.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bs' -> () -> ConduitT ByteString TarChunk m ()
forall a. a -> ConduitT ByteString TarChunk m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        | Bool
otherwise -> do
                            ByteString -> ConduitT ByteString TarChunk m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs'
                            TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ TarException -> TarChunk
ChunkException (TarException -> TarChunk) -> TarException -> TarChunk
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
BadTrailer FileOffset
offset'
            Int
512 ->
                case FileOffset -> ByteString -> Either TarException Header
parseHeader FileOffset
offset ByteString
bs of
                    Left TarException
e -> do
                        ByteString -> ConduitT ByteString TarChunk m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs
                        TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ TarException -> TarChunk
ChunkException TarException
e
                    Right Header
h -> do
                        TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ Header -> TarChunk
ChunkHeader Header
h
                        offset' <- FileOffset
-> FileOffset -> ConduitT ByteString TarChunk m FileOffset
forall {m :: * -> *} {t}.
(Monad m, Integral t) =>
FileOffset -> t -> ConduitT ByteString TarChunk m FileOffset
payloads (FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
512) (FileOffset -> ConduitT ByteString TarChunk m FileOffset)
-> FileOffset -> ConduitT ByteString TarChunk m FileOffset
forall a b. (a -> b) -> a -> b
$ Header -> FileOffset
headerPayloadSize Header
h
                        let expectedOffset = FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
512 FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ Header -> FileOffset
headerPayloadSize Header
h FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+
                                (case FileOffset
512 FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
- (Header -> FileOffset
headerPayloadSize Header
h FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
512) of
                                    FileOffset
512 -> FileOffset
0
                                    FileOffset
x   -> FileOffset
x)
                        assert (offset' == expectedOffset) (loop offset')
            Int
_ -> do
                ByteString -> ConduitT ByteString TarChunk m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs
                TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ TarException -> TarChunk
ChunkException (TarException -> TarChunk) -> TarException -> TarChunk
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
IncompleteHeader FileOffset
offset

    payloads :: FileOffset -> t -> ConduitT ByteString TarChunk m FileOffset
payloads !FileOffset
offset t
0 = do
        let padding :: Int
padding =
                case FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
512 of
                    FileOffset
0 -> Int
0
                    FileOffset
x -> Int
512 Int -> Int -> Int
forall a. Num a => a -> a -> a
- FileOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
x
        Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE Int
Index ByteString
padding ConduitT ByteString ByteString m ()
-> ConduitT ByteString TarChunk m ()
-> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString TarChunk m ()
forall (m :: * -> *) a o. Monad m => ConduitT a o m ()
sinkNull
        FileOffset -> ConduitT ByteString TarChunk m FileOffset
forall a. a -> ConduitT ByteString TarChunk m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset -> ConduitT ByteString TarChunk m FileOffset)
-> FileOffset -> ConduitT ByteString TarChunk m FileOffset
forall a b. (a -> b) -> a -> b
$! FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
padding
    payloads !FileOffset
offset !t
size = do
        mbs <- ConduitT ByteString TarChunk m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case mbs of
            Maybe ByteString
Nothing -> do
                TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ TarException -> TarChunk
ChunkException (TarException -> TarChunk) -> TarException -> TarChunk
forall a b. (a -> b) -> a -> b
$ FileOffset -> ByteCount -> TarException
IncompletePayload FileOffset
offset (ByteCount -> TarException) -> ByteCount -> TarException
forall a b. (a -> b) -> a -> b
$ t -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
size
                FileOffset -> ConduitT ByteString TarChunk m FileOffset
forall a. a -> ConduitT ByteString TarChunk m a
forall (m :: * -> *) a. Monad m => a -> m a
return FileOffset
offset
            Just ByteString
bs -> do
                let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt (t -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t -> t -> t
forall a. Ord a => a -> a -> a
min t
size (Int -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)))) ByteString
bs
                TarChunk -> ConduitT ByteString TarChunk m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT ByteString TarChunk m ())
-> TarChunk -> ConduitT ByteString TarChunk m ()
forall a b. (a -> b) -> a -> b
$ FileOffset -> ByteString -> TarChunk
ChunkPayload FileOffset
offset ByteString
x
                let size' :: t
size' = t
size t -> t -> t
forall a. Num a => a -> a -> a
- Int -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
x)
                    offset' :: FileOffset
offset' = FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
x)
                Bool
-> ConduitT ByteString TarChunk m ()
-> ConduitT ByteString TarChunk m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
y) (ByteString -> ConduitT ByteString TarChunk m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
y)
                FileOffset -> t -> ConduitT ByteString TarChunk m FileOffset
payloads FileOffset
offset' t
size'


-- | Process a single tar entry. See 'withEntries' for more details.
--
-- @since 0.1.0
--
withEntry :: MonadThrow m
          => (Header -> ConduitM ByteString o m r)
          -> ConduitM TarChunk o m r
withEntry :: forall (m :: * -> *) o r.
MonadThrow m =>
(Header -> ConduitM ByteString o m r) -> ConduitM TarChunk o m r
withEntry Header -> ConduitM ByteString o m r
inner = do
    mc <- ConduitT TarChunk o m (Maybe TarChunk)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case mc of
        Maybe TarChunk
Nothing -> TarException -> ConduitT TarChunk o m r
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
NoMoreHeaders
        Just (ChunkHeader Header
h) -> ConduitM TarChunk ByteString m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit ConduitM TarChunk ByteString m ()
-> ConduitM ByteString o m r -> ConduitT TarChunk o m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Header -> ConduitM ByteString o m r
inner Header
h ConduitM ByteString o m r
-> ConduitT ByteString o m () -> ConduitM ByteString o m r
forall a b.
ConduitT ByteString o m a
-> ConduitT ByteString o m b -> ConduitT ByteString o m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ConduitT ByteString o m ()
forall (m :: * -> *) a o. Monad m => ConduitT a o m ()
sinkNull)
        Just x :: TarChunk
x@(ChunkPayload FileOffset
offset ByteString
_bs) -> do
            TarChunk -> ConduitT TarChunk o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover TarChunk
x
            TarException -> ConduitT TarChunk o m r
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarException -> ConduitT TarChunk o m r)
-> TarException -> ConduitT TarChunk o m r
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
UnexpectedPayload FileOffset
offset
        Just (ChunkException TarException
e) -> TarException -> ConduitT TarChunk o m r
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
e


payloadsConduit :: MonadThrow m
               => ConduitM TarChunk ByteString m ()
payloadsConduit :: forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit = do
    mx <- ConduitT TarChunk ByteString m (Maybe TarChunk)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case mx of
        Just (ChunkPayload FileOffset
_ ByteString
bs) -> ByteString -> ConduitT TarChunk ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs ConduitT TarChunk ByteString m ()
-> ConduitT TarChunk ByteString m ()
-> ConduitT TarChunk ByteString m ()
forall a b.
ConduitT TarChunk ByteString m a
-> ConduitT TarChunk ByteString m b
-> ConduitT TarChunk ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT TarChunk ByteString m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit
        Just x :: TarChunk
x@ChunkHeader {}    -> TarChunk -> ConduitT TarChunk ByteString m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover TarChunk
x
        Just (ChunkException TarException
e)  -> TarException -> ConduitT TarChunk ByteString m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
e
        Maybe TarChunk
Nothing                  -> () -> ConduitT TarChunk ByteString m ()
forall a. a -> ConduitT TarChunk ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
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.untarChunks           -- 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)

@since 0.1.0
-}
withEntries :: MonadThrow m
            => (Header -> ConduitM ByteString o m ())
            -> ConduitM TarChunk o m ()
withEntries :: forall (m :: * -> *) o.
MonadThrow m =>
(Header -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()
withEntries = ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall (m :: * -> *) i o.
Monad m =>
ConduitT i o m () -> ConduitT i o m ()
peekForever (ConduitT TarChunk o m () -> ConduitT TarChunk o m ())
-> ((Header -> ConduitM ByteString o m ())
    -> ConduitT TarChunk o m ())
-> (Header -> ConduitM ByteString o m ())
-> ConduitT TarChunk o m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> ConduitM ByteString o m ()) -> ConduitT TarChunk o m ()
forall (m :: * -> *) o r.
MonadThrow m =>
(Header -> ConduitM ByteString o m r) -> ConduitM TarChunk o m r
withEntry


-- | Extract a tarball, similarly to `withEntries`, but instead of dealing directly with tar format,
-- this conduit allows you to work directly on file abstractions `FileInfo`. For now support is
-- minimal:
--
-- * Old v7 tar format.
-- * ustar: POSIX 1003.1-1988 format
-- * and only some portions of GNU format:
--   * Larger values for `fileUserId`, `fileGroupId`, `fileSize` and `fileModTime`.
--   * 'L' type - long file names, but only up to 4096 chars to prevent DoS attack
--   * other types are simply discarded
--
-- /Note/ - Here is a really good reference for specifics of different tar formats:
-- <https://github.com/libarchive/libarchive/wiki/ManPageTar5>
--
-- @since 0.2.2
withFileInfo :: MonadThrow m
             => (FileInfo -> ConduitM ByteString o m ())
             -> ConduitM TarChunk o m ()
withFileInfo :: forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM TarChunk o m ()
withFileInfo FileInfo -> ConduitM ByteString o m ()
inner = ConduitT TarChunk o m ()
start
  where
    start :: ConduitT TarChunk o m ()
start = ConduitT TarChunk o m (Maybe TarChunk)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT TarChunk o m (Maybe TarChunk)
-> (Maybe TarChunk -> ConduitT TarChunk o m ())
-> ConduitT TarChunk o m ()
forall a b.
ConduitT TarChunk o m a
-> (a -> ConduitT TarChunk o m b) -> ConduitT TarChunk o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT TarChunk o m ()
-> (TarChunk -> ConduitT TarChunk o m ())
-> Maybe TarChunk
-> ConduitT TarChunk o m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT TarChunk o m ()
forall a. a -> ConduitT TarChunk o m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) TarChunk -> ConduitT TarChunk o m ()
go
    go :: TarChunk -> ConduitT TarChunk o m ()
go TarChunk
x =
        case TarChunk
x of
            ChunkHeader Header
h
                | Header -> Word8
headerLinkIndicator Header
h Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
55 ->
                    if Header -> ShortByteString
headerMagicVersion Header
h ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString
gnuTarMagicVersion
                        then Header -> ConduitT TarChunk o m (Maybe TarChunk)
forall (m :: * -> *) o.
MonadThrow m =>
Header -> ConduitM TarChunk o m (Maybe TarChunk)
handleGnuTarHeader Header
h ConduitT TarChunk o m (Maybe TarChunk)
-> (Maybe TarChunk -> ConduitT TarChunk o m ())
-> ConduitT TarChunk o m ()
forall a b.
ConduitT TarChunk o m a
-> (a -> ConduitT TarChunk o m b) -> ConduitT TarChunk o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT TarChunk o m ()
-> (TarChunk -> ConduitT TarChunk o m ())
-> Maybe TarChunk
-> ConduitT TarChunk o m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConduitT TarChunk o m ()
start TarChunk -> ConduitT TarChunk o m ()
go
                        else (TarChunk -> Bool) -> ConduitT TarChunk o m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> Bool) -> ConduitT a o m ()
dropWhileC
                                 (\case
                                      ChunkPayload FileOffset
_ ByteString
_ -> Bool
True
                                      TarChunk
_                -> Bool
False) ConduitT TarChunk o m ()
-> ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall a b.
ConduitT TarChunk o m a
-> ConduitT TarChunk o m b -> ConduitT TarChunk o m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT TarChunk o m ()
start
            ChunkHeader Header
h -> do
                ConduitM TarChunk ByteString m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit ConduitM TarChunk ByteString m ()
-> ConduitM ByteString o m () -> ConduitT TarChunk o m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (FileInfo -> ConduitM ByteString o m ()
inner (Header -> FileInfo
fileInfoFromHeader Header
h) ConduitM ByteString o m ()
-> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall a b.
ConduitT ByteString o m a
-> ConduitT ByteString o m b -> ConduitT ByteString o m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ConduitM ByteString o m ()
forall (m :: * -> *) a o. Monad m => ConduitT a o m ()
sinkNull)
                ConduitT TarChunk o m ()
start
            ChunkPayload FileOffset
offset ByteString
_bs -> do
                TarChunk -> ConduitT TarChunk o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover TarChunk
x
                TarException -> ConduitT TarChunk o m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarException -> ConduitT TarChunk o m ())
-> TarException -> ConduitT TarChunk o m ()
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
UnexpectedPayload FileOffset
offset
            ChunkException TarException
e -> TarException -> ConduitT TarChunk o m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
e


-- | Take care of custom GNU tar format.
handleGnuTarHeader :: MonadThrow m
                   => Header
                   -> ConduitM TarChunk o m (Maybe TarChunk)
handleGnuTarHeader :: forall (m :: * -> *) o.
MonadThrow m =>
Header -> ConduitM TarChunk o m (Maybe TarChunk)
handleGnuTarHeader Header
h =
    case Header -> Word8
headerLinkIndicator Header
h of
        Word8
76 -> do
            let pSize :: FileOffset
pSize = Header -> FileOffset
headerPayloadSize Header
h
            -- guard against names that are too long in order to prevent a DoS attack on unbounded
            -- file names
            Bool -> ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileOffset
0 FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
< FileOffset
pSize Bool -> Bool -> Bool
&& FileOffset
pSize FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
<= FileOffset
4096) (ConduitT TarChunk o m () -> ConduitT TarChunk o m ())
-> ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall a b. (a -> b) -> a -> b
$
                TarException -> ConduitT TarChunk o m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarException -> ConduitT TarChunk o m ())
-> TarException -> ConduitT TarChunk o m ()
forall a b. (a -> b) -> a -> b
$
                FileOffset -> Char -> FilePath -> TarException
FileTypeError (Header -> FileOffset
headerPayloadOffset Header
h) Char
'L' (FilePath -> TarException) -> FilePath -> TarException
forall a b. (a -> b) -> a -> b
$ FilePath
"Filepath is too long: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FileOffset -> FilePath
forall a. Show a => a -> FilePath
show FileOffset
pSize
            longFileNameBuilder <- ConduitM TarChunk ByteString m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit ConduitM TarChunk ByteString m ()
-> ConduitT ByteString o m Builder -> ConduitT TarChunk o m Builder
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> Builder) -> ConduitT ByteString o m Builder
forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
foldMapC ByteString -> Builder
byteString
            let longFileName = LazyByteString -> ByteString
SL.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => LazyByteString -> LazyByteString
LazyByteString -> LazyByteString
SL.init (LazyByteString -> LazyByteString)
-> (Builder -> LazyByteString) -> Builder -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
longFileNameBuilder
            mcNext <- await
            case mcNext of
                Just (ChunkHeader Header
nh) -> do
                    Bool -> ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> ByteString -> Bool
S.isPrefixOf (ShortByteString -> ByteString
fromShort (Header -> ShortByteString
headerFileNameSuffix Header
nh)) ByteString
longFileName) (ConduitT TarChunk o m () -> ConduitT TarChunk o m ())
-> ConduitT TarChunk o m () -> ConduitT TarChunk o m ()
forall a b. (a -> b) -> a -> b
$
                        TarException -> ConduitT TarChunk o m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarException -> ConduitT TarChunk o m ())
-> TarException -> ConduitT TarChunk o m ()
forall a b. (a -> b) -> a -> b
$
                        FileOffset -> Char -> FilePath -> TarException
FileTypeError (Header -> FileOffset
headerPayloadOffset Header
nh) Char
'L'
                        FilePath
"Long filename doesn't match the original."
                    Maybe TarChunk -> ConduitM TarChunk o m (Maybe TarChunk)
forall a. a -> ConduitT TarChunk o m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                        (TarChunk -> Maybe TarChunk
forall a. a -> Maybe a
Just (TarChunk -> Maybe TarChunk) -> TarChunk -> Maybe TarChunk
forall a b. (a -> b) -> a -> b
$ Header -> TarChunk
ChunkHeader (Header -> TarChunk) -> Header -> TarChunk
forall a b. (a -> b) -> a -> b
$
                         Header
nh
                         { headerFileNameSuffix = toShort longFileName
                         , headerFileNamePrefix = SS.empty
                         })
                Just c :: TarChunk
c@(ChunkPayload FileOffset
offset ByteString
_) -> do
                    TarChunk -> ConduitT TarChunk o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover TarChunk
c
                    TarException -> ConduitM TarChunk o m (Maybe TarChunk)
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarException -> ConduitM TarChunk o m (Maybe TarChunk))
-> TarException -> ConduitM TarChunk o m (Maybe TarChunk)
forall a b. (a -> b) -> a -> b
$ FileOffset -> TarException
InvalidHeader FileOffset
offset
                Just (ChunkException TarException
exc) -> TarException -> ConduitM TarChunk o m (Maybe TarChunk)
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
exc
                Maybe TarChunk
Nothing -> TarException -> ConduitM TarChunk o m (Maybe TarChunk)
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT TarChunk o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarException
NoMoreHeaders
        Word8
83 -> do
            ConduitM TarChunk ByteString m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM TarChunk ByteString m ()
payloadsConduit ConduitM TarChunk ByteString m ()
-> ConduitT ByteString o m () -> ConduitT TarChunk o m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString o m ()
forall (m :: * -> *) a o. Monad m => ConduitT a o m ()
sinkNull -- discard sparse files payload
            -- TODO : Implement restoring of sparse files
            Maybe TarChunk -> ConduitM TarChunk o m (Maybe TarChunk)
forall a. a -> ConduitT TarChunk o m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TarChunk
forall a. Maybe a
Nothing
        Word8
_ -> Maybe TarChunk -> ConduitM TarChunk o m (Maybe TarChunk)
forall a. a -> ConduitT TarChunk o m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TarChunk
forall a. Maybe a
Nothing

-- | 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
      => (FileInfo -> ConduitM ByteString o m ())
      -> ConduitM ByteString o m ()
untar :: forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar FileInfo -> ConduitM ByteString o m ()
inner = ConduitM ByteString TarChunk m ()
forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
untarChunks ConduitM ByteString TarChunk m ()
-> ConduitT TarChunk o m () -> ConduitM ByteString o m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (FileInfo -> ConduitM ByteString o m ())
-> ConduitT TarChunk o m ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM TarChunk o m ()
withFileInfo FileInfo -> ConduitM ByteString o m ()
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 :: forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untarRaw FileInfo -> ConduitM ByteString o m ()
inner = ConduitM ByteString TarChunk m ()
forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
untarChunksRaw ConduitM ByteString TarChunk m ()
-> ConduitT TarChunk o m () -> ConduitM ByteString o m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (FileInfo -> ConduitM ByteString o m ())
-> ConduitT TarChunk o m ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM TarChunk o m ()
withFileInfo FileInfo -> ConduitM ByteString o m ()
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 :: forall (m :: * -> *).
Monad m =>
ConduitM TarChunk TarChunk (StateT PaxState m) ()
applyPaxChunkHeaders = (TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
 -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
-> (TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall a b. (a -> b) -> a -> b
$ \TarChunk
i -> do
    state@(PaxState g x) <- StateT PaxState m PaxState
-> ConduitT TarChunk TarChunk (StateT PaxState m) PaxState
forall (m :: * -> *) a.
Monad m =>
m a -> ConduitT TarChunk TarChunk m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT PaxState m PaxState
forall s (m :: * -> *). MonadState s m => m s
get
    let updateState PaxHeader -> PaxState -> PaxState
f = do
            p <- ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader
forall (m :: * -> *).
Monad m =>
ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader
parsePax
            lift $ put $ f p state
    case i of
        ChunkHeader Header
h -> case Header -> Word8
headerLinkIndicator Header
h of
            -- 'g' typeflag unique to pax header block
            Word8
0x67 -> (PaxHeader -> PaxState -> PaxState)
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall {m :: * -> *}.
Monad m =>
(PaxHeader -> PaxState -> PaxState)
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
updateState PaxHeader -> PaxState -> PaxState
updateGlobal
            -- 'x' typeflag unique to pax header block
            Word8
0x78 -> (PaxHeader -> PaxState -> PaxState)
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall {m :: * -> *}.
Monad m =>
(PaxHeader -> PaxState -> PaxState)
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
updateState PaxHeader -> PaxState -> PaxState
updateNext
            -- All other typeflag
            Word8
_ -> do
                TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
-> TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall a b. (a -> b) -> a -> b
$ Header -> TarChunk
ChunkHeader (Header -> TarChunk) -> Header -> TarChunk
forall a b. (a -> b) -> a -> b
$ PaxHeader -> Header -> Header
applyPax (PaxHeader -> PaxHeader -> PaxHeader
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union PaxHeader
x PaxHeader
g) Header
h
                StateT PaxState m ()
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ConduitT TarChunk TarChunk m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT PaxState m ()
 -> ConduitT TarChunk TarChunk (StateT PaxState m) ())
-> StateT PaxState m ()
-> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall a b. (a -> b) -> a -> b
$ PaxState -> StateT PaxState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PaxState -> StateT PaxState m ())
-> PaxState -> StateT PaxState m ()
forall a b. (a -> b) -> a -> b
$ PaxState -> PaxState
clearNext PaxState
state
        TarChunk
_ -> TarChunk -> ConduitT TarChunk TarChunk (StateT PaxState m) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield TarChunk
i
 where
    updateGlobal :: PaxHeader -> PaxState -> PaxState
updateGlobal PaxHeader
p (PaxState PaxHeader
g PaxHeader
x) = PaxHeader -> PaxHeader -> PaxState
PaxState (PaxHeader -> PaxHeader -> PaxHeader
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union PaxHeader
p PaxHeader
g) PaxHeader
x
    updateNext :: PaxHeader -> PaxState -> PaxState
updateNext PaxHeader
p (PaxState PaxHeader
g PaxHeader
_) = PaxHeader -> PaxHeader -> PaxState
PaxState PaxHeader
g PaxHeader
p
    clearNext :: PaxState -> PaxState
clearNext = PaxHeader -> PaxState -> PaxState
updateNext PaxHeader
forall a. Monoid a => a
mempty

-- | Only the \'comment\', \'gid\', \'gname\', \'linkpath\',\'path\', \'size\',
-- \'uid\' and \'uname\' pax keywords are supported.
applyPax :: PaxHeader -> Header -> Header
applyPax :: PaxHeader -> Header -> Header
applyPax PaxHeader
p Header
h =
      Header -> Header
updateGid
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updateGname
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updateLinkpath
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updatePath
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updateSize
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updateUid
    (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ Header -> Header
updateUname Header
h
  where
    update ::
           ByteString
        -> (ByteString -> Header -> Header)
        -> (Header -> Header)
    update :: ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
k ByteString -> Header -> Header
f = (Header -> Header)
-> (ByteString -> Header -> Header)
-> Maybe ByteString
-> Header
-> Header
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Header -> Header
forall a. a -> a
id ByteString -> Header -> Header
f (ByteString -> PaxHeader -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
k PaxHeader
p)
    ifValueDecimal ::
           Integral i
        => (i -> Header -> Header)
        -> ByteString
        -> (Header -> Header)
    ifValueDecimal :: forall i.
Integral i =>
(i -> Header -> Header) -> ByteString -> Header -> Header
ifValueDecimal i -> Header -> Header
f ByteString
v = if (Word8 -> Bool) -> ByteString -> Bool
S.all Word8 -> Bool
isDecimal ByteString
v
        then i -> Header -> Header
f (ByteString -> i
forall i. Integral i => ByteString -> i
parseDecimal ByteString
v)
        else Header -> Header
forall a. a -> a
id
    -- There is no 'updateComment' because comments are ignored.
    updateGid :: Header -> Header
updateGid = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"gid" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ (GroupID -> Header -> Header) -> ByteString -> Header -> Header
forall i.
Integral i =>
(i -> Header -> Header) -> ByteString -> Header -> Header
ifValueDecimal ((GroupID -> Header -> Header) -> ByteString -> Header -> Header)
-> (GroupID -> Header -> Header) -> ByteString -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \GroupID
v Header
h' -> Header
h'
        { headerGroupId = v }
    updateGname :: Header -> Header
updateGname = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"gname" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \ByteString
v Header
h' -> Header
h' { headerGroupName = toShort v }
    updateLinkpath :: Header -> Header
updateLinkpath =
        ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"linkpath" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \ByteString
v Header
h' -> Header
h' { headerLinkName = toShort v }
    updatePath :: Header -> Header
updatePath = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"path" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \ByteString
v Header
h' -> Header
h'
        { headerFileNameSuffix = toShort v, headerFileNamePrefix = mempty }
    updateSize :: Header -> Header
updateSize = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"size" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ (FileOffset -> Header -> Header) -> ByteString -> Header -> Header
forall i.
Integral i =>
(i -> Header -> Header) -> ByteString -> Header -> Header
ifValueDecimal ((FileOffset -> Header -> Header)
 -> ByteString -> Header -> Header)
-> (FileOffset -> Header -> Header)
-> ByteString
-> Header
-> Header
forall a b. (a -> b) -> a -> b
$ \FileOffset
v Header
h' -> Header
h'
        { headerPayloadSize = v }
    updateUid :: Header -> Header
updateUid = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"uid" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ (UserID -> Header -> Header) -> ByteString -> Header -> Header
forall i.
Integral i =>
(i -> Header -> Header) -> ByteString -> Header -> Header
ifValueDecimal ((UserID -> Header -> Header) -> ByteString -> Header -> Header)
-> (UserID -> Header -> Header) -> ByteString -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \UserID
v Header
h' -> Header
h'
        { headerOwnerId = v }
    updateUname :: Header -> Header
updateUname = ByteString -> (ByteString -> Header -> Header) -> Header -> Header
update ByteString
"uname" ((ByteString -> Header -> Header) -> Header -> Header)
-> (ByteString -> Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ \ByteString
v Header
h' -> Header
h' { headerOwnerName = toShort v }

parsePax :: Monad m => ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader
parsePax :: forall (m :: * -> *).
Monad m =>
ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader
parsePax = ByteString -> PaxHeader
paxParser (ByteString -> PaxHeader)
-> ConduitT TarChunk TarChunk (StateT PaxState m) ByteString
-> ConduitT TarChunk TarChunk (StateT PaxState m) PaxHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> ConduitT TarChunk TarChunk (StateT PaxState m) ByteString
forall {m :: * -> *} {o}.
Monad m =>
ByteString -> ConduitT TarChunk o m ByteString
combineChunkPayloads ByteString
forall a. Monoid a => a
mempty
 where
  combineChunkPayloads :: ByteString -> ConduitT TarChunk o m ByteString
combineChunkPayloads ByteString
bs = ConduitT TarChunk o m (Maybe TarChunk)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT TarChunk o m (Maybe TarChunk)
-> (Maybe TarChunk -> ConduitT TarChunk o m ByteString)
-> ConduitT TarChunk o m ByteString
forall a b.
ConduitT TarChunk o m a
-> (a -> ConduitT TarChunk o m b) -> ConduitT TarChunk o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe TarChunk
Nothing -> ByteString -> ConduitT TarChunk o m ByteString
forall a. a -> ConduitT TarChunk o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
    Just (ChunkPayload FileOffset
_ ByteString
b) ->
      -- This uses <> (Data.ByteString.Internal.Type.append) rather than, say,
      -- [ByteString] (created in reverse order) and
      -- Data.ByteString.Internal.Type.concat on the reverse of the list. The
      -- reason for doing so is an expectation that, in practice, the pax
      -- extended header data will be received as a single chunk in the very
      -- great majority of cases and, when it is not, in the great majority of
      -- remaining cases it will be received as two sequential chunks. This is
      -- optimised for that expectation, rather than the receipt of the data in
      -- a large number of small chunks.
      ByteString -> ConduitT TarChunk o m ByteString
combineChunkPayloads (ByteString -> ConduitT TarChunk o m ByteString)
-> ByteString -> ConduitT TarChunk o m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b
    Just TarChunk
other -> do
      TarChunk -> ConduitT TarChunk o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover TarChunk
other
      ByteString -> ConduitT TarChunk o m ByteString
forall a. a -> ConduitT TarChunk o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

-- | 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 :: ByteString -> PaxHeader
paxParser ByteString
b
    -- This is an error case.
    | ByteString -> Bool
S.null ByteString
b = PaxHeader
forall a. Monoid a => a
mempty
paxParser ByteString
b = [(ByteString, ByteString)] -> ByteString -> PaxHeader
paxParser' [] ByteString
b
  where
    paxParser' :: [(ByteString, ByteString)] -> ByteString -> PaxHeader
    paxParser' :: [(ByteString, ByteString)] -> ByteString -> PaxHeader
paxParser' [(ByteString, ByteString)]
l ByteString
b0
        | ByteString -> Bool
S.null ByteString
b0 = [(ByteString, ByteString)] -> PaxHeader
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ByteString, ByteString)]
l
    paxParser' [(ByteString, ByteString)]
l ByteString
b0 =
        PaxHeader
-> (((ByteString, ByteString), ByteString) -> PaxHeader)
-> Maybe ((ByteString, ByteString), ByteString)
-> PaxHeader
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PaxHeader
forall a. Monoid a => a
mempty (\((ByteString, ByteString)
pair, ByteString
b1) -> [(ByteString, ByteString)] -> ByteString -> PaxHeader
paxParser' ((ByteString, ByteString)
pair(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
l) ByteString
b1) (ByteString -> Maybe ((ByteString, ByteString), ByteString)
recordParser ByteString
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 :: ByteString -> Maybe ((ByteString, ByteString), ByteString)
recordParser ByteString
b0 = do
    let (ByteString
nb, ByteString
b1) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.span Word8 -> Bool
isDecimal ByteString
b0
    n <- Bool -> Int -> Maybe Int
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
nb) (ByteString -> Int
forall i. Integral i => ByteString -> i
parseDecimal ByteString
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 :: Word8
newline = Word8
0x0a -- UTF-8 '\n'
    equals :: Word8
equals = Word8
0x3d -- UTF-8 '='
    toMaybe :: Bool -> a -> Maybe a
    toMaybe :: forall a. Bool -> a -> Maybe a
toMaybe Bool
False a
_ = Maybe a
forall a. Maybe a
Nothing
    toMaybe Bool
True a
x = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    skip :: (Word8 -> Bool) -> ByteString -> Maybe ByteString
skip Word8 -> Bool
p ByteString
b = do
        (w, b') <- ByteString -> Maybe (Word8, ByteString)
S.uncons ByteString
b
        if p w then Just b' else Nothing
    isSpace :: Word8 -> Bool
isSpace = (Word8
forall i. Integral i => i
space Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==)
    isEquals :: Word8 -> Bool
isEquals = (Word8
equals Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==)
    isNewline :: Word8 -> Bool
isNewline = (Word8
newline Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==)

parseDecimal :: Integral i => ByteString -> i
parseDecimal :: forall i. Integral i => ByteString -> i
parseDecimal = i -> ByteString -> i
forall i. Integral i => i -> ByteString -> i
parseBase i
10

isDecimal :: Word8 -> Bool
isDecimal :: Word8 -> Bool
isDecimal Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
zero Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
nine
  where
    nine :: Word8
nine = Word8
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
-- order. Very useful with `restoreFile` and `restoreFileInto`, since they restore direcory
-- modification timestamps only after files have been fully written to disk.
--
-- @since 0.2.0
untarWithFinalizers ::
       (MonadThrow m, MonadIO m)
    => (FileInfo -> ConduitM ByteString (IO ()) m ())
    -> ConduitM ByteString c m ()
untarWithFinalizers :: forall (m :: * -> *) c.
(MonadThrow m, MonadIO m) =>
(FileInfo -> ConduitM ByteString (IO ()) m ())
-> ConduitM ByteString c m ()
untarWithFinalizers FileInfo -> ConduitM ByteString (IO ()) m ()
inner = do
    finilizers <- (FileInfo -> ConduitM ByteString (IO ()) m ())
-> ConduitM ByteString (IO ()) m ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar FileInfo -> ConduitM ByteString (IO ()) m ()
inner ConduitM ByteString (IO ()) m ()
-> ConduitT (IO ()) c m (IO ()) -> ConduitT ByteString c m (IO ())
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (IO () -> IO () -> IO ()) -> IO () -> ConduitT (IO ()) c m (IO ())
forall (m :: * -> *) a b o.
Monad m =>
(a -> b -> a) -> a -> ConduitT b o m a
foldlC IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    liftIO finilizers


-- | Same as `untarWithFinalizers`, but will also produce a list of any exceptions that might have
-- occured during restoration process.
--
-- @since 0.2.5
untarWithExceptions ::
       (MonadThrow m, MonadIO m)
    => (FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
    -> ConduitM ByteString c m [(FileInfo, [SomeException])]
untarWithExceptions :: forall (m :: * -> *) c.
(MonadThrow m, MonadIO m) =>
(FileInfo
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> ConduitM ByteString c m [(FileInfo, [SomeException])]
untarWithExceptions FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
inner = do
    finalizers <- (FileInfo
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
inner ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitT
     (IO (FileInfo, [SomeException]))
     c
     m
     (IO [(FileInfo, [SomeException])])
-> ConduitT ByteString c m (IO [(FileInfo, [SomeException])])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (IO (FileInfo, [SomeException])
 -> IO [(FileInfo, [SomeException])])
-> ConduitT
     (IO (FileInfo, [SomeException]))
     c
     m
     (IO [(FileInfo, [SomeException])])
forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
C.foldMapC (((FileInfo, [SomeException]) -> [(FileInfo, [SomeException])])
-> IO (FileInfo, [SomeException])
-> IO [(FileInfo, [SomeException])]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileInfo, [SomeException]) -> [(FileInfo, [SomeException])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    filter (not . null . snd) <$> liftIO finalizers


--------------------------------------------------------------------------------
-- Create a tar file -----------------------------------------------------------
--------------------------------------------------------------------------------

gnuTarMagicVersion :: ShortByteString
gnuTarMagicVersion :: ShortByteString
gnuTarMagicVersion = ByteString -> ShortByteString
toShort (FilePath -> ByteString
S8.pack FilePath
"ustar  \NUL")

ustarMagicVersion :: ShortByteString
ustarMagicVersion :: ShortByteString
ustarMagicVersion = ByteString -> ShortByteString
toShort (FilePath -> ByteString
S8.pack FilePath
"ustar\NUL00")

blockSize :: FileOffset
blockSize :: FileOffset
blockSize = FileOffset
512

terminatorBlock :: ByteString
terminatorBlock :: ByteString
terminatorBlock = Int -> Word8 -> ByteString
S.replicate (FileOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset
2 FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
* FileOffset
blockSize)) Word8
0

defHeader :: FileOffset -> Header
defHeader :: FileOffset -> Header
defHeader FileOffset
offset = Header
          { headerOffset :: FileOffset
headerOffset = FileOffset
offset
          , headerPayloadOffset :: FileOffset
headerPayloadOffset = FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
512
          , headerFileNameSuffix :: ShortByteString
headerFileNameSuffix = ShortByteString
SS.empty
          , headerFileMode :: CMode
headerFileMode = CMode
0o644
          , headerOwnerId :: UserID
headerOwnerId = UserID
0
          , headerGroupId :: GroupID
headerGroupId = GroupID
0
          , headerPayloadSize :: FileOffset
headerPayloadSize = FileOffset
0
          , headerTime :: EpochTime
headerTime = EpochTime
0
          , headerLinkIndicator :: Word8
headerLinkIndicator = Word8
0
          , headerLinkName :: ShortByteString
headerLinkName = ShortByteString
SS.empty
          , headerMagicVersion :: ShortByteString
headerMagicVersion = ShortByteString
ustarMagicVersion
          , headerOwnerName :: ShortByteString
headerOwnerName = ShortByteString
"root"
          , headerGroupName :: ShortByteString
headerGroupName = ShortByteString
"root"
          , headerDeviceMajor :: DeviceID
headerDeviceMajor = DeviceID
0
          , headerDeviceMinor :: DeviceID
headerDeviceMinor = DeviceID
0
          , headerFileNamePrefix :: ShortByteString
headerFileNamePrefix = ShortByteString
SS.empty
          }


headerFromFileInfo ::
       MonadThrow m
    => FileOffset -- ^ Starting offset within the tarball. Must be multiple of 512, otherwise error.
    -> FileInfo -- ^ File info.
    -> m (Either TarCreateException Header)
headerFromFileInfo :: forall (m :: * -> *).
MonadThrow m =>
FileOffset -> FileInfo -> m (Either TarCreateException Header)
headerFromFileInfo FileOffset
offset FileInfo
fi = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
512 FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
== FileOffset
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TarCreateException -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException -> m ()) -> TarCreateException -> m ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
        FilePath
"<headerFromFileInfo>: Offset must always be a multiple of 512 for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FileInfo -> FilePath
getFileInfoPath FileInfo
fi
    let (ShortByteString
prefix, ShortByteString
suffix) = Int -> ByteString -> (ShortByteString, ShortByteString)
splitPathAt Int
100 (ByteString -> (ShortByteString, ShortByteString))
-> ByteString -> (ShortByteString, ShortByteString)
forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
    if ShortByteString -> Int
SS.length ShortByteString
prefix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
155 Bool -> Bool -> Bool
|| ShortByteString -> Bool
SS.null ShortByteString
suffix
        then Either TarCreateException Header
-> m (Either TarCreateException Header)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TarCreateException Header
 -> m (Either TarCreateException Header))
-> Either TarCreateException Header
-> m (Either TarCreateException Header)
forall a b. (a -> b) -> a -> b
$ TarCreateException -> Either TarCreateException Header
forall a b. a -> Either a b
Left (TarCreateException -> Either TarCreateException Header)
-> TarCreateException -> Either TarCreateException Header
forall a b. (a -> b) -> a -> b
$ FileInfo -> TarCreateException
FileNameTooLong FileInfo
fi
        else do
            (payloadSize, linkName, linkIndicator) <-
                case FileInfo -> FileType
fileType FileInfo
fi of
                    FileType
FTNormal -> (FileOffset, ShortByteString, Word8)
-> m (FileOffset, ShortByteString, Word8)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo -> FileOffset
fileSize FileInfo
fi, ShortByteString
SS.empty, Word8
48)
                    FTHardLink ByteString
ln -> (FileOffset, ShortByteString, Word8)
-> m (FileOffset, ShortByteString, Word8)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset
0, ByteString -> ShortByteString
toShort ByteString
ln, Word8
49)
                    FTSymbolicLink ByteString
ln -> (FileOffset, ShortByteString, Word8)
-> m (FileOffset, ShortByteString, Word8)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset
0, ByteString -> ShortByteString
toShort ByteString
ln, Word8
50)
                    FileType
FTDirectory -> (FileOffset, ShortByteString, Word8)
-> m (FileOffset, ShortByteString, Word8)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset
0, ShortByteString
SS.empty, Word8
53)
                    FileType
fty ->
                        TarCreateException -> m (FileOffset, ShortByteString, Word8)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException -> m (FileOffset, ShortByteString, Word8))
-> TarCreateException -> m (FileOffset, ShortByteString, Word8)
forall a b. (a -> b) -> a -> b
$
                        FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
                        FilePath
"<headerFromFileInfo>: Unsupported file type: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FileType -> FilePath
forall a. Show a => a -> FilePath
show FileType
fty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FileInfo -> FilePath
getFileInfoPath FileInfo
fi
            return $
                Right
                    Header
                    { headerOffset = offset
                    , headerPayloadOffset = offset + 512
                    , headerFileNameSuffix = suffix
                    , headerFileMode = fileMode fi
                    , headerOwnerId = fileUserId fi
                    , headerGroupId = fileGroupId fi
                    , headerPayloadSize = payloadSize
                    , headerTime = fileModTime fi
                    , headerLinkIndicator = linkIndicator
                    , headerLinkName = linkName
                    , headerMagicVersion = ustarMagicVersion
                    , headerOwnerName = toShort $ fileUserName fi
                    , headerGroupName = toShort $ fileGroupName fi
                    , headerDeviceMajor = 0
                    , headerDeviceMinor = 0
                    , headerFileNamePrefix = prefix
                    }


-- | Split a file path at the @n@ mark from the end, while still keeping the
-- split as a valid path, i.e split at a path separator only.
splitPathAt :: Int -> ByteString -> (ShortByteString, ShortByteString)
splitPathAt :: Int -> ByteString -> (ShortByteString, ShortByteString)
splitPathAt Int
n ByteString
fp
    | ByteString -> Int
S.length ByteString
fp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n = (ShortByteString
SS.empty, ByteString -> ShortByteString
toShort ByteString
fp)
    | Bool
otherwise =
        let sfp :: [ByteString]
sfp = (Char -> Bool) -> ByteString -> [ByteString]
S8.splitWith Char -> Bool
isPathSeparator ByteString
fp
            sepWith :: ByteString
-> (Int, [ByteString], [ByteString])
-> (Int, [ByteString], [ByteString])
sepWith ByteString
p (Int
tlen, [ByteString]
prefix', [ByteString]
suffix') =
                case ByteString -> Int
S.length ByteString
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tlen of
                    Int
tlen'
                        | Int
tlen' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n -> (Int
tlen', [ByteString]
prefix', ByteString
p ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
suffix')
                    Int
tlen' -> (Int
tlen', ByteString
p ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
prefix', [ByteString]
suffix')
            (Int
_, [ByteString]
prefix, [ByteString]
suffix) = (ByteString
 -> (Int, [ByteString], [ByteString])
 -> (Int, [ByteString], [ByteString]))
-> (Int, [ByteString], [ByteString])
-> [ByteString]
-> (Int, [ByteString], [ByteString])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ByteString
-> (Int, [ByteString], [ByteString])
-> (Int, [ByteString], [ByteString])
sepWith (Int
0, [], []) [ByteString]
sfp
            toShortPath :: [ByteString] -> ShortByteString
toShortPath = ByteString -> ShortByteString
toShort (ByteString -> ShortByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
S8.intercalate ByteString
pathSeparatorS
        in ([ByteString] -> ShortByteString
toShortPath [ByteString]
prefix, [ByteString] -> ShortByteString
toShortPath [ByteString]
suffix)

packHeader :: MonadThrow m => Header -> m S.ByteString
packHeader :: forall (m :: * -> *). MonadThrow m => Header -> m ByteString
packHeader Header
header = do
    (left, right) <- Header -> m (LazyByteString, LazyByteString)
forall (m :: * -> *).
MonadThrow m =>
Header -> m (LazyByteString, LazyByteString)
packHeaderNoChecksum Header
header
    let sumsl :: SL.ByteString -> Int
        sumsl = (Int -> Word8 -> Int) -> Int -> LazyByteString -> Int
forall a. (a -> Word8 -> a) -> a -> LazyByteString -> a
SL.foldl' (\ !Int
acc !Word8
v -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v) Int
0
        checksum = LazyByteString -> Int
sumsl LazyByteString
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ LazyByteString -> Int
sumsl LazyByteString
right
    encChecksum <-
        either
            (\(Int
_, Int
val) ->
                 TarCreateException -> m Builder
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException -> m Builder)
-> TarCreateException -> m Builder
forall a b. (a -> b) -> a -> b
$
                 FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
                 FilePath
"<packHeader>: Impossible happened - Checksum " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                 Int -> FilePath
forall a. Show a => a -> FilePath
show Int
val FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" doesn't fit into header for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Header -> FilePath
headerFilePath Header
header)
            return $
        encodeOctal 8 checksum
    return $ SL.toStrict $ left <> toLazyByteString encChecksum <> right

packHeaderNoChecksum :: MonadThrow m => Header -> m (SL.ByteString, SL.ByteString)
packHeaderNoChecksum :: forall (m :: * -> *).
MonadThrow m =>
Header -> m (LazyByteString, LazyByteString)
packHeaderNoChecksum h :: Header
h@Header {Word8
EpochTime
DeviceID
GroupID
CMode
FileOffset
UserID
ShortByteString
headerFileNamePrefix :: Header -> ShortByteString
headerDeviceMinor :: Header -> DeviceID
headerDeviceMajor :: Header -> DeviceID
headerGroupName :: Header -> ShortByteString
headerOwnerName :: Header -> ShortByteString
headerMagicVersion :: Header -> ShortByteString
headerLinkName :: Header -> ShortByteString
headerLinkIndicator :: Header -> Word8
headerTime :: Header -> EpochTime
headerPayloadSize :: Header -> FileOffset
headerGroupId :: Header -> GroupID
headerOwnerId :: Header -> UserID
headerFileMode :: Header -> CMode
headerFileNameSuffix :: Header -> ShortByteString
headerPayloadOffset :: Header -> FileOffset
headerOffset :: Header -> FileOffset
headerOffset :: FileOffset
headerPayloadOffset :: FileOffset
headerFileNameSuffix :: ShortByteString
headerFileMode :: CMode
headerOwnerId :: UserID
headerGroupId :: GroupID
headerPayloadSize :: FileOffset
headerTime :: EpochTime
headerLinkIndicator :: Word8
headerLinkName :: ShortByteString
headerMagicVersion :: ShortByteString
headerOwnerName :: ShortByteString
headerGroupName :: ShortByteString
headerDeviceMajor :: DeviceID
headerDeviceMinor :: DeviceID
headerFileNamePrefix :: ShortByteString
..} = do
    let CTime Int64
headerTime' = EpochTime
headerTime
        magic0 :: ShortByteString
magic0 = ShortByteString
headerMagicVersion
    (magic1, hOwnerId) <- ShortByteString
-> FilePath -> Int -> UserID -> m (ShortByteString, Builder)
forall {m :: * -> *} {a}.
(MonadThrow m, Show a, Storable a, Bits a, Integral a) =>
ShortByteString
-> FilePath -> Int -> a -> m (ShortByteString, Builder)
encodeNumber ShortByteString
magic0 FilePath
"ownerId" Int
8 UserID
headerOwnerId
    (magic2, hGroupId) <- encodeNumber magic1 "groupId" 8 headerGroupId
    (magic3, hPayloadSize) <- encodeNumber magic2 "payloadSize" 12 headerPayloadSize
    (magic4, hTime) <- encodeNumber magic3 "time" 12 headerTime'
    (magic5, hDevMajor) <- encodeDevice magic4 "Major" headerDeviceMajor
    (magic6, hDevMinor) <- encodeDevice magic5 "Minor" headerDeviceMinor
    hNameSuffix <- encodeShort h "nameSuffix" 100 headerFileNameSuffix
    hFileMode <- throwNumberEither "fileMode" $ encodeOctal 8 headerFileMode
    hLinkName <- encodeShort h "linkName" 100 headerLinkName
    hMagicVersion <- encodeShort h "magicVersion" 8 magic6
    hOwnerName <- encodeShort h "ownerName" 32 headerOwnerName
    hGroupName <- encodeShort h "groupName" 32 headerGroupName
    hNamePrefix <- encodeShort h "namePrefix" 155 headerFileNamePrefix
    return
        ( toLazyByteString $
          hNameSuffix <>
          hFileMode <>
          hOwnerId <>
          hGroupId <>
          hPayloadSize <>
          hTime
        , toLazyByteString $
          word8 headerLinkIndicator <>
          hLinkName <>
          hMagicVersion <>
          hOwnerName <>
          hGroupName <>
          hDevMajor <>
          hDevMinor <>
          hNamePrefix <>
          byteString (S.replicate 12 0)
        )
  where
    encodeNumber :: ShortByteString
-> FilePath -> Int -> a -> m (ShortByteString, Builder)
encodeNumber ShortByteString
magic FilePath
field Int
len = FilePath
-> Either (Int, a) (ShortByteString, Builder)
-> m (ShortByteString, Builder)
forall {m :: * -> *} {a} {a} {a}.
(MonadThrow m, Show a, Show a) =>
FilePath -> Either (a, a) a -> m a
throwNumberEither FilePath
field (Either (Int, a) (ShortByteString, Builder)
 -> m (ShortByteString, Builder))
-> (a -> Either (Int, a) (ShortByteString, Builder))
-> a
-> m (ShortByteString, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString
-> Either (Int, a) Builder
-> Either (Int, a) (ShortByteString, Builder)
forall {a}.
(Storable a, Bits a, Integral a) =>
ShortByteString
-> Either (Int, a) Builder
-> Either (Int, a) (ShortByteString, Builder)
fallbackHex ShortByteString
magic (Either (Int, a) Builder
 -> Either (Int, a) (ShortByteString, Builder))
-> (a -> Either (Int, a) Builder)
-> a
-> Either (Int, a) (ShortByteString, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Either (Int, a) Builder
forall a. Integral a => Int -> a -> Either (Int, a) Builder
encodeOctal Int
len
    encodeDevice :: ShortByteString -> FilePath -> a -> m (ShortByteString, Builder)
encodeDevice ShortByteString
magic FilePath
_ a
0     = (ShortByteString, Builder) -> m (ShortByteString, Builder)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShortByteString
magic, ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
S.replicate Int
8 Word8
0)
    encodeDevice ShortByteString
magic FilePath
m a
devid = ShortByteString
-> FilePath -> Int -> a -> m (ShortByteString, Builder)
forall {m :: * -> *} {a}.
(MonadThrow m, Show a, Storable a, Bits a, Integral a) =>
ShortByteString
-> FilePath -> Int -> a -> m (ShortByteString, Builder)
encodeNumber ShortByteString
magic (FilePath
"device" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
m) Int
8 a
devid
    fallbackHex :: ShortByteString
-> Either (Int, a) Builder
-> Either (Int, a) (ShortByteString, Builder)
fallbackHex ShortByteString
magic (Right Builder
enc)       = (ShortByteString, Builder)
-> Either (Int, a) (ShortByteString, Builder)
forall a b. b -> Either a b
Right (ShortByteString
magic, Builder
enc)
    fallbackHex ShortByteString
_     (Left (Int
len, a
val)) = (,) ShortByteString
gnuTarMagicVersion (Builder -> (ShortByteString, Builder))
-> Either (Int, a) Builder
-> Either (Int, a) (ShortByteString, Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> a -> Either (Int, a) Builder
forall a.
(Storable a, Bits a, Integral a) =>
Int -> a -> Either (Int, a) Builder
encodeHex Int
len a
val
    throwNumberEither :: FilePath -> Either (a, a) a -> m a
throwNumberEither FilePath
_     (Right a
v)         = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
    throwNumberEither FilePath
field (Left (a
len, a
val)) =
        TarCreateException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException -> m a) -> TarCreateException -> m a
forall a b. (a -> b) -> a -> b
$
        FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
        FilePath
"<packHeaderNoChecksum>: Tar value overflow for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        Header -> FilePath
headerFilePath Header
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FilePath
" (for field '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
field FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' with maxLen " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
len FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
val


-- | Encode a number as hexadecimal with most significant bit set to 1. Returns Left if the value
-- doesn't fit in a ByteString of the supplied length, also prohibits negative numbers if precision
-- of value is higher than available length. Eg. length 8 can't reliably encoed negative numbers,
-- since MSB is already used for flagging Hex extension.
encodeHex :: (Storable a, Bits a, Integral a) =>
             Int -> a -> Either (Int, a) Builder
encodeHex :: forall a.
(Storable a, Bits a, Integral a) =>
Int -> a -> Either (Int, a) Builder
encodeHex !Int
len !a
val =
    if a -> a
forall a. Bits a => a -> a
complement (a -> a
forall a. Bits a => a -> a
complement a
0 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
infoBits) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
val a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
val Bool -> Bool -> Bool
&&
       Bool -> Bool
not (a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. Storable a => a -> Int
sizeOf a
val)
        then Int -> a -> Builder -> Either (Int, a) Builder
forall {a} {m :: * -> *}.
(Bits a, Integral a, Monad m) =>
Int -> a -> Builder -> m Builder
go Int
0 a
val Builder
forall a. Monoid a => a
mempty
        else (Int, a) -> Either (Int, a) Builder
forall a b. a -> Either a b
Left (Int
len, a
val)
  where
    len' :: Int
len' = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    infoBits :: Int
infoBits = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    go :: Int -> a -> Builder -> m Builder
go !Int
n !a
cur !Builder
acc
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len' = Int -> a -> Builder -> m Builder
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (a
cur a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) (Word8 -> Builder
word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
cur a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc)
        | Bool
otherwise = Builder -> m Builder
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Builder
word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
cur a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x7F) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc)


-- | Encode a number in 8base padded with zeros and terminated with NUL.
encodeOctal :: (Integral a) =>
                Int -> a -> Either (Int, a) Builder
encodeOctal :: forall a. Integral a => Int -> a -> Either (Int, a) Builder
encodeOctal !Int
len' !a
val
    | a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = (Int, a) -> Either (Int, a) Builder
forall a b. a -> Either a b
Left (Int
len', a
val)
    | Bool
otherwise = Int -> a -> Builder -> Either (Int, a) Builder
forall {a}.
Integral a =>
Int -> a -> Builder -> Either (Int, a) Builder
go Int
0 a
val (Word8 -> Builder
word8 Word8
0)
  where
    !len :: Int
len = Int
len' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    go :: Int -> a -> Builder -> Either (Int, a) Builder
go !Int
n !a
cur !Builder
acc
        | a
cur a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 =
            if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
                then Builder -> Either (Int, a) Builder
forall a. a -> Either (Int, a) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Either (Int, a) Builder)
-> Builder -> Either (Int, a) Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString (Int -> Word8 -> ByteString
S.replicate (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Word8
48) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc
                else Builder -> Either (Int, a) Builder
forall a. a -> Either (Int, a) a
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
acc
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len =
            let !(a
q, a
r) = a
cur a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`quotRem` a
8
            in Int -> a -> Builder -> Either (Int, a) Builder
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
q (Word8 -> Builder
word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
r Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
48) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc)
        | Bool
otherwise = (Int, a) -> Either (Int, a) Builder
forall a b. a -> Either a b
Left (Int
len', a
val)



-- | Encode a `ShortByteString` with an exact length, NUL terminating if it is
-- shorter, but throwing `TarCreationError` if it is longer.
encodeShort :: MonadThrow m => Header -> String -> Int -> ShortByteString -> m Builder
encodeShort :: forall (m :: * -> *).
MonadThrow m =>
Header -> FilePath -> Int -> ShortByteString -> m Builder
encodeShort Header
h FilePath
field !Int
len !ShortByteString
sbs
    | Int
lenShort Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len = Builder -> m Builder
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Builder
shortByteString ShortByteString
sbs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Int -> Word8 -> ByteString
S.replicate (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lenShort) Word8
0)
    | Bool
otherwise =
        TarCreateException -> m Builder
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException -> m Builder)
-> TarCreateException -> m Builder
forall a b. (a -> b) -> a -> b
$
        FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
        FilePath
"<encodeShort>: Tar string value overflow for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        Header -> FilePath
headerFilePath Header
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FilePath
" (for field '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
field FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' with maxLen " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
len FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
S8.unpack (ShortByteString -> ByteString
fromShort ShortByteString
sbs)
  where
    lenShort :: Int
lenShort = ShortByteString -> Int
SS.length ShortByteString
sbs


-- | Produce a ByteString chunk with NUL characters of the size needed to get up
-- to the next 512 byte mark in respect to the supplied offset and return that
-- offset incremented to that mark.
yieldNulPadding :: Monad m => FileOffset -> ConduitM i ByteString m FileOffset
yieldNulPadding :: forall (m :: * -> *) i.
Monad m =>
FileOffset -> ConduitM i ByteString m FileOffset
yieldNulPadding FileOffset
n = do
    let pad :: FileOffset
pad = FileOffset
blockSize FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
- (FileOffset
n FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
blockSize)
    if FileOffset
pad FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
/= FileOffset
blockSize
        then ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Int -> Word8 -> ByteString
S.replicate (FileOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
pad) Word8
0) ConduitT i ByteString m ()
-> ConduitT i ByteString m FileOffset
-> ConduitT i ByteString m FileOffset
forall a b.
ConduitT i ByteString m a
-> ConduitT i ByteString m b -> ConduitT i ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FileOffset -> ConduitT i ByteString m FileOffset
forall a. a -> ConduitT i ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset
n FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
pad)
        else FileOffset -> ConduitT i ByteString m FileOffset
forall a. a -> ConduitT i ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return FileOffset
n



-- | Handle tar payload, while validating its size and padding it to the full
-- block at the end.
tarPayload :: MonadThrow m =>
              FileOffset -- ^ Received payload size
           -> Header -- ^ Header for the file that we are currently receiving the payload for
           -> (FileOffset -> ConduitM (Either a ByteString) ByteString m FileOffset)
           -- ^ Continuation for after all payload has been received
           -> ConduitM (Either a ByteString) ByteString m FileOffset
tarPayload :: forall (m :: * -> *) a.
MonadThrow m =>
FileOffset
-> Header
-> (FileOffset
    -> ConduitM (Either a ByteString) ByteString m FileOffset)
-> ConduitM (Either a ByteString) ByteString m FileOffset
tarPayload FileOffset
size Header
header FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
cont
    | FileOffset
size FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
== Header -> FileOffset
headerPayloadSize Header
header = FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
cont (Header -> FileOffset
headerOffset Header
header FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
blockSize)
    | Bool
otherwise = FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
go FileOffset
size
  where
    go :: FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
go FileOffset
prevSize = do
        eContent <- ConduitT
  (Either a ByteString) ByteString m (Maybe (Either a ByteString))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case eContent of
            Just h :: Either a ByteString
h@(Left a
_) -> do
                Either a ByteString
-> ConduitT (Either a ByteString) ByteString m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Either a ByteString
h
                TarCreateException
-> ConduitM (Either a ByteString) ByteString m FileOffset
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either a ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitM (Either a ByteString) ByteString m FileOffset)
-> TarCreateException
-> ConduitM (Either a ByteString) ByteString m FileOffset
forall a b. (a -> b) -> a -> b
$
                    FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
                    FilePath
"<tarPayload>: Not enough payload for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Header -> FilePath
headerFilePath Header
header
            Just (Right ByteString
content) -> do
                let nextSize :: FileOffset
nextSize = FileOffset
prevSize FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
                Bool
-> ConduitT (Either a ByteString) ByteString m ()
-> ConduitT (Either a ByteString) ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileOffset
nextSize FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
<= Header -> FileOffset
headerPayloadSize Header
header) (ConduitT (Either a ByteString) ByteString m ()
 -> ConduitT (Either a ByteString) ByteString m ())
-> ConduitT (Either a ByteString) ByteString m ()
-> ConduitT (Either a ByteString) ByteString m ()
forall a b. (a -> b) -> a -> b
$
                    TarCreateException
-> ConduitT (Either a ByteString) ByteString m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either a ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitT (Either a ByteString) ByteString m ())
-> TarCreateException
-> ConduitT (Either a ByteString) ByteString m ()
forall a b. (a -> b) -> a -> b
$
                    FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
                    FilePath
"<tarPayload>: Too much payload (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FileOffset -> FilePath
forall a. Show a => a -> FilePath
show FileOffset
nextSize FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") for file with size (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FileOffset -> FilePath
forall a. Show a => a -> FilePath
show (Header -> FileOffset
headerPayloadSize Header
header) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Header -> FilePath
headerFilePath Header
header
                ByteString -> ConduitT (Either a ByteString) ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
content
                if FileOffset
nextSize FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
== Header -> FileOffset
headerPayloadSize Header
header
                    then do
                        paddedSize <- FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
forall (m :: * -> *) i.
Monad m =>
FileOffset -> ConduitM i ByteString m FileOffset
yieldNulPadding FileOffset
nextSize
                        cont (headerPayloadOffset header + paddedSize)
                    else FileOffset
-> ConduitM (Either a ByteString) ByteString m FileOffset
go FileOffset
nextSize
            Maybe (Either a ByteString)
Nothing ->
                TarCreateException
-> ConduitM (Either a ByteString) ByteString m FileOffset
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either a ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitM (Either a ByteString) ByteString m FileOffset)
-> TarCreateException
-> ConduitM (Either a ByteString) ByteString m FileOffset
forall a b. (a -> b) -> a -> b
$
                FilePath -> TarCreateException
TarCreationError FilePath
"<tarPayload>: Stream finished abruptly. Not enough payload."



tarHeader :: MonadThrow m =>
             FileOffset -> ConduitM (Either Header ByteString) ByteString m FileOffset
tarHeader :: forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either Header ByteString) ByteString m FileOffset
tarHeader FileOffset
offset = do
    eContent <- ConduitT
  (Either Header ByteString)
  ByteString
  m
  (Maybe (Either Header ByteString))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case eContent of
        Just (Right ByteString
bs) | ByteString -> Bool
S.null ByteString
bs -> FileOffset
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either Header ByteString) ByteString m FileOffset
tarHeader FileOffset
offset -- ignore empty content
        Just c :: Either Header ByteString
c@(Right ByteString
_) -> do
            Either Header ByteString
-> ConduitT (Either Header ByteString) ByteString m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Either Header ByteString
c
            TarCreateException
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either Header ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitT (Either Header ByteString) ByteString m FileOffset)
-> TarCreateException
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall a b. (a -> b) -> a -> b
$
                FilePath -> TarCreateException
TarCreationError FilePath
"<tarHeader>: Received payload without a corresponding Header."
        Just (Left Header
header) -> do
            Header
-> ConduitT (Either Header ByteString) ByteString m ByteString
forall (m :: * -> *). MonadThrow m => Header -> m ByteString
packHeader Header
header ConduitT (Either Header ByteString) ByteString m ByteString
-> (ByteString
    -> ConduitT (Either Header ByteString) ByteString m ())
-> ConduitT (Either Header ByteString) ByteString m ()
forall a b.
ConduitT (Either Header ByteString) ByteString m a
-> (a -> ConduitT (Either Header ByteString) ByteString m b)
-> ConduitT (Either Header ByteString) ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> ConduitT (Either Header ByteString) ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
            FileOffset
-> Header
-> (FileOffset
    -> ConduitT (Either Header ByteString) ByteString m FileOffset)
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall (m :: * -> *) a.
MonadThrow m =>
FileOffset
-> Header
-> (FileOffset
    -> ConduitM (Either a ByteString) ByteString m FileOffset)
-> ConduitM (Either a ByteString) ByteString m FileOffset
tarPayload FileOffset
0 Header
header FileOffset
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either Header ByteString) ByteString m FileOffset
tarHeader
        Maybe (Either Header ByteString)
Nothing -> do
            ByteString -> ConduitT (Either Header ByteString) ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
terminatorBlock
            FileOffset
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall a. a -> ConduitT (Either Header ByteString) ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOffset
 -> ConduitT (Either Header ByteString) ByteString m FileOffset)
-> FileOffset
-> ConduitT (Either Header ByteString) ByteString m FileOffset
forall a b. (a -> b) -> a -> b
$ FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
terminatorBlock)



tarFileInfo :: MonadThrow m =>
               FileOffset -> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tarFileInfo :: forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tarFileInfo FileOffset
offset = do
    eContent <- ConduitT
  (Either FileInfo ByteString)
  ByteString
  m
  (Maybe (Either FileInfo ByteString))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case eContent of
        Just (Right ByteString
bs)
            | ByteString -> Bool
S.null ByteString
bs -> FileOffset
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tarFileInfo FileOffset
offset -- ignore empty content
        Just c :: Either FileInfo ByteString
c@(Right ByteString
_) -> do
            Either FileInfo ByteString
-> ConduitT (Either FileInfo ByteString) ByteString m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Either FileInfo ByteString
c
            TarCreateException
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either FileInfo ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitT (Either FileInfo ByteString) ByteString m FileOffset)
-> TarCreateException
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall a b. (a -> b) -> a -> b
$
                FilePath -> TarCreateException
TarCreationError FilePath
"<tarFileInfo>: Received payload without a corresponding FileInfo."
        Just (Left FileInfo
fi) -> do
            eHeader <- FileOffset
-> FileInfo
-> ConduitT
     (Either FileInfo ByteString)
     ByteString
     m
     (Either TarCreateException Header)
forall (m :: * -> *).
MonadThrow m =>
FileOffset -> FileInfo -> m (Either TarCreateException Header)
headerFromFileInfo FileOffset
offset FileInfo
fi
            case eHeader of
                Left (FileNameTooLong FileInfo
_) -> do
                    let fPath :: ByteString
fPath = FileInfo -> ByteString
filePath FileInfo
fi
                        fPathLen :: FileOffset
fPathLen = Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
fPath Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                        pad :: FileOffset
pad =
                            case FileOffset
fPathLen FileOffset -> FileOffset -> FileOffset
forall a. Integral a => a -> a -> a
`mod` FileOffset
blockSize of
                                FileOffset
0 -> FileOffset
0
                                FileOffset
x -> FileOffset
blockSize FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
- FileOffset
x
                    eHeader' <-
                        FileOffset
-> FileInfo
-> ConduitT
     (Either FileInfo ByteString)
     ByteString
     m
     (Either TarCreateException Header)
forall (m :: * -> *).
MonadThrow m =>
FileOffset -> FileInfo -> m (Either TarCreateException Header)
headerFromFileInfo
                            (FileOffset
offset FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
blockSize FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
fPathLen FileOffset -> FileOffset -> FileOffset
forall a. Num a => a -> a -> a
+ FileOffset
pad)
                            (FileInfo
fi {filePath = S.take 100 fPath})
                    header <- either throwM return eHeader'
                    pHeader <- packHeader header
                    pFileNameHeader <-
                        packHeader $
                        (defHeader offset)
                        { headerFileNameSuffix = "././@LongLink"
                        , headerPayloadSize = fPathLen
                        , headerLinkIndicator = 76 -- 'L'
                        , headerMagicVersion = gnuTarMagicVersion
                        }
                    yield pFileNameHeader
                    yield fPath
                    yield $ S.replicate (fromIntegral pad + 1) 0
                    yield pHeader
                    tarPayload 0 header tarFileInfo
                Left TarCreateException
exc -> TarCreateException
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT (Either FileInfo ByteString) ByteString m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TarCreateException
exc
                Right Header
header -> do
                    Header
-> ConduitT (Either FileInfo ByteString) ByteString m ByteString
forall (m :: * -> *). MonadThrow m => Header -> m ByteString
packHeader Header
header ConduitT (Either FileInfo ByteString) ByteString m ByteString
-> (ByteString
    -> ConduitT (Either FileInfo ByteString) ByteString m ())
-> ConduitT (Either FileInfo ByteString) ByteString m ()
forall a b.
ConduitT (Either FileInfo ByteString) ByteString m a
-> (a -> ConduitT (Either FileInfo ByteString) ByteString m b)
-> ConduitT (Either FileInfo ByteString) ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> ConduitT (Either FileInfo ByteString) ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
                    FileOffset
-> Header
-> (FileOffset
    -> ConduitT (Either FileInfo ByteString) ByteString m FileOffset)
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall (m :: * -> *) a.
MonadThrow m =>
FileOffset
-> Header
-> (FileOffset
    -> ConduitM (Either a ByteString) ByteString m FileOffset)
-> ConduitM (Either a ByteString) ByteString m FileOffset
tarPayload FileOffset
0 Header
header FileOffset
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tarFileInfo
        Maybe (Either FileInfo ByteString)
Nothing -> FileOffset
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall a. a -> ConduitT (Either FileInfo ByteString) ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return FileOffset
offset



-- | Create a tar archive by suppying a stream of `Left` `FileInfo`s. Whenever a
-- file type is `FTNormal`, it must be immediately followed by its content as
-- `Right` `ByteString`. The produced `ByteString` is in the raw tar format and
-- is properly terminated at the end, therefore it can not be extended
-- afterwards. Returned is the total size of the bytestring as a `FileOffset`.
--
-- @since 0.2.0
tar :: MonadThrow m =>
       ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tar :: forall (m :: * -> *).
MonadThrow m =>
ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tar = do
    offset <- FileOffset
-> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tarFileInfo FileOffset
0
    yield terminatorBlock
    return $ offset + fromIntegral (S.length terminatorBlock)


-- | Just like `tar`, except gives you the ability to work at a lower `Header`
-- level, versus more user friendly `FileInfo`. A deeper understanding of tar
-- format is necessary in order to work directly with `Header`s.
--
-- @since 0.2.0
tarEntries :: MonadThrow m =>
              ConduitM (Either Header ByteString) ByteString m FileOffset
tarEntries :: forall (m :: * -> *).
MonadThrow m =>
ConduitM (Either Header ByteString) ByteString m FileOffset
tarEntries = do
    offset <- FileOffset
-> ConduitM (Either Header ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
FileOffset
-> ConduitM (Either Header ByteString) ByteString m FileOffset
tarHeader FileOffset
0
    yield terminatorBlock
    return $ offset + fromIntegral (S.length terminatorBlock)



-- | Turn a stream of file paths into a stream of `FileInfo` and file
-- content. All paths will be decended into recursively.
--
-- @since 0.2.0
filePathConduit :: (MonadThrow m, MonadResource m) =>
                   ConduitM FilePath (Either FileInfo ByteString) m ()
filePathConduit :: forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath (Either FileInfo ByteString) m ()
filePathConduit = do
    mfp <- ConduitT FilePath (Either FileInfo ByteString) m (Maybe FilePath)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case mfp of
        Just FilePath
fp -> do
            fi <- IO FileInfo
-> ConduitT FilePath (Either FileInfo ByteString) m FileInfo
forall a.
IO a -> ConduitT FilePath (Either FileInfo ByteString) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileInfo
 -> ConduitT FilePath (Either FileInfo ByteString) m FileInfo)
-> IO FileInfo
-> ConduitT FilePath (Either FileInfo ByteString) m FileInfo
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileInfo
getFileInfo FilePath
fp
            case fileType fi of
                FileType
FTNormal -> do
                    Either FileInfo ByteString
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (FileInfo -> Either FileInfo ByteString
forall a b. a -> Either a b
Left FileInfo
fi)
                    FilePath -> ConduitT FilePath ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFile (FileInfo -> FilePath
getFileInfoPath FileInfo
fi) ConduitT FilePath ByteString m ()
-> ConduitT ByteString (Either FileInfo ByteString) m ()
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> Either FileInfo ByteString)
-> ConduitT ByteString (Either FileInfo ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC ByteString -> Either FileInfo ByteString
forall a b. b -> Either a b
Right
                FTSymbolicLink ByteString
_ -> Either FileInfo ByteString
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (FileInfo -> Either FileInfo ByteString
forall a b. a -> Either a b
Left FileInfo
fi)
                FileType
FTDirectory -> do
                    Either FileInfo ByteString
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (FileInfo -> Either FileInfo ByteString
forall a b. a -> Either a b
Left FileInfo
fi)
                    FilePath -> ConduitT FilePath FilePath m ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i FilePath m ()
sourceDirectory (FileInfo -> FilePath
getFileInfoPath FileInfo
fi) ConduitT FilePath FilePath m ()
-> ConduitT FilePath (Either FileInfo ByteString) m ()
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath (Either FileInfo ByteString) m ()
filePathConduit
                FileType
fty -> do
                    FilePath -> ConduitT FilePath (Either FileInfo ByteString) m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover FilePath
fp
                    TarCreateException
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT FilePath (Either FileInfo ByteString) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TarCreateException
 -> ConduitT FilePath (Either FileInfo ByteString) m ())
-> TarCreateException
-> ConduitT FilePath (Either FileInfo ByteString) m ()
forall a b. (a -> b) -> a -> b
$
                        FilePath -> TarCreateException
TarCreationError (FilePath -> TarCreateException) -> FilePath -> TarCreateException
forall a b. (a -> b) -> a -> b
$
                        FilePath
"<filePathConduit>: Unsupported file type: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FileType -> FilePath
forall a. Show a => a -> FilePath
show FileType
fty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FileInfo -> FilePath
getFileInfoPath FileInfo
fi
            filePathConduit
        Maybe FilePath
Nothing -> () -> ConduitT FilePath (Either FileInfo ByteString) m ()
forall a. a -> ConduitT FilePath (Either FileInfo ByteString) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Recursively tar all of the files and directories. There will be no
-- conversion between relative and absolute paths, so just like with GNU @tar@
-- cli tool, it may be necessary to `setCurrentDirectory` in order to get the
-- paths relative. Using `filePathConduit` directly, while modifying the
-- `filePath`, would be another approach to handling the file paths.
--
-- @since 0.2.0
tarFilePath :: (MonadThrow m, MonadResource m) => ConduitM FilePath ByteString m FileOffset
tarFilePath :: forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath ByteString m FileOffset
tarFilePath = ConduitM FilePath (Either FileInfo ByteString) m ()
forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath (Either FileInfo ByteString) m ()
filePathConduit ConduitM FilePath (Either FileInfo ByteString) m ()
-> ConduitT (Either FileInfo ByteString) ByteString m FileOffset
-> ConduitT FilePath ByteString m FileOffset
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Either FileInfo ByteString) ByteString m FileOffset
forall (m :: * -> *).
MonadThrow m =>
ConduitM (Either FileInfo ByteString) ByteString m FileOffset
tar


-- | Uses `tarFilePath` to create a tarball, that will recursively include the
-- supplied list of all the files and directories
--
-- @since 0.2.0
createTarball :: FilePath -- ^ File name for the tarball
              -> [FilePath] -- ^ List of files and directories to include in the tarball
              -> IO ()
createTarball :: FilePath -> [FilePath] -> IO ()
createTarball FilePath
tarfp [FilePath]
dirs =
    ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ConduitT () (Element [FilePath]) (ResourceT IO) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [FilePath]
dirs ConduitT () FilePath (ResourceT IO) ()
-> ConduitT FilePath Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT FilePath ByteString (ResourceT IO) FileOffset
-> ConduitT FilePath ByteString (ResourceT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ConduitT FilePath ByteString (ResourceT IO) FileOffset
forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath ByteString m FileOffset
tarFilePath ConduitT FilePath ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) ()
-> ConduitT FilePath Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| FilePath -> ConduitT ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
sinkFile FilePath
tarfp

-- | Take a list of files and paths, recursively tar them and write output into supplied handle.
--
-- @since 0.2.0
writeTarball :: Handle -- ^ Handle where created tarball will be written to
             -> [FilePath] -- ^ List of files and directories to include in the tarball
             -> IO ()
writeTarball :: Handle -> [FilePath] -> IO ()
writeTarball Handle
tarHandle [FilePath]
dirs =
    ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ConduitT () (Element [FilePath]) (ResourceT IO) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [FilePath]
dirs ConduitT () FilePath (ResourceT IO) ()
-> ConduitT FilePath Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT FilePath ByteString (ResourceT IO) FileOffset
-> ConduitT FilePath ByteString (ResourceT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ConduitT FilePath ByteString (ResourceT IO) FileOffset
forall (m :: * -> *).
(MonadThrow m, MonadResource m) =>
ConduitM FilePath ByteString m FileOffset
tarFilePath ConduitT FilePath ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) ()
-> ConduitT FilePath Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Handle -> ConduitT ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
tarHandle


-- always use forward slash, see
-- https://github.com/snoyberg/tar-conduit/issues/21
pathSeparatorS :: ByteString
pathSeparatorS :: ByteString
pathSeparatorS = ByteString
"/" -- S8.singleton pathSeparator


fileInfoFromHeader :: Header -> FileInfo
fileInfoFromHeader :: Header -> FileInfo
fileInfoFromHeader header :: Header
header@Header {Word8
EpochTime
DeviceID
GroupID
CMode
FileOffset
UserID
ShortByteString
headerFileNamePrefix :: Header -> ShortByteString
headerDeviceMinor :: Header -> DeviceID
headerDeviceMajor :: Header -> DeviceID
headerGroupName :: Header -> ShortByteString
headerOwnerName :: Header -> ShortByteString
headerMagicVersion :: Header -> ShortByteString
headerLinkName :: Header -> ShortByteString
headerLinkIndicator :: Header -> Word8
headerTime :: Header -> EpochTime
headerPayloadSize :: Header -> FileOffset
headerGroupId :: Header -> GroupID
headerOwnerId :: Header -> UserID
headerFileMode :: Header -> CMode
headerFileNameSuffix :: Header -> ShortByteString
headerPayloadOffset :: Header -> FileOffset
headerOffset :: Header -> FileOffset
headerOffset :: FileOffset
headerPayloadOffset :: FileOffset
headerFileNameSuffix :: ShortByteString
headerFileMode :: CMode
headerOwnerId :: UserID
headerGroupId :: GroupID
headerPayloadSize :: FileOffset
headerTime :: EpochTime
headerLinkIndicator :: Word8
headerLinkName :: ShortByteString
headerMagicVersion :: ShortByteString
headerOwnerName :: ShortByteString
headerGroupName :: ShortByteString
headerDeviceMajor :: DeviceID
headerDeviceMinor :: DeviceID
headerFileNamePrefix :: ShortByteString
..} =
    FileInfo
    { filePath :: ByteString
filePath = Header -> ByteString
headerFilePathBS Header
header
    , fileUserId :: UserID
fileUserId = UserID
headerOwnerId
    , fileUserName :: ByteString
fileUserName = ShortByteString -> ByteString
fromShort ShortByteString
headerOwnerName
    , fileGroupId :: GroupID
fileGroupId = GroupID
headerGroupId
    , fileGroupName :: ByteString
fileGroupName = ShortByteString -> ByteString
fromShort ShortByteString
headerGroupName
    , fileMode :: CMode
fileMode = CMode
headerFileMode
    , fileSize :: FileOffset
fileSize = FileOffset
headerPayloadSize
    , fileType :: FileType
fileType = Header -> FileType
headerFileType Header
header
    , fileModTime :: EpochTime
fileModTime = EpochTime
headerTime
    }


-- | Extract a tarball while using `restoreFileInfo` for writing files onto the file
-- system. Restoration process is cross platform and should work concistently both on Windows and
-- Posix systems.
--
-- @since 0.2.0
extractTarball :: FilePath -- ^ Filename for the tarball
               -> Maybe FilePath -- ^ Folder where tarball should be extract
                                 -- to. Default is the current path
               -> IO ()
extractTarball :: FilePath -> Maybe FilePath -> IO ()
extractTarball FilePath
tarfp Maybe FilePath
mcd = do
    cd <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getCurrentDirectory FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
mcd
    createDirectoryIfMissing True cd
    runConduitRes $ sourceFileBS tarfp .| untarWithFinalizers (restoreFileInto cd)


prependDirectory :: FilePath -> FileInfo -> FileInfo
prependDirectory :: FilePath -> FileInfo -> FileInfo
prependDirectory FilePath
cd FileInfo
fi = FileInfo
fi {filePath = prependDir $ getFileInfoPath fi,
                             fileType = prependDirIfNeeded (fileType fi)}
  where
    -- Hard links need to be interpreted based on `cd`, not just CWD, if relative,
    -- otherwise they may point to some invalid location.
    prependDirIfNeeded :: FileType -> FileType
prependDirIfNeeded (FTHardLink ByteString
p)
        | FilePath -> Bool
isRelative (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
decodeFilePath ByteString
p = ByteString -> FileType
FTHardLink (FilePath -> ByteString
prependDir (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
decodeFilePath ByteString
p)
    prependDirIfNeeded FileType
other            = FileType
other
    prependDir :: FilePath -> ByteString
prependDir FilePath
p                        = FilePath -> ByteString
encodeFilePath (FilePath
cd FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" FilePath
p)


-- | Restore all files into a folder. Absolute file paths will be turned into
-- relative to the supplied folder.
restoreFileInto :: MonadResource m =>
                   FilePath -> FileInfo -> ConduitM ByteString (IO ()) m ()
restoreFileInto :: forall (m :: * -> *).
MonadResource m =>
FilePath -> FileInfo -> ConduitM ByteString (IO ()) m ()
restoreFileInto FilePath
cd = FileInfo -> ConduitM ByteString (IO ()) m ()
forall (m :: * -> *).
MonadResource m =>
FileInfo -> ConduitM ByteString (IO ()) m ()
restoreFile (FileInfo -> ConduitM ByteString (IO ()) m ())
-> (FileInfo -> FileInfo)
-> FileInfo
-> ConduitM ByteString (IO ()) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FileInfo -> FileInfo
prependDirectory FilePath
cd

-- | Restore all files into a folder. Absolute file paths will be turned into relative to the
-- supplied folder. Yields a list with exceptions instead of throwing them.
--
-- @since 0.2.5
restoreFileIntoLenient :: MonadResource m =>
    FilePath -> FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileIntoLenient :: forall (m :: * -> *).
MonadResource m =>
FilePath
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileIntoLenient FilePath
cd = Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *).
MonadResource m =>
Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileWithErrors Bool
True (FileInfo
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> (FileInfo -> FileInfo)
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FileInfo -> FileInfo
prependDirectory FilePath
cd

-- | Same as `extractTarball`, but ignores possible extraction errors. It can still throw a
-- `TarException` if the tarball is corrupt or malformed.
--
-- @since 0.2.5
extractTarballLenient :: FilePath -- ^ Filename for the tarball
                   -> Maybe FilePath -- ^ Folder where tarball should be extract
                   -- to. Default is the current path
                   -> IO [(FileInfo, [SomeException])]
extractTarballLenient :: FilePath -> Maybe FilePath -> IO [(FileInfo, [SomeException])]
extractTarballLenient FilePath
tarfp Maybe FilePath
mcd = do
    cd <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getCurrentDirectory FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
mcd
    createDirectoryIfMissing True cd
    runConduitRes $
        sourceFileBS tarfp .| untarWithExceptions (restoreFileIntoLenient cd)



-- | Restore files onto the file system. Produces actions that will set the modification time on the
-- directories, which can be executed after the pipeline has finished and all files have been
-- written to disk.
restoreFile :: (MonadResource m) =>
               FileInfo -> ConduitM S8.ByteString (IO ()) m ()
restoreFile :: forall (m :: * -> *).
MonadResource m =>
FileInfo -> ConduitM ByteString (IO ()) m ()
restoreFile FileInfo
fi = Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *).
MonadResource m =>
Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileWithErrors Bool
False FileInfo
fi ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitT (IO (FileInfo, [SomeException])) (IO ()) m ()
-> ConduitT ByteString (IO ()) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (IO (FileInfo, [SomeException]) -> IO ())
-> ConduitT (IO (FileInfo, [SomeException])) (IO ()) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC IO (FileInfo, [SomeException]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void


-- | Restore files onto the file system, much in the same way `restoreFile` does it, except with
-- ability to ignore restoring problematic files and report errors that occured as a list of
-- exceptions, which will be returned as a list when finilizer executed. If a list is empty, it
-- means, that no errors occured and a file only had a finilizer associated with it.
--
-- @since 0.2.4
restoreFileWithErrors ::
       (MonadResource m)
    => Bool -- ^ Lenient flag, results in exceptions thrown instead of collected when set to @False@.
    -> FileInfo
    -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileWithErrors :: forall (m :: * -> *).
MonadResource m =>
Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileWithErrors = Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *).
MonadResource m =>
Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileInternal