cabal-install/src/Distribution/Client/Tar.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  Distribution.Client.Tar
   6 -- Copyright   :  (c) 2007 Bjorn Bringert,
   7 --                    2008 Andrea Vezzosi,
   8 --                    2008-2009 Duncan Coutts
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  duncan@community.haskell.org
  12 -- Portability :  portable
  13 --
  14 -- Reading, writing and manipulating \"@.tar@\" archive files.
  15 --
  16 -----------------------------------------------------------------------------
  17 module Distribution.Client.Tar (
  18   -- * @tar.gz@ operations
  19   createTarGzFile,
  20   extractTarGzFile,
  21
  22   -- * Other local utils
  23   buildTreeRefTypeCode,
  24   buildTreeSnapshotTypeCode,
  25   isBuildTreeRefTypeCode,
  26   filterEntries,
  27   filterEntriesM,
  28   entriesToList,
  29   ) where
  30
  31 import Distribution.Client.Compat.Prelude
  32 import Prelude ()
  33
  34 import qualified Data.ByteString.Lazy    as BS
  35 import qualified Codec.Archive.Tar       as Tar
  36 import qualified Codec.Archive.Tar.Entry as Tar
  37 import qualified Codec.Archive.Tar.Check as Tar
  38 import qualified Codec.Compression.GZip  as GZip
  39 import qualified Distribution.Client.GZipUtils as GZipUtils
  40
  41 -- for foldEntries...
  42 import Control.Exception (throw)
  43
  44 --
  45 -- * High level operations
  46 --
  47
  48 createTarGzFile :: FilePath  -- ^ Full Tarball path
  49                 -> FilePath  -- ^ Base directory
  50                 -> FilePath  -- ^ Directory to archive, relative to base dir
  51                 -> IO ()
  52 createTarGzFile tar base dir =
  53   BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]
  54
  55 extractTarGzFile :: FilePath -- ^ Destination directory
  56                  -> FilePath -- ^ Expected subdir (to check for tarbombs)
  57                  -> FilePath -- ^ Tarball
  58                 -> IO ()
  59 extractTarGzFile dir expected tar =
  60   Tar.unpack dir . Tar.checkTarbomb expected . Tar.read
  61   . GZipUtils.maybeDecompress =<< BS.readFile tar
  62
  63 instance (Exception a, Exception b) => Exception (Either a b) where
  64   toException (Left  e) = toException e
  65   toException (Right e) = toException e
  66
  67   fromException e =
  68     case fromException e of
  69       Just e' -> Just (Left e')
  70       Nothing -> case fromException e of
  71                    Just e' -> Just (Right e')
  72                    Nothing -> Nothing
  73
  74
  75 -- | Type code for the local build tree reference entry type. We don't use the
  76 -- symbolic link entry type because it allows only 100 ASCII characters for the
  77 -- path.
  78 buildTreeRefTypeCode :: Tar.TypeCode
  79 buildTreeRefTypeCode = 'C'
  80
  81 -- | Type code for the local build tree snapshot entry type.
  82 buildTreeSnapshotTypeCode :: Tar.TypeCode
  83 buildTreeSnapshotTypeCode = 'S'
  84
  85 -- | Is this a type code for a build tree reference?
  86 isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool
  87 isBuildTreeRefTypeCode typeCode
  88   | (typeCode == buildTreeRefTypeCode
  89      || typeCode == buildTreeSnapshotTypeCode) = True
  90   | otherwise                                  = False
  91
  92 filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e
  93 filterEntries p =
  94   Tar.foldEntries
  95     (\e es -> if p e then Tar.Next e es else es)
  96     Tar.Done
  97     Tar.Fail
  98
  99 filterEntriesM :: Monad m => (Tar.Entry -> m Bool)
 100                -> Tar.Entries e -> m (Tar.Entries e)
 101 filterEntriesM p =
 102   Tar.foldEntries
 103     (\entry rest -> do
 104          keep <- p entry
 105          xs   <- rest
 106          if keep
 107            then return (Tar.Next entry xs)
 108            else return xs)
 109     (return Tar.Done)
 110     (return . Tar.Fail)
 111
 112 entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]
 113 entriesToList = Tar.foldEntries (:) [] throw
 114