{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Distribution.Client.Tar (
createTarGzFile,
extractTarGzFile,
buildTreeRefTypeCode,
buildTreeSnapshotTypeCode,
isBuildTreeRefTypeCode,
filterEntries,
filterEntriesM,
entriesToList,
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Data.ByteString.Lazy as BS
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Check as Tar
import qualified Codec.Compression.GZip as GZip
import qualified Distribution.Client.GZipUtils as GZipUtils
import Control.Exception (throw)
createTarGzFile :: FilePath
-> FilePath
-> FilePath
-> IO ()
createTarGzFile :: FilePath -> FilePath -> FilePath -> IO ()
createTarGzFile FilePath
tar FilePath
base FilePath
dir =
FilePath -> ByteString -> IO ()
BS.writeFile FilePath
tar (ByteString -> IO ())
-> ([Entry] -> ByteString) -> [Entry] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.compress (ByteString -> ByteString)
-> ([Entry] -> ByteString) -> [Entry] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write ([Entry] -> IO ()) -> IO [Entry] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> [FilePath] -> IO [Entry]
Tar.pack FilePath
base [FilePath
dir]
extractTarGzFile :: FilePath
-> FilePath
-> FilePath
-> IO ()
FilePath
dir FilePath
expected FilePath
tar =
FilePath -> Entries (Either FormatError TarBombError) -> IO ()
forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack FilePath
dir (Entries (Either FormatError TarBombError) -> IO ())
-> (ByteString -> Entries (Either FormatError TarBombError))
-> ByteString
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> Entries FormatError -> Entries (Either FormatError TarBombError)
forall e. FilePath -> Entries e -> Entries (Either e TarBombError)
Tar.checkTarbomb FilePath
expected (Entries FormatError -> Entries (Either FormatError TarBombError))
-> (ByteString -> Entries FormatError)
-> ByteString
-> Entries (Either FormatError TarBombError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
(ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
BS.readFile FilePath
tar
instance (Exception a, Exception b) => Exception (Either a b) where
toException :: Either a b -> SomeException
toException (Left a
e) = a -> SomeException
forall e. Exception e => e -> SomeException
toException a
e
toException (Right b
e) = b -> SomeException
forall e. Exception e => e -> SomeException
toException b
e
fromException :: SomeException -> Maybe (Either a b)
fromException SomeException
e =
case SomeException -> Maybe a
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just a
e' -> Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (a -> Either a b
forall a b. a -> Either a b
Left a
e')
Maybe a
Nothing -> case SomeException -> Maybe b
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just b
e' -> Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (b -> Either a b
forall a b. b -> Either a b
Right b
e')
Maybe b
Nothing -> Maybe (Either a b)
forall a. Maybe a
Nothing
buildTreeRefTypeCode :: Tar.TypeCode
buildTreeRefTypeCode :: TypeCode
buildTreeRefTypeCode = TypeCode
'C'
buildTreeSnapshotTypeCode :: Tar.TypeCode
buildTreeSnapshotTypeCode :: TypeCode
buildTreeSnapshotTypeCode = TypeCode
'S'
isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool
isBuildTreeRefTypeCode :: TypeCode -> Bool
isBuildTreeRefTypeCode TypeCode
typeCode
| (TypeCode
typeCode TypeCode -> TypeCode -> Bool
forall a. Eq a => a -> a -> Bool
== TypeCode
buildTreeRefTypeCode
Bool -> Bool -> Bool
|| TypeCode
typeCode TypeCode -> TypeCode -> Bool
forall a. Eq a => a -> a -> Bool
== TypeCode
buildTreeSnapshotTypeCode) = Bool
True
| Bool
otherwise = Bool
False
filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e
filterEntries :: (Entry -> Bool) -> Entries e -> Entries e
filterEntries Entry -> Bool
p =
(Entry -> Entries e -> Entries e)
-> Entries e -> (e -> Entries e) -> Entries e -> Entries e
forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
Tar.foldEntries
(\Entry
e Entries e
es -> if Entry -> Bool
p Entry
e then Entry -> Entries e -> Entries e
forall e. Entry -> Entries e -> Entries e
Tar.Next Entry
e Entries e
es else Entries e
es)
Entries e
forall e. Entries e
Tar.Done
e -> Entries e
forall e. e -> Entries e
Tar.Fail
filterEntriesM :: Monad m => (Tar.Entry -> m Bool)
-> Tar.Entries e -> m (Tar.Entries e)
filterEntriesM :: (Entry -> m Bool) -> Entries e -> m (Entries e)
filterEntriesM Entry -> m Bool
p =
(Entry -> m (Entries e) -> m (Entries e))
-> m (Entries e)
-> (e -> m (Entries e))
-> Entries e
-> m (Entries e)
forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
Tar.foldEntries
(\Entry
entry m (Entries e)
rest -> do
Bool
keep <- Entry -> m Bool
p Entry
entry
Entries e
xs <- m (Entries e)
rest
if Bool
keep
then Entries e -> m (Entries e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> Entries e -> Entries e
forall e. Entry -> Entries e -> Entries e
Tar.Next Entry
entry Entries e
xs)
else Entries e -> m (Entries e)
forall (m :: * -> *) a. Monad m => a -> m a
return Entries e
xs)
(Entries e -> m (Entries e)
forall (m :: * -> *) a. Monad m => a -> m a
return Entries e
forall e. Entries e
Tar.Done)
(Entries e -> m (Entries e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entries e -> m (Entries e))
-> (e -> Entries e) -> e -> m (Entries e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Entries e
forall e. e -> Entries e
Tar.Fail)
entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]
entriesToList :: Entries e -> [Entry]
entriesToList = (Entry -> [Entry] -> [Entry])
-> [Entry] -> (e -> [Entry]) -> Entries e -> [Entry]
forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
Tar.foldEntries (:) [] e -> [Entry]
forall a e. Exception e => e -> a
throw