{-# LANGUAGE OverloadedStrings #-}
-- | 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 System.FilePath           (normalise, takeDirectory, (</>))

import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc)
import Distribution.Package                          (Package (packageId))
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.Simple.PackageDescription        (readGenericPackageDescription)
import Distribution.Simple.PreProcess                (knownSuffixHandlers)
import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)
import Distribution.Simple.Utils                     (die')
import Distribution.Types.GenericPackageDescription  (GenericPackageDescription)

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

-- | 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
  PackageDescription
pd <- do
    let err :: FilePath
err = FilePath
"Error reading source files of package."
    FilePath
desc <- Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindAddSourcePackageDesc Verbosity
verbosity FilePath
packageDir FilePath
err
    GenericPackageDescription -> PackageDescription
flattenPackageDescription (GenericPackageDescription -> PackageDescription)
-> IO GenericPackageDescription -> IO PackageDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity FilePath
desc

  Verbosity
-> (Verbosity -> FilePath -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSourcesWithDie Verbosity
verbosity (\Verbosity
_ FilePath
_ -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []) FilePath
packageDir PackageDescription
pd [PPSuffixHandler]
knownSuffixHandlers

-- | 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 :: Verbosity -> FilePath -> IO a
thisDie Verbosity
v FilePath
s = Verbosity -> FilePath -> IO a
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
v (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"sdist of " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (GenericPackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s

    [FilePath]
files' <- Verbosity
-> (Verbosity -> FilePath -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSourcesWithDie Verbosity
verbosity Verbosity -> FilePath -> IO [FilePath]
forall a. Verbosity -> FilePath -> IO a
thisDie FilePath
dir (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
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise [FilePath]
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 (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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err)
                Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
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 (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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err)
                        Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
Tar.directoryEntry TarPath
path]

                ByteString
contents <- IO ByteString
-> StateT (Set FilePath) (WriterT [Entry] IO) ByteString
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 (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 (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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err)
                    Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(TarPath -> ByteString -> Entry
Tar.fileEntry TarPath
path ByteString
contents) { entryPermissions :: Permissions
Tar.entryPermissions = Permissions
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) = Int64 -> ByteString -> (ByteString, ByteString)
BSL.splitAt Int64
9 ByteString
bs
                rest' :: ByteString
rest' = 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 { entryTime :: Int64
Tar.entryTime = Int64
1000000000 }
    ByteString -> IO ByteString
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entry -> Entry
setModTime [Entry]
entries