Issue 5586 srcpkgrepo not local

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
 
 --
 

cabal-install/Distribution/Client/FetchUtils.hs

@@ -99,8 +99,8 @@ checkFetched loc = case loc of
       return (Just $ RemoteTarballPackage uri file)
     RepoTarballPackage repo pkgid (Just file) ->
       return (Just $ RepoTarballPackage repo pkgid file)
-    RemoteSourceRepoPackage repo (Just dir) ->
-      return (Just $ RemoteSourceRepoPackage repo dir)
+    RemoteSourceRepoPackage repo (Just file) ->
+      return (Just $ RemoteSourceRepoPackage repo file)
 
     RemoteTarballPackage     _uri Nothing -> return Nothing
     RemoteSourceRepoPackage _repo Nothing -> return Nothing

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -200,13 +200,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
           -- artifacts under the shared dist directory.
           dryRunLocalPkg pkg depsBuildStatus srcdir
 
-        Just (RemoteSourceRepoPackage _repo srcdir) ->
-          -- At this point, source repos are essentially the same as local
-          -- dirs, since we've already download them.
-          dryRunLocalPkg pkg depsBuildStatus srcdir
-
-        -- The three tarball cases are handled the same as each other,
-        -- though depending on the build style.
+        -- The rest cases are all tarball cases are,
+        -- and handled the same as each other though depending on the build style.
         Just (LocalTarballPackage    tarball) ->
           dryRunTarballPkg pkg depsBuildStatus tarball
 
@@ -216,6 +211,10 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
         Just (RepoTarballPackage _ _ tarball) ->
           dryRunTarballPkg pkg depsBuildStatus tarball
 
+        Just (RemoteSourceRepoPackage _repo tarball) ->
+          dryRunTarballPkg pkg depsBuildStatus tarball
+
+
     dryRunTarballPkg :: ElaboratedConfiguredPackage
                      -> [BuildStatus]
                      -> FilePath

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -127,6 +127,8 @@ import Distribution.Version
          ( Version )
 import qualified Distribution.Deprecated.ParseUtils as OldParser
          ( ParseResult(..), locatedErrorMsg, showPWarning )
+import Distribution.Client.SrcDist
+         ( packageDirToSdist )
 
 import qualified Codec.Archive.Tar       as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
@@ -1170,6 +1172,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
         syncSourceRepos verbosity vcs
           [ (repo, repoPath)
           | (repo, _, repoPath) <- repoGroupWithPaths ]
+        -- TODO phadej 2020-06-18 add post-sync script
 
         -- But for reading we go through each 'SourceRepo' including its subdir
         -- value and have to know which path each one ended up in.
@@ -1199,24 +1202,30 @@ syncAndReadSourcePackagesRemoteRepos verbosity
                   : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]
 
     readPackageFromSourceRepo
-        :: SourceRepositoryPackage Maybe -> FilePath
+        :: SourceRepositoryPackage Maybe
+        -> FilePath
         -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
     readPackageFromSourceRepo repo repoPath = do
-        let packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
+        let packageDir :: FilePath
+            packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
+
         entries <- liftIO $ getDirectoryContents packageDir
-        --TODO: wrap exceptions
+        --TODO: dcoutts 2018-06-23: wrap exceptions
         case filter (\e -> takeExtension e == ".cabal") entries of
           []       -> liftIO $ throwIO $ NoCabalFileFound packageDir
           (_:_:_)  -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir
           [cabalFileName] -> do
+            let cabalFilePath = packageDir </> cabalFileName
             monitorFiles [monitorFileHashed cabalFilePath]
-            liftIO $ fmap (mkSpecificSourcePackage location)
-                   . readSourcePackageCabalFile verbosity cabalFilePath
-                 =<< BS.readFile cabalFilePath
-            where
-              cabalFilePath = packageDir </> cabalFileName
-              location      = RemoteSourceRepoPackage repo packageDir
+            gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath
+
+            -- write sdist tarball, to repoPath-pgkid
+            tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir
+            let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz"
+            liftIO $ LBS.writeFile tarballPath tarball
 
+            let location = RemoteSourceRepoPackage repo tarballPath
+            return $ mkSpecificSourcePackage location gpd
 
     reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
     reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems
