{-# 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 (dieWithException)
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
import Distribution.Client.Errors
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles Verbosity
verbosity FilePath
packageDir = do
pd <- do
let err :: FilePath
err = FilePath
"Error reading source files of package."
desc <- Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindAddSourcePackageDesc Verbosity
verbosity FilePath
packageDir FilePath
err
flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc
listPackageSourcesWithDie verbosity (\Verbosity
_ CabalException
_ -> [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) packageDir pd knownSuffixHandlers
packageDirToSdist
:: Verbosity
-> GenericPackageDescription
-> FilePath
-> IO BSL.ByteString
packageDirToSdist :: Verbosity -> GenericPackageDescription -> FilePath -> IO ByteString
packageDirToSdist Verbosity
verbosity GenericPackageDescription
gpd FilePath
dir = do
files' <- Verbosity
-> (Verbosity -> CabalException -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSourcesWithDie Verbosity
verbosity Verbosity -> CabalException -> IO [FilePath]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException FilePath
dir (GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd) [PPSuffixHandler]
knownSuffixHandlers
let 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 = 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)
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)
when needsEntry $ do
modify (Set.insert fileDir)
case Tar.toTarPath True 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]
contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
case Tar.toTarPath False (prefix </> 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}]
entries <- execWriterT (evalStateT entriesM mempty)
let
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
setModTime :: Tar.Entry -> Tar.Entry
setModTime Entry
entry = Entry
entry{Tar.entryTime = 1000000000}
return . normalize . GZip.compress . Tar.write $ fmap setModTime entries