Merge branch 'master' into 401-docker-images

* master:
  #279 Add retries (default 3) to verifiedDownload
  Upper limit on number of flag combinations to test #543
  Flip order of build and test/bench opts parser
  Move `boptsCoverage` and `boptsNoTests` to `TestOpts`
  Replace `boptsAdditionalArgs` with fields in `FinalAction`
  Add benchmark and test options to FinalAction
  Implement `stack bench --benchmark-arguments`
  Fix #537
  Targets outside of root dir don't build (fixes #366)
  Add changelog for #517
  Add --no-run-tests parameter to stack test.

.gitignore

@@ -3,6 +3,7 @@
 *.swp
 *.tag
 *~
+*_flymake.hs
 .hsenv
 .stack-work/
 /.cabal-sandbox/

ChangeLog.md

@@ -2,6 +2,9 @@
 
 * Set the `HASKELL_DIST_DIR` environment variable [#524](https://github.com/commercialhaskell/stack/pull/524)
 * Track build status of tests and benchmarks [#525](https://github.com/commercialhaskell/stack/issues/525)
+* `--no-run-tests` [#517](https://github.com/commercialhaskell/stack/pull/517)
+* Targets outside of root dir don't build [#366](https://github.com/commercialhaskell/stack/issues/366)
+* Upper limit on number of flag combinations to test [#543](https://github.com/commercialhaskell/stack/issues/543)
 
 ## 0.1.2.0
 

src/Network/HTTP/Download.hs

@@ -4,6 +4,7 @@
 module Network.HTTP.Download
     ( verifiedDownload
     , DownloadRequest(..)
+    , drRetriesDefault
     , HashCheck(..)
     , CheckHexDigest(..)
     , LengthCheck
@@ -69,6 +70,7 @@ download req destpath = do
             { drRequest = req
             , drHashChecks = []
             , drLengthCheck = Nothing
+            , drRetries = drRetriesDefault
             }
     let progressHook = return ()
     verifiedDownload downloadReq destpath progressHook

src/Network/HTTP/Download/Verified.hs

@@ -9,6 +9,7 @@
 module Network.HTTP.Download.Verified
   ( verifiedDownload
   , DownloadRequest(..)
+  , drRetriesDefault
   , HashCheck(..)
   , CheckHexDigest(..)
   , LengthCheck
@@ -50,9 +51,14 @@ data DownloadRequest = DownloadRequest
     { drRequest :: Request
     , drHashChecks :: [HashCheck]
     , drLengthCheck :: Maybe LengthCheck
+    , drRetries :: Int
     }
   deriving Show
 
+-- | Default to retrying thrice.
+drRetriesDefault :: Int
+drRetriesDefault = 3
+
 data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck
   { hashCheckAlgorithm :: a
   , hashCheckHexDigest :: CheckHexDigest
@@ -84,6 +90,8 @@ data VerifiedDownloadException
           String -- algorithm
           CheckHexDigest -- expected
           String -- actual (shown)
+    | ZeroTries
+          Request
   deriving (Typeable)
 instance Show VerifiedDownloadException where
     show (WrongContentLength req expected actual) =
@@ -101,6 +109,10 @@ instance Show VerifiedDownloadException where
         ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"
         ++ "Actual:   " ++ actual ++ "\n"
         ++ "For: " ++ show (getUri req)
+    show (ZeroTries req) =
+        "Download expectation failure:\n"
+        ++ "Download was needed but <= 0 retries were requested.\n"
+        ++ "For: " ++ show (getUri req)
 
 instance Exception VerifiedDownloadException
 
@@ -168,6 +180,24 @@ sinkHashUsing _ = sinkHash
 hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
 hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
 
+-- TODO(DanBurton): use Control.Retry instead.
+-- Type inference drives the decision of which exceptions merit a retry.
+retry :: (MonadCatch m, Exception e)
+  => Int -- ^ The number of times to retry
+  -> m a -- ^ Action to retry
+  -> m (Either [e] a)
+retry n0 action =
+    go n0 []
+  where
+    go n es
+      | n <= 0 = return (Left es)
+      | otherwise = do
+          eRes <- try action
+          case eRes of
+            Left e -> go (n - 1) (e : es)
+            Right a -> return (Right a)
+
+
 -- | Copied and extended version of Network.HTTP.Download.download.
 --
 -- Has the following additional features:
@@ -178,7 +208,9 @@ hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
 -- * Verifies md5 if response includes content-md5 header
 -- * Verifies the expected hashes
 --
--- Throws VerifiedDownloadException, and whatever else "download" throws.
+-- Throws VerifiedDownloadException.
+-- Throws IOExceptions related to file system operations.
+-- Throws HttpException.
 verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
          => DownloadRequest
          -> Path Abs File -- ^ destination
@@ -189,9 +221,14 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
     env <- ask
     liftIO $ whenM' getShouldDownload $ do
         createDirectoryIfMissing True dir
-        withBinaryFile fptmp WriteMode $ \h ->
-            flip runReaderT env $
-                withResponse req (go h)
+        withBinaryFile fptmp WriteMode $ \h -> do
+            eRes <- retry drRetries $
+                flip runReaderT env $
+                    withResponse req (go h)
+            case (eRes :: Either [HttpException] ()) of
+                Left [] -> throwM $ ZeroTries req
+                Left (e:_) -> throwM e -- just re-throw the latest HttpException
+                Right () -> return ()
         renameFile fptmp fp
   where
     whenM' mp m = do

src/Stack/Build/Execute.hs

@@ -123,7 +123,7 @@ printPlan finalAction plan = do
     let mfinalLabel =
             case finalAction of
                 DoNothing -> Nothing
-                DoBenchmarks -> Just "benchmark"
+                DoBenchmarks _ -> Just "benchmark"
                 DoTests _ -> Just "test"
     case mfinalLabel of
         Nothing -> return ()
@@ -405,8 +405,8 @@ toActions runInBase ee (mbuild, mfinal) =
     mfunc =
         case boptsFinalAction $ eeBuildOpts ee of
             DoNothing -> Nothing
-            DoTests rerunTests -> Just (singleTest rerunTests, checkTest)
-            DoBenchmarks -> Just (singleBench, checkBench)
+            DoTests topts -> Just (singleTest topts, checkTest)
+            DoBenchmarks beopts -> Just (singleBench beopts, checkBench)
 
     checkTest task =
         case taskType task of
@@ -684,12 +684,12 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
             Set.empty
 
 singleTest :: M env m
-           => Bool -- ^ rerun tests?
+           => TestOpts
            -> ActionContext
            -> ExecuteEnv
            -> Task
            -> m ()
-singleTest rerunTests ac ee task =
+singleTest topts ac ee task =
     withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console mlogFile -> do
         (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"]
         config <- asks getConfig
@@ -701,7 +701,8 @@ singleTest rerunTests ac ee task =
                     TTLocal lp -> lpDirtyFiles lp
                     _ -> assert False True) ||
                 not testBuilt
-            needHpc = boptsCoverage (eeBuildOpts ee)
+
+            needHpc = toCoverage topts
 
             componentsRaw =
                 case taskType task of
@@ -721,15 +722,19 @@ singleTest rerunTests ac ee task =
             setTestBuilt pkgDir
 
         toRun <-
-            if rerunTests
-                then return True
-                else do
-                    success <- checkTestSuccess pkgDir
-                    if success
-                        then do
-                            unless (null testsToRun) $ announce "skipping already passed test"
-                            return False
-                        else return True
+            if toDisableRun topts
+              then do
+                  announce "Test running disabled by --no-run-tests flag."
+                  return False
+              else if toRerunTests topts
+                  then return True
+                  else do
+                      success <- checkTestSuccess pkgDir
+                      if success
+                          then do
+                              unless (null testsToRun) $ announce "skipping already passed test"
+                              return False
+                          else return True
 
         when toRun $ do
             bconfig <- asks getBuildConfig
@@ -762,11 +767,10 @@ singleTest rerunTests ac ee task =
                                 $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))
                             removeFileIfExists nameTix
 
-                        let args = boptsTestArgs (eeBuildOpts ee)
-                            argsDisplay =
-                                case args of
-                                  [] -> ""
-                                  _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
+                        let args = toAdditionalArgs topts
+                            argsDisplay = case args of
+                                            [] -> ""
+                                            _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
                         announce $ "test (suite: " <> testName <> argsDisplay <> ")"
                         let cp = (proc (toFilePath exeName) args)
                                 { cwd = Just $ toFilePath pkgDir
@@ -868,11 +872,12 @@ generateHpcReport pkgDir hpcDir dotHpcDir tixes = do
             , ["--reset-hpcdirs"]]
 
 singleBench :: M env m
-            => ActionContext
+            => BenchmarkOpts
+            -> ActionContext
             -> ExecuteEnv
             -> Task
             -> m ()
-singleBench ac ee task =
+singleBench beopts ac ee task =
     withSingleContext ac ee task $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do
         (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"]
 
@@ -892,9 +897,11 @@ singleBench ac ee task =
             config <- asks getConfig
             cabal (console && configHideTHLoading config) ["build"]
             setBenchBuilt pkgDir
-
+        let args = maybe []
+                         ((:[]) . ("--benchmark-options=" <>))
+                         (beoAdditionalArgs beopts)
         announce "benchmarks"
-        cabal False ["bench"]
+        cabal False ("bench" : args)
 
 -- | Grab all output from the given @Handle@ and print it to stdout, stripping
 -- Template Haskell "Loading package" lines. Does work in a separate thread.

src/Stack/Build/Source.hs

@@ -172,16 +172,18 @@ loadLocals :: forall m env .
            -> Map PackageName Version
            -> m ([LocalPackage], Set PackageName, Set PackageIdentifier)
 loadLocals bopts latestVersion = do
-    targets <- mapM parseTarget $
+    (isWanted', names, idents) <-
         case boptsTargets bopts of
-            [] -> ["."]
-            x -> x
-
-    -- Group targets by their kind
-    (dirs, names, idents) <-
-        case partitionEithers targets of
-            ([], targets') -> return $ partitionTargetSpecs targets'
-            (bad, _) -> throwM $ Couldn'tParseTargets bad
+            -- If there are no targets specified: build all locals
+            [] -> return (\_ _ -> True, Map.empty, Set.empty)
+            targets -> do
+                targets' <- mapM parseTarget $ boptsTargets bopts
+                -- Group targets by their kind
+                (dirs, names, idents) <-
+                    case partitionEithers targets' of
+                        ([], targets') -> return $ partitionTargetSpecs targets'
+                        (bad, _) -> throwM $ Couldn'tParseTargets bad
+                return (isWanted dirs names, names, idents)
 
     econfig <- asks getEnvConfig
     bconfig <- asks getBuildConfig
@@ -191,7 +193,7 @@ loadLocals bopts latestVersion = do
     lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do
         cabalfp <- getCabalFileName dir
         name <- parsePackageNameFromFilePath cabalfp
-        let wanted = validWanted && isWanted dirs names dir name
+        let wanted = validWanted && isWanted' dir name
             config = PackageConfig
                 { packageConfigEnableTests = False
                 , packageConfigEnableBenchmarks = False
@@ -204,7 +206,9 @@ loadLocals bopts latestVersion = do
                     case boptsFinalAction bopts of
                         DoTests _ -> wanted
                         _ -> False
-                , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks
+                , packageConfigEnableBenchmarks = wanted && case boptsFinalAction bopts of
+                                                              (DoBenchmarks _) -> True
+                                                              _ -> False
                 }
         pkg <- readPackage config cabalfp
         pkgFinal <- readPackage configFinal cabalfp

src/Stack/Build/Types.hs

@@ -20,6 +20,8 @@ module Stack.Build.Types
     ,LocalPackage(..)
     ,BaseConfigOpts(..)
     ,Plan(..)
+    ,TestOpts(..)
+    ,BenchmarkOpts(..)
     ,FinalAction(..)
     ,BuildOpts(..)
     ,defaultBuildOpts
@@ -289,14 +291,9 @@ data BuildOpts =
             -- ^ Install executables to user path after building?
             ,boptsPreFetch :: !Bool
             -- ^ Fetch all packages immediately
-            ,boptsTestArgs :: ![String]
-            -- ^ Arguments to pass to the test suites if we're running them.
             ,boptsOnlySnapshot :: !Bool
             -- ^ Only install packages in the snapshot database, skipping
             -- packages intended for the local database.
-            ,boptsCoverage :: !Bool
-            -- ^ Enable code coverage report generation for test
-            -- suites.
             ,boptsFileWatch :: !Bool
             -- ^ Watch files for changes and automatically rebuild
             ,boptsKeepGoing :: !(Maybe Bool)
@@ -318,18 +315,28 @@ defaultBuildOpts = BuildOpts
     , boptsFlags = Map.empty
     , boptsInstallExes = False
     , boptsPreFetch = False
-    , boptsTestArgs = []
     , boptsOnlySnapshot = False
-    , boptsCoverage = False
     , boptsFileWatch = False
     , boptsKeepGoing = Nothing
     }
 
+-- | Options for the 'FinalAction' 'DoTests'
+data TestOpts =
+  TestOpts {toRerunTests :: !Bool -- ^ Whether successful tests will be run gain
+           ,toAdditionalArgs :: ![String] -- ^ Arguments passed to the test program
+           ,toCoverage :: !Bool -- ^ Generate a code coverage report
+           ,toDisableRun :: !Bool -- ^ Disable running of tests
+           } deriving (Eq,Show)
+
+-- | Options for the 'FinalAction' 'DoBenchmarks'
+data BenchmarkOpts =
+  BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program
+                } deriving (Eq,Show)
+
 -- | Run a Setup.hs action after building a package, before installing.
 data FinalAction
-  = DoTests
-      Bool -- rerun tests which already passed?
-  | DoBenchmarks
+  = DoTests TestOpts
+  | DoBenchmarks BenchmarkOpts
   | DoNothing
   deriving (Eq,Show)
 

src/Stack/BuildPlan.hs

@@ -522,7 +522,11 @@ checkBuildPlan locals mbp gpd = do
 
     flagName' = fromCabalFlagName . flagName
 
-    flagOptions = map Map.fromList $ mapM getOptions $ genPackageFlags gpd
+    -- Avoid exponential complexity in flag combinations making us sad pandas.
+    -- See: https://github.com/commercialhaskell/stack/issues/543
+    maxFlagOptions = 128
+
+    flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd
     getOptions f
         | flagManual f = [(flagName' f, flagDefault f)]
         | flagDefault f =

src/Stack/Fetch.hs

@@ -396,6 +396,7 @@ fetchPackages' mdistDir toFetchAll = do
                 { drRequest = req
                 , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch)
                 , drLengthCheck = fmap fromIntegral $ tfSize toFetch
+                , drRetries = drRetriesDefault
                 }
         let progressSink = do
                 liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"

src/Stack/Setup.hs

@@ -47,7 +47,7 @@ import qualified Data.Yaml as Yaml
 import           Distribution.System (OS (..), Arch (..), Platform (..))
 import           Distribution.Text (simpleParse)
 import           Network.HTTP.Client.Conduit
-import           Network.HTTP.Download (verifiedDownload, DownloadRequest(..))
+import           Network.HTTP.Download (verifiedDownload, DownloadRequest(..), drRetriesDefault)
 import           Path
 import           Path.IO
 import           Prelude -- Fix AMP warning
@@ -696,6 +696,7 @@ chattyDownload label url path = do
             { drRequest = req
             , drHashChecks = []
             , drLengthCheck = Nothing
+            , drRetries = drRetriesDefault
             }
     runInBase <- liftBaseWith $ \run -> return (void . run)
     x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)