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

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