Merge pull request #6916 from phadej/packageDirToSdist

packageDirToSdist
haskell · Jun 18, 2020 · 5fc3d8c · 5fc3d8c
2 parents 8f0ffb7 + 68e9e1a
commit 5fc3d8c
Show file tree

Hide file tree

Showing 2 changed files with 86 additions and 71 deletions.
diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs
@@ -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
 
 --
 

diff --git a/cabal-install/Distribution/Client/SrcDist.hs b/cabal-install/Distribution/Client/SrcDist.hs
@@ -1,18 +1,34 @@
+{-# 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