stack 0.1.1.0 → 0.1.2.0
raw patch · 35 files changed
+1680/−511 lines, 35 filesdep +QuickCheckdep +byteabledep +fsnotifydep ~bytestringdep ~optparse-applicative
Dependencies added: QuickCheck, byteable, fsnotify
Dependency ranges changed: bytestring, optparse-applicative
Files
- ChangeLog.md +21/−0
- README.md +1/−0
- src/Control/Concurrent/Execute.hs +29/−15
- src/Data/Attoparsec/Args.hs +69/−1
- src/Network/HTTP/Download/Verified.hs +3/−7
- src/Path/Find.hs +6/−1
- src/Stack/Build.hs +25/−4
- src/Stack/Build/Cache.hs +38/−35
- src/Stack/Build/ConstructPlan.hs +4/−4
- src/Stack/Build/Execute.hs +131/−101
- src/Stack/Build/Haddock.hs +11/−5
- src/Stack/Build/Source.hs +79/−9
- src/Stack/Build/Types.hs +53/−11
- src/Stack/BuildPlan.hs +12/−1
- src/Stack/Config.hs +10/−3
- src/Stack/Constants.hs +10/−0
- src/Stack/Docker.hs +80/−100
- src/Stack/Dot.hs +218/−52
- src/Stack/Exec.hs +8/−0
- src/Stack/Fetch.hs +1/−1
- src/Stack/FileWatch.hs +102/−0
- src/Stack/Ide.hs +169/−0
- src/Stack/Init.hs +22/−7
- src/Stack/Package.hs +4/−3
- src/Stack/PackageDump.hs +1/−1
- src/Stack/Setup.hs +57/−31
- src/Stack/Types/BuildPlan.hs +8/−1
- src/Stack/Types/Config.hs +14/−0
- src/Stack/Upgrade.hs +19/−20
- src/System/Process/Read.hs +2/−1
- src/main/Main.hs +177/−89
- src/test/Network/HTTP/Download/VerifiedSpec.hs +162/−0
- src/test/Stack/DotSpec.hs +116/−0
- stack.cabal +14/−4
- stack.yaml +4/−4
ChangeLog.md view
@@ -1,3 +1,24 @@+## 0.1.2.0++* Add `--prune` flag to `stack dot` [#487](https://github.com/commercialhaskell/stack/issues/487)+* Add `--[no-]external`,`--[no-]include-base` flags to `stack dot` [#437](https://github.com/commercialhaskell/stack/issues/437)+* Add `--ignore-subdirs` flag to init command [#435](https://github.com/commercialhaskell/stack/pull/435)+* Handle attempt to use non-existing resolver [#436](https://github.com/commercialhaskell/stack/pull/436)+* Add `--force` flag to `init` command+* exec style commands accept the `--package` option (see [Reddit discussion](http://www.reddit.com/r/haskell/comments/3bd66h/stack_runghc_turtle_as_haskell_script_solution/))+* `stack upload` without arguments doesn't do anything [#439](https://github.com/commercialhaskell/stack/issues/439)+* Print latest version of packages on conflicts [#450](https://github.com/commercialhaskell/stack/issues/450)+* Flag to avoid rerunning tests that haven't changed [#451](https://github.com/commercialhaskell/stack/issues/451)+* stack can act as a script interpreter (see [Script interpreter] (https://github.com/commercialhaskell/stack/wiki/Script-interpreter) and [Reddit discussion](http://www.reddit.com/r/haskell/comments/3bd66h/stack_runghc_turtle_as_haskell_script_solution/))+* Add the __`--file-watch`__ flag to auto-rebuild on file changes [#113](https://github.com/commercialhaskell/stack/issues/113)+* Rename `stack docker exec` to `stack exec --plain`+* Add the `--skip-msys` flag [#377](https://github.com/commercialhaskell/stack/issues/377)+* `--keep-going`, turned on by default for tests and benchmarks [#478](https://github.com/commercialhaskell/stack/issues/478)+* `concurrent-tests: BOOL` [#492](https://github.com/commercialhaskell/stack/issues/492)+* Use hashes to check file dirtiness [#502](https://github.com/commercialhaskell/stack/issues/502)+* Install correct GHC build on systems with libgmp.so.3 [#465](https://github.com/commercialhaskell/stack/issues/465)+* `stack upgrade` checks version before upgrading [#447](https://github.com/commercialhaskell/stack/issues/447)+ ## 0.1.1.0 * Remove GHC uncompressed tar file after installation [#376](https://github.com/commercialhaskell/stack/issues/376)
README.md view
@@ -1,6 +1,7 @@ ## The Haskell Tool Stack [](https://travis-ci.org/commercialhaskell/stack)+ `stack` is a cross-platform program for developing Haskell projects. It is aimed at Haskellers both new and experienced.
src/Control/Concurrent/Execute.hs view
@@ -14,7 +14,7 @@ import Control.Concurrent.Async (Concurrently (..), async) import Control.Concurrent.STM import Control.Exception-import Control.Monad (join)+import Control.Monad (join, unless) import Data.Foldable (sequenceA_) import Data.Set (Set) import qualified Data.Set as Set@@ -45,6 +45,8 @@ , esExceptions :: TVar [SomeException] , esInAction :: TVar (Set ActionId) , esCompleted :: TVar Int+ , esFinalLock :: Maybe (TMVar ())+ , esKeepGoing :: Bool } data ExecuteException@@ -57,15 +59,21 @@ "Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team." runActions :: Int -- ^ threads+ -> Bool -- ^ keep going after one task has failed+ -> Bool -- ^ run final actions concurrently? -> [Action] -> (TVar Int -> IO ()) -- ^ progress updated -> IO [SomeException]-runActions threads actions0 withProgress = do+runActions threads keepGoing concurrentFinal actions0 withProgress = do es <- ExecuteState <$> newTVarIO actions0 <*> newTVarIO [] <*> newTVarIO Set.empty <*> newTVarIO 0+ <*> (if concurrentFinal+ then pure Nothing+ else Just <$> atomically (newTMVar ()))+ <*> pure keepGoing _ <- async $ withProgress $ esCompleted es if threads <= 1 then runActions' es@@ -78,7 +86,7 @@ where breakOnErrs inner = do errs <- readTVar esExceptions- if null errs+ if null errs || esKeepGoing then inner else return $ return () withActions inner = do@@ -92,10 +100,18 @@ inAction <- readTVar esInAction if Set.null inAction then do- modifyTVar esExceptions (toException InconsistentDependencies:)+ unless esKeepGoing $+ modifyTVar esExceptions (toException InconsistentDependencies:) return $ return () else retry (xs, action:ys) -> do+ unlock <-+ case (actionId action, esFinalLock) of+ (ActionId _ ATFinal, Just lock) -> do+ takeTMVar lock+ return $ putTMVar lock ()+ _ -> return $ return ()+ let as' = xs ++ ys inAction <- readTVar esInAction let remaining = Set.union@@ -107,15 +123,13 @@ eres <- try $ restore $ actionDo action ActionContext { acRemaining = remaining }- case eres of- Left err -> atomically $ do- modifyTVar esExceptions (err:)- modifyTVar esInAction (Set.delete $ actionId action)- modifyTVar esCompleted (+1)- Right () -> do- atomically $ do- modifyTVar esInAction (Set.delete $ actionId action)- modifyTVar esCompleted (+1)+ atomically $ do+ unlock+ modifyTVar esInAction (Set.delete $ actionId action)+ modifyTVar esCompleted (+1)+ case eres of+ Left err -> modifyTVar esExceptions (err:)+ Right () -> let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }- modifyTVar esActions $ map dropDep- restore loop+ in modifyTVar esActions $ map dropDep+ restore loop
src/Data/Attoparsec/Args.hs view
@@ -1,12 +1,27 @@+{-# LANGUAGE OverloadedStrings #-} -- | Parsing argument-like things. -module Data.Attoparsec.Args (EscapingMode(..), argsParser) where+module Data.Attoparsec.Args+ ( EscapingMode(..)+ , argsParser+ , parseArgs+ , withInterpreterArgs+ ) where import Control.Applicative import Data.Attoparsec.Text ((<?>)) import qualified Data.Attoparsec.Text as P import Data.Attoparsec.Types (Parser)+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import System.Directory (doesFileExist)+import System.Environment (getArgs, withArgs)+import System.IO (IOMode (ReadMode), withBinaryFile) -- | Mode for parsing escape characters. data EscapingMode@@ -14,6 +29,10 @@ | NoEscaping deriving (Show,Eq,Enum) +-- | Parse arguments using 'argsParser'.+parseArgs :: EscapingMode -> Text -> Either String [String]+parseArgs mode t = P.parseOnly (argsParser mode) t+ -- | A basic argument parser. It supports space-separated text, and -- string quotation with identity escaping: \x -> x. argsParser :: EscapingMode -> Parser Text [String]@@ -28,3 +47,52 @@ escaped = P.char '\\' *> P.anyChar nonquote = P.satisfy (not . (=='"')) naked = P.satisfy (not . flip elem ("\" " :: String))++-- | Use 'withArgs' on result of 'getInterpreterArgs'.+withInterpreterArgs :: String -> ([String] -> Bool -> IO a) -> IO a+withInterpreterArgs progName inner = do+ (args, isInterpreter) <- getInterpreterArgs progName+ withArgs args $ inner args isInterpreter++-- | Check if command-line looks like it's being used as a script interpreter,+-- and if so look for a @-- progName ...@ comment that contains additional+-- arguments.+getInterpreterArgs :: String -> IO ([String], Bool)+getInterpreterArgs progName = do+ args0 <- getArgs+ case args0 of+ (x:_) -> do+ isFile <- doesFileExist x+ if isFile+ then do+ margs <-+ withBinaryFile x ReadMode $ \h ->+ CB.sourceHandle h+ $= CB.lines+ $= CL.map killCR+ $$ sinkInterpreterArgs progName+ return $ case margs of+ Nothing -> (args0, True)+ Just args -> (args ++ "--" : args0, True)+ else return (args0, False)+ _ -> return (args0, False)+ where+ killCR bs+ | S.null bs || S.last bs /= 13 = bs+ | otherwise = S.init bs++sinkInterpreterArgs :: Monad m => String -> Sink ByteString m (Maybe [String])+sinkInterpreterArgs progName =+ await >>= maybe (return Nothing) checkShebang+ where+ checkShebang bs+ | "#!" `S.isPrefixOf` bs = fmap (maybe Nothing parseArgs') await+ | otherwise = return (parseArgs' bs)++ parseArgs' bs =+ case decodeUtf8' bs of+ Left _ -> Nothing+ Right t ->+ case P.parseOnly (argsParser Escaping) t of+ Right ("--":progName':rest) | progName' == progName -> Just rest+ _ -> Nothing
src/Network/HTTP/Download/Verified.hs view
@@ -33,7 +33,7 @@ import Data.ByteString (ByteString) import Data.Conduit import Data.Conduit.Binary (sourceHandle, sinkHandle)-import Data.Foldable (traverse_)+import Data.Foldable (traverse_,for_) import Data.Monoid import Data.String import Data.Typeable (Typeable)@@ -217,12 +217,8 @@ `catch` \(_ :: VerifyFileException) -> return False `catch` \(_ :: VerifiedDownloadException) -> return False - whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()- whenJust (Just a) f = f a- whenJust _ _ = return ()- checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do- whenJust drLengthCheck $ checkFileSizeExpectations h+ for_ drLengthCheck $ checkFileSizeExpectations h sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks) -- doesn't move the handle@@ -244,7 +240,7 @@ go h res = do let headers = responseHeaders res- whenJust drLengthCheck $ checkContentLengthHeader headers+ for_ drLengthCheck $ checkContentLengthHeader headers let hashChecks = (case List.lookup hContentMD5 headers of Just md5BS -> [ HashCheck
src/Path/Find.hs view
@@ -12,6 +12,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class+import System.IO.Error (isPermissionError) import Data.List import Path import Path.IO@@ -60,7 +61,11 @@ -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse. -> IO [Path Abs File] -- ^ List of matching files. findFiles dir p traversep =- do (dirs,files) <- listDirectory dir+ do (dirs,files) <- catchJust (\ e -> if isPermissionError e+ then Just ()+ else Nothing)+ (listDirectory dir)+ (\ _ -> return ([], [])) subResults <- forM dirs (\entry ->
src/Stack/Build.hs view
@@ -14,7 +14,8 @@ module Stack.Build (build- ,clean)+ ,clean+ ,withLoadPackage) where import Control.Monad@@ -26,7 +27,10 @@ import Data.Function import Data.Map.Strict (Map) import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import Network.HTTP.Client.Conduit (HasHttpManager)+import Path import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Build.ConstructPlan@@ -45,11 +49,22 @@ type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) -- | Build-build :: M env m => BuildOpts -> m ()-build bopts = do+build :: M env m+ => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files+ -> BuildOpts+ -> m ()+build setLocalFiles bopts = do menv <- getMinimalEnvOverride (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts++ -- Set local files, necessary for file watching+ stackYaml <- asks $ bcStackYaml . getBuildConfig+ liftIO $ setLocalFiles+ $ Set.insert stackYaml+ $ Set.unions+ $ map lpFiles locals+ (installedMap, locallyRegistered) <- getInstalled menv GetInstalledOpts@@ -87,7 +102,13 @@ } -- | Provide a function for loading package information from the package index-withLoadPackage :: M env m+withLoadPackage :: ( MonadIO m+ , HasHttpManager env+ , MonadReader env m+ , MonadBaseControl IO m+ , MonadCatch m+ , MonadLogger m+ , HasEnvConfig env) => EnvOverride -> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a) -> m a
src/Stack/Build/Cache.hs view
@@ -7,7 +7,6 @@ ( tryGetBuildCache , tryGetConfigCache , tryGetCabalMod- , getPackageFileModTimes , getInstalledExes , buildCacheTimes , tryGetFlagCache@@ -18,11 +17,13 @@ , writeBuildCache , writeConfigCache , writeCabalMod+ , setTestSuccess+ , unsetTestSuccess+ , checkTestSuccess ) where import Control.Exception.Enclosed (catchIO, handleIO, tryIO)-import Control.Monad.Catch (MonadCatch, MonadThrow, catch,- throwM)+import Control.Monad.Catch (MonadThrow, catch, throwM) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader@@ -31,19 +32,15 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, mapMaybe)-import qualified Data.Set as Set+import Data.Maybe (fromMaybe, mapMaybe) import GHC.Generics (Generic) import Path import Path.IO import Stack.Build.Types import Stack.Constants-import Stack.Package import Stack.Types import System.Directory (createDirectoryIfMissing, getDirectoryContents,- getModificationTime, removeFile) import System.IO.Error (isDoesNotExistError) @@ -86,16 +83,16 @@ -- | Stored on disk to know whether the flags have changed or any -- files have changed. data BuildCache = BuildCache- { buildCacheTimes :: !(Map FilePath ModTime)+ { buildCacheTimes :: !(Map FilePath FileCacheInfo) -- ^ Modification times of files. }- deriving (Generic,Eq)+ deriving (Generic) instance Binary BuildCache -- | Try to read the dirtiness cache for the given package directory. tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)- => Path Abs Dir -> m (Maybe BuildCache)-tryGetBuildCache = tryGetCache buildCacheFile+ => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))+tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile -- | Try to read the dirtiness cache for the given package directory. tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)@@ -126,7 +123,7 @@ -- | Write the dirtiness cache for this package's files. writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)- => Path Abs Dir -> Map FilePath ModTime -> m ()+ => Path Abs Dir -> Map FilePath FileCacheInfo -> m () writeBuildCache dir times = writeCache dir@@ -206,25 +203,31 @@ Binary.encodeFile (toFilePath file) cache --- | Get the modified times of all known files in the package,--- including the package's cabal file itself.-getPackageFileModTimes :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)- => Package- -> Path Abs File -- ^ cabal file- -> m (Map FilePath ModTime)-getPackageFileModTimes pkg cabalfp = do- files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp- liftM (Map.fromList . catMaybes)- $ mapM getModTimeMaybe- $ Set.toList files- where- getModTimeMaybe fp =- liftIO- (catch- (liftM- (Just . (toFilePath fp,) . modTime)- (getModificationTime (toFilePath fp)))- (\e ->- if isDoesNotExistError e- then return Nothing- else throwM e))+-- | Mark a test suite as having succeeded+setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+setTestSuccess dir =+ writeCache+ dir+ testSuccessFile+ True++-- | Mark a test suite as not having succeeded+unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+unsetTestSuccess dir =+ writeCache+ dir+ testSuccessFile+ False++-- | Check if the test suite already passed+checkTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m Bool+checkTestSuccess dir =+ liftM+ (fromMaybe False)+ (tryGetCache testSuccessFile dir)
src/Stack/Build/ConstructPlan.hs view
@@ -336,16 +336,16 @@ deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, range) -> do eres <- addDep depname+ let mlatest = Map.lookup depname $ latestVersions ctx case eres of Left e -> let bd = case e of- UnknownPackage name ->- NotInBuildPlan $ Map.lookup name $ latestVersions ctx+ UnknownPackage name -> assert (name == depname) NotInBuildPlan _ -> Couldn'tResolveItsDependencies- in return $ Left (depname, (range, bd))+ in return $ Left (depname, (range, mlatest, bd)) Right adr | not $ adrVersion adr `withinRange` range ->- return $ Left (depname, (range, DependencyMismatch $ adrVersion adr))+ return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) Right (ADRToInstall task) -> return $ Right (Set.singleton $ taskProvides task, Set.empty, taskLocation task) Right (ADRFound loc _ (Executable _)) -> return $ Right
src/Stack/Build/Execute.hs view
@@ -124,7 +124,7 @@ case finalAction of DoNothing -> Nothing DoBenchmarks -> Just "benchmark"- DoTests -> Just "test"+ DoTests _ -> Just "test" case mfinalLabel of Nothing -> return () Just finalLabel -> do@@ -333,8 +333,20 @@ (planTasks plan) (planFinals plan) threads <- asks $ configJobs . getConfig+ concurrentTests <- asks $ configConcurrentTests . getConfig+ let keepGoing =+ case boptsKeepGoing eeBuildOpts of+ Just kg -> kg+ Nothing ->+ case boptsFinalAction eeBuildOpts of+ DoNothing -> False+ _ -> True+ concurrentFinal =+ case boptsFinalAction eeBuildOpts of+ DoTests _ -> concurrentTests+ _ -> True terminal <- asks getTerminal- errs <- liftIO $ runActions threads actions $ \doneVar -> do+ errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do let total = length actions loop prev | prev == total =@@ -393,7 +405,7 @@ mfunc = case boptsFinalAction $ eeBuildOpts ee of DoNothing -> Nothing- DoTests -> Just (singleTest, checkTest)+ DoTests rerunTests -> Just (singleTest rerunTests, checkTest) DoBenchmarks -> Just (singleBench, checkBench) checkTest task =@@ -618,9 +630,10 @@ withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console _mlogFile -> do (cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp [] - fileModTimes <- getPackageFileModTimes package cabalfp markExeNotInstalled (taskLocation task) taskProvides- writeBuildCache pkgDir fileModTimes+ case taskType of+ TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp+ TTUpstream _ _ -> return () announce "build" config <- asks getConfig@@ -665,16 +678,18 @@ when (doHaddock && shouldHaddockDeps eeBuildOpts) $ copyDepHaddocks eeEnvOverride+ eeBaseConfigOpts (pkgDbs ++ [eeGlobalDB]) (PackageIdentifier (packageName package) (packageVersion package)) Set.empty singleTest :: M env m- => ActionContext+ => Bool -- ^ rerun tests?+ -> ActionContext -> ExecuteEnv -> Task -> m ()-singleTest ac ee task =+singleTest rerunTests 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@@ -683,7 +698,6 @@ (case taskType task of TTLocal lp -> lpDirtyFiles lp _ -> assert False True)- || True -- FIXME above logic is incorrect, see: https://github.com/commercialhaskell/stack/issues/319 needHpc = boptsCoverage (eeBuildOpts ee) componentsRaw =@@ -695,103 +709,119 @@ when needBuild $ do announce "build (test)"- fileModTimes <- getPackageFileModTimes package cabalfp- writeBuildCache pkgDir fileModTimes+ unsetTestSuccess pkgDir+ case taskType task of+ TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp+ TTUpstream _ _ -> assert False $ return () cabal (console && configHideTHLoading config) $ "build" : components - bconfig <- asks getBuildConfig- buildDir <- distDirFromDir pkgDir- hpcDir <- hpcDirFromDir pkgDir- when needHpc (createTree hpcDir)- let dotHpcDir = pkgDir </> dotHpc- exeExtension =- case configPlatform $ getConfig bconfig of- Platform _ Windows -> ".exe"- _ -> ""+ 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 - errs <- liftM Map.unions $ forM testsToRun $ \testName -> do- nameDir <- parseRelDir $ T.unpack testName- nameExe <- parseRelFile $ T.unpack testName ++ exeExtension- nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix"- let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe- exists <- fileExists exeName- menv <- liftIO $ configEnvOverride config EnvSettings- { esIncludeLocals = taskLocation task == Local- , esIncludeGhcPackagePath = True- , esStackExe = True- }- if exists- then do- -- We clear out the .tix files before doing a run.- when needHpc $ do- tixexists <- fileExists nameTix- when tixexists $- $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))- removeFileIfExists nameTix+ when toRun $ do+ bconfig <- asks getBuildConfig+ buildDir <- distDirFromDir pkgDir+ hpcDir <- hpcDirFromDir pkgDir+ when needHpc (createTree hpcDir)+ let dotHpcDir = pkgDir </> dotHpc+ exeExtension =+ case configPlatform $ getConfig bconfig of+ Platform _ Windows -> ".exe"+ _ -> "" - let args = boptsTestArgs (eeBuildOpts ee)- 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- , Process.env = envHelper menv- , std_in = CreatePipe- , std_out =- case mlogFile of- Nothing -> Inherit- Just (_, h) -> UseHandle h- , std_err =- case mlogFile of- Nothing -> Inherit- Just (_, h) -> UseHandle h- }+ errs <- liftM Map.unions $ forM testsToRun $ \testName -> do+ nameDir <- parseRelDir $ T.unpack testName+ nameExe <- parseRelFile $ T.unpack testName ++ exeExtension+ nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix"+ let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe+ exists <- fileExists exeName+ menv <- liftIO $ configEnvOverride config EnvSettings+ { esIncludeLocals = taskLocation task == Local+ , esIncludeGhcPackagePath = True+ , esStackExe = True+ }+ if exists+ then do+ -- We clear out the .tix files before doing a run.+ when needHpc $ do+ tixexists <- fileExists nameTix+ when tixexists $+ $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))+ removeFileIfExists nameTix - -- Use createProcess_ to avoid the log file being closed afterwards- (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp- liftIO $ hClose inH- ec <- liftIO $ waitForProcess ph- -- Move the .tix file out of the package directory- -- into the hpc work dir, for tidiness.- when needHpc $- moveFileIfExists nameTix hpcDir- return $ case ec of- ExitSuccess -> Map.empty- _ -> Map.singleton testName $ Just ec- else do- $logError $ T.concat- [ "Test suite "- , testName- , " executable not found for "- , T.pack $ packageNameString $ packageName package- ]- return $ Map.singleton testName Nothing- when needHpc $ do- createTree (hpcDir </> dotHpc)- exists <- dirExists dotHpcDir- when exists $ do- copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)- removeTree dotHpcDir- (_,files) <- listDirectory hpcDir- let tixes =- filter (isSuffixOf ".tix" . toFilePath . filename) files- generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes+ let args = boptsTestArgs (eeBuildOpts ee)+ 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+ , Process.env = envHelper menv+ , std_in = CreatePipe+ , std_out =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ , std_err =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ } - bs <- liftIO $- case mlogFile of- Nothing -> return ""- Just (logFile, h) -> do- hClose h- S.readFile $ toFilePath logFile+ -- Use createProcess_ to avoid the log file being closed afterwards+ (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp+ liftIO $ hClose inH+ ec <- liftIO $ waitForProcess ph+ -- Move the .tix file out of the package directory+ -- into the hpc work dir, for tidiness.+ when needHpc $+ moveFileIfExists nameTix hpcDir+ return $ case ec of+ ExitSuccess -> Map.empty+ _ -> Map.singleton testName $ Just ec+ else do+ $logError $ T.concat+ [ "Test suite "+ , testName+ , " executable not found for "+ , T.pack $ packageNameString $ packageName package+ ]+ return $ Map.singleton testName Nothing+ when needHpc $ do+ createTree (hpcDir </> dotHpc)+ exists <- dirExists dotHpcDir+ when exists $ do+ copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)+ removeTree dotHpcDir+ (_,files) <- listDirectory hpcDir+ let tixes =+ filter (isSuffixOf ".tix" . toFilePath . filename) files+ generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes - unless (Map.null errs) $ throwM $ TestSuiteFailure- (taskProvides task)- errs- (fmap fst mlogFile)- bs+ bs <- liftIO $+ case mlogFile of+ Nothing -> return ""+ Just (logFile, h) -> do+ hClose h+ S.readFile $ toFilePath logFile + unless (Map.null errs) $ throwM $ TestSuiteFailure+ (taskProvides task)+ errs+ (fmap fst mlogFile)+ bs++ setTestSuccess pkgDir+ -- | Determine the tests to be run based on the list of components. compareTestsComponents :: [Text] -- ^ components -> [Text] -- ^ all test names@@ -838,18 +868,18 @@ -> Task -> m () singleBench ac ee task =- withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console _mlogFile -> do+ 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"] let needBuild = neededConfig || (case taskType task of TTLocal lp -> lpDirtyFiles lp _ -> assert False True)- || True -- FIXME above logic is incorrect, see: https://github.com/commercialhaskell/stack/issues/319 when needBuild $ do announce "build (benchmarks)"- fileModTimes <- getPackageFileModTimes package cabalfp- writeBuildCache pkgDir fileModTimes+ case taskType task of+ TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp+ TTUpstream _ _ -> assert False $ return () config <- asks getConfig cabal (console && configHideTHLoading config) ["build"]
src/Stack/Build/Haddock.hs view
@@ -55,11 +55,12 @@ -- available where viewing the docs (e.g. if building in a Docker container). copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride+ -> BaseConfigOpts -> [Path Abs Dir] -> PackageIdentifier -> Set (Path Abs Dir) -> m ()-copyDepHaddocks envOverride pkgDbs pkgId extraDestDirs = do+copyDepHaddocks envOverride bco pkgDbs pkgId extraDestDirs = do mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride pkgDbs pkgId case mpkgHtmlDir of Nothing -> return ()@@ -72,9 +73,14 @@ mDepOrigDir <- findGhcPkgHaddockHtml envOverride pkgDbs depId case mDepOrigDir of Nothing -> return ()- Just depOrigDir ->- copyWhenNeeded (Set.insert (parent pkgHtmlDir) extraDestDirs)- depId depOrigDir+ Just depOrigDir -> do+ let extraDestDirs' =+ -- Parent test ensures we don't try to copy docs to global locations+ if (bcoSnapInstallRoot bco) `isParentOf` pkgHtmlDir ||+ (bcoLocalInstallRoot bco) `isParentOf` pkgHtmlDir+ then Set.insert (parent pkgHtmlDir) extraDestDirs+ else extraDestDirs+ copyWhenNeeded extraDestDirs' depId depOrigDir copyWhenNeeded destDirs depId depOrigDir = do depRelDir <- parseRelDir (packageIdentifierString depId) copied <- forM (Set.toList destDirs) $ \destDir -> do@@ -86,7 +92,7 @@ when needCopy $ doCopy depOrigDir depCopyDir return needCopy when (or copied) $- copyDepHaddocks envOverride pkgDbs depId destDirs+ copyDepHaddocks envOverride bco pkgDbs depId destDirs getNeedCopy depOrigDir depCopyDir = do let depOrigIndex = haddockIndexFile depOrigDir depCopyIndex = haddockIndexFile depCopyDir
src/Stack/Build/Source.hs view
@@ -14,13 +14,21 @@ ) where import Network.HTTP.Client.Conduit (HasHttpManager)-import Control.Applicative ((<|>), (<$>))+import Control.Applicative ((<|>), (<$>), (<*>))+import Control.Exception (catch) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource+import Crypto.Hash (Digest, SHA256)+import Crypto.Hash.Conduit (sinkHash)+import Data.Byteable (toBytes)+import qualified Data.ByteString as S+import Data.Conduit (($$), ZipSink (..))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL import Data.Either import qualified Data.Foldable as F import Data.Function@@ -29,13 +37,13 @@ import qualified Data.Map as Map import Data.Map.Strict (Map) import Data.Maybe-import Data.Monoid ((<>))+import Data.Monoid ((<>), Any (..), mconcat) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Path-import Prelude hiding (FilePath, writeFile)+import Prelude hiding (writeFile) import Stack.Build.Cache import Stack.Build.Types import Stack.BuildPlan (loadMiniBuildPlan,@@ -45,6 +53,8 @@ import Stack.PackageIndex import Stack.Types import System.Directory hiding (findExecutable, findFiles)+import System.IO (withBinaryFile, IOMode (ReadMode))+import System.IO.Error (isDoesNotExistError) type SourceMap = Map PackageName PackageSource @@ -190,7 +200,10 @@ , packageConfigPlatform = configPlatform $ getConfig bconfig } configFinal = config- { packageConfigEnableTests = wanted && boptsFinalAction bopts == DoTests+ { packageConfigEnableTests =+ case boptsFinalAction bopts of+ DoTests _ -> wanted+ _ -> False , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks } pkg <- readPackage config cabalfp@@ -198,15 +211,17 @@ when (packageName pkg /= name) $ throwM $ MismatchedCabalName cabalfp (packageName pkg) mbuildCache <- tryGetBuildCache dir- fileModTimes <- getPackageFileModTimes pkg cabalfp+ files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp+ (isDirty, newBuildCache) <- checkBuildCache+ (fromMaybe Map.empty mbuildCache)+ (map toFilePath $ Set.toList files) return LocalPackage { lpPackage = pkg , lpPackageFinal = pkgFinal , lpWanted = wanted- , lpDirtyFiles =- maybe True- ((/= fileModTimes) . buildCacheTimes)- mbuildCache+ , lpFiles = files+ , lpDirtyFiles = isDirty+ , lpNewBuildCache = newBuildCache , lpCabalFile = cabalfp , lpDir = dir , lpComponents = fromMaybe Set.empty $ Map.lookup name names@@ -309,3 +324,58 @@ -- the version matches what's in the snapshot, so just use the snapshot version Just version' | version == version' -> m _ -> Map.insert name version m++-- | Compare the current filesystem state to the cached information, and+-- determine (1) if the files are dirty, and (2) the new cache values.+checkBuildCache :: MonadIO m+ => Map FilePath FileCacheInfo -- ^ old cache+ -> [FilePath] -- ^ files in package+ -> m (Bool, Map FilePath FileCacheInfo)+checkBuildCache oldCache files = liftIO $ do+ (Any isDirty, m) <- fmap mconcat $ mapM go files+ return (isDirty, m)+ where+ go fp = do+ mmodTime <- getModTimeMaybe fp+ case mmodTime of+ Nothing -> return (Any False, Map.empty)+ Just modTime' -> do+ (isDirty, newFci) <-+ case Map.lookup fp oldCache of+ Just fci+ | fciModTime fci == modTime' -> return (False, fci)+ | otherwise -> do+ newFci <- calcFci modTime' fp+ let isDirty =+ fciSize fci /= fciSize newFci ||+ fciHash fci /= fciHash newFci+ return (isDirty, newFci)+ Nothing -> do+ newFci <- calcFci modTime' fp+ return (True, newFci)+ return (Any isDirty, Map.singleton fp newFci)++ getModTimeMaybe fp =+ liftIO+ (catch+ (liftM+ (Just . modTime)+ (getModificationTime fp))+ (\e ->+ if isDoesNotExistError e+ then return Nothing+ else throwM e))++ calcFci modTime' fp =+ withBinaryFile fp ReadMode $ \h -> do+ (size, digest) <- CB.sourceHandle h $$ getZipSink+ ((,)+ <$> ZipSink (CL.fold+ (\x y -> x + fromIntegral (S.length y))+ 0)+ <*> ZipSink sinkHash)+ return FileCacheInfo+ { fciModTime = modTime'+ , fciSize = size+ , fciHash = toBytes (digest :: Digest SHA256)+ }
src/Stack/Build/Types.hs view
@@ -22,13 +22,15 @@ ,Plan(..) ,FinalAction(..) ,BuildOpts(..)+ ,defaultBuildOpts ,TaskType(..) ,TaskConfigOpts(..) ,ConfigCache(..) ,ConstructPlanException(..) ,configureOpts ,BadDependency(..)- ,wantedLocalPackages)+ ,wantedLocalPackages+ ,FileCacheInfo (..)) where import Control.DeepSeq@@ -52,6 +54,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Calendar import Data.Time.Clock+import Data.Word (Word64) import Distribution.System (Arch) import Distribution.Text (display) import GHC.Generics@@ -183,7 +186,7 @@ getExtras (DependencyPlanFailures _ m) = Map.unions $ map go $ Map.toList m where- go (name, (_range, NotInBuildPlan (Just version))) =+ go (name, (_range, Just version, NotInBuildPlan)) = Map.singleton name version go _ = Map.empty -- Supressing duplicate output@@ -208,15 +211,17 @@ data ConstructPlanException = DependencyCycleDetected [PackageName]- | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, BadDependency))+ | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestVersion, BadDependency)) | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all -- ^ Recommend adding to extra-deps, give a helpful version number? deriving (Typeable, Eq) +-- | For display purposes only, Nothing if package not found+type LatestVersion = Maybe Version+ -- | Reason why a dependency was not used data BadDependency = NotInBuildPlan- (Maybe Version) -- recommended version, for extra-deps output | Couldn'tResolveItsDependencies | DependencyMismatch Version deriving (Typeable, Eq)@@ -239,16 +244,17 @@ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines doubleIndent = indent . indent appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""- showDep (name, (range, badDep)) = concat+ showDep (name, (range, mlatest, badDep)) = concat [ show name , ": needed (" , display range- , "), but "+ , ")"+ , case mlatest of+ Nothing -> ""+ Just latest -> ", latest is " ++ versionString latest+ , ", but " , case badDep of- NotInBuildPlan mlatest -> "not present in build plan" ++- (case mlatest of- Nothing -> ""- Just latest -> ", latest is " ++ versionString latest)+ NotInBuildPlan -> "not present in build plan" Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies" DependencyMismatch version -> versionString version ++ " found" ]@@ -291,15 +297,41 @@ ,boptsCoverage :: !Bool -- ^ Enable code coverage report generation for test -- suites.+ ,boptsFileWatch :: !Bool+ -- ^ Watch files for changes and automatically rebuild+ ,boptsKeepGoing :: !(Maybe Bool)+ -- ^ Keep building/running after failure } deriving (Show) +defaultBuildOpts :: BuildOpts+defaultBuildOpts = BuildOpts+ { boptsTargets = []+ , boptsLibProfile = False+ , boptsExeProfile = False+ , boptsEnableOptimizations = Nothing+ , boptsHaddock = False+ , boptsHaddockDeps = Nothing+ , boptsFinalAction = DoNothing+ , boptsDryrun = False+ , boptsGhcOptions = []+ , boptsFlags = Map.empty+ , boptsInstallExes = False+ , boptsPreFetch = False+ , boptsTestArgs = []+ , boptsOnlySnapshot = False+ , boptsCoverage = False+ , boptsFileWatch = False+ , boptsKeepGoing = Nothing+ }+ -- | Run a Setup.hs action after building a package, before installing. data FinalAction = DoTests+ Bool -- rerun tests which already passed? | DoBenchmarks | DoNothing- deriving (Eq,Bounded,Enum,Show)+ deriving (Eq,Show) -- | Package dependency oracle. newtype PkgDepsOracle =@@ -329,6 +361,8 @@ , lpDir :: !(Path Abs Dir) -- ^ Directory of the package. , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build?+ , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files+ , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package , lpComponents :: !(Set Text) -- ^ components to build, passed directly to Setup.hs build } deriving Show@@ -500,3 +534,11 @@ data Installed = Library GhcPkgId | Executable PackageIdentifier deriving (Show, Eq, Ord)++data FileCacheInfo = FileCacheInfo+ { fciModTime :: !ModTime+ , fciSize :: !Word64+ , fciHash :: !S.ByteString+ }+ deriving (Generic, Show)+instance Binary FileCacheInfo
src/Stack/BuildPlan.hs view
@@ -64,6 +64,8 @@ import qualified Distribution.Version as C import Distribution.Text (display) import Network.HTTP.Download+import Network.HTTP.Types (Status(..))+import Network.HTTP.Client (checkStatus) import Path import Prelude -- Fix AMP warning import Stack.Constants@@ -81,9 +83,16 @@ (Path Abs File) -- stack.yaml file (Map PackageName (Maybe Version, (Set PackageName))) -- truly unknown (Map PackageName (Set PackageIdentifier)) -- shadowed+ | SnapshotNotFound SnapName deriving (Typeable) instance Exception BuildPlanException instance Show BuildPlanException where+ show (SnapshotNotFound snapName) = unlines+ [ "SnapshotNotFound " ++ snapName'+ , "Non existing resolver: " ++ snapName' ++ "."+ , "For a complete list of available snapshots see https://www.stackage.org/snapshots"+ ]+ where snapName' = show $ renderSnapName snapName show (UnknownPackages stackYaml unknown shadowed) = unlines $ unknown' ++ shadowed' where@@ -462,7 +471,7 @@ req <- parseUrl $ T.unpack url $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." $logDebug $ "Downloading build plan from: " <> url- _ <- download req fp+ _ <- download req { checkStatus = handle404 } fp $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return @@ -473,6 +482,8 @@ LTS _ _ -> "lts-haskell" Nightly _ -> "stackage-nightly" url = rawGithubUrl "fpco" reponame "master" file+ handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name+ handle404 _ _ _ = Nothing -- | Find the set of @FlagName@s necessary to get the given -- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will
src/Stack/Config.hs view
@@ -47,7 +47,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Yaml as Yaml-import Distribution.System (OS (Windows), Platform (..), buildPlatform)+import Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text import Distribution.Version (simplifyVersionRange) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)@@ -116,6 +116,7 @@ configSystemGHC = fromMaybe True configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck+ configSkipMsys = fromMaybe False configMonoidSkipMsys configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs@@ -153,13 +154,14 @@ case configMonoidJobs of Nothing -> liftIO getNumCapabilities Just i -> return i+ let configConcurrentTests = fromMaybe True configMonoidConcurrentTests return Config {..} -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker =- (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck -> mempty+ (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC@@ -169,6 +171,7 @@ , configMonoidJobs = jobs , configMonoidExtraIncludeDirs = includes , configMonoidExtraLibDirs = libs+ , configMonoidSkipMsys = skipMsys }) <$> Docker.dockerOptsParser docker <*> maybeBoolFlags@@ -209,6 +212,10 @@ "skip-ghc-check" "skipping the GHC version and architecture check" idm+ <*> maybeBoolFlags+ "skip-msys"+ "skipping the local MSYS installation (Windows only)"+ idm -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at:@@ -275,7 +282,7 @@ Nothing -> case noConfigStrat of ThrowException -> do currDir <- getWorkingDir- cabalFiles <- findCabalFiles currDir+ cabalFiles <- findCabalFiles True currDir throwM $ NoProjectConfigFound currDir $ Just $ if null cabalFiles then "new" else "init" ExecStrategy -> do
src/Stack/Constants.hs view
@@ -19,6 +19,7 @@ ,configCacheFile ,configCabalMod ,buildCacheFile+ ,testSuccessFile ,stackProgName ,wiredInPackages ,cabalPackageName@@ -106,6 +107,15 @@ buildCacheFile dir = do liftM (</> $(mkRelFile "stack-build-cache"))+ (distDirFromDir dir)++-- | The filename used to mark tests as having succeeded+testSuccessFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory+ -> m (Path Abs File)+testSuccessFile dir =+ liftM+ (</> $(mkRelFile "stack-test-success")) (distDirFromDir dir) -- | The filename used for dirtiness check of config.
src/Stack/Docker.hs view
@@ -11,11 +11,11 @@ ,dockerOptsParser ,dockerOptsFromMonoid ,dockerPullCmdName+ ,execWithOptionalContainer+ ,execWithRequiredContainer ,preventInContainer ,pull- ,rerunCmdWithOptionalContainer- ,rerunCmdWithRequiredContainer- ,rerunWithOptionalContainer+ ,reexecWithOptionalContainer ,reset ) where @@ -29,6 +29,7 @@ import Control.Monad.Writer (execWriter,runWriter,tell) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)+import Data.Attoparsec.Args (EscapingMode (Escaping), parseArgs) import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS@@ -49,35 +50,30 @@ import Path import Path.IO (getWorkingDir,listDirectory) import Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar)+import Stack.Exec import Stack.Types import Stack.Types.Internal import Stack.Docker.GlobalDB import System.Directory (createDirectoryIfMissing,removeDirectoryRecursive,removeFile) import System.Directory (doesDirectoryExist) import System.Environment (lookupEnv,getProgName,getArgs,getExecutablePath)-import System.Exit (ExitCode(ExitSuccess),exitWith) import System.FilePath (dropTrailingPathSeparator,takeBaseName) import System.Info (arch,os) import System.IO (stderr,stdin,stdout,hIsTerminalDevice)-import qualified System.Process as Proc import System.Process.PagerEditor (editByteString) import System.Process.Read import System.Process.Run import Text.Printf (printf) -#ifndef mingw32_HOST_OS-import System.Posix.Signals (installHandler,sigTERM,Handler(Catch))-#endif- -- | If Docker is enabled, re-runs the currently running OS command in a Docker container. -- Otherwise, runs the inner action.-rerunWithOptionalContainer+reexecWithOptionalContainer :: M env m => Maybe (Path Abs Dir) -> IO () -> m ()-rerunWithOptionalContainer mprojectRoot =- rerunCmdWithOptionalContainer mprojectRoot getCmdArgs+reexecWithOptionalContainer mprojectRoot =+ execWithOptionalContainer mprojectRoot getCmdArgs where getCmdArgs = do args <- getArgs@@ -94,33 +90,33 @@ -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.-rerunCmdWithOptionalContainer+execWithOptionalContainer :: M env m => Maybe (Path Abs Dir) -> IO (FilePath,[String],Config -> Config) -> IO () -> m ()-rerunCmdWithOptionalContainer mprojectRoot getCmdArgs inner =+execWithOptionalContainer mprojectRoot getCmdArgs inner = do config <- asks getConfig inContainer <- getInContainer if inContainer || not (dockerEnable (configDocker config)) then liftIO inner else do (cmd_,args,modConfig) <- liftIO getCmdArgs- runContainerAndExit modConfig mprojectRoot cmd_ args [] (return ())+ runContainerAndExit modConfig mprojectRoot cmd_ args [] -- | If Docker is enabled, re-runs the OS command returned by the second argument in a--- Docker container. Otherwise, runs the inner action.-rerunCmdWithRequiredContainer+-- Docker container. Otherwise, throws 'DockerMustBeEnabledException'.+execWithRequiredContainer :: M env m => Maybe (Path Abs Dir) -> IO (FilePath,[String],Config -> Config) -> m ()-rerunCmdWithRequiredContainer mprojectRoot getCmdArgs =+execWithRequiredContainer mprojectRoot getCmdArgs = do config <- asks getConfig- when (not (dockerEnable (configDocker config)))+ unless (dockerEnable (configDocker config)) (throwM DockerMustBeEnabledException) (cmd_,args,modConfig) <- liftIO getCmdArgs- runContainerAndExit modConfig mprojectRoot cmd_ args [] (return ())+ runContainerAndExit modConfig mprojectRoot cmd_ args [] -- | Error if running in a container. preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()@@ -145,14 +141,12 @@ -> FilePath -> [String] -> [(String, String)]- -> IO () -> m () runContainerAndExit modConfig mprojectRoot cmnd args- envVars- successPostAction =+ envVars = do config <- fmap modConfig (asks getConfig) let docker = configDocker config envOverride <- getEnvOverride (configPlatform config)@@ -209,69 +203,68 @@ sandboxSubdirs = map (\d -> sandboxRepoDir </> d) sandboxedHomeSubdirectories isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal- execDockerProcess =- do mapM_ (createDirectoryIfMissing True)- (concat [[toFilePath sandboxHomeDir- ,toFilePath sandboxSandboxDir- ,toFilePath stackRoot] ++- map toFilePath sandboxSubdirs])- execProcessAndExit- envOverride- "docker"- (concat- [["run"- ,"--net=host"- ,"-e",inContainerEnvVar ++ "=1"- ,"-e",stackRootEnvVar ++ "=" ++ toFPNoTrailingSep stackRoot- ,"-e","WORK_UID=" ++ uid- ,"-e","WORK_GID=" ++ gid- ,"-e","WORK_WD=" ++ toFPNoTrailingSep pwd- ,"-e","WORK_HOME=" ++ toFPNoTrailingSep sandboxRepoDir- ,"-e","WORK_ROOT=" ++ toFPNoTrailingSep projectRoot- ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++ toFPNoTrailingSep stackRoot- ,"-v",toFPNoTrailingSep projectRoot ++ ":" ++ toFPNoTrailingSep projectRoot- ,"-v",toFPNoTrailingSep sandboxSandboxDir ++ ":" ++ toFPNoTrailingSep sandboxDir- ,"-v",toFPNoTrailingSep sandboxHomeDir ++ ":" ++ toFPNoTrailingSep sandboxRepoDir- ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++- toFPNoTrailingSep (sandboxRepoDir </> $(mkRelDir ("." ++ stackProgName ++ "/")))]- ,if oldImage- then ["-e",sandboxIDEnvVar ++ "=" ++ sandboxID- ,"--entrypoint=/root/entrypoint.sh"]- else []- ,case (dockerPassHost docker,dockerHost) of- (True,Just x@('u':'n':'i':'x':':':'/':'/':s)) -> ["-e","DOCKER_HOST=" ++ x- ,"-v",s ++ ":" ++ s]- (True,Just x) -> ["-e","DOCKER_HOST=" ++ x]- (True,Nothing) -> ["-v","/var/run/docker.sock:/var/run/docker.sock"]- (False,_) -> []- ,case (dockerPassHost docker,dockerCertPath) of- (True,Just x) -> ["-e","DOCKER_CERT_PATH=" ++ x- ,"-v",x ++ ":" ++ x]- _ -> []- ,case (dockerPassHost docker,dockerTlsVerify) of- (True,Just x )-> ["-e","DOCKER_TLS_VERIFY=" ++ x]- _ -> []- ,concatMap sandboxSubdirArg sandboxSubdirs- ,concatMap mountArg (dockerMount docker)- ,case dockerContainerName docker of- Just name -> ["--name=" ++ name]- Nothing -> []- ,if dockerDetach docker- then ["-d"]- else concat [["--rm" | not (dockerPersist docker)]- ,["-t" | isTerm]- ,["-i" | isTerm]]- ,dockerRunArgs docker- ,[image]- ,map (\(k,v) -> k ++ "=" ++ v) envVars- ,[cmnd]- ,args])- successPostAction- liftIO (do updateDockerImageLastUsed config- (iiId imageInfo)- (toFilePath projectRoot)- execDockerProcess)+ liftIO+ (do updateDockerImageLastUsed config+ (iiId imageInfo)+ (toFilePath projectRoot) + mapM_ (createDirectoryIfMissing True)+ (concat [[toFilePath sandboxHomeDir+ ,toFilePath sandboxSandboxDir+ ,toFilePath stackRoot] +++ map toFilePath sandboxSubdirs]))+ exec+ plainEnvSettings+ "docker"+ (concat+ [["run"+ ,"--net=host"+ ,"-e",inContainerEnvVar ++ "=1"+ ,"-e",stackRootEnvVar ++ "=" ++ toFPNoTrailingSep stackRoot+ ,"-e","WORK_UID=" ++ uid+ ,"-e","WORK_GID=" ++ gid+ ,"-e","WORK_WD=" ++ toFPNoTrailingSep pwd+ ,"-e","WORK_HOME=" ++ toFPNoTrailingSep sandboxRepoDir+ ,"-e","WORK_ROOT=" ++ toFPNoTrailingSep projectRoot+ ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++ toFPNoTrailingSep stackRoot+ ,"-v",toFPNoTrailingSep projectRoot ++ ":" ++ toFPNoTrailingSep projectRoot+ ,"-v",toFPNoTrailingSep sandboxSandboxDir ++ ":" ++ toFPNoTrailingSep sandboxDir+ ,"-v",toFPNoTrailingSep sandboxHomeDir ++ ":" ++ toFPNoTrailingSep sandboxRepoDir+ ,"-v",toFPNoTrailingSep stackRoot ++ ":" +++ toFPNoTrailingSep (sandboxRepoDir </> $(mkRelDir ("." ++ stackProgName ++ "/")))]+ ,if oldImage+ then ["-e",sandboxIDEnvVar ++ "=" ++ sandboxID+ ,"--entrypoint=/root/entrypoint.sh"]+ else []+ ,case (dockerPassHost docker,dockerHost) of+ (True,Just x@('u':'n':'i':'x':':':'/':'/':s)) -> ["-e","DOCKER_HOST=" ++ x+ ,"-v",s ++ ":" ++ s]+ (True,Just x) -> ["-e","DOCKER_HOST=" ++ x]+ (True,Nothing) -> ["-v","/var/run/docker.sock:/var/run/docker.sock"]+ (False,_) -> []+ ,case (dockerPassHost docker,dockerCertPath) of+ (True,Just x) -> ["-e","DOCKER_CERT_PATH=" ++ x+ ,"-v",x ++ ":" ++ x]+ _ -> []+ ,case (dockerPassHost docker,dockerTlsVerify) of+ (True,Just x )-> ["-e","DOCKER_TLS_VERIFY=" ++ x]+ _ -> []+ ,concatMap sandboxSubdirArg sandboxSubdirs+ ,concatMap mountArg (dockerMount docker)+ ,case dockerContainerName docker of+ Just name -> ["--name=" ++ name]+ Nothing -> []+ ,if dockerDetach docker+ then ["-d"]+ else concat [["--rm" | not (dockerPersist docker)]+ ,["-t" | isTerm]+ ,["-i"]]+ ,dockerRunArgs docker+ ,[image]+ ,map (\(k,v) -> k ++ "=" ++ v) envVars+ ,[cmnd]+ ,args])+ where lookupImageEnv name vars = case lookup name vars of@@ -587,19 +580,6 @@ where minimumDockerVersion = $(mkVersion "1.3.0") prohibitedDockerVersions = [$(mkVersion "1.2.0")] --- | Run a process, then exit with the same exit code.-execProcessAndExit :: EnvOverride -> FilePath -> [String] -> IO () -> IO ()-execProcessAndExit envOverride cmnd args successPostAction =- do (_, _, _, h) <- Proc.createProcess (Proc.proc cmnd args){Proc.delegate_ctlc = True- ,Proc.env = envHelper envOverride}-#ifndef mingw32_HOST_OS- _ <- installHandler sigTERM (Catch (Proc.terminateProcess h)) Nothing-#endif- exitCode <- Proc.waitForProcess h- when (exitCode == ExitSuccess)- successPostAction- exitWith exitCode- -- | Remove the project's Docker sandbox. reset :: (MonadIO m) => Maybe (Path Abs Dir) -> Bool -> m () reset maybeProjectRoot keepHome =@@ -688,7 +668,7 @@ hide <> metavar "NAME" <> help "Docker container name")- <*> wordsStrOption (long (dockerOptName dockerRunArgsArgName) <>+ <*> argsStrOption (long (dockerOptName dockerRunArgsArgName) <> hide <> value [] <> metavar "'ARG1 [ARG2 ...]'" <>@@ -708,7 +688,7 @@ where dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName maybeStrOption = optional . option str- wordsStrOption = option (fmap words str)+ argsStrOption = option (fmap (either error id . parseArgs Escaping . T.pack) str) hide = if showOptions then idm else internal <> hidden
src/Stack/Dot.hs view
@@ -1,69 +1,235 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-module Stack.Dot where-+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Stack.Dot (dot+ ,DotOpts(..)+ ,dotOptsParser+ ,resolveDependencies+ ,printGraph+ ,pruneGraph+ ) where -import Control.Monad (when)+import Control.Monad (void) import Control.Monad.Catch (MonadCatch)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger, logInfo) import Control.Monad.Reader (MonadReader)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Char (isSpace) import qualified Data.Foldable as F-import Data.Monoid ((<>))+import qualified Data.HashSet as HashSet+import Data.List.Split (splitOn)+import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set) import qualified Data.Set as Set-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Traversable as T+import Network.HTTP.Client.Conduit (HasHttpManager)+import Options.Applicative+import Options.Applicative.Builder.Extra (boolFlags)+import Stack.Build (withLoadPackage) import Stack.Build.Source import Stack.Build.Types+import Stack.Constants import Stack.Package import Stack.Types --- | Convert a package name to a graph node name.-nodeName :: PackageName -> T.Text-nodeName name = "\"" <> T.pack (packageNameString name) <> "\""+-- | Options record for `stack dot`+data DotOpts = DotOpts+ { dotIncludeExternal :: Bool+ -- ^ Include external dependencies+ , dotIncludeBase :: Bool+ -- ^ Include dependencies on base+ , dotDependencyDepth :: Maybe Int+ -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint+ , dotPrune :: Set String+ -- ^ Package names to prune from the graph+ } -dot :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadCatch m,HasEnvConfig env)- => m ()-dot = do- (locals, _names, _idents) <- loadLocals- BuildOpts- { boptsTargets = []- , boptsLibProfile = False- , boptsExeProfile = False- , boptsEnableOptimizations = Nothing- , boptsHaddock = False- , boptsHaddockDeps = Nothing- , boptsFinalAction = DoNothing- , boptsDryrun = False- , boptsGhcOptions = []- , boptsFlags = Map.empty- , boptsInstallExes = False- , boptsPreFetch = False- , boptsTestArgs = []- , boptsOnlySnapshot = False- , boptsCoverage = False- }- Map.empty- let localNames = Set.fromList $ map (packageName . lpPackage) locals+-- | Parser for arguments to `stack dot`+dotOptsParser :: Parser DotOpts+dotOptsParser = DotOpts+ <$> includeExternal+ <*> includeBase+ <*> depthLimit+ <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs+ where includeExternal = boolFlags False+ "external"+ "inclusion of external dependencies"+ idm+ includeBase = boolFlags True+ "include-base"+ "inclusion of dependencies on base"+ idm+ depthLimit =+ optional (option auto+ (long "depth" <>+ metavar "DEPTH" <>+ help ("Limit the depth of dependency resolution " <>+ "(Default: No limit)")))+ prunedPkgs = optional (strOption+ (long "prune" <>+ metavar "PACKAGES" <>+ help ("Prune each package name " <>+ "from the comma separated list " <>+ "of package names PACKAGES"))) - $logInfo "digraph deps {"- $logInfo "splines=polyline;"+ splitNames :: String -> [String]+ splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn "," - F.forM_ locals $ \lp -> do- let deps = Set.intersection localNames $ packageAllDeps $ lpPackage lp- F.forM_ deps $ \dep ->- $logInfo $ T.concat- [ nodeName $ packageName $ lpPackage lp- , " -> "- , nodeName dep- , ";"- ]- when (Set.null deps) $- $logInfo $ T.concat- [ "{rank=max; "- , nodeName $ packageName $ lpPackage lp- , "}"- ]+-- | Visualize the project's dependencies as a graphviz graph+dot :: (HasEnvConfig env+ ,HasHttpManager env+ ,MonadBaseControl IO m+ ,MonadCatch m+ ,MonadIO m+ ,MonadLogger m+ ,MonadReader env m+ )+ => DotOpts+ -> m ()+dot dotOpts = do+ (locals,_,_) <- loadLocals defaultBuildOpts Map.empty+ (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts+ let graph = Map.fromList (localDependencies dotOpts locals)+ menv <- getMinimalEnvOverride+ resultGraph <- withLoadPackage menv (\loader -> do+ let depLoader = createDepLoader sourceMap (fmap3 packageAllDeps loader)+ liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)+ let pkgsToPrune = if dotIncludeBase dotOpts+ then dotPrune dotOpts+ else Set.insert "base" (dotPrune dotOpts)+ localNames = Set.fromList (map (packageName . lpPackage) locals)+ prunedGraph = pruneGraph localNames pkgsToPrune resultGraph+ printGraph dotOpts locals prunedGraph+ where -- fmap a function over the result of a function with 3 arguments+ fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e+ fmap3 f g a b c = f <$> g a b c - $logInfo "}"+-- | `pruneGraph dontPrune toPrune graph` prunes all packages in+-- `graph` with a name in `toPrune` and removes resulting orphans+-- unless they are in `dontPrune`+pruneGraph :: (F.Foldable f, F.Foldable g)+ => f PackageName+ -> g String+ -> Map PackageName (Set PackageName)+ -> Map PackageName (Set PackageName)+pruneGraph dontPrune names =+ pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg pkgDeps ->+ if show pkg `F.elem` names+ then Nothing+ else let filtered = Set.filter (\n -> show n `F.notElem` names) pkgDeps+ in if Set.null filtered && not (Set.null pkgDeps)+ then Nothing+ else Just filtered)++-- | Make sure that all unreachable nodes (orphans) are pruned+pruneUnreachable :: F.Foldable f+ => f PackageName+ -> Map PackageName (Set PackageName)+ -> Map PackageName (Set PackageName)+pruneUnreachable dontPrune = fixpoint prune+ where fixpoint :: Eq a => (a -> a) -> a -> a+ fixpoint f v = if f v == v then v else fixpoint f (f v)+ prune graph' = Map.filterWithKey (\k _ -> reachable k) graph'+ where reachable k = k `F.elem` dontPrune || k `Set.member` reachables+ reachables = F.fold graph'+++-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached+resolveDependencies :: (Applicative m, Monad m)+ => Maybe Int+ -> Map PackageName (Set PackageName)+ -> (PackageName -> m (Set PackageName))+ -> m (Map PackageName (Set PackageName))+resolveDependencies (Just 0) graph _ = return graph+resolveDependencies limit graph loadPackageDeps = do+ let values = Set.unions (Map.elems graph)+ keys = Map.keysSet graph+ next = Set.difference values keys+ if Set.null next+ then return graph+ else do+ x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next)+ resolveDependencies (subtract 1 <$> limit)+ (Map.unionWith Set.union graph (Map.fromList x))+ loadPackageDeps++-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package+createDepLoader :: Applicative m+ => Map PackageName PackageSource+ -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName))+ -> PackageName+ -> m (Set PackageName)+createDepLoader sourceMap loadPackageDeps pkgName =+ case Map.lookup pkgName sourceMap of+ Just (PSLocal lp) -> pure (packageAllDeps (lpPackage lp))+ Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags+ Nothing -> pure Set.empty++-- | Resolve the direct (depth 0) external dependencies of the given local packages+localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,Set PackageName)]+localDependencies dotOpts locals = map (\lp -> (packageName (lpPackage lp), deps lp)) locals+ where deps lp = if dotIncludeExternal dotOpts+ then Set.delete (lpName lp) (packageAllDeps (lpPackage lp))+ else Set.intersection localNames (packageAllDeps (lpPackage lp))+ lpName lp = packageName (lpPackage lp)+ localNames = Set.fromList $ map (packageName . lpPackage) locals++-- | Print a graphviz graph of the edges in the Map and highlight the given local packages+printGraph :: (Applicative m, MonadLogger m)+ => DotOpts+ -> [LocalPackage]+ -> Map PackageName (Set PackageName)+ -> m ()+printGraph dotOpts locals graph = do+ $logInfo "strict digraph deps {"+ printLocalNodes dotOpts filteredLocals+ printLeaves graph+ void (Map.traverseWithKey printEdges graph)+ $logInfo "}"+ where filteredLocals = filter (\local ->+ show (packageName (lpPackage local)) `Set.notMember` dotPrune dotOpts) locals++-- | Print the local nodes with a different style depending on options+printLocalNodes :: (F.Foldable t, MonadLogger m)+ => DotOpts+ -> t LocalPackage+ -> m ()+printLocalNodes dotOpts locals = $logInfo (Text.intercalate "\n" lpNodes)+ where applyStyle :: Text -> Text+ applyStyle n = if dotIncludeExternal dotOpts+ then n <> " [style=dashed];"+ else n <> " [style=solid];"+ lpNodes :: [Text]+ lpNodes = map (applyStyle . nodeName . packageName . lpPackage) (F.toList locals)++-- | Print nodes without dependencies+printLeaves :: (Applicative m, MonadLogger m) => Map PackageName (Set PackageName) -> m ()+printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null++-- | `printDedges p ps` prints an edge from p to every ps+printEdges :: (Applicative m, MonadLogger m) => PackageName -> Set PackageName -> m ()+printEdges package deps = F.for_ deps (printEdge package)++-- | Print an edge between the two package names+printEdge :: MonadLogger m => PackageName -> PackageName -> m ()+printEdge from to = $logInfo (Text.concat [ nodeName from, " -> ", nodeName to, ";"])++-- | Convert a package name to a graph node name.+nodeName :: PackageName -> Text+nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""++-- | Print a node with no dependencies+printLeaf :: MonadLogger m => PackageName -> m ()+printLeaf package = $logInfo . Text.concat $+ if isWiredIn package+ then ["{rank=max; ", nodeName package, " [shape=box]; };"]+ else ["{rank=max; ", nodeName package, "; };"]++-- | Check if the package is wired in (shipped with) ghc+isWiredIn :: PackageName -> Bool+isWiredIn = (`HashSet.member` wiredInPackages)
src/Stack/Exec.hs view
@@ -26,6 +26,14 @@ , esStackExe = True } +-- | Environment settings which do not embellish the environment+plainEnvSettings :: EnvSettings+plainEnvSettings = EnvSettings+ { esIncludeLocals = False+ , esIncludeGhcPackagePath = False+ , esStackExe = False+ }+ -- | Execute a process within the Stack configured environment. exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m) => EnvSettings -> String -> [String] -> m b
src/Stack/Fetch.hs view
@@ -398,7 +398,7 @@ , drLengthCheck = fmap fromIntegral $ tfSize toFetch } let progressSink = do- liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": downloading"+ liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink let fp = toFilePath destpath
+ src/Stack/FileWatch.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Stack.FileWatch+ ( fileWatch+ , printExceptionStderr+ ) where++import Blaze.ByteString.Builder (toLazyByteString, copyByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromShow)+import Control.Concurrent.Async (race_)+import Control.Concurrent.STM+import Control.Exception (Exception)+import Control.Exception.Enclosed (tryAny)+import Control.Monad (forever, unless)+import qualified Data.ByteString.Lazy as L+import qualified Data.Map.Strict as Map+import Data.Monoid ((<>))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String (fromString)+import Data.Traversable (forM)+import Path+import System.FSNotify+import System.IO (stderr)++-- | Print an exception to stderr+printExceptionStderr :: Exception e => e -> IO ()+printExceptionStderr e =+ L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"++-- | Run an action, watching for file changes+--+-- The action provided takes a callback that is used to set the files to be+-- watched. When any of those files are changed, we rerun the action again.+fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ())+ -> IO ()+fileWatch inner = withManager $ \manager -> do+ dirtyVar <- newTVarIO True+ watchVar <- newTVarIO Map.empty++ let onChange = atomically $ writeTVar dirtyVar True++ setWatched :: Set (Path Abs File) -> IO ()+ setWatched files = do+ watch0 <- readTVarIO watchVar+ let actions = Map.mergeWithKey+ keepListening+ stopListening+ startListening+ watch0+ newDirs+ watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do+ mv <- mmv+ return $+ case mv of+ Nothing -> Map.empty+ Just v -> Map.singleton k v+ atomically $ writeTVar watchVar $ Map.unions watch1+ where+ newDirs = Map.fromList $ map (, ())+ $ Set.toList+ $ Set.map parent files++ keepListening _dir listen () = Just $ return $ Just listen+ stopListening = Map.map $ \f -> do+ () <- f+ return Nothing+ startListening = Map.mapWithKey $ \dir () -> do+ let dir' = fromString $ toFilePath dir+ listen <- watchDir manager dir' (const True) (const onChange)+ return $ Just listen++ let watchInput = do+ line <- getLine+ unless (line == "quit") $ do+ case line of+ "help" -> do+ putStrLn ""+ putStrLn "help: display this help"+ putStrLn "quit: exit"+ putStrLn "build: force a rebuild"+ putStrLn "watched: display watched directories"+ "build" -> onChange+ "watched" -> do+ watch <- readTVarIO watchVar+ mapM_ (putStrLn . toFilePath) (Map.keys watch)+ _ -> putStrLn $ "Unknown command: " ++ show line++ watchInput++ race_ watchInput $ forever $ do+ atomically $ do+ dirty <- readTVar dirtyVar+ check dirty+ writeTVar dirtyVar False++ eres <- tryAny $ inner setWatched+ case eres of+ Left e -> printExceptionStderr e+ Right () -> putStrLn "Success! Waiting for next file change."++ putStrLn "Type help for available commands"
+ src/Stack/Ide.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++-- | Run a IDE configured with the user's project(s).++module Stack.Ide (ide) where++import Control.Concurrent+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Aeson+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import qualified Data.Set as S+import Data.Text (Text)+import Path+import Path.IO+import Stack.Build.Source+import Stack.Constants+import Stack.Exec (defaultEnvSettings)+import Stack.Package+import Stack.Types+import System.Directory (doesFileExist)+import System.Exit+import System.IO+import qualified System.Process as P+import System.Process.Read++-- | Launch a GHCi IDE for the given local project targets with the+-- given options and configure it with the load paths and extensions+-- of those targets.+ide+ :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)+ => [Text] -- ^ Targets.+ -> [String] -- ^ GHC options.+ -> m ()+ide targets useropts = do+ econfig <- asks getEnvConfig+ bconfig <- asks getBuildConfig+ pwd <- getWorkingDir+ pkgs <-+ liftM catMaybes $+ forM (M.toList (bcPackages bconfig)) $+ \(dir,validWanted) ->+ do cabalfp <- getCabalFileName dir+ name <- parsePackageNameFromFilePath cabalfp+ let config =+ PackageConfig+ { packageConfigEnableTests = True+ , packageConfigEnableBenchmarks = True+ , packageConfigFlags = localFlags mempty bconfig name+ , packageConfigGhcVersion = envConfigGhcVersion econfig+ , packageConfigPlatform = configPlatform+ (getConfig bconfig)+ }+ pkg <- readPackage config cabalfp+ if validWanted && wanted pwd cabalfp pkg+ then do+ pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp+ srcfiles <-+ getPackageFiles (packageFiles pkg) Modules cabalfp+ dist <- distDirFromDir dir+ autogen <- return (autogenDir dist)+ paths_foo <-+ liftM+ (autogen </>)+ (parseRelFile+ ("Paths_" +++ packageNameString name ++ ".hs"))+ paths_foo_exists <- fileExists paths_foo+ return+ (Just+ ( packageName pkg+ , ["--dist-dir=" <> toFilePath dist] +++ map ("--ghc-option=" ++) (filter (not . badForGhci) pkgOpts)+ , mapMaybe+ (stripDir pwd)+ (S.toList srcfiles <>+ if paths_foo_exists+ then [paths_foo]+ else [])))+ else return Nothing+ localdb <- packageDatabaseLocal+ depsdb <- packageDatabaseDeps+ let pkgopts = concat (map _2 pkgs)+ srcfiles = concatMap (map toFilePath . _3) pkgs+ pkgdbs =+ ["--package-db=" <> toFilePath depsdb <> ":" <> toFilePath localdb]+ exec+ "stack-ide"+ (["--local-work-dir="++toFilePath pwd] +++ map ("--ghc-option=" ++) (filter (not . badForGhci) useropts) <> pkgopts <> pkgdbs)+ (encode (initialRequest srcfiles))+ where+ wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir+ where+ isInWantedList = elem (packageNameText (packageName pkg)) targets+ targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd+ badForGhci x =+ isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")+ _1 (x,_,_) = x+ _2 (_,x,_) = x+ _3 (_,_,x) = x++-- | Make the initial request.+initialRequest :: [FilePath] -> Value+initialRequest srcfiles =+ object+ [ "tag" .= "RequestUpdateSession"+ , "contents" .=+ [ object+ [ "tag" .= "RequestUpdateTargets"+ , "contents" .= object+ [ "tag" .= "TargetsInclude"+ , "contents" .= srcfiles ]+ ]+ ]+ ]++-- | Execute a process within the Stack configured environment.+exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m)+ => String -> [String] -> ByteString -> m b+exec cmd args input = do+ config <- asks getConfig+ menv <-+ liftIO+ (configEnvOverride+ config+ defaultEnvSettings+ { esIncludeGhcPackagePath = False+ })+ exists <- liftIO $ doesFileExist cmd+ cmd' <-+ if exists+ then return cmd+ else liftM toFilePath $+ join $ System.Process.Read.findExecutable menv cmd+ let cp =+ (P.proc cmd' args)+ { P.env = envHelper menv+ , P.delegate_ctlc = True+ , P.std_in = P.CreatePipe+ }+ $logProcessRun cmd' args+ (Just procin,Nothing,Nothing,ph) <- liftIO (P.createProcess cp)+ liftIO+ (do hSetBuffering stdin LineBuffering+ hSetBuffering procin LineBuffering)+ liftIO (do {-S8.hPutStrLn stdout (L.toStrict input)-}+ S8.hPutStrLn procin (L.toStrict input))+ _tid <-+ liftIO+ (forkIO+ (forever+ (do bytes <- S.getLine+ S.hPutStr procin bytes)))+ ec <- liftIO (P.waitForProcess ph)+ liftIO (exitWith ec)
src/Stack/Init.hs view
@@ -43,9 +43,9 @@ import Stack.Types import System.Directory (getDirectoryContents) -findCabalFiles :: MonadIO m => Path Abs Dir -> m [Path Abs File]-findCabalFiles dir =- liftIO $ findFiles dir isCabal (not . isIgnored)+findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]+findCabalFiles recurse dir =+ liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir)) where isCabal path = ".cabal" `isSuffixOf` toFilePath path @@ -68,9 +68,12 @@ let dest = currDir </> stackDotYaml dest' = toFilePath dest exists <- fileExists dest- when exists $ error "Refusing to overwrite existing stack.yaml, please delete before running stack init"+ when (not (forceOverwrite initOpts) && exists) $+ error ("Refusing to overwrite existing stack.yaml, " <>+ "please delete before running stack init " <>+ "or if you are sure use \"--force\"") - cabalfps <- findCabalFiles currDir+ cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir $logInfo $ "Writing default config file to: " <> T.pack dest' $logInfo $ "Basing on cabal files:" mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps@@ -128,7 +131,7 @@ -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts -> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)-getDefaultResolver cabalfps gpds initOpts = do+getDefaultResolver cabalfps gpds initOpts = case ioMethod initOpts of MethodSnapshot snapPref -> do msnapshots <- getSnapshots'@@ -195,6 +198,10 @@ data InitOpts = InitOpts { ioMethod :: !Method -- ^ Preferred snapshots+ , forceOverwrite :: Bool+ -- ^ Force overwrite of existing stack.yaml+ , includeSubDirs :: Bool+ -- ^ If True, include all .cabal files found in any sub directories } data SnapPref = PrefNone | PrefLTS | PrefNightly@@ -204,8 +211,16 @@ initOptsParser :: Parser InitOpts initOptsParser =- InitOpts <$> method+ InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs where+ ignoreSubDirs = flag False+ True+ (long "ignore-subdirs" <>+ help "Do not search for .cabal files in sub directories")+ overwrite = flag False+ True+ (long "force" <>+ help "Force overwriting of an existing stack.yaml if it exists") method = solver <|> (MethodResolver <$> resolver) <|> (MethodSnapshot <$> snapPref)
src/Stack/Package.hs view
@@ -29,7 +29,8 @@ ,packageToolDependencies ,packageDependencies ,packageIdentifier- ,CabalFileType(..))+ ,CabalFileType(..)+ ,autogenDir) where import Control.Exception hiding (try,catch)@@ -62,7 +63,7 @@ import Distribution.PackageDescription hiding (FlagName) import Distribution.PackageDescription.Parse import Distribution.Simple.Utils-import Distribution.System (OS, Arch, Platform (..))+import Distribution.System (OS (..), Arch, Platform (..)) import Distribution.Text (display) import Distribution.Version (intersectVersionRanges) import Path as FL@@ -614,7 +615,7 @@ mkResolveConditions ghcVersion (Platform arch os) flags = ResolveConditions { rcFlags = flags , rcGhcVersion = ghcVersion- , rcOS = os+ , rcOS = if isWindows os then Windows else os , rcArch = arch }
src/Stack/PackageDump.hs view
@@ -378,7 +378,7 @@ start' bs1 = toConsumer (valSrc =$= inner key) >>= yield >> start where- (key, bs2) = S.breakByte _colon bs1+ (key, bs2) = S.break (== _colon) bs1 (spaces, bs3) = S.span (== _space) $ S.drop 1 bs2 indent = S.length key + 1 + S.length spaces
src/Stack/Setup.hs view
@@ -39,6 +39,8 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Typeable (Typeable) import qualified Data.Yaml as Yaml@@ -49,13 +51,13 @@ import Path import Path.IO import Prelude -- Fix AMP warning-import Safe (readMay)+import Safe (headMay, readMay) import Stack.Build.Types-import Stack.GhcPkg (getCabalPkgVer, getGlobalDB)+import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB) import Stack.Solver (getGhcVersion) import Stack.Types import Stack.Types.StackT-import System.Directory (doesDirectoryExist, createDirectoryIfMissing, removeFile)+import System.Directory (createDirectoryIfMissing, removeFile) import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator)@@ -75,11 +77,13 @@ -- ^ Run a sanity check on the selected GHC , soptsSkipGhcCheck :: !Bool -- ^ Don't check for a compatible GHC version/architecture+ , soptsSkipMsys :: !Bool+ -- ^ Do not use a custom msys installation on Windows } deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String]- | UnknownGHCVersion Version (Set MajorVersion)+ | UnknownGHCVersion Text Version (Set MajorVersion) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) deriving Typeable@@ -93,10 +97,10 @@ show (MissingDependencies tools) = "The following executables are missing and must be installed: " ++ intercalate ", " tools- show (UnknownGHCVersion version known) = concat+ show (UnknownGHCVersion oskey version known) = concat [ "No information found for GHC version " , versionString version- , ". Known GHC major versions: "+ , ".\nSupported GHC major versions for OS key '" ++ T.unpack oskey ++ "': " , intercalate ", " (map show $ Set.toList known) ] show (UnknownOSKey oskey) =@@ -125,6 +129,7 @@ , soptsForceReinstall = False , soptsSanityCheck = False , soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig+ , soptsSkipMsys = configSkipMsys $ bcConfig bconfig } mghcBin <- ensureGHC sopts menv0 <- getMinimalEnvOverride@@ -164,13 +169,13 @@ localsPath = augmentPath (mkDirs' True) mpath deps <- runReaderT packageDatabaseDeps envConfig0- depsExists <- liftIO $ doesDirectoryExist $ toFilePath deps+ createDatabase menv1 deps localdb <- runReaderT packageDatabaseLocal envConfig0- localdbExists <- liftIO $ doesDirectoryExist $ toFilePath localdb+ createDatabase menv1 localdb globalDB <- mkEnvOverride platform env1 >>= getGlobalDB let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat- [ [toFilePathNoTrailingSlash localdb | locals && localdbExists]- , [toFilePathNoTrailingSlash deps | depsExists]+ [ [toFilePathNoTrailingSlash localdb | locals]+ , [toFilePathNoTrailingSlash deps] , [toFilePathNoTrailingSlash globalDB] ] @@ -261,10 +266,11 @@ config <- asks getConfig let tools = case configPlatform config of- Platform _ Windows ->- [ ($(mkPackageName "ghc"), Just expected)- , ($(mkPackageName "git"), Nothing)- ]+ Platform _ os | isWindows os ->+ ($(mkPackageName "ghc"), Just expected)+ : (if soptsSkipMsys sopts+ then []+ else [($(mkPackageName "git"), Nothing)]) _ -> [ ($(mkPackageName "ghc"), Just expected) ]@@ -282,7 +288,7 @@ return si installed <- runReaderT listInstalled config- idents <- mapM (ensureTool sopts installed getSetupInfo' msystem) tools+ idents <- mapM (ensureTool menv0 sopts installed getSetupInfo' msystem) tools paths <- runReaderT (mapM binDirs $ catMaybes idents) config return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing@@ -394,11 +400,11 @@ config <- asks getConfig dir <- installDir ident case (configPlatform config, packageNameString $ packageIdentifierName ident) of- (Platform _ Windows, "ghc") -> return+ (Platform _ (isWindows -> True), "ghc") -> return [ dir </> $(mkRelDir "bin") , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin") ]- (Platform _ Windows, "git") -> return+ (Platform _ (isWindows -> True), "git") -> return [ dir </> $(mkRelDir "cmd") , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin") ]@@ -410,13 +416,14 @@ return [] ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)- => SetupOpts+ => EnvOverride+ -> SetupOpts -> [PackageIdentifier] -- ^ already installed -> m SetupInfo -> Maybe (Version, Arch) -- ^ installed GHC -> (PackageName, Maybe Version) -> m (Maybe PackageIdentifier)-ensureTool sopts installed getSetupInfo' msystem (name, mversion)+ensureTool menv sopts installed getSetupInfo' msystem (name, mversion) | not $ null available = return $ Just $ PackageIdentifier name $ maximum available | not $ soptsInstallIfMissing sopts = if name == $(mkPackageName "ghc")@@ -434,7 +441,7 @@ let pair = siPortableGit si return (pair, installGitWindows) "ghc" -> do- osKey <- getOSKey+ osKey <- getOSKey menv pairs <- case Map.lookup osKey $ siGHCs si of Nothing -> throwM $ UnknownOSKey osKey@@ -445,12 +452,12 @@ Just version -> return version pair <- case Map.lookup (getMajorVersion version) pairs of- Nothing -> throwM $ UnknownGHCVersion version (Map.keysSet pairs)+ Nothing -> throwM $ UnknownGHCVersion osKey version (Map.keysSet pairs) Just pair -> return pair platform <- asks $ configPlatform . getConfig let installer = case platform of- Platform _ Windows -> installGHCWindows+ Platform _ os | isWindows os -> installGHCWindows _ -> installGHCPosix return (pair, installer) x -> error $ "Invariant violated: ensureTool on " ++ x@@ -477,12 +484,13 @@ getMajorVersion expected == getMajorVersion actual && actual >= expected -getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env) => m Text-getOSKey = do+getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)+ => EnvOverride -> m Text+getOSKey menv = do platform <- asks $ configPlatform . getConfig case platform of- Platform I386 Linux -> return "linux32"- Platform X86_64 Linux -> return "linux64"+ Platform I386 Linux -> ("linux32" <>) <$> getLinuxSuffix+ Platform X86_64 Linux -> ("linux64" <>) <$> getLinuxSuffix Platform I386 OSX -> return "macosx" Platform X86_64 OSX -> return "macosx" Platform I386 FreeBSD -> return "freebsd32"@@ -491,7 +499,20 @@ Platform X86_64 OpenBSD -> return "openbsd64" Platform I386 Windows -> return "windows32" Platform X86_64 Windows -> return "windows64"++ Platform I386 (OtherOS "windowsintegersimple") -> return "windowsintegersimple32"+ Platform X86_64 (OtherOS "windowsintegersimple") -> return "windowsintegersimple64"+ Platform arch os -> throwM $ UnsupportedSetupCombo os arch+ where+ getLinuxSuffix = do+ executablePath <- liftIO getExecutablePath+ elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]+ return $ case elddOut of+ Left _ -> ""+ Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut then "-gmp4" else ""+ hasLineWithFirstWord w =+ elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadPair@@ -581,11 +602,13 @@ -> PackageIdentifier -> m () installGHCWindows si archiveFile archiveType destDir _ = do- case archiveType of- TarXz -> return ()- _ -> error $ "GHC on Windows must be a .tar.xz file"+ suffix <-+ case archiveType of+ TarXz -> return ".xz"+ TarBz2 -> return ".bz2"+ _ -> error $ "GHC on Windows must be a tarball file" tarFile <-- case T.stripSuffix ".xz" $ T.pack $ toFilePath archiveFile of+ case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x @@ -729,7 +752,10 @@ ] ghc <- join $ findExecutable menv "ghc" $logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc)- eres <- tryProcessStdout (Just dir') menv "ghc" [fp]+ eres <- tryProcessStdout (Just dir') menv "ghc"+ [ fp+ , "-no-user-package-db"+ ] case eres of Left e -> throwM $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct
src/Stack/Types/BuildPlan.hs view
@@ -22,6 +22,7 @@ , MiniPackageInfo (..) , renderSnapName , parseSnapName+ , isWindows ) where import Control.Applicative@@ -51,7 +52,7 @@ import qualified Data.Traversable as T import Data.Typeable (TypeRep, Typeable, typeOf) import Data.Vector (Vector)-import Distribution.System (Arch, OS)+import Distribution.System (Arch, OS (..)) import qualified Distribution.Text as DT import qualified Distribution.Version as C import GHC.Generics (Generic)@@ -386,3 +387,9 @@ } deriving (Generic, Show, Eq) instance Binary.Binary MiniPackageInfo+++isWindows :: OS -> Bool+isWindows Windows = True+isWindows (OtherOS "windowsintegersimple") = True+isWindows _ = False
src/Stack/Types/Config.hs view
@@ -87,6 +87,8 @@ -- version is available? Can be overridden by command line options. ,configSkipGHCCheck :: !Bool -- ^ Don't bother checking the GHC version or architecture.+ ,configSkipMsys :: !Bool+ -- ^ On Windows: don't use a locally installed MSYS ,configLocalBin :: !(Path Abs Dir) -- ^ Directory we should install executables into ,configRequireStackVersion :: !VersionRange@@ -99,6 +101,8 @@ -- ^ --extra-lib-dirs arguments ,configConfigMonoid :: !ConfigMonoid -- ^ @ConfigMonoid@ used to generate this+ ,configConcurrentTests :: !Bool+ -- ^ Run test suites concurrently } -- | Information on a single package index@@ -416,6 +420,8 @@ -- ^ See: 'configInstallGHC' ,configMonoidSkipGHCCheck :: !(Maybe Bool) -- ^ See: 'configSkipGHCCheck'+ ,configMonoidSkipMsys :: !(Maybe Bool)+ -- ^ See: 'configSkipMsys' ,configMonoidRequireStackVersion :: !VersionRange -- ^ See: 'configRequireStackVersion' ,configMonoidOS :: !(Maybe String)@@ -428,6 +434,8 @@ -- ^ See: 'configExtraIncludeDirs' ,configMonoidExtraLibDirs :: !(Set Text) -- ^ See: 'configExtraLibDirs'+ ,configMonoidConcurrentTests :: !(Maybe Bool)+ -- ^ See: 'configConcurrentTests' } deriving Show @@ -441,12 +449,14 @@ , configMonoidSystemGHC = Nothing , configMonoidInstallGHC = Nothing , configMonoidSkipGHCCheck = Nothing+ , configMonoidSkipMsys = Nothing , configMonoidRequireStackVersion = anyVersion , configMonoidOS = Nothing , configMonoidArch = Nothing , configMonoidJobs = Nothing , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty+ , configMonoidConcurrentTests = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r@@ -457,6 +467,7 @@ , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r , configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r+ , configMonoidSkipMsys = configMonoidSkipMsys l <|> configMonoidSkipMsys r , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l) (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r@@ -464,6 +475,7 @@ , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)+ , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r } instance FromJSON ConfigMonoid where@@ -478,6 +490,7 @@ configMonoidSystemGHC <- obj .:? "system-ghc" configMonoidInstallGHC <- obj .:? "install-ghc" configMonoidSkipGHCCheck <- obj .:? "skip-ghc-check"+ configMonoidSkipMsys <- obj .:? "skip-msys" configMonoidRequireStackVersion <- unVersionRangeJSON <$> obj .:? "require-stack-version" .!= VersionRangeJSON anyVersion@@ -486,6 +499,7 @@ configMonoidJobs <- obj .:? "jobs" configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty+ configMonoidConcurrentTests <- obj .:? "concurrent-tests" return ConfigMonoid {..} -- | Newtype for non-orphan FromJSON instance.
src/Stack/Upgrade.hs view
@@ -7,12 +7,14 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader+import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control+import Data.Foldable (forM_) import qualified Data.Map as Map import qualified Data.Set as Set import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager) import Path+import qualified Paths_stack as Paths import Stack.Build import Stack.Build.Types import Stack.Config@@ -32,7 +34,7 @@ upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do menv <- getMinimalEnvOverride tmp <- parseAbsDir tmp'- dir <-+ mdir <- if fromGit then do $logInfo "Cloning stack"@@ -44,48 +46,45 @@ , "1" ] Nothing- return $ tmp </> $(mkRelDir "stack")+ return $ Just $ tmp </> $(mkRelDir "stack") else do updateAllIndices menv caches <- getPackageCaches menv let latest = Map.fromListWith max $ map toTuple- $ Map.keys caches+ $ Map.keys++ -- Mistaken upload to Hackage, just ignore it+ $ Map.delete (PackageIdentifier+ $(mkPackageName "stack")+ $(mkVersion "9.9.9"))++ caches case Map.lookup $(mkPackageName "stack") latest of Nothing -> error "No stack found in package indices"+ Just version | version <= fromCabalVersion Paths.version -> do+ $logInfo "Already at latest version, no upgrade required"+ return Nothing Just version -> do let ident = PackageIdentifier $(mkPackageName "stack") version paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident case Map.lookup ident paths of Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"- Just path -> return path+ Just path -> return $ Just path manager <- asks getHttpManager logLevel <- asks getLogLevel terminal <- asks getTerminal configMonoid <- asks $ configConfigMonoid . getConfig - liftIO $ do+ forM_ mdir $ \dir -> liftIO $ do bconfig <- runStackLoggingT manager logLevel terminal $ do lc <- loadConfig configMonoid (Just $ dir </> $(mkRelFile "stack.yaml")) lcLoadBuildConfig lc mresolver ThrowException envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv- runStackT manager logLevel envConfig1 terminal $ build BuildOpts+ runStackT manager logLevel envConfig1 terminal $ build (const $ return ()) defaultBuildOpts { boptsTargets = ["stack"]- , boptsLibProfile = False- , boptsExeProfile = False- , boptsEnableOptimizations = Nothing- , boptsHaddock = False- , boptsHaddockDeps = Nothing- , boptsFinalAction = DoNothing- , boptsDryrun = False- , boptsGhcOptions = []- , boptsFlags = Map.empty , boptsInstallExes = True- , boptsPreFetch = False- , boptsTestArgs = []- , boptsOnlySnapshot = False- , boptsCoverage = False }
src/System/Process/Read.hs view
@@ -57,7 +57,7 @@ import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable)-import Distribution.System (OS (Windows), Platform (Platform))+import Distribution.System (OS (Windows, OtherOS), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) import Prelude -- Fix AMP warning import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)@@ -108,6 +108,7 @@ isWindows = case platform of Platform _ Windows -> True+ Platform _ (OtherOS "windowsintegersimple") -> True _ -> False -- | Helper conversion function
src/main/Main.hs view
@@ -9,14 +9,12 @@ module Main where -import Blaze.ByteString.Builder (toLazyByteString, copyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (ask)-import qualified Data.ByteString.Lazy as L+import Data.Attoparsec.Args (withInterpreterArgs) import Data.Char (toLower) import Data.List import qualified Data.List as List@@ -46,10 +44,12 @@ import Stack.Dot import Stack.Exec import Stack.Fetch+import Stack.FileWatch import Stack.Init import Stack.New import qualified Stack.PackageIndex import Stack.Repl+import Stack.Ide import Stack.Setup import Stack.Solver (solveExtraDeps) import Stack.Types@@ -60,13 +60,13 @@ import System.Directory (canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit-import System.FilePath (searchPathSeparator)+import System.FilePath (searchPathSeparator,dropTrailingPathSeparator) import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import System.Process.Read -- | Commandline dispatcher. main :: IO ()-main =+main = withInterpreterArgs stackProgName $ \args isInterpreter -> do -- Line buffer the output by default, particularly for non-terminal runs. -- See https://github.com/commercialhaskell/stack/pull/360 hSetBuffering stdout LineBuffering@@ -76,14 +76,13 @@ plugins <- findPlugins (T.pack stackProgName) tryRunPlugin plugins progName <- getProgName- args <- getArgs isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName (Docker.dockerOptsParser True) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") let versionString' = $(simpleVersion Meta.version)- (level,run) <-+ eGlobalRun <- try $ simpleOptions versionString' "stack - The Haskell Tool Stack"@@ -100,8 +99,13 @@ (buildOpts Build) addCommand "test" "Build and test the project(s) in this directory/configuration"- (buildCmd DoTests)- (buildOpts Test)+ (\(rerun, bopts) -> buildCmd (DoTests rerun) bopts)+ ((,)+ <$> boolFlags True+ "rerun-tests"+ "running already successful tests"+ idm+ <*> (buildOpts Test)) addCommand "bench" "Build and benchmark the project(s) in this directory/configuration" (buildCmd DoBenchmarks)@@ -161,30 +165,15 @@ addCommand "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd- (pure ())+ dotOptsParser addCommand "exec" "Execute a command" execCmd- ((,,)- <$> strArgument (metavar "CMD")- <*> many (strArgument (metavar "-- ARGS (e.g. stack exec -- ghc --version)"))- <*> (EnvSettings- <$> pure True- <*> boolFlags True- "ghc-package-path"- "setting the GHC_PACKAGE_PATH variable for the subprocess"- idm- <*> boolFlags True- "stack-exe"- "setting the STACK_EXE environment variable to the path for the stack executable"- idm))+ (execOptsParser Nothing) addCommand "ghc" "Run ghc" execCmd- ((,,)- <$> pure "ghc"- <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))- <*> pure defaultEnvSettings)+ (execOptsParser $ Just "ghc") addCommand "ghci" "Run ghci in the context of project(s)" replCmd@@ -203,13 +192,22 @@ help "Use this command for the GHC to run"))) <*> flag False True (long "no-load" <> help "Don't load modules on start-up"))+ addCommand "ide"+ "Run ide-backend-client with the correct arguments"+ ideCmd+ ((,) <$>+ fmap (map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help "If none specified, use all packages defined in current directory"))) <*>+ fmap (fromMaybe [])+ (optional (argsOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi")))) addCommand "runghc" "Run runghc" execCmd- ((,,)- <$> pure "runghc"- <*> many (strArgument (metavar "-- ARGS (e.g. stack runghc -- X.hs)"))- <*> pure defaultEnvSettings)+ (execOptsParser $ Just "runghc") addCommand "clean" "Clean the local packages" cleanCmd@@ -229,23 +227,30 @@ addCommand Docker.dockerCleanupCmdName "Clean up Docker images and containers" dockerCleanupCmd- dockerCleanupOpts- addCommand "exec"- "Execute a command in a Docker container without setting up Haskell environment first"- dockerExecCmd- ((,) <$> strArgument (metavar "[--] CMD")- <*> many (strArgument (metavar "ARGS"))))+ dockerCleanupOpts) ) -- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322- when (globalLogLevel level == LevelDebug) $ putStrLn versionString'- run level `catch` \e -> do- -- This special handler stops "stack: " from being printed before the- -- exception- case fromException e of- Just ec -> exitWith ec- Nothing -> do- L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"- exitFailure+ case eGlobalRun of+ Left (exitCode :: ExitCode) -> do+ when isInterpreter $+ putStrLn $ concat+ [ "\nIf you are trying to use "+ , stackProgName+ , " as a script interpreter, a\n'-- "+ , stackProgName+ , " [options] runghc [options]' comment is required."+ , "\nSee https://github.com/commercialhaskell/stack/wiki/Script-interpreter" ]+ throwIO exitCode+ Right (global,run) -> do+ when (globalLogLevel global == LevelDebug) $ putStrLn versionString'+ run global `catch` \e -> do+ -- This special handler stops "stack: " from being printed before the+ -- exception+ case fromException e of+ Just ec -> exitWith ec+ Nothing -> do+ printExceptionStderr e+ exitFailure where dockerHelpOptName = Docker.dockerCmdName ++ "-help" @@ -326,21 +331,22 @@ -- really it's mainly for the documentation aspect. -- -- When printing output we generate @PathInfo@ and pass it to the--- function to generate an appropriate string.+-- function to generate an appropriate string. Trailing slashes are+-- removed, see #506 paths :: [(String, Text, PathInfo -> Text)] paths = [ ( "Global stack root directory" , "global-stack-root" , \pi ->- T.pack (toFilePath (configStackRoot (bcConfig (piBuildConfig pi)))))+ T.pack (toFilePathNoTrailing (configStackRoot (bcConfig (piBuildConfig pi))))) , ( "Project root (derived from stack.yaml file)" , "project-root" , \pi ->- T.pack (toFilePath (bcRoot (piBuildConfig pi))))+ T.pack (toFilePathNoTrailing (bcRoot (piBuildConfig pi)))) , ( "Configuration location (where the stack.yaml file is)" , "config-location" , \pi ->- T.pack (toFilePath (bcStackYaml (piBuildConfig pi))))+ T.pack (toFilePathNoTrailing (bcStackYaml (piBuildConfig pi)))) , ( "PATH environment variable" , "bin-path" , \pi ->@@ -348,11 +354,11 @@ , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" , \pi ->- T.pack (toFilePath (configLocalPrograms (bcConfig (piBuildConfig pi)))))+ T.pack (toFilePathNoTrailing (configLocalPrograms (bcConfig (piBuildConfig pi))))) , ( "Local bin path where stack installs executables" , "local-bin-path" , \pi ->- T.pack (toFilePath (configLocalBin (bcConfig (piBuildConfig pi)))))+ T.pack (toFilePathNoTrailing (configLocalBin (bcConfig (piBuildConfig pi))))) , ( "Extra include directories" , "extra-include-dirs" , \pi ->@@ -366,23 +372,24 @@ , ( "Snapshot package database" , "snapshot-pkg-db" , \pi ->- T.pack (toFilePath (piSnapDb pi)))+ T.pack (toFilePathNoTrailing (piSnapDb pi))) , ( "Local project package database" , "local-pkg-db" , \pi ->- T.pack (toFilePath (piLocalDb pi)))+ T.pack (toFilePathNoTrailing (piLocalDb pi))) , ( "Snapshot installation root" , "snapshot-install-root" , \pi ->- T.pack (toFilePath (piSnapRoot pi)))+ T.pack (toFilePathNoTrailing (piSnapRoot pi))) , ( "Local project installation root" , "local-install-root" , \pi ->- T.pack (toFilePath (piLocalRoot pi)))+ T.pack (toFilePathNoTrailing (piLocalRoot pi))) , ( "Dist work directory" , "dist-dir" , \pi ->- T.pack (toFilePath (piDistDir pi)))]+ T.pack (toFilePathNoTrailing (piDistDir pi)))]+ where toFilePathNoTrailing = dropTrailingPathSeparator . toFilePath data SetupCmdOpts = SetupCmdOpts { scoGhcVersion :: !(Maybe Version)@@ -407,7 +414,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer+ Docker.reexecWithOptionalContainer (lcProjectRoot lc) (runStackLoggingT manager globalLogLevel globalTerminal $ do (ghc, mstack) <-@@ -426,6 +433,7 @@ , soptsForceReinstall = scoForceReinstall , soptsSanityCheck = True , soptsSkipGhcCheck = False+ , soptsSkipMsys = configSkipMsys $ lcConfig lc } case mpaths of Nothing -> $logInfo "GHC on PATH would be used"@@ -439,7 +447,7 @@ withConfig go@GlobalOpts{..} inner = do (manager, lc) <- loadConfigWithOpts go runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $+ Docker.reexecWithOptionalContainer (lcProjectRoot lc) $ runStackT manager globalLogLevel (lcConfig lc) globalTerminal inner @@ -450,7 +458,7 @@ withBuildConfig go@GlobalOpts{..} strat inner = do (manager, lc) <- loadConfigWithOpts go runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $ do+ Docker.reexecWithOptionalContainer (lcProjectRoot lc) $ do bconfig <- runStackLoggingT manager globalLogLevel globalTerminal $ lcLoadBuildConfig lc globalResolver strat envConfig <-@@ -498,15 +506,23 @@ return $ Map.singleton pn' $ Map.singleton flagN b _ -> readerError "Must have a colon" +-- | Helper for build and install commands+buildCmdHelper :: NoBuildConfigStrategy -> FinalAction -> BuildOpts -> GlobalOpts -> IO ()+buildCmdHelper strat finalAction opts go+ | boptsFileWatch opts = fileWatch inner+ | otherwise = inner $ const $ return ()+ where+ inner setLocalFiles =+ withBuildConfig go strat $+ Stack.Build.build setLocalFiles opts { boptsFinalAction = finalAction }+ -- | Build the project. buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()-buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go ThrowException $- Stack.Build.build opts { boptsFinalAction = finalAction }+buildCmd = buildCmdHelper ThrowException -- | Install installCmd :: BuildOpts -> GlobalOpts -> IO ()-installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $- Stack.Build.build opts { boptsInstallExes = True }+installCmd opts = buildCmdHelper ExecStrategy DoNothing opts { boptsInstallExes = True } -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO ()@@ -525,28 +541,99 @@ -- | Upload to Hackage uploadCmd :: [String] -> GlobalOpts -> IO ()-uploadCmd args0 go = do+uploadCmd args go = do (manager,lc) <- loadConfigWithOpts go let config = lcConfig lc- args = if null args0 then ["."] else args0- liftIO $ do- uploader <- Upload.mkUploader- config- $ Upload.setGetManager (return manager)- Upload.defaultUploadSettings- mapM_ (Upload.upload uploader) args+ if null args+ then error "To upload the current project, please run 'stack upload .'"+ else liftIO $ do+ uploader <- Upload.mkUploader+ config+ $ Upload.setGetManager (return manager)+ Upload.defaultUploadSettings+ mapM_ (Upload.upload uploader) args +data ExecOpts = ExecOpts+ { eoCmd :: !String+ , eoArgs :: ![String]+ , eoExtra :: !ExecOptsExtra+ }++data ExecOptsExtra+ = ExecOptsPlain+ | ExecOptsEmbellished+ { eoEnvSettings :: !EnvSettings+ , eoPackages :: ![String]+ }++execOptsParser :: Maybe String -- ^ command+ -> Parser ExecOpts+execOptsParser mcmd =+ ExecOpts+ <$> maybe eoCmdParser pure mcmd+ <*> eoArgsParser+ <*> (eoPlainParser <|>+ ExecOptsEmbellished+ <$> eoEnvSettingsParser+ <*> eoPackagesParser)+ where+ eoCmdParser :: Parser String+ eoCmdParser = strArgument (metavar "CMD")++ eoArgsParser :: Parser [String]+ eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))++ eoEnvSettingsParser :: Parser EnvSettings+ eoEnvSettingsParser = EnvSettings+ <$> pure True+ <*> boolFlags True+ "ghc-package-path"+ "setting the GHC_PACKAGE_PATH variable for the subprocess"+ idm+ <*> boolFlags True+ "stack-exe"+ "setting the STACK_EXE environment variable to the path for the stack executable"+ idm++ eoPackagesParser :: Parser [String]+ eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))++ eoPlainParser :: Parser ExecOptsExtra+ eoPlainParser = flag' ExecOptsPlain+ (long "plain" <>+ help "Use an unmodified environment (only useful with Docker)")+ -- | Execute a command.-execCmd :: (String, [String],EnvSettings) -> GlobalOpts -> IO ()-execCmd (cmd,args,envSettings) go@GlobalOpts{..} =- withBuildConfig go ExecStrategy $- exec envSettings cmd args+execCmd :: ExecOpts -> GlobalOpts -> IO ()+execCmd ExecOpts {..} go@GlobalOpts{..} =+ case eoExtra of+ ExecOptsPlain -> do+ (manager,lc) <- liftIO $ loadConfigWithOpts go+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ Docker.execWithOptionalContainer+ (lcProjectRoot lc)+ (return (eoCmd, eoArgs, id)) $+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ exec plainEnvSettings eoCmd eoArgs+ ExecOptsEmbellished {..} ->+ withBuildConfig go ExecStrategy $ do+ let targets = concatMap words eoPackages+ unless (null targets) $+ Stack.Build.build (const $ return ()) defaultBuildOpts+ { boptsTargets = map T.pack targets+ }+ exec eoEnvSettings eoCmd eoArgs --- | Run the REPL in the context of a project, with+-- | Run the REPL in the context of a project. replCmd :: ([Text], [String], FilePath, Bool) -> GlobalOpts -> IO () replCmd (targets,args,path,noload) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do repl targets args path noload +-- | Run ide-backend in the context of a project.+ideCmd :: ([Text], [String]) -> GlobalOpts -> IO ()+ideCmd (targets,args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do+ ide targets args+ -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () dockerPullCmd _ go@GlobalOpts{..} = do@@ -569,15 +656,6 @@ Docker.preventInContainer $ Docker.cleanup cleanupOpts --- | Execute a command-dockerExecCmd :: (String, [String]) -> GlobalOpts -> IO ()-dockerExecCmd (cmd,args) go@GlobalOpts{..} = do- (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.preventInContainer $- Docker.rerunCmdWithRequiredContainer (lcProjectRoot lc)- (return (cmd,args,id))- -- | Command sum type for conditional arguments. data Command = Build@@ -590,7 +668,8 @@ buildOpts cmd = fmap process $ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>- flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage+ flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage <*>+ fileWatch' <*> keepGoing where process bopts = if boptsCoverage bopts then bopts { boptsExeProfile = True@@ -670,6 +749,15 @@ help "Generate a code coverage report") else pure False + fileWatch' = flag False True+ (long "file-watch" <>+ help "Watch for changes in local files and automatically rebuild")++ keepGoing = maybeBoolFlags+ "keep-going"+ "continue running after a step fails (default: false for build, true for test/bench)"+ idm+ -- | Parser for docker cleanup arguments. dockerCleanupOpts :: Parser Docker.CleanupOpts dockerCleanupOpts =@@ -822,5 +910,5 @@ idm -- | Visualize dependencies-dotCmd :: () -> GlobalOpts -> IO ()-dotCmd () go = withBuildConfig go ThrowException dot+dotCmd :: DotOpts -> GlobalOpts -> IO ()+dotCmd dotOpts go = withBuildConfig go ThrowException (dot dotOpts)
+ src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE RecordWildCards #-}+module Network.HTTP.Download.VerifiedSpec where++import Crypto.Hash+import Control.Monad (unless)+import Control.Monad.Trans.Reader+import Data.Maybe+import Network.HTTP.Client.Conduit+import Network.HTTP.Download.Verified+import Path+import System.Directory+import System.IO.Temp+import Test.Hspec hiding (shouldNotBe, shouldNotReturn)+++-- TODO: share across test files+withTempDir :: (Path Abs Dir -> IO a) -> IO a+withTempDir f = withSystemTempDirectory "NHD_VerifiedSpec" $ \dirFp -> do+ dir <- parseAbsDir dirFp+ f dir+++-- | An example path to download the exampleReq.+getExamplePath :: Path Abs Dir -> IO (Path Abs File)+getExamplePath dir = do+ file <- parseRelFile "cabal-install-1.22.4.0.tar.gz"+ return (dir </> file)++-- | An example DownloadRequest that uses a SHA1+exampleReq :: DownloadRequest+exampleReq = fromMaybe (error "exampleReq") $ do+ req <- parseUrl "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz"+ return DownloadRequest+ { drRequest = req+ , drHashChecks = [exampleHashCheck]+ , drLengthCheck = Just exampleLengthCheck+ }++exampleHashCheck :: HashCheck+exampleHashCheck = HashCheck+ { hashCheckAlgorithm = SHA1+ , hashCheckHexDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec2"+ }++exampleLengthCheck :: LengthCheck+exampleLengthCheck = 302513++-- | The wrong ContentLength for exampleReq+exampleWrongContentLength :: Int+exampleWrongContentLength = 302512++-- | The wrong SHA1 digest for exampleReq+exampleWrongDigest :: CheckHexDigest+exampleWrongDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec3"++exampleWrongContent :: String+exampleWrongContent = "example wrong content"++isWrongContentLength :: VerifiedDownloadException -> Bool+isWrongContentLength WrongContentLength{} = True+isWrongContentLength _ = False++isWrongDigest :: VerifiedDownloadException -> Bool+isWrongDigest WrongDigest{} = True+isWrongDigest _ = False++data T = T+ { manager :: Manager+ }++runWith :: Manager -> ReaderT Manager m r -> m r+runWith = flip runReaderT++setup :: IO T+setup = do+ manager <- newManager+ return T{..}++teardown :: T -> IO ()+teardown _ = return ()++shouldNotBe :: (Show a, Eq a) => a -> a -> Expectation+actual `shouldNotBe` expected =+ unless (actual /= expected) (expectationFailure msg)+ where+ msg = "Value was exactly what it shouldn't be: " ++ show expected++shouldNotReturn :: (Show a, Eq a) => IO a -> a -> Expectation+action `shouldNotReturn` unexpected = action >>= (`shouldNotBe` unexpected)++spec :: Spec+spec = beforeAll setup $ afterAll teardown $ do+ let exampleProgressHook = return ()++ describe "verifiedDownload" $ do+ -- Preconditions:+ -- * the exampleReq server is running+ -- * the test runner has working internet access to it+ it "downloads the file correctly" $ \T{..} -> withTempDir $ \dir -> do+ examplePath <- getExamplePath dir+ let exampleFilePath = toFilePath examplePath+ doesFileExist exampleFilePath `shouldReturn` False+ let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook+ go `shouldReturn` True+ doesFileExist exampleFilePath `shouldReturn` True++ it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir $ \dir -> do+ examplePath <- getExamplePath dir+ let exampleFilePath = toFilePath examplePath+ doesFileExist exampleFilePath `shouldReturn` False+ let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook+ go `shouldReturn` True+ doesFileExist exampleFilePath `shouldReturn` True+ go `shouldReturn` False+ doesFileExist exampleFilePath `shouldReturn` True++ -- https://github.com/commercialhaskell/stack/issues/372+ it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir $ \dir -> do+ examplePath <- getExamplePath dir+ let exampleFilePath = toFilePath examplePath+ writeFile exampleFilePath exampleWrongContent+ doesFileExist exampleFilePath `shouldReturn` True+ readFile exampleFilePath `shouldReturn` exampleWrongContent+ let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook+ go `shouldReturn` True+ doesFileExist exampleFilePath `shouldReturn` True+ readFile exampleFilePath `shouldNotReturn` exampleWrongContent++ it "rejects incorrect content length" $ \T{..} -> withTempDir $ \dir -> do+ examplePath <- getExamplePath dir+ let exampleFilePath = toFilePath examplePath+ let wrongContentLengthReq = exampleReq+ { drLengthCheck = Just exampleWrongContentLength+ }+ let go = runWith manager $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook+ go `shouldThrow` isWrongContentLength+ doesFileExist exampleFilePath `shouldReturn` False++ it "rejects incorrect digest" $ \T{..} -> withTempDir $ \dir -> do+ examplePath <- getExamplePath dir+ let exampleFilePath = toFilePath examplePath+ let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }+ let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }+ let go = runWith manager $ verifiedDownload wrongDigestReq examplePath exampleProgressHook+ go `shouldThrow` isWrongDigest+ doesFileExist exampleFilePath `shouldReturn` False++ -- https://github.com/commercialhaskell/stack/issues/240+ it "can download hackage tarballs" $ \T{..} -> withTempDir $ \dir -> do+ dest <- fmap (dir </>) $ parseRelFile "acme-missiles-0.3.tar.gz"+ let destFp = toFilePath dest+ req <- parseUrl "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"+ let dReq = DownloadRequest+ { drRequest = req+ , drHashChecks = []+ , drLengthCheck = Nothing+ }+ let progressHook = return ()+ let go = runWith manager $ verifiedDownload dReq dest progressHook+ doesFileExist destFp `shouldReturn` False+ go `shouldReturn` True+ doesFileExist destFp `shouldReturn` True
+ src/test/Stack/DotSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Test suite for Stack.Dot+module Stack.DotSpec where++import Data.ByteString.Char8 (ByteString)+import qualified Data.Foldable as F+import Data.Functor.Identity+import Data.List ((\\))+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Options.Applicative (execParserPure,idm,prefs,info,getParseResult)+import Stack.Types+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+#if MIN_VERSION_QuickCheck(2,8,0)+import Test.QuickCheck (forAll,sublistOf)+#endif++import Stack.Dot++spec :: Spec+spec = do+ let graph =+ Map.mapKeys pkgName+ . fmap (Set.map pkgName)+ . Map.fromList $ [("one",Set.fromList ["base","free"])+ ,("two",Set.fromList ["base","free","mtl","transformers","one"])+ ]+ describe "Stack.Dot" $ do+ it "does nothing if depth is 0" $+ resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph++ it "with depth 1, more dependencies are resolved" $ do+ let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph+ resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader)+ resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader)+ Map.size resultGraph < Map.size resultGraph' `shouldBe` True++ it "cycles are ignored" $ do+ let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph+ resultGraph = resolveDependencies Nothing graph stubLoader+ resultGraph' = resolveDependencies Nothing graph' stubLoader+ fmap Map.size resultGraph' `shouldBe` fmap ((+1) . Map.size) resultGraph++#if MIN_VERSION_QuickCheck(2,8,0)+ prop "requested packages are pruned" $ do+ let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)+ forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->+ let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph+ in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune)++ prop "pruning removes orhpans" $ do+ let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)+ orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g+ forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->+ let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph+ in null (Map.keys (orphans pruned) \\ [pkgName "one", pkgName "two"])+#endif++ where graphElem e graph = Set.member e . Set.unions . Map.elems $ graph++{- Helper functions below -}++-- Unsafe internal helper to create a package name+pkgName :: ByteString -> PackageName+pkgName = fromMaybe failure . parsePackageName+ where+ failure = error "Internal error during package name creation in DotSpec.pkgName"++-- Stub, simulates the function to load package dependecies+stubLoader :: PackageName -> Identity (Set PackageName)+stubLoader name = return . Set.fromList . map pkgName $ case show name of+ "StateVar" -> ["stm","transformers"]+ "array" -> []+ "bifunctors" -> ["semigroupoids","semigroups","tagged"]+ "binary" -> ["array","bytestring","containers"]+ "bytestring" -> ["deepseq","ghc-prim","integer-gmp"]+ "comonad" -> ["containers","contravariant","distributive"+ ,"semigroups","tagged","transformers","transformers-compat"+ ]+ "cont" -> ["StateVar","semigroups","transformers","transformers-compat","void"]+ "containers" -> ["array","deepseq","ghc-prim"]+ "deepseq" -> ["array"]+ "distributive" -> ["ghc-prim","tagged","transformers","transformers-compat"]+ "free" -> ["bifunctors","comonad","distributive","mtl"+ ,"prelude-extras","profunctors","semigroupoids"+ ,"semigroups","template-haskell","transformers"+ ]+ "ghc" -> []+ "hashable" -> ["bytestring","ghc-prim","integer-gmp","text"]+ "integer" -> []+ "mtl" -> ["transformers"]+ "nats" -> []+ "one" -> ["free"]+ "prelude" -> []+ "profunctors" -> ["comonad","distributive","semigroupoids","tagged","transformers"]+ "semigroupoids" -> ["comonad","containers","contravariant","distributive"+ ,"semigroups","transformers","transformers-compat"+ ]+ "semigroups" -> ["bytestring","containers","deepseq","hashable"+ ,"nats","text","unordered-containers"+ ]+ "stm" -> ["array"]+ "tagged" -> ["template-haskell"]+ "template" -> []+ "text" -> ["array","binary","bytestring","deepseq","ghc-prim","integer-gmp"]+ "transformers" -> []+ "two" -> ["free","mtl","one","transformers"]+ "unordered" -> ["deepseq","hashable"]+ "void" -> ["ghc-prim","hashable","semigroups"]+ _ -> []
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.1.1.0+version: 0.1.2.0 synopsis: The Haskell Tool Stack description: Please see the README.md for usage information, and the wiki on Github for more details. Also, note that@@ -50,6 +50,7 @@ Stack.Dot Stack.Fetch Stack.Exec+ Stack.FileWatch Stack.GhcPkg Stack.Init Stack.New@@ -57,6 +58,7 @@ Stack.PackageDump Stack.PackageIndex Stack.Repl+ Stack.Ide Stack.Setup Stack.Solver Stack.Types@@ -84,6 +86,7 @@ System.Process.Log System.Process.Run Network.HTTP.Download.Verified+ Data.Attoparsec.Args other-modules: Network.HTTP.Download Control.Concurrent.Execute Path.Find@@ -95,16 +98,17 @@ Data.Binary.VersionTagged Data.Set.Monad Data.Maybe.Extra- Data.Attoparsec.Args build-depends: Cabal >= 1.18.1.5 , aeson >= 0.8.0.2 , async >= 2.0.2 , attoparsec >= 0.12.1.5 , base >= 4 && <5 , base16-bytestring+ , base64-bytestring , bifunctors >= 4.2.1 , binary >= 0.7- , base64-bytestring+ , blaze-builder+ , byteable , bytestring , conduit-combinators >= 0.3.1 , conduit >= 1.2.4@@ -117,6 +121,7 @@ , exceptions >= 0.8.0.2 , fast-logger >= 2.3.1 , filepath >= 1.3.0.2+ , fsnotify , hashable >= 1.2.3.2 , http-client >= 0.4.9 , http-client-tls >= 0.2.2@@ -137,6 +142,7 @@ , process >= 1.2.0.0 , resourcet >= 1.1.4.1 , safe >= 0.3+ , split , stm >= 2.4.4 , streaming-commons >= 0.1.10.0 , tar >= 0.4.1.0@@ -167,7 +173,6 @@ Plugins.Commands build-depends: base >=4.7 && < 5- , blaze-builder , bytestring >= 0.10.4.0 , containers , exceptions@@ -201,8 +206,10 @@ , Stack.BuildPlanSpec , Stack.Build.ExecuteSpec , Stack.ConfigSpec+ , Stack.DotSpec , Stack.PackageDumpSpec , Stack.ArgsSpec+ , Network.HTTP.Download.VerifiedSpec ghc-options: -Wall -threaded build-depends: base >=4.7 && <5 , hspec@@ -222,6 +229,9 @@ , resourcet , Cabal , text+ , optparse-applicative+ , bytestring+ , QuickCheck default-language: Haskell2010 test-suite stack-integration-test
stack.yaml view
@@ -1,7 +1,7 @@ packages: - . extra-deps:-- optparse-simple-0.0.3-- path-0.5.1-- monad-unlift-0.1.1.0-resolver: lts-2.9+- path-0.5.2+- Win32-notify-0.3.0.1+- hfsevents-0.1.5+resolver: lts-2.17