{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- | Utilities to implement cabal @v2-sdist@.
module Distribution.Client.SrcDist
  ( allPackageSourceFiles
  , packageDirToSdist
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify)
import Control.Monad.Trans (liftIO)
import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)

import Distribution.Client.Errors
import Distribution.Client.Utils (tryReadAddSourcePackageDesc)
import Distribution.Package (Package (packageId))
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.SrcDist (listPackageSourcesWithDie)
import Distribution.Simple.Utils (dieWithException)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import Distribution.Utils.Path
  ( getSymbolicPath
  , makeSymbolicPath
  )

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Set as Set
import System.Directory (canonicalizePath)
import System.FilePath

-- | List all source files of a given add-source dependency. Exits with error if
-- something is wrong (e.g. there is no .cabal file in the given directory).
--
-- Used in sandbox and projectbuilding.
-- TODO: when sandboxes are removed, move to ProjectBuilding.
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles Verbosity
verbosity FilePath
packageDir = do
  let err :: FilePath
err = FilePath
"Error reading source files of package."
  GenericPackageDescription
gpd <- Verbosity -> FilePath -> FilePath -> IO GenericPackageDescription
tryReadAddSourcePackageDesc Verbosity
verbosity FilePath
packageDir FilePath
err
  let pd :: PackageDescription
pd = GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd
  [SymbolicPath Pkg 'File]
srcs <-
    Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDescription
-> [PPSuffixHandler]
-> IO [SymbolicPath Pkg 'File]
listPackageSourcesWithDie
      Verbosity
verbosity
      (\Verbosity
_ CabalException
_ -> [res] -> IO [res]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
      (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just (SymbolicPath CWD ('Dir Pkg)
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> SymbolicPath CWD ('Dir Pkg)
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ FilePath -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
packageDir)
      PackageDescription
pd
      [PPSuffixHandler]
knownSuffixHandlers
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath [SymbolicPath Pkg 'File]
srcs

-- | Create a tarball for a package in a directory
packageDirToSdist
  :: Verbosity
  -> GenericPackageDescription
  -- ^ read in GPD
  -> FilePath
  -- ^ directory containing that GPD
  -> IO BSL.ByteString
  -- ^ resulting sdist tarball
packageDirToSdist :: Verbosity -> GenericPackageDescription -> FilePath -> IO ByteString
packageDirToSdist Verbosity
verbosity GenericPackageDescription
gpd FilePath
dir = do
  -- let thisDie :: Verbosity -> String -> IO a
  --    thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
  FilePath
absDir <- FilePath -> IO FilePath
canonicalizePath FilePath
dir
  [SymbolicPath Pkg 'File]
files' <- Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDescription
-> [PPSuffixHandler]
-> IO [SymbolicPath Pkg 'File]
listPackageSourcesWithDie Verbosity
verbosity Verbosity -> CabalException -> IO [res]
forall res. Verbosity -> CabalException -> IO [res]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just (SymbolicPath CWD ('Dir Pkg)
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> SymbolicPath CWD ('Dir Pkg)
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ FilePath -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
absDir) (GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd) [PPSuffixHandler]
knownSuffixHandlers
  let files :: [FilePath]
      files :: [FilePath]
files = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (SymbolicPath Pkg 'File -> FilePath)
-> SymbolicPath Pkg 'File
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath) [SymbolicPath Pkg 'File]
files'

  let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
      entriesM :: StateT (Set FilePath) (WriterT [Entry] IO) ()
entriesM = do
        let prefix :: FilePath
prefix = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (GenericPackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd)
        (Set FilePath -> Set FilePath)
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
prefix)
        case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
True FilePath
prefix of
          Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
          Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
forall tarPath linkTarget. tarPath -> GenEntry tarPath linkTarget
Tar.directoryEntry TarPath
path]

        [FilePath]
-> (FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
files ((FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
 -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> (FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
          let fileDir :: FilePath
fileDir = FilePath -> FilePath
takeDirectory (FilePath
prefix FilePath -> FilePath -> FilePath
</> FilePath
file)
          Bool
needsEntry <- (Set FilePath -> Bool)
-> StateT (Set FilePath) (WriterT [Entry] IO) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember FilePath
fileDir)

          Bool
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsEntry (StateT (Set FilePath) (WriterT [Entry] IO) ()
 -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ do
            (Set FilePath -> Set FilePath)
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
fileDir)
            case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
True FilePath
fileDir of
              Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
              Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
forall tarPath linkTarget. tarPath -> GenEntry tarPath linkTarget
Tar.directoryEntry TarPath
path]

          ByteString
contents <- IO ByteString
-> StateT (Set FilePath) (WriterT [Entry] IO) ByteString
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> StateT (Set FilePath) (WriterT [Entry] IO) ByteString)
-> (FilePath -> IO ByteString)
-> FilePath
-> StateT (Set FilePath) (WriterT [Entry] IO) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.fromStrict (IO ByteString -> IO ByteString)
-> (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile (FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ByteString)
-> FilePath
-> StateT (Set FilePath) (WriterT [Entry] IO) ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
          case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
False (FilePath
prefix FilePath -> FilePath -> FilePath
</> FilePath
file) of
            Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
            Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(TarPath -> ByteString -> Entry
forall tarPath linkTarget.
tarPath -> ByteString -> GenEntry tarPath linkTarget
Tar.fileEntry TarPath
path ByteString
contents){Tar.entryPermissions = Tar.ordinaryFilePermissions}]

  [Entry]
entries <- WriterT [Entry] IO () -> IO [Entry]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (StateT (Set FilePath) (WriterT [Entry] IO) ()
-> Set FilePath -> WriterT [Entry] IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Set FilePath) (WriterT [Entry] IO) ()
entriesM Set FilePath
forall a. Monoid a => a
mempty)
  let
    -- Pretend our GZip file is made on Unix.
    normalize :: ByteString -> ByteString
normalize ByteString
bs = [ByteString] -> ByteString
BSL.concat [ByteString
pfx, ByteString
"\x03", ByteString
rest']
      where
        (ByteString
pfx, ByteString
rest) = EpochTime -> ByteString -> (ByteString, ByteString)
BSL.splitAt EpochTime
9 ByteString
bs
        rest' :: ByteString
rest' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BSL.tail ByteString
rest
    -- The Unix epoch, which is the default value, is
    -- unsuitable because it causes unpacking problems on
    -- Windows; we need a post-1980 date. One gigasecond
    -- after the epoch is during 2001-09-09, so that does
    -- nicely. See #5596.
    setModTime :: Tar.Entry -> Tar.Entry
    setModTime :: Entry -> Entry
setModTime Entry
entry = Entry
entry{Tar.entryTime = 1000000000}
  ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> ([Entry] -> ByteString) -> [Entry] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
normalize (ByteString -> ByteString)
-> ([Entry] -> ByteString) -> [Entry] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.compress (ByteString -> ByteString)
-> ([Entry] -> ByteString) -> [Entry] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write ([Entry] -> IO ByteString) -> [Entry] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Entry -> Entry) -> [Entry] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entry -> Entry
setModTime [Entry]
entries