{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Distribution.Client.Tar
(
createTarGzFile
, TarComp.extractTarGzFile
, buildTreeRefTypeCode
, buildTreeSnapshotTypeCode
, isBuildTreeRefTypeCode
, filterEntries
, filterEntriesM
, entriesToList
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString.Lazy as BS
import qualified Distribution.Client.Compat.Tar as TarComp
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]
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 :: forall e. (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 tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries
(\Entry
e Entries e
es -> if Entry -> Bool
p Entry
e then Entry -> Entries e -> Entries e
forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Tar.Next Entry
e Entries e
es else Entries e
es)
Entries e
forall tarPath linkTarget e. GenEntries tarPath linkTarget e
Tar.Done
e -> Entries e
forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Tar.Fail
filterEntriesM
:: Monad m
=> (Tar.Entry -> m Bool)
-> Tar.Entries e
-> m (Tar.Entries e)
filterEntriesM :: forall (m :: * -> *) e.
Monad m =>
(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 tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries
( \Entry
entry m (Entries e)
rest -> do
keep <- Entry -> m Bool
p Entry
entry
xs <- rest
if keep
then return (Tar.Next entry xs)
else return xs
)
(Entries e -> m (Entries e)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Entries e
forall tarPath linkTarget e. GenEntries tarPath linkTarget e
Tar.Done)
(Entries e -> m (Entries e)
forall a. a -> m a
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 tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Tar.Fail)
entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]
entriesToList :: forall e. Exception e => Entries e -> [Entry]
entriesToList = (Entry -> [Entry] -> [Entry])
-> [Entry]
-> (e -> [Entry])
-> GenEntries TarPath LinkTarget e
-> [Entry]
forall tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries (:) [] e -> [Entry]
forall a e. (?callStack::CallStack, Exception e) => e -> a
throw