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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 -- | Utilities to implement cabal @v2-sdist@.
   3 module Distribution.Client.SrcDist (
   4     allPackageSourceFiles,
   5     packageDirToSdist,
   6 )  where
   7
   8 import Distribution.Client.Compat.Prelude
   9 import Prelude ()
  10
  11 import Control.Monad.State.Lazy  (StateT, evalStateT, gets, modify)
  12 import Control.Monad.Trans       (liftIO)
  13 import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)
  14 import System.FilePath           (normalise, takeDirectory, (</>))
  15
  16 import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc)
  17 import Distribution.Package                          (Package (packageId))
  18 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
  19 import Distribution.Simple.PackageDescription        (readGenericPackageDescription)
  20 import Distribution.Simple.PreProcess                (knownSuffixHandlers)
  21 import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)
  22 import Distribution.Simple.Utils                     (die')
  23 import Distribution.Types.GenericPackageDescription  (GenericPackageDescription)
  24
  25 import qualified Codec.Archive.Tar       as Tar
  26 import qualified Codec.Archive.Tar.Entry as Tar
  27 import qualified Codec.Compression.GZip  as GZip
  28 import qualified Data.ByteString         as BS
  29 import qualified Data.ByteString.Lazy    as BSL
  30 import qualified Data.Set                as Set
  31
  32 -- | List all source files of a given add-source dependency. Exits with error if
  33 -- something is wrong (e.g. there is no .cabal file in the given directory).
  34 --
  35 -- Used in sandbox and projectbuilding.
  36 -- TODO: when sandboxes are removed, move to ProjectBuilding.
  37 --
  38 allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
  39 allPackageSourceFiles verbosity packageDir = do
  40   pd <- do
  41     let err = "Error reading source files of package."
  42     desc <- tryFindAddSourcePackageDesc verbosity packageDir err
  43     flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc
  44
  45   listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers
  46
  47 -- | Create a tarball for a package in a directory
  48 packageDirToSdist
  49     :: Verbosity
  50     -> GenericPackageDescription  -- ^ read in GPD
  51     -> FilePath                   -- ^ directory containing that GPD
  52     -> IO BSL.ByteString          -- ^ resulting sdist tarball
  53 packageDirToSdist verbosity gpd dir = do
  54     let thisDie :: Verbosity -> String -> IO a
  55         thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
  56
  57     files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers
  58     let files :: [FilePath]
  59         files = nub $ sort $ map normalise files'
  60
  61     let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
  62         entriesM = do
  63             let prefix = prettyShow (packageId gpd)
  64             modify (Set.insert prefix)
  65             case Tar.toTarPath True prefix of
  66                 Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
  67                 Right path -> tell [Tar.directoryEntry path]
  68
  69             for_ files $ \file -> do
  70                 let fileDir = takeDirectory (prefix </> file)
  71                 needsEntry <- gets (Set.notMember fileDir)
  72
  73                 when needsEntry $ do
  74                     modify (Set.insert fileDir)
  75                     case Tar.toTarPath True fileDir of
  76                         Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
  77                         Right path -> tell [Tar.directoryEntry path]
  78
  79                 contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
  80                 case Tar.toTarPath False (prefix </> file) of
  81                     Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
  82                     Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]
  83
  84     entries <- execWriterT (evalStateT entriesM mempty)
  85     let -- Pretend our GZip file is made on Unix.
  86         normalize bs = BSL.concat [pfx, "\x03", rest']
  87             where
  88                 (pfx, rest) = BSL.splitAt 9 bs
  89                 rest' = BSL.tail rest
  90         -- The Unix epoch, which is the default value, is
  91         -- unsuitable because it causes unpacking problems on
  92         -- Windows; we need a post-1980 date. One gigasecond
  93         -- after the epoch is during 2001-09-09, so that does
  94         -- nicely. See #5596.
  95         setModTime :: Tar.Entry -> Tar.Entry
  96         setModTime entry = entry { Tar.entryTime = 1000000000 }
  97     return . normalize . GZip.compress . Tar.write $ fmap setModTime entries