Merge pull request #3187 from martin-kolinek/sdist-build

Support building the sdist and upload tarball

Author: mgsloan

ChangeLog.md

@@ -1088,6 +1088,8 @@ Other enhancements:
 * `stack build --fast` turns off optimizations
 * Show progress while downloading package index
   [#1223](https://github.com/commercialhaskell/stack/issues/1223).
+* Allow running tests on tarball created by sdist and upload
+  [#717](https://github.com/commercialhaskell/stack/issues/717).
 
 Bug fixes:
 

src/Stack/Config.hs

@@ -44,6 +44,7 @@ module Stack.Config
   ,defaultConfigYaml
   ,getProjectConfig
   ,LocalConfigStatus(..)
+  ,removePathFromPackageEntry
   ) where
 
 import qualified Codec.Archive.Tar as Tar
@@ -791,6 +792,30 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
                     throwM $ UnexpectedArchiveContents dirs files
         _ -> return dir
 
+-- | Remove path from package entry. If the package entry contains subdirs, then it removes
+-- the subdir. If the package entry points to the path to remove, this function returns
+-- Nothing. If the package entry doesn't mention the path to remove, it is returned unchanged
+removePathFromPackageEntry
+    :: (StackMiniM env m, HasConfig env)
+    => EnvOverride
+    -> Path Abs Dir -- ^ project root
+    -> Path Abs Dir -- ^ path to remove
+    -> PackageEntry
+    -> m (Maybe PackageEntry)
+    -- ^ Nothing if the whole package entry should be removed, otherwise
+    -- it returns the updated PackageEntry
+removePathFromPackageEntry menv projectRoot pathToRemove packageEntry = do
+  locationPath <- resolvePackageLocation menv projectRoot (peLocation packageEntry)
+  case peSubdirs packageEntry of
+    [] -> if locationPath == pathToRemove then return Nothing else return (Just packageEntry)
+    subdirPaths -> do
+      let shouldKeepSubdir path = do
+            resolvedPath <- resolveDir locationPath path
+            return (pathToRemove /= resolvedPath)
+      filteredSubdirs <- filterM shouldKeepSubdir subdirPaths
+      if null filteredSubdirs then return Nothing else return (Just packageEntry {peSubdirs = filteredSubdirs})
+
+
 
 -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it.
 --

src/Stack/Options/SDistParser.hs

@@ -0,0 +1,29 @@
+module Stack.Options.SDistParser where
+
+import           Data.Monoid
+import           Options.Applicative
+import           Options.Applicative.Builder.Extra
+import           Stack.SDist
+import           Stack.Options.HpcReportParser (pvpBoundsOption)
+
+-- | Parser for arguments to `stack sdist` and `stack upload`
+sdistOptsParser :: Bool -- ^ Whether to sign by default `stack upload` does, `stack sdist` doesn't
+                -> Parser SDistOpts
+sdistOptsParser signDefault = SDistOpts <$>
+  many (strArgument $ metavar "DIR" <> completer dirCompleter) <*>
+  optional pvpBoundsOption <*>
+  ignoreCheckSwitch <*>
+  (if signDefault
+    then switch (long "no-signature" <> help "Do not sign & upload signatures")
+    else switch (long "sign" <> help "Sign & upload signatures")) <*>
+  strOption
+  (long "sig-server" <> metavar "URL" <> showDefault <>
+    value "https://sig.commercialhaskell.org" <>
+    help "URL") <*>
+  buildPackageOption
+  where
+    ignoreCheckSwitch =
+      switch (long "ignore-check"
+               <> help "Do not check package for common mistakes")
+    buildPackageOption =
+      boolFlags False "test-tarball" "building of the resulting tarball" idm

src/Stack/SDist.hs

@@ -11,18 +11,21 @@ module Stack.SDist
     ( getSDistTarball
     , checkSDistTarball
     , checkSDistTarball'
+    , SDistOpts (..)
     ) where
 
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
 import qualified Codec.Compression.GZip as GZip
 import           Control.Applicative
 import           Control.Concurrent.Execute (ActionContext(..))
-import           Control.Monad (unless, void, liftM)
+import           Control.Monad (unless, void, liftM, filterM, foldM, when)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
+import           Control.Monad.Reader.Class (local)
 import           Control.Monad.Trans.Control (liftBaseWith)
+import           Control.Monad.Trans.Unlift (MonadBaseUnlift)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
@@ -35,7 +38,7 @@ import           Data.List.Extra (nubOrd)
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromMaybe)
+import           Data.Maybe (fromMaybe, catMaybes)
 import           Data.Monoid ((<>))
 import qualified Data.Set as Set
 import qualified Data.Text as T
