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

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