@@ -1231,13 +1240,11 @@ syncAndReadSourcePackagesRemoteRepos verbosity
 --
 mkSpecificSourcePackage :: PackageLocation FilePath
                         -> GenericPackageDescription
-                        -> PackageSpecifier
-                             (SourcePackage (PackageLocation (Maybe FilePath)))
+                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
 mkSpecificSourcePackage location pkg =
     SpecificSourcePackage SourcePackage
       { srcpkgPackageId     = packageId pkg
       , srcpkgDescription   = pkg
-        --TODO: it is silly that we still have to use a Maybe FilePath here
       , srcpkgSource        = fmap Just location
       , srcpkgDescrOverride = Nothing
       }

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -593,19 +593,25 @@ rebuildInstallPlan verbosity
           Map.fromList
             [ (pkgname, stanzas)
             | pkg <- localPackages
+              -- TODO: misnormer: we should separate
+              -- builtin/global/inplace/local packages
+              -- and packages explicitly mentioned in the project
+              --
             , let pkgname            = pkgSpecifierTarget pkg
                   testsEnabled       = lookupLocalPackageConfig
                                          packageConfigTests
                                          projectConfig pkgname
                   benchmarksEnabled  = lookupLocalPackageConfig
                                          packageConfigBenchmarks
                                          projectConfig pkgname
-                  stanzas =
-                    Map.fromList $
+                  isLocal = isJust (shouldBeLocal pkg)
+                  stanzas
+                    | isLocal = Map.fromList $
                       [ (TestStanzas, enabled)
-                      | enabled <- flagToList testsEnabled ]
-                   ++ [ (BenchStanzas , enabled)
+                      | enabled <- flagToList testsEnabled ] ++
+                      [ (BenchStanzas , enabled)
                       | enabled <- flagToList benchmarksEnabled ]
+                    | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ]
             ]
 
     -- Elaborate the solver's install plan to get a fully detailed plan. This
@@ -823,10 +829,14 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
 
         -- Tarballs from remote URLs. We must have downloaded these already
         -- (since we extracted the .cabal file earlier)
-        --TODO: [required eventually] finish remote tarball functionality
---        allRemoteTarballPkgs =
---          [ (pkgid, )
---          | (pkgid, RemoteTarballPackage ) <- allPkgLocations ]
+        remoteTarballPkgs =
+          [ (pkgid, tarball)
+          | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ]
+
+        -- tarballs from source-repository-package stanzas
+        sourceRepoTarballPkgs =
+          [ (pkgid, tarball)
+          | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ]
 
         -- Tarballs from repositories, either where the repository provides
         -- hashes as part of the repo metadata, or where we will have to
@@ -906,6 +916,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
     --
     let allTarballFilePkgs :: [(PackageId, FilePath)]
         allTarballFilePkgs = localTarballPkgs
+                          ++ remoteTarballPkgs
+                          ++ sourceRepoTarballPkgs
                           ++ repoTarballPkgsDownloaded
                           ++ repoTarballPkgsNewlyDownloaded
     hashesFromTarballFiles <- liftIO $
@@ -1925,16 +1937,6 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
         Set.fromList (catMaybes (map shouldBeLocal localPackages))
         --TODO: localPackages is a misnomer, it's all project packages
         -- here is where we decide which ones will be local!
-      where
-        shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId
-        shouldBeLocal NamedPackage{}              = Nothing
-        shouldBeLocal (SpecificSourcePackage pkg)
-          | LocalTarballPackage _ <- srcpkgSource pkg = Nothing
-          | otherwise = Just (packageId pkg)
-        -- TODO: Is it only LocalTarballPackages we can know about without
-        -- them being "local" in the sense meant here?
-        --
-        -- Also, review use of SourcePackage's loc vs ProjectPackageLocation
 
     pkgsUseSharedLibrary :: Set PackageId
     pkgsUseSharedLibrary =
@@ -1995,6 +1997,12 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
 
 -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping
 
+shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId
+shouldBeLocal NamedPackage{}              = Nothing
+shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of
+    LocalUnpackedPackage _ -> Just (packageId pkg)
+    _                      -> Nothing
+
 -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'.
 matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool
 matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)