@@ -50,14 +53,16 @@ import           Distribution.PackageDescription.PrettyPrint (showGenericPackage
 import           Distribution.Text (display)
 import           Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion)
 import           Distribution.Version.Extra
+import           Lens.Micro (set)
 import           Path
 import           Path.IO hiding (getModificationTime, getPermissions)
 import           Prelude -- Fix redundant import warnings
-import           Stack.Build (mkBaseConfigOpts)
+import           Stack.Build (mkBaseConfigOpts, build)
 import           Stack.Build.Execute
 import           Stack.Build.Installed
 import           Stack.Build.Source (loadSourceMap, getDefaultPackageConfig)
 import           Stack.Build.Target
+import           Stack.Config (resolvePackageEntry, removePathFromPackageEntry)
 import           Stack.Constants
 import           Stack.Package
 import           Stack.Types.Build
@@ -74,6 +79,21 @@ import qualified System.FilePath as FP
 -- | Special exception to throw when you want to fail because of bad results
 -- of package check.
 
+data SDistOpts = SDistOpts
+  { sdoptsDirsToWorkWith :: [String]
+  -- ^ Directories to package
+  , sdoptsPvpBounds :: Maybe PvpBounds
+  -- ^ PVP Bounds overrides
+  , sdoptsIgnoreCheck :: Bool
+  -- ^ Whether to ignore check of the package for common errors
+  , sdoptsSign :: Bool
+  -- ^ Whether to sign the package
+  , sdoptsSignServerUrl :: String
+  -- ^ The URL of the signature server
+  , sdoptsBuildTarball :: Bool
+  -- ^ Whether to build the tarball
+  }
+
 newtype CheckException
   = CheckException (NonEmpty Check.PackageCheck)
   deriving (Typeable)
@@ -317,13 +337,21 @@ dirsFromFiles dirs = Set.toAscList (Set.delete "." results)
 -- and will throw an exception in case of critical errors.
 --
 -- Note that we temporarily decompress the archive to analyze it.
-checkSDistTarball :: (StackM env m, HasEnvConfig env)
-  => Path Abs File -- ^ Absolute path to tarball
+checkSDistTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
+  => SDistOpts -- ^ The configuration of what to check
+  -> Path Abs File -- ^ Absolute path to tarball
   -> m ()
-checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do
+checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do
     pkgDir  <- (pkgDir' </>) `liftM`
         (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)
     --               ^ drop ".tar"     ^ drop ".gz"
+    when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir)
+    unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir)
+
+checkPackageInExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
+  => Path Abs Dir -- ^ Absolute path to tarball
+  -> m ()
+checkPackageInExtractedTarball pkgDir = do
     cabalfp <- findOrGenerateCabalFile pkgDir
     name    <- parsePackageNameFromFilePath cabalfp
     config  <- getDefaultPackageConfig
@@ -345,16 +373,56 @@ checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do
         Nothing -> return ()
         Just ne -> throwM $ CheckException ne
 
+buildExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) => Path Abs Dir -> m ()
+buildExtractedTarball pkgDir = do
+  projectRoot <- view projectRootL
+  envConfig <- view envConfigL
+  menv <- getMinimalEnvOverride
+  localPackageToBuild <- readLocalPackage pkgDir
+  let packageEntries = bcPackageEntries (envConfigBuildConfig envConfig)
+      getPaths entry = do
+        resolvedEntry <- resolvePackageEntry menv projectRoot entry
+        return $ fmap fst resolvedEntry
+  allPackagePaths <- fmap mconcat (mapM getPaths packageEntries)
+  -- We remove the path based on the name of the package
+  let isPathToRemove path = do
+        localPackage <- readLocalPackage path
+        return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)
+  pathsToRemove <- filterM isPathToRemove allPackagePaths
+  let adjustPackageEntries entries path = do
+        adjustedPackageEntries <- mapM (removePathFromPackageEntry menv projectRoot path) entries
+        return (catMaybes adjustedPackageEntries)
+  entriesWithoutBuiltPackage <- foldM adjustPackageEntries packageEntries pathsToRemove
+  let newEntry = PackageEntry Nothing (PLFilePath (toFilePath pkgDir)) []
+  newPackagesRef <- liftIO (newIORef Nothing)
+  let adjustEnvForBuild env =
+        let updatedEnvConfig = envConfig
+              {envConfigPackagesRef = newPackagesRef
+              ,envConfigBuildConfig = updatePackageInBuildConfig (envConfigBuildConfig envConfig)
+              }
+        in set envConfigL updatedEnvConfig env
+      updatePackageInBuildConfig buildConfig = buildConfig
+        { bcPackageEntries = newEntry : entriesWithoutBuiltPackage
+        , bcConfig = (bcConfig buildConfig)
+                     { configBuild = defaultBuildOpts
+                       { boptsTests = True
+                       }
+                     }
+        }
+  local adjustEnvForBuild $
+    build (const (return ())) Nothing defaultBuildOptsCLI
+
 -- | Version of 'checkSDistTarball' that first saves lazy bytestring to
 -- temporary directory and then calls 'checkSDistTarball' on it.
-checkSDistTarball' :: (StackM env m, HasEnvConfig env)
-  => String       -- ^ Tarball name
+checkSDistTarball' :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
+  => SDistOpts
+  -> String       -- ^ Tarball name
   -> L.ByteString -- ^ Tarball contents as a byte string
   -> m ()
-checkSDistTarball' name bytes = withSystemTempDir "stack" $ \tpath -> do
+checkSDistTarball' opts name bytes = withSystemTempDir "stack" $ \tpath -> do
     npath   <- (tpath </>) `liftM` parseRelFile name
     liftIO $ L.writeFile (toFilePath npath) bytes
-    checkSDistTarball npath
+    checkSDistTarball opts npath
 
 withTempTarGzContents :: (MonadIO m, MonadMask m)
   => Path Abs File         -- ^ Location of tarball

src/main/Main.hs

@@ -82,17 +82,19 @@ import           Stack.Options.DotParser
 import           Stack.Options.ExecParser
 import           Stack.Options.GhciParser
 import           Stack.Options.GlobalParser
+
 import           Stack.Options.HpcReportParser
 import           Stack.Options.NewParser
 import           Stack.Options.NixParser
 import           Stack.Options.ScriptParser
+import           Stack.Options.SDistParser
 import           Stack.Options.SolverParser
 import           Stack.Options.Utils
 import qualified Stack.PackageIndex
 import qualified Stack.Path
 import           Stack.Runners
 import           Stack.Script
-import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball')
+import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..))
 import           Stack.SetupCmd
 import qualified Stack.Sig as Sig
 import           Stack.Solver (solveExtraDeps)
@@ -299,26 +301,12 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
             "upload"
             "Upload a package to Hackage"
             uploadCmd
-            ((,,,,) <$> many (strArgument $ metavar "TARBALL/DIR" <> completer fileCompleter) <*>
-             optional pvpBoundsOption <*>
-             ignoreCheckSwitch <*>
-             switch (long "no-signature" <> help "Do not sign & upload signatures") <*>
-             strOption
-             (long "sig-server" <> metavar "URL" <> showDefault <>
-              value "https://sig.commercialhaskell.org" <>
-              help "URL"))
+            (sdistOptsParser True)
         addCommand'
             "sdist"
             "Create source distribution tarballs"
             sdistCmd
-            ((,,,,) <$> many (strArgument $ metavar "DIR" <> completer dirCompleter) <*>
-             optional pvpBoundsOption <*>
-             ignoreCheckSwitch <*>
-             switch (long "sign" <> help "Sign & upload signatures") <*>
-             strOption
-             (long "sig-server" <> metavar "URL" <> showDefault <>
-              value "https://sig.commercialhaskell.org" <>
-              help "URL"))
+            (sdistOptsParser False)
         addCommand' "dot"
                     "Visualize your project's dependency graph using Graphviz dot"
                     dotCmd
@@ -447,10 +435,6 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
                         hpcReportOptsParser)
         )
       where
