{-# LANGUAGE OverloadedStrings #-}
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
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 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []) FilePath
packageDir PackageDescription
pd [PPSuffixHandler]
knownSuffixHandlers
packageDirToSdist
:: Verbosity
-> GenericPackageDescription
-> FilePath
-> IO BSL.ByteString
packageDirToSdist :: Verbosity -> GenericPackageDescription -> FilePath -> IO ByteString
packageDirToSdist Verbosity
verbosity GenericPackageDescription
gpd FilePath
dir = do
let thisDie :: Verbosity -> String -> IO a
thisDie :: forall a. Verbosity -> FilePath -> IO a
thisDie Verbosity
v FilePath
s = forall a. Verbosity -> FilePath -> IO a
die' Verbosity
v forall a b. (a -> b) -> a -> b
$ FilePath
"sdist of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd) forall a. [a] -> [a] -> [a]
++ FilePath
": " forall a. [a] -> [a] -> [a]
++ FilePath
s
[FilePath]
files' <- Verbosity
-> (Verbosity -> FilePath -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSourcesWithDie Verbosity
verbosity forall a. Verbosity -> FilePath -> IO a
thisDie FilePath
dir (GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd) [PPSuffixHandler]
knownSuffixHandlers
let files :: [FilePath]
files :: [FilePath]
files = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ 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 = forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " forall a. [a] -> [a] -> [a]
++ FilePath
err)
Right TarPath
path -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
Tar.directoryEntry TarPath
path]
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
files 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Ord a => a -> Set a -> Bool
Set.notMember FilePath
fileDir)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsEntry forall a b. (a -> b) -> a -> b
$ do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " forall a. [a] -> [a] -> [a]
++ FilePath
err)
Right TarPath
path -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
Tar.directoryEntry TarPath
path]
ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
"Error packing sdist: " forall a. [a] -> [a] -> [a]
++ FilePath
err)
Right TarPath
path -> 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 <- forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Set FilePath) (WriterT [Entry] IO) ()
entriesM forall a. Monoid a => a
mempty)
let
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
BSL.tail ByteString
rest
setModTime :: Tar.Entry -> Tar.Entry
setModTime :: Entry -> Entry
setModTime Entry
entry = Entry
entry { entryTime :: EpochTime
Tar.entryTime = EpochTime
1000000000 }
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.compress forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write 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