{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Tar
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009 Duncan Coutts
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-- Reading, writing and manipulating \"@.tar@\" archive files.
module Distribution.Client.Tar
  ( -- * @tar.gz@ operations
    createTarGzFile
  , TarComp.extractTarGzFile

    -- * Other local utils
  , 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

-- for foldEntries...
import Control.Exception (throw)

--

-- * High level operations

--

createTarGzFile
  :: FilePath
  -- ^ Full Tarball path
  -> FilePath
  -- ^ Base directory
  -> FilePath
  -- ^ Directory to archive, relative to base dir
  -> 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]

-- | Type code for the local build tree reference entry type. We don't use the
-- symbolic link entry type because it allows only 100 ASCII characters for the
-- path.
buildTreeRefTypeCode :: Tar.TypeCode
buildTreeRefTypeCode :: TypeCode
buildTreeRefTypeCode = TypeCode
'C'

-- | Type code for the local build tree snapshot entry type.
buildTreeSnapshotTypeCode :: Tar.TypeCode
buildTreeSnapshotTypeCode :: TypeCode
buildTreeSnapshotTypeCode = TypeCode
'S'

-- | Is this a type code for a build tree reference?
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
        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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> Entries e -> Entries e
forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Tar.Next Entry
entry Entries e
xs)
          else Entries e -> m (Entries e)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Entries e
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. Exception e => e -> a
throw