{-# 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 (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 -- ^ Destination directory
                 -> FilePath -- ^ Expected subdir (to check for tarbombs)
                 -> FilePath -- ^ Tarball
                -> IO ()
extractTarGzFile :: FilePath -> FilePath -> FilePath -> IO ()
extractTarGzFile 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


-- | 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 :: (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