{-# 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,
  extractTarGzFile,

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

-- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.compress forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write 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 -- ^ Destination directory
                 -> FilePath -- ^ Expected subdir (to check for tarbombs)
                 -> FilePath -- ^ Tarball
                -> IO ()
extractTarGzFile :: FilePath -> FilePath -> FilePath -> IO ()
extractTarGzFile FilePath
dir FilePath
expected FilePath
tar =
  forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack FilePath
dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. FilePath -> Entries e -> Entries (Either e TarBombError)
Tar.checkTarbomb FilePath
expected forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress 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) = forall e. Exception e => e -> SomeException
toException a
e
  toException (Right b
e) = forall e. Exception e => e -> SomeException
toException b
e

  fromException :: SomeException -> Maybe (Either a b)
fromException SomeException
e =
    case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just a
e' -> forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left a
e')
      Maybe a
Nothing -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                   Just b
e' -> forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right b
e')
                   Maybe b
Nothing -> forall a. Maybe a
Nothing


-- | 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 forall a. Eq a => a -> a -> Bool
== TypeCode
buildTreeRefTypeCode
     Bool -> Bool -> Bool
|| TypeCode
typeCode 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 =
  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 forall e. Entry -> Entries e -> Entries e
Tar.Next Entry
e Entries e
es else Entries e
es)
    forall e. Entries e
Tar.Done
    forall e. e -> Entries 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 =
  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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Entry -> Entries e -> Entries e
Tar.Next Entry
entry Entries e
xs)
           else forall (m :: * -> *) a. Monad m => a -> m a
return Entries e
xs)
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Entries e
Tar.Done)
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Entries e
Tar.Fail)

entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]
entriesToList :: forall e. Exception e => Entries e -> [Entry]
entriesToList = forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
Tar.foldEntries (:) [] forall a e. Exception e => e -> a
throw