never executed always true always false

    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