-        ignoreCheckSwitch =
-            switch (long "ignore-check"
-                    <> help "Do not check package for common mistakes")
-
         -- addCommand hiding global options
         addCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a
                     -> AddCommand
@@ -672,15 +656,15 @@ upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $
             upgradeOpts'
 
 -- | Upload to Hackage
-uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO ()
-uploadCmd ([], _, _, _, _) _ = throwString "Error: To upload the current package, please run 'stack upload .'"
-uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
+uploadCmd :: SDistOpts -> GlobalOpts -> IO ()
+uploadCmd (SDistOpts [] _ _ _ _ _) _ = throwString "Error: To upload the current package, please run 'stack upload .'"
+uploadCmd sdistOpts go = do
     let partitionM _ [] = return ([], [])
         partitionM f (x:xs) = do
             r <- f x
             (as, bs) <- partitionM f xs
             return $ if r then (x:as, bs) else (as, x:bs)
-    (files, nonFiles) <- partitionM D.doesFileExist args
+    (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)
     (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles
     unless (null invalid) $ do
         hPutStrLn stderr $
@@ -690,55 +674,54 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
     withBuildConfigAndLock go $ \_ -> do
         config <- view configL
         getCreds <- liftIO (runOnce (Upload.loadCreds config))
-        unless ignoreCheck $
-            mapM_ (resolveFile' >=> checkSDistTarball) files
+        mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
         forM_
             files
             (\file ->
                   do tarFile <- resolveFile' file
                      liftIO $ do
                        creds <- getCreds
                        Upload.upload creds (toFilePath tarFile)
-                     unless
-                         don'tSign
+                     when
+                         (sdoptsSign sdistOpts)
                          (void $
                           Sig.sign
-                              sigServerUrl
+                              (sdoptsSignServerUrl sdistOpts)
                               tarFile))
         unless (null dirs) $
             forM_ dirs $ \dir -> do
                 pkgDir <- resolveDir' dir
-                (tarName, tarBytes, mcabalRevision) <- getSDistTarball mpvpBounds pkgDir
-                unless ignoreCheck $ checkSDistTarball' tarName tarBytes
+                (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir
+                checkSDistTarball' sdistOpts tarName tarBytes
                 liftIO $ do
                   creds <- getCreds
                   Upload.uploadBytes creds tarName tarBytes
                   forM_ mcabalRevision $ uncurry $ Upload.uploadRevision creds
                 tarPath <- parseRelFile tarName
-                unless
-                    don'tSign
+                when
+                    (sdoptsSign sdistOpts)
                     (void $
                      Sig.signTarBytes
-                         sigServerUrl
+                         (sdoptsSignServerUrl sdistOpts)
                          tarPath
                          tarBytes)
 
-sdistCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO ()
-sdistCmd (dirs, mpvpBounds, ignoreCheck, sign, sigServerUrl) go =
+sdistCmd :: SDistOpts -> GlobalOpts -> IO ()
+sdistCmd sdistOpts go =
     withBuildConfig go $ do -- No locking needed.
         -- If no directories are specified, build all sdist tarballs.
-        dirs' <- if null dirs
+        dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)
             then liftM Map.keys getLocalPackages
-            else mapM resolveDir' dirs
+            else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)
         forM_ dirs' $ \dir -> do
-            (tarName, tarBytes, _mcabalRevision) <- getSDistTarball mpvpBounds dir
+            (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir
             distDir <- distDirFromDir dir
             tarPath <- (distDir </>) <$> parseRelFile tarName
             ensureDir (parent tarPath)
             liftIO $ L.writeFile (toFilePath tarPath) tarBytes
-            unless ignoreCheck (checkSDistTarball tarPath)
+            checkSDistTarball sdistOpts tarPath
             $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)
-            when sign (void $ Sig.sign sigServerUrl tarPath)
+            when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath)
 
 -- | Execute a command.
 execCmd :: ExecOpts -> GlobalOpts -> IO ()

stack.cabal

@@ -137,6 +137,7 @@ library
                      Stack.Options.PackageParser
                      Stack.Options.ResolverParser
                      Stack.Options.ScriptParser
+                     Stack.Options.SDistParser
                      Stack.Options.SolverParser
                      Stack.Options.TestParser
                      Stack.Options.Utils