Skip to content
Snippets Groups Projects
Commit 68e9e1aa authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Add packageDirToSdist to CmdSdist

parent 8f0ffb7d
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
cabal-install/Distribution/Client/CmdSdist.hs
+ 21
− 68
View file @ 68e9e1aa
......@@ -51,6 +51,8 @@ import Distribution.Simple.Setup
)
import Distribution.Simple.SrcDist
( listPackageSources )
import Distribution.Client.SrcDist
( packageDirToSdist )
import Distribution.Simple.Utils
( die', notice, withOutputMarker, wrapText )
import Distribution.Types.ComponentName
......@@ -60,24 +62,13 @@ import Distribution.Types.PackageName
import Distribution.Verbosity
( normal )
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Monad.Trans
( liftIO )
import Control.Monad.State.Lazy
( StateT, modify, gets, evalStateT )
import Control.Monad.Writer.Lazy
( WriterT, tell, execWriterT )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Set as Set
import System.Directory
( getCurrentDirectory
, createDirectoryIfMissing, makeAbsolute
)
import System.FilePath
( (</>), (<.>), makeRelative, normalise, takeDirectory )
( (</>), (<.>), makeRelative, normalise )
-------------------------------------------------------------------------------
-- Command
......@@ -238,72 +229,34 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
RepoTarballPackage {} -> death
let -- Write String to stdout or file, using the default TextEncoding.
write
| outputFile == "-" = putStr . withOutputMarker verbosity
| otherwise = writeFile outputFile
write str
| outputFile == "-" = putStr (withOutputMarker verbosity str)
| otherwise = do
writeFile outputFile str
notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
-- Write raw ByteString to stdout or file as it is, without encoding.
writeLBS
| outputFile == "-" = BSL.putStr
| otherwise = BSL.writeFile outputFile
writeLBS lbs
| outputFile == "-" = BSL.putStr lbs
| otherwise = do
BSL.writeFile outputFile lbs
notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
case dir0 of
Left tgz -> do
case format of
TarGzArchive -> do
writeLBS =<< BSL.readFile tgz
when (outputFile /= "-") $
notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
_ -> die' verbosity ("cannot convert tarball package to " ++ show format)
Right dir -> do
files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers
let files = nub $ sort $ map normalise files'
Right dir -> case format of
SourceList nulSep -> do
files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers
let files = nub $ sort $ map normalise files'
let prefix = makeRelative projectRootDir dir
write $ concat [prefix </> i ++ [nulSep] | i <- files]
case format of
SourceList nulSep -> do
let prefix = makeRelative projectRootDir dir
write $ concat [prefix </> i ++ [nulSep] | i <- files]
when (outputFile /= "-") $
notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
TarGzArchive -> do
let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
entriesM = do
let prefix = prettyShow (packageId pkg)
modify (Set.insert prefix)
case Tar.toTarPath True prefix of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [Tar.directoryEntry path]
for_ files $ \file -> do
let fileDir = takeDirectory (prefix </> file)
needsEntry <- gets (Set.notMember fileDir)
when needsEntry $ do
modify (Set.insert fileDir)
case Tar.toTarPath True fileDir of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [Tar.directoryEntry path]
contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
case Tar.toTarPath False (prefix </> file) of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]
entries <- execWriterT (evalStateT entriesM mempty)
let -- Pretend our GZip file is made on Unix.
normalize bs = BSL.concat [pfx, "\x03", rest']
where
(pfx, rest) = BSL.splitAt 9 bs
rest' = BSL.tail 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 entry = entry { Tar.entryTime = 1000000000 }
writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries
when (outputFile /= "-") $
notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
TarGzArchive -> do
packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS
--
......
cabal-install/Distribution/Client/SrcDist.hs
+ 65
− 3
View file @ 68e9e1aa
{-# LANGUAGE OverloadedStrings #-}
-- | Utilities to implemenet cabal @v2-sdist@.
module Distribution.Client.SrcDist (
allPackageSourceFiles,
packageDirToSdist,
) where
import Distribution.Solver.Compat.Prelude
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.PackageDescription.Parsec (readGenericPackageDescription)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.SrcDist (listPackageSources)
import Distribution.Simple.SrcDist (listPackageSourcesWithDie)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils (die')
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import Distribution.Client.Utils (tryFindAddSourcePackageDesc)
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).
......@@ -29,3 +45,49 @@ allPackageSourceFiles verbosity packageDir = do
listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd 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 gpd dir = do
files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers
let files = nub $ sort $ map normalise files'
let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
entriesM = do
let prefix = prettyShow (packageId gpd)
modify (Set.insert prefix)
case Tar.toTarPath True prefix of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [Tar.directoryEntry path]
for_ files $ \file -> do
let fileDir = takeDirectory (prefix </> file)
needsEntry <- gets (Set.notMember fileDir)
when needsEntry $ do
modify (Set.insert fileDir)
case Tar.toTarPath True fileDir of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [Tar.directoryEntry path]
contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
case Tar.toTarPath False (prefix </> file) of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]
entries <- execWriterT (evalStateT entriesM mempty)
let -- Pretend our GZip file is made on Unix.
normalize bs = BSL.concat [pfx, "\x03", rest']
where
(pfx, rest) = BSL.splitAt 9 bs
rest' = BSL.tail 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 entry = entry { Tar.entryTime = 1000000000 }
return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment