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

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