stack 0.0.2.1 → 0.0.3
raw patch · 34 files changed
+1915/−615 lines, 34 filesdep ~path
Dependency ranges changed: path
Files
- ChangeLog.md +10/−0
- src/Options/Applicative/Args.hs +49/−0
- src/Path/IO.hs +13/−1
- src/Stack/Build.hs +4/−1
- src/Stack/Build/ConstructPlan.hs +49/−9
- src/Stack/Build/Execute.hs +88/−20
- src/Stack/Build/Source.hs +53/−25
- src/Stack/Build/Types.hs +84/−69
- src/Stack/BuildPlan.hs +42/−55
- src/Stack/Config.hs +95/−84
- src/Stack/Constants.hs +8/−0
- src/Stack/Docker.hs +35/−30
- src/Stack/Exec.hs +39/−0
- src/Stack/Fetch.hs +81/−60
- src/Stack/GhcPkg.hs +11/−19
- src/Stack/Init.hs +229/−0
- src/Stack/New.hs +8/−0
- src/Stack/Package.hs +126/−2
- src/Stack/PackageDump.hs +5/−16
- src/Stack/PackageIndex.hs +37/−29
- src/Stack/Repl.hs +85/−0
- src/Stack/Setup.hs +22/−19
- src/Stack/Types/Config.hs +36/−6
- src/Stack/Types/Internal.hs +7/−0
- src/Stack/Types/StackT.hs +19/−13
- src/Stack/Upload.hs +351/−0
- src/System/Process/Log.hs +36/−0
- src/System/Process/Read.hs +102/−87
- src/main/Main.hs +130/−58
- src/main/Plugins.hs +11/−1
- src/test/Stack/ArgsSpec.hs +31/−0
- src/test/Stack/BuildPlanSpec.hs +4/−4
- src/test/Stack/ConfigSpec.hs +5/−5
- stack.cabal +10/−2
ChangeLog.md view
@@ -1,3 +1,13 @@+## Unreleased++* `--prefetch` [#297](https://github.com/commercialhaskell/stack/issues/297)+* `upload` command ported from stackage-upload [#225](https://github.com/commercialhaskell/stack/issues/225)+* `--only-snapshot` [#310](https://github.com/commercialhaskell/stack/issues/310)+* `--resolver` [#224](https://github.com/commercialhaskell/stack/issues/224)+* `stack init` [#253](https://github.com/commercialhaskell/stack/issues/253)+* `--extra-include-dirs` and `--extra-lib-dirs` [#333](https://github.com/commercialhaskell/stack/issues/333)+* Specify intra-package target [#201](https://github.com/commercialhaskell/stack/issues/201)+ ## 0.0.2 * Fix some Windows specific bugs [#216](https://github.com/commercialhaskell/stack/issues/216)
+ src/Options/Applicative/Args.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Accepting arguments to be passed through to a sub-process.++module Options.Applicative.Args+ (argsArgument+ ,argsOption+ ,parseArgsFromString+ ,argsParser)+ where++import Control.Applicative+import Data.Attoparsec.Text ((<?>))+import qualified Data.Attoparsec.Text as P+import Data.Attoparsec.Types (Parser)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Options.Applicative as O++-- | An argument which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.+argsArgument :: O.Mod O.ArgumentFields [String] -> O.Parser [String]+argsArgument =+ O.argument+ (do string <- O.str+ either O.readerError return (parseArgsFromString string))++-- | An option which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.+argsOption :: O.Mod O.OptionFields [String] -> O.Parser [String]+argsOption =+ O.option+ (do string <- O.str+ either O.readerError return (parseArgsFromString string))++-- | Parse from a string.+parseArgsFromString :: String -> Either String [String]+parseArgsFromString = P.parseOnly argsParser . T.pack++-- | A basic argument parser. It supports space-separated text, and+-- string quotation with identity escaping: \x -> x.+argsParser :: Parser Text [String]+argsParser = many (P.skipSpace *> (quoted <|> unquoted)) <*+ P.skipSpace <* (P.endOfInput <?> "unterminated string")+ where+ unquoted = P.many1 naked+ quoted = P.char '"' *> string <* P.char '"'+ string = many (escaped <|> nonquote)+ escaped = P.char '\\' *> P.anyChar+ nonquote = P.satisfy (not . (=='"'))+ naked = P.satisfy (not . flip elem ("\" " :: String))
src/Path/IO.hs view
@@ -12,7 +12,9 @@ ,ResolveException(..) ,removeFileIfExists ,removeTree- ,removeTreeIfExists)+ ,removeTreeIfExists+ ,fileExists+ ,dirExists) where import Control.Exception hiding (catch)@@ -138,3 +140,13 @@ (\e -> if isDoesNotExistError e then return () else throwIO e))++-- | Does the given file exist?+fileExists :: MonadIO m => Path b File -> m Bool+fileExists =+ liftIO . doesFileExist . toFilePath++-- | Does the given directory exist?+dirExists :: MonadIO m => Path b Dir -> m Bool+dirExists =+ liftIO . doesFileExist . toFilePath
src/Stack/Build.hs view
@@ -47,7 +47,7 @@ #endif --} -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)+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 ()@@ -60,6 +60,9 @@ baseConfigOpts <- mkBaseConfigOpts bopts plan <- withLoadPackage menv $ \loadPackage -> constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap++ when (boptsPreFetch bopts) $+ preFetch plan if boptsDryrun bopts then printPlan (boptsFinalAction bopts) plan
src/Stack/Build/ConstructPlan.hs view
@@ -10,7 +10,9 @@ import Control.Exception.Lifted import Control.Monad+import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class+import Control.Monad.Logger (MonadLogger) import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8@@ -28,6 +30,7 @@ import Distribution.Package (Dependency (..)) import Distribution.Version (anyVersion, intersectVersionRanges)+import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (FilePath, pi, writeFile) import Stack.Build.Cache import Stack.Build.Installed@@ -36,6 +39,7 @@ import Stack.BuildPlan import Stack.Package+import Stack.PackageIndex import Stack.Types data PackageInfo@@ -84,6 +88,7 @@ , ctxBuildConfig :: !BuildConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName)+ , latestVersions :: !(Map PackageName Version) } instance HasStackRoot Ctx@@ -93,7 +98,7 @@ getBuildConfig = ctxBuildConfig constructPlan :: forall env m.- (MonadThrow m, MonadReader env m, HasBuildConfig env, MonadIO m)+ (MonadCatch m, MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env) => MiniBuildPlan -> BaseConfigOpts -> [LocalPackage]@@ -104,11 +109,19 @@ -> InstalledMap -> m Plan constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPackage0 sourceMap installedMap = do+ menv <- getMinimalEnvOverride+ caches <- getPackageCaches menv+ let latest = Map.fromListWith max $ map toTuple $ Map.keys caches+ bconfig <- asks getBuildConfig+ let onWanted =+ case boptsFinalAction $ bcoBuildOpts baseConfigOpts0 of+ DoNothing -> void . addDep . packageName . lpPackage+ _ -> addFinal let inner = do- mapM_ addFinal $ filter lpWanted locals+ mapM_ onWanted $ filter lpWanted locals mapM_ addDep $ Set.toList extraToBuild0- ((), m, (efinals, installExes)) <- liftIO $ runRWST inner (ctx bconfig) M.empty+ ((), m, (efinals, installExes)) <- liftIO $ runRWST inner (ctx bconfig latest) M.empty let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m@@ -119,7 +132,11 @@ let toTask (_, ADRFound _ _) = Nothing toTask (name, ADRToInstall task) = Just (name, task) tasks = M.fromList $ mapMaybe toTask adrs- return Plan+ maybeStripLocals+ | boptsOnlySnapshot $ bcoBuildOpts baseConfigOpts0 =+ stripLocals+ | otherwise = id+ return $ maybeStripLocals Plan { planTasks = tasks , planFinals = M.fromList finals , planUnregisterLocal = mkUnregisterLocal tasks locallyRegistered@@ -128,9 +145,9 @@ then installExes else Map.empty }- else throwM $ ConstructPlanExceptions errs+ else throwM $ ConstructPlanExceptions errs (bcStackYaml bconfig) where- ctx bconfig = Ctx+ ctx bconfig latest = Ctx { mbp = mbp0 , baseConfigOpts = baseConfigOpts0 , loadPackage = loadPackage0@@ -141,6 +158,7 @@ , ctxBuildConfig = bconfig , callStack = [] , extraToBuild = extraToBuild0+ , latestVersions = latest } toolMap = getToolMap mbp0 @@ -160,8 +178,6 @@ addFinal :: LocalPackage -> M () addFinal lp = do- void $ addDep $ packageName package- depsRes <- addPackageDeps package res <- case depsRes of Left e -> return $ Left e@@ -174,6 +190,7 @@ , taskConfigOpts = TaskConfigOpts missing $ \missing' -> let allDeps = Set.union present missing' in configureOpts+ (getConfig ctx) (baseConfigOpts ctx) allDeps True -- wanted@@ -263,6 +280,7 @@ , taskConfigOpts = TaskConfigOpts missing $ \missing' -> let allDeps = Set.union present missing' in configureOpts+ (getConfig ctx) (baseConfigOpts ctx) allDeps (psWanted ps)@@ -287,6 +305,7 @@ addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId)) addPackageDeps package = do+ ctx <- ask deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, range) -> do eres <- addDep depname@@ -294,7 +313,8 @@ Left e -> let bd = case e of- UnknownPackage _ -> NotInBuildPlan+ UnknownPackage name ->+ NotInBuildPlan $ Map.lookup name $ latestVersions ctx _ -> Couldn'tResolveItsDependencies in return $ Left (depname, (range, bd)) Right adr | not $ adrVersion adr `withinRange` range ->@@ -324,6 +344,7 @@ checkDirtiness ps installed package present = do ctx <- ask let configOpts = configureOpts+ (getConfig ctx) (baseConfigOpts ctx) present (psWanted ps)@@ -332,6 +353,10 @@ configCache = ConfigCache { configCacheOpts = map encodeUtf8 configOpts , configCacheDeps = present+ , configCacheComponents =+ case ps of+ PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp+ PSUpstream _ _ _ -> Set.empty } moldOpts <- tryGetFlagCache installed case moldOpts of@@ -360,3 +385,18 @@ return $ Map.unionsWith intersectVersionRanges $ packageDeps p : map (toolToPackages ctx) (packageTools p)++-- | Strip out anything from the @Plan@ intended for the local database+stripLocals :: Plan -> Plan+stripLocals plan = plan+ { planTasks = Map.filter checkTask $ planTasks plan+ , planFinals = Map.empty+ , planUnregisterLocal = Set.empty+ , planInstallExes = Map.filter (/= Local) $ planInstallExes plan+ }+ where+ checkTask task =+ case taskType task of+ TTLocal _ -> False+ TTUpstream _ Local -> False+ TTUpstream _ Snap -> True
src/Stack/Build/Execute.hs view
@@ -7,6 +7,7 @@ -- Perform a build module Stack.Build.Execute ( printPlan+ , preFetch , executePlan ) where @@ -67,9 +68,29 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process.Internals (createProcess_) import System.Process.Read+import System.Process.Log (showProcessArgDebug) -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)+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) +preFetch :: M env m => Plan -> m ()+preFetch plan+ | Set.null idents = $logDebug "Nothing to fetch"+ | otherwise = do+ $logDebug $ T.pack $+ "Prefetching: " +++ intercalate ", " (map packageIdentifierString $ Set.toList idents)+ menv <- getMinimalEnvOverride+ fetchPackages menv idents+ where+ idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan++ toIdent (name, task) =+ case taskType task of+ TTLocal _ -> Set.empty+ TTUpstream package _ -> Set.singleton $ PackageIdentifier+ name+ (packageVersion package)+ printPlan :: M env m => FinalAction -> Plan@@ -211,19 +232,21 @@ currExe <- liftIO getExecutablePath -- needed for windows, see below - forM_ (Map.toList $ planInstallExes plan) $ \(name, loc) -> do+ installed <- forM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do let bindir = case loc of Snap -> snapBin Local -> localBin mfp <- resolveFileMaybe bindir $ T.unpack name ++ ext case mfp of- Nothing -> $logWarn $ T.concat- [ "Couldn't find executable "- , name- , " in directory "- , T.pack $ toFilePath bindir- ]+ Nothing -> do+ $logWarn $ T.concat+ [ "Couldn't find executable "+ , name+ , " in directory "+ , T.pack $ toFilePath bindir+ ]+ return Nothing Just file -> do let destFile = destDir' FP.</> T.unpack name ++ ext $logInfo $ T.concat@@ -237,7 +260,17 @@ Platform _ Windows | FP.equalFilePath destFile currExe -> windowsRenameCopy (toFilePath file) destFile _ -> copyFile (toFilePath file) destFile+ return $ Just (destDir', [T.append name (T.pack ext)]) + let destToInstalled = Map.fromListWith (++) (catMaybes installed)+ unless (Map.null destToInstalled) $ $logInfo ""+ forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do+ $logInfo $ T.concat+ [ "Installed executables to "+ , T.pack dest+ , ":"]+ forM_ executables $ \exe -> $logInfo $ T.append "- " exe+ -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. windowsRenameCopy :: FilePath -> FilePath -> IO ()@@ -279,13 +312,15 @@ (planTasks plan) (planFinals plan) threads <- asks $ configJobs . getConfig+ terminal <- asks getTerminal errs <- liftIO $ runActions threads actions $ \doneVar -> do let total = length actions loop prev | prev == total = runInBase $ $logStickyDone ("Completed all " <> T.pack (show total) <> " actions.") | otherwise = do- runInBase $ $logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))+ when terminal $ runInBase $+ $logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total)) done <- atomically $ do done <- readTVar doneVar check $ done /= prev@@ -380,6 +415,10 @@ newConfigCache = ConfigCache { configCacheOpts = map encodeUtf8 configOpts , configCacheDeps = allDeps+ , configCacheComponents =+ case taskType of+ TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp+ TTUpstream _ _ -> Set.empty } let needConfig = mOldConfigCache /= Just newConfigCache@@ -388,7 +427,6 @@ deleteCaches pkgDir announce cabal False $ "configure" : map T.unpack configOpts- $logDebug $ T.pack $ show configOpts writeConfigCache pkgDir newConfigCache writeCabalMod pkgDir newCabalMod @@ -472,8 +510,24 @@ eeCabalPkgVer)) : "-clear-package-db" : "-global-package-db"- -- TODO: Perhaps we want to include the snapshot package database here- -- as well++ -- This next line is debatable. It adds access to the+ -- snapshot package database for Cabal. There are two+ -- possible objections:+ --+ -- 1. This doesn't isolate the build enough; arbitrary+ -- other packages available could cause the build to+ -- succeed or fail.+ --+ -- 2. This doesn't provide enough packages: we should also+ -- include the local database when building local packages.+ --+ -- One possible solution to these points would be to use+ -- -hide-all-packages and explicitly list which packages+ -- can be used by Setup.hs, and have that based on the+ -- dependencies of the package itself.+ : ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts))+ : toFilePath setuphs : ("--builddir=" ++ toFilePath distRelativeDir') : args@@ -491,7 +545,7 @@ Nothing -> Inherit Just (_, h) -> UseHandle h }- $logDebug $ "Running: " <> T.pack (show $ toFilePath exeName : fullArgs)+ $logProcessRun (toFilePath exeName) fullArgs -- Use createProcess_ to avoid the log file being closed afterwards (Just inH, moutH, Nothing, ph) <- liftIO $ createProcess_ "singleBuild" cp@@ -534,7 +588,10 @@ announce "build" config <- asks getConfig- cabal (console && configHideTHLoading config) ["build"]+ cabal (console && configHideTHLoading config) $+ case taskType of+ TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp)+ TTUpstream _ _ -> ["build"] withMVar eeInstallLock $ \() -> do announce "install"@@ -573,8 +630,11 @@ (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 (test)"+ fileModTimes <- getPackageFileModTimes package cabalfp+ writeBuildCache pkgDir fileModTimes cabal (console && configHideTHLoading config) ["build"] bconfig <- asks getBuildConfig@@ -589,15 +649,20 @@ nameDir <- liftIO $ parseRelDir $ T.unpack testName nameExe <- liftIO $ parseRelFile $ T.unpack testName ++ exeExtension let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe- exists <- liftIO $ doesFileExist $ toFilePath exeName+ exists <- fileExists exeName menv <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True } if exists then do- announce $ "test " <> testName- let cp = (proc (toFilePath exeName) [])+ 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@@ -637,15 +702,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 config <- asks getConfig cabal (console && configHideTHLoading config) ["build"] @@ -736,11 +804,11 @@ getSetupHs :: Path Abs Dir -- ^ project directory -> IO (Maybe (Path Abs File)) getSetupHs dir = do- exists1 <- doesFileExist (toFilePath fp1)+ exists1 <- fileExists fp1 if exists1 then return $ Just fp1 else do- exists2 <- doesFileExist (toFilePath fp2)+ exists2 <- fileExists fp2 if exists2 then return $ Just fp2 else return Nothing
src/Stack/Build/Source.hs view
@@ -8,10 +8,11 @@ ( loadSourceMap , SourceMap , PackageSource (..)+ , localFlags ) where import Network.HTTP.Client.Conduit (HasHttpManager)-import Control.Applicative ((<|>))+import Control.Applicative ((<|>), (<$>)) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class@@ -28,6 +29,7 @@ import Data.Monoid ((<>)) 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)@@ -136,10 +138,10 @@ case boptsTargets bopts of [] -> ["."] x -> x- (dirs, (names0, idents)) <- case partitionEithers targets of- ([], targets') -> return $ fmap partitionEithers $ partitionEithers targets'- (bad, _) -> throwM $ Couldn'tParseTargets bad- let names = Set.fromList names0+ (dirs, names, idents) <-+ case partitionEithers targets of+ ([], targets') -> return $ partitionTargetSpecs targets'+ (bad, _) -> throwM $ Couldn'tParseTargets bad bconfig <- asks getBuildConfig lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do@@ -149,7 +151,7 @@ config = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False- , packageConfigFlags = localFlags bopts bconfig name+ , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name , packageConfigGhcVersion = bcGhcVersion bconfig , packageConfigPlatform = configPlatform $ getConfig bconfig }@@ -173,39 +175,65 @@ mbuildCache , lpCabalFile = cabalfp , lpDir = dir+ , lpComponents = fromMaybe Set.empty $ Map.lookup name names } let known = Set.fromList $ map (packageName . lpPackage) lps- unknown = Set.difference names known+ unknown = Set.difference (Map.keysSet names) known - return (lps, unknown, Set.fromList idents)+ return (lps, unknown, idents) where parseTarget t = do let s = T.unpack t isDir <- liftIO $ doesDirectoryExist s if isDir- then liftM (Right . Left) $ liftIO (canonicalizePath s) >>= parseAbsDir- else return $ case parsePackageNameFromString s of- Left _ ->- case parsePackageIdentifierFromString s of- Left _ ->- case T.stripSuffix ":latest" t of- Just t'- | Just name <- parsePackageNameFromString $ T.unpack t'- , Just version <- Map.lookup name latestVersion- -> Right $ Right $ Right $ PackageIdentifier name version- _ -> Left t- Right ident -> Right $ Right $ Right ident- Right pname -> Right $ Right $ Left pname+ then liftM (Right . TSDir) $ liftIO (canonicalizePath s) >>= parseAbsDir+ else return+ $ maybe (Left t) Right+ $ (flip TSName Set.empty <$> parsePackageNameFromString s)+ <|> (TSIdent <$> parsePackageIdentifierFromString s)+ <|> (do+ t' <- T.stripSuffix ":latest" t+ name <- parsePackageNameFromString $ T.unpack t'+ version <- Map.lookup name latestVersion+ Just $ TSIdent $ PackageIdentifier name version)+ <|> (do+ let (name', rest) = T.break (== ':') t+ component <- T.stripPrefix ":" rest+ name <- parsePackageNameFromString $ T.unpack name'+ Just $ TSName name $ Set.singleton component) isWanted dirs names dir name =- name `Set.member` names ||+ name `Map.member` names || any (`isParentOf` dir) dirs || any (== dir) dirs +data TargetSpec+ = TSName PackageName (Set Text)+ | TSIdent PackageIdentifier+ | TSDir (Path Abs Dir)++partitionTargetSpecs :: [TargetSpec] -> ([Path Abs Dir], Map PackageName (Set Text), Set PackageIdentifier)+partitionTargetSpecs =+ loop id Map.empty Set.empty+ where+ loop dirs names idents ts0 =+ case ts0 of+ [] -> (dirs [], names, idents)+ TSName name comps:ts -> loop+ dirs+ (Map.insertWith Set.union name comps names)+ idents+ ts+ TSIdent ident:ts -> loop dirs names (Set.insert ident idents) ts+ TSDir dir:ts -> loop (dirs . (dir:)) names idents ts+ -- | All flags for a local package-localFlags :: BuildOpts -> BuildConfig -> PackageName -> Map FlagName Bool-localFlags bopts bconfig name = Map.union- (fromMaybe Map.empty $ Map.lookup name $ boptsFlags bopts)+localFlags :: (Map PackageName (Map FlagName Bool))+ -> BuildConfig+ -> PackageName+ -> Map FlagName Bool+localFlags boptsflags bconfig name = Map.union+ (fromMaybe Map.empty $ Map.lookup name $ boptsflags) (fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig) -- | Add in necessary packages to extra dependencies
src/Stack/Build/Types.hs view
@@ -9,11 +9,30 @@ -- | All data types. -module Stack.Build.Types where+module Stack.Build.Types+ (StackBuildException(..)+ ,Location(..)+ ,ModTime+ ,modTime+ ,Installed(..)+ ,PackageInstallInfo(..)+ ,Task(..)+ ,LocalPackage(..)+ ,BaseConfigOpts(..)+ ,Plan(..)+ ,FinalAction(..)+ ,BuildOpts(..)+ ,TaskType(..)+ ,TaskConfigOpts(..)+ ,ConfigCache(..)+ ,ConstructPlanException(..)+ ,configureOpts+ ,BadDependency(..))+ where import Control.DeepSeq import Control.Exception-import Data.Aeson.Extended+ import Data.Binary (Binary(..)) import qualified Data.ByteString as S import Data.Char (isSpace)@@ -32,6 +51,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Calendar import Data.Time.Clock+import Distribution.System (Arch) import Distribution.Text (display) import GHC.Generics import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, (</>))@@ -45,7 +65,7 @@ -- Exceptions data StackBuildException = Couldn'tFindPkgId PackageName- | GHCVersionMismatch (Maybe Version) Version (Maybe (Path Abs File))+ | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File)) -- ^ Path to the stack.yaml file | Couldn'tParseTargets [Text] | UnknownTargets@@ -53,7 +73,9 @@ (Map PackageName Version) -- not in snapshot, here's the most recent version in the index (Path Abs File) -- stack.yaml | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File))- | ConstructPlanExceptions [ConstructPlanException]+ | ConstructPlanExceptions+ [ConstructPlanException]+ (Path Abs File) -- stack.yaml | CabalExitedUnsuccessfully ExitCode PackageIdentifier@@ -70,15 +92,21 @@ ", the package id couldn't be found " <> "(via ghc-pkg describe " <> packageNameString name <> "). This shouldn't happen, " <> "please report as a bug")- show (GHCVersionMismatch mactual expected mstack) = concat+ show (GHCVersionMismatch mactual (expected, earch) mstack) = concat [ case mactual of Nothing -> "No GHC found, expected version "- Just actual ->- "GHC version mismatched, found " ++- versionString actual ++- ", but expected version "+ Just (actual, arch) -> concat+ [ "GHC version mismatched, found "+ , versionString actual+ , " ("+ , display arch+ , ")"+ , ", but expected version "+ ] , versionString expected- , " (based on "+ , " ("+ , display earch+ , ") (based on " , case mstack of Nothing -> "command line arguments" Just stack -> "resolver setting in " ++ toFilePath stack@@ -123,12 +151,33 @@ -- TODO Should we load up the full error output and print it here? Just logFile -> "Full log available at " ++ toFilePath logFile ]- show (ConstructPlanExceptions exceptions) =+ show (ConstructPlanExceptions exceptions stackYaml) = "While constructing the BuildPlan the following exceptions were encountered:" ++- appendExceptions (removeDuplicates exceptions)+ appendExceptions exceptions' +++ if Map.null extras then "" else (unlines+ $ ("\n\nRecommended action: try adding the following to your extra-deps in "+ ++ toFilePath stackYaml)+ : map (\(name, version) -> concat+ [ "- "+ , packageNameString name+ , "-"+ , versionString version+ ]) (Map.toList extras)+ ) where+ exceptions' = removeDuplicates exceptions appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) "" removeDuplicates = nub+ extras = Map.unions $ map getExtras exceptions'++ getExtras (DependencyCycleDetected _) = Map.empty+ getExtras (UnknownPackage _) = Map.empty+ getExtras (DependencyPlanFailures _ m) =+ Map.unions $ map go $ Map.toList m+ where+ go (name, (_range, NotInBuildPlan (Just version))) =+ Map.singleton name version+ go _ = Map.empty -- Supressing duplicate output show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) = let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))@@ -158,7 +207,8 @@ -- | Reason why a dependency was not used data BadDependency- = NotInBuildPlan -- TODO add recommended version so it can be added to extra-deps+ = NotInBuildPlan+ (Maybe Version) -- recommended version, for extra-deps output | Couldn'tResolveItsDependencies | DependencyMismatch Version deriving (Typeable, Eq)@@ -187,7 +237,10 @@ , display range , "), but " , case badDep of- NotInBuildPlan -> "not present in build plan"+ NotInBuildPlan mlatest -> "not present in build plan" +++ (case mlatest of+ Nothing -> ""+ Just latest -> ", latest is " ++ versionString latest) Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies" DependencyMismatch version -> versionString version ++ " found" ]@@ -216,49 +269,16 @@ ,boptsFlags :: !(Map PackageName (Map FlagName Bool)) ,boptsInstallExes :: !Bool -- ^ Install executables to user path after building?+ ,boptsPreFetch :: !Bool+ -- ^ Fetch all packages immediately+ ,boptsTestArgs :: ![String]+ -- ^ Arguments to pass to the test suites if we're running them.+ ,boptsOnlySnapshot :: !Bool+ -- ^ Only install packages in the snapshot database, skipping+ -- packages intended for the local database. } deriving (Show) --- | Configuration for testing.-data TestConfig =- TestConfig {tconfigTargets :: ![Text]- }- deriving (Show)---- | Configuration for haddocking.-data HaddockConfig =- HaddockConfig {hconfigTargets :: ![Text]- }- deriving (Show)---- | Configuration for benchmarking.-data BenchmarkConfig =- BenchmarkConfig {benchTargets :: ![Text]- ,benchInDocker :: !Bool}- deriving (Show)---- | Generated config for a package build.-data GenConfig =- GenConfig {gconfigOptimize :: !Bool- ,gconfigLibProfiling :: !Bool- ,gconfigExeProfiling :: !Bool- ,gconfigGhcOptions :: ![Text]- ,gconfigFlags :: !(Map FlagName Bool)- ,gconfigPkgId :: Maybe GhcPkgId}- deriving (Generic,Show)--instance FromJSON GenConfig-instance ToJSON GenConfig--defaultGenConfig :: GenConfig-defaultGenConfig =- GenConfig {gconfigOptimize = False- ,gconfigLibProfiling = False- ,gconfigExeProfiling = False- ,gconfigGhcOptions = []- ,gconfigFlags = mempty- ,gconfigPkgId = Nothing}- -- | Run a Setup.hs action after building a package, before installing. data FinalAction = DoTests@@ -267,19 +287,6 @@ | DoNothing deriving (Eq,Bounded,Enum,Show) -data Dependencies =- Dependencies {depsLibraries :: [PackageName]- ,depsTools :: [PackageName]}- deriving (Show,Typeable,Data)---- | Used for mutex locking on the install step. Beats magic ().-data InstallLock = InstallLock---- | Mutex for reading/writing .config files in dist/ of--- packages. Shake works in parallel, without this there are race--- conditions.-data ConfigLock = ConfigLock- -- | Package dependency oracle. newtype PkgDepsOracle = PkgDeps PackageName@@ -303,6 +310,7 @@ , 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?+ , lpComponents :: !(Set Text) -- ^ components to build, passed directly to Setup.hs build } deriving Show @@ -316,6 +324,10 @@ -- the complete GhcPkgId (only a PackageIdentifier) in the configure -- options, just using the previous value is insufficient to know if -- dependencies have changed.+ , configCacheComponents :: !(Set S.ByteString)+ -- ^ The components to be built. It's a bit of a hack to include this in+ -- here, as it's not a configure option (just a build option), but this+ -- is a convenient way to force compilation when the components change. } deriving (Generic,Eq,Show) instance Binary ConfigCache@@ -371,13 +383,14 @@ } -- | Render a @BaseConfigOpts@ to an actual list of options-configureOpts :: BaseConfigOpts+configureOpts :: Config+ -> BaseConfigOpts -> Set GhcPkgId -- ^ dependencies -> Bool -- ^ wanted? -> Location -> Map FlagName Bool -> [Text]-configureOpts bco deps wanted loc flags = map T.pack $ concat+configureOpts config bco deps wanted loc flags = map T.pack $ concat [ ["--user", "--package-db=clear", "--package-db=global"] , map (("--package-db=" ++) . toFilePath) $ case loc of Snap -> [bcoSnapDB bco]@@ -401,6 +414,8 @@ , if wanted then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts) else []+ , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))+ , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config)) ] where bopts = bcoBuildOpts bco
src/Stack/BuildPlan.hs view
@@ -25,9 +25,7 @@ ) where import Control.Applicative-import Control.Arrow ((&&&)) import Control.Exception (assert)-import Control.Exception.Enclosed (handleIO) import Control.Monad (liftM, forM) import Control.Monad.Catch import Control.Monad.IO.Class@@ -45,7 +43,7 @@ import qualified Data.HashMap.Strict as HM import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.List (intercalate, sort)+import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe)@@ -62,6 +60,8 @@ flagDefault, flagManual, flagName, genPackageFlags, executables, exeName, library, libBuildInfo, buildable)+import qualified Distribution.Package as C+import qualified Distribution.PackageDescription as C import Network.HTTP.Download import Path import Prelude -- Fix AMP warning@@ -72,7 +72,7 @@ import Stack.PackageIndex import Stack.Types import Stack.Types.StackT-import System.Directory (createDirectoryIfMissing, getDirectoryContents)+import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) data BuildPlanException@@ -160,7 +160,7 @@ -- This function will not provide test suite and benchmark dependencies. -- -- This may fail if a target package is not present in the @BuildPlan@.-resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env)+resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m) => EnvOverride -> MiniBuildPlan -> (PackageName -> Bool) -- ^ is it shadowed by a local package?@@ -191,7 +191,7 @@ , rsUsedBy :: Map PackageName (Set PackageName) } -toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)+toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) => BuildPlan -> m MiniBuildPlan toMiniBuildPlan bp = do extras <- addDeps ghcVersion $ fmap goPP $ bpPackages bp@@ -216,7 +216,7 @@ ) -- | Add in the resolved dependencies from the package index-addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)+addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) => Version -- ^ GHC version -> Map PackageName (Version, Map FlagName Bool) -> m (Map PackageName MiniPackageInfo)@@ -329,12 +329,20 @@ -- | Map from tool name to package providing it getToolMap :: MiniBuildPlan -> Map ByteString (Set PackageName)-getToolMap mbp = Map.unionsWith Set.union+getToolMap mbp =+ Map.unionsWith Set.union++ {- We no longer do this, following discussion at:++ https://github.com/commercialhaskell/stack/issues/308#issuecomment-112076704+ -- First grab all of the package names, for times where a build tool is -- identified by package name $ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps))+ -}+ -- And then get all of the explicit executable names- : concatMap goPair (Map.toList ps)+ $ concatMap goPair (Map.toList ps) where ps = mbpPackages mbp @@ -379,7 +387,7 @@ -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan- :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)+ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadCatch m) => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do@@ -441,12 +449,10 @@ -- only modify non-manual flags, and will prefer default values for flags. -- Returns @Nothing@ if no combination exists. checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)- => SnapName -- ^ used only for debugging purposes- -> MiniBuildPlan+ => MiniBuildPlan -> GenericPackageDescription -> m (Maybe (Map FlagName Bool))-checkBuildPlan name mbp gpd = do- $logInfo $ "Checking against build plan " <> renderSnapName name+checkBuildPlan mbp gpd = do platform <- asks (configPlatform . getConfig) loop platform flagOptions where@@ -516,48 +522,29 @@ -- | Find a snapshot and set of flags that is compatible with the given -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)- => GenericPackageDescription- -> Snapshots- -> m (Maybe (SnapName, Map FlagName Bool))-findBuildPlan gpd snapshots = do- -- Get the most recent LTS and Nightly in the snapshots directory and- -- prefer them over anything else, since odds are high that something- -- already exists for them.- existing <-- liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $- snapshotsDir >>=- liftIO . handleIO (const $ return [])- . getDirectoryContents . toFilePath- let isLTS LTS{} = True- isLTS Nightly{} = False- isNightly Nightly{} = True- isNightly LTS{} = False-- let names = nubOrd $ concat- [ take 2 $ filter isLTS existing- , take 2 $ filter isNightly existing- , map (uncurry LTS)- (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)- , [Nightly $ snapshotsNightly snapshots]- ]- loop [] = return Nothing- loop (name:names') = do- mbp <- loadMiniBuildPlan name- mflags <- checkBuildPlan name mbp gpd- case mflags of- Nothing -> loop names'- Just flags -> return $ Just (name, flags)- loop names---- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.-nubOrd :: Ord a => [a] -> [a]-nubOrd =- go Set.empty+ => [GenericPackageDescription]+ -> [SnapName]+ -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))+findBuildPlan gpds0 =+ loop where- go _ [] = []- go s (x:xs)- | x `Set.member` s = go s xs- | otherwise = x : go (Set.insert x s) xs+ loop [] = return Nothing+ loop (name:names') = do+ mbp <- loadMiniBuildPlan name+ $logInfo $ "Checking against build plan " <> renderSnapName name+ let checkGPDs flags [] = return $ Just (name, flags)+ checkGPDs flags (gpd:gpds) = do+ let C.PackageIdentifier pname' _ = C.package $ C.packageDescription gpd+ pname = fromCabalPackageName pname'+ mflags <- checkBuildPlan mbp gpd+ case mflags of+ Nothing -> loop names'+ Just flags' -> checkGPDs+ (if Map.null flags'+ then flags+ else Map.insert pname flags' flags)+ gpds+ checkGPDs Map.empty gpds0 shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName
src/Stack/Config.hs view
@@ -40,13 +40,8 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as L import Data.Either (partitionEithers)-import Data.Map (Map) import qualified Data.IntMap as IntMap import qualified Data.Map as Map-import qualified Distribution.Package as C-import qualified Distribution.PackageDescription as C-import qualified Distribution.Text-import Distribution.Version (simplifyVersionRange) import Data.Maybe import Data.Monoid import qualified Data.Set as S@@ -54,6 +49,8 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Yaml as Yaml import Distribution.System (OS (Windows), Platform (..), buildPlatform)+import qualified Distribution.Text+import Distribution.Version (simplifyVersionRange) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl) import Network.HTTP.Download (download) import Options.Applicative (Parser, idm, strOption, long, short, metavar, help, option, auto)@@ -62,57 +59,29 @@ import Path.IO import qualified Paths_stack as Meta import Stack.BuildPlan-import Stack.Types.Config import Stack.Constants import qualified Stack.Docker as Docker-import Stack.Package+import Stack.Init import Stack.Types import System.Directory import System.Environment-import System.IO (IOMode (ReadMode), withBinaryFile)+import System.IO import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull) --- | Get the default resolver value-getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)- => Path Abs Dir- -> m (Resolver, Map PackageName (Map FlagName Bool))-getDefaultResolver dir = do- cabalfp <- getCabalFileName dir- gpd <- readPackageUnresolved cabalfp- snapshots <- getSnapshots `catch` \e -> do- $logError $- "Unable to download snapshot list, and therefore could " <>- "not generate a stack.yaml file automatically"- $logError $- "This sometimes happens due to missing Certificate Authorities " <>- "on your system. For more information, see:"- $logError ""- $logError " https://github.com/commercialhaskell/stack/issues/234"- $logError ""- $logError "You can try again, or create your stack.yaml file by hand. See:"- $logError ""- $logError " https://github.com/commercialhaskell/stack/wiki/stack.yaml"- $logError ""- throwM (e :: SomeException)- mpair <- findBuildPlan gpd snapshots- let name =- case C.package $ C.packageDescription gpd of- C.PackageIdentifier cname _ ->- fromCabalPackageName cname- case mpair of- Just (snap, flags) ->- return (ResolverSnapshot snap, Map.singleton name flags)- Nothing -> do- let snap = case IntMap.maxViewWithKey (snapshotsLts snapshots) of- Just ((x, y), _) -> LTS x y- Nothing -> Nightly $ snapshotsNightly snapshots- $logWarn $ T.concat- [ "No matching snapshot was found for your package, "- , "falling back to: "- , renderSnapName snap- ]- $logWarn "This behavior will improve in the future, please see: https://github.com/commercialhaskell/stack/issues/253"- return (ResolverSnapshot snap, Map.empty)+-- | Get the latest snapshot resolver available.+getLatestResolver+ :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)+ => m Resolver+getLatestResolver = do+ snapshots <- getSnapshots+ let mlts = do+ (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))+ return (LTS x y)+ snap =+ case mlts of+ Nothing -> Nightly (snapshotsNightly snapshots)+ Just lts -> lts+ return (ResolverSnapshot snap) data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid@@ -187,6 +156,9 @@ configSystemGHC = fromMaybe True configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC + configExtraIncludeDirs = configMonoidExtraIncludeDirs+ configExtraLibDirs = configMonoidExtraLibDirs+ -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform@@ -224,13 +196,15 @@ -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker =- (\opts systemGHC installGHC arch os jobs -> mempty+ (\opts systemGHC installGHC arch os jobs includes libs -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC , configMonoidArch = arch , configMonoidOS = os , configMonoidJobs = jobs+ , configMonoidExtraIncludeDirs = includes+ , configMonoidExtraLibDirs = libs }) <$> Docker.dockerOptsParser docker <*> maybeBoolFlags@@ -257,6 +231,16 @@ <> metavar "JOBS" <> help "Number of concurrent jobs to run" ))+ <*> fmap (S.fromList . map T.pack) (many $ strOption+ ( long "extra-include-dirs"+ <> metavar "DIR"+ <> help "Extra directories to check for C header files"+ ))+ <*> fmap (S.fromList . map T.pack) (many $ strOption+ ( long "extra-lib-dirs"+ <> metavar "DIR"+ <> help "Extra directories to check for libraries"+ )) -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at:@@ -299,7 +283,7 @@ menv <- runReaderT getMinimalEnvOverride config return $ LoadConfig { lcConfig = config- , lcLoadBuildConfig = loadBuildConfig menv mproject config+ , lcLoadBuildConfig = loadBuildConfig menv mproject config stackRoot , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject } @@ -313,39 +297,62 @@ -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values.-loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)+loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m) => EnvOverride -> Maybe (Project, Path Abs File, ConfigMonoid) -> Config+ -> Path Abs Dir+ -> Maybe Resolver -- override resolver -> NoBuildConfigStrategy -> m BuildConfig-loadBuildConfig menv mproject config noConfigStrat = do+loadBuildConfig menv mproject config stackRoot mresolver noConfigStrat = do env <- ask let miniConfig = MiniConfig (getHttpManager env) config- (project, stackYamlFP) <- case mproject of+ (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp) Nothing -> case noConfigStrat of ThrowException -> do currDir <- getWorkingDir+ cabalFiles <- findCabalFiles currDir throwM $ NoProjectConfigFound currDir- ExecStrategy ->- error "You do not have a stack.yaml. This will be handled in the future, see https://github.com/fpco/stack/issues/59"- CreateConfig -> do- currDir <- getWorkingDir- (r, flags) <- runReaderT (getDefaultResolver currDir) miniConfig- let dest = currDir </> stackDotYaml+ $ Just $ if null cabalFiles then "new" else "init"+ ExecStrategy -> do+ let dest :: Path Abs File+ dest = destDir </> stackDotYaml+ destDir = implicitGlobalDir stackRoot+ dest' :: FilePath dest' = toFilePath dest- exists <- liftIO $ doesFileExist dest'- when exists $ error "Invariant violated: in toBuildConfig's Nothing branch, and the stack.yaml file exists"- $logInfo $ "Writing default config file to: " <> T.pack dest'- let p = Project- { projectPackages = [packageEntryCurrDir]- , projectExtraDeps = Map.empty- , projectFlags = flags- , projectResolver = r- }- liftIO $ Yaml.encodeFile dest' p- return (p, dest)+ liftIO (createDirectoryIfMissing True (toFilePath destDir))+ exists <- fileExists dest+ if exists+ then do+ inTerminal <- liftIO (hIsTerminalDevice stdout)+ ProjectAndConfigMonoid project _ <- loadYaml dest+ when inTerminal $ do+ case mresolver of+ Nothing ->+ $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <>+ " from global config file: " <> T.pack dest')+ Just resolver ->+ $logInfo ("Using resolver: " <> renderResolver resolver <>+ " specified on command line")+ return (project, dest)+ else do+ r <- runReaderT getLatestResolver miniConfig+ $logInfo ("Using latest snapshot resolver: " <> renderResolver r)+ $logInfo ("Writing global (non-project-specific) config file to: " <> T.pack dest')+ $logInfo "Note: You can change the snapshot via the resolver field there."+ let p = Project+ { projectPackages = mempty+ , projectExtraDeps = mempty+ , projectFlags = mempty+ , projectResolver = r+ }+ liftIO $ Yaml.encodeFile dest' p+ return (p, dest)+ let project = project'+ { projectResolver = fromMaybe (projectResolver project') mresolver+ } ghcVersion <- case projectResolver project of@@ -371,11 +378,13 @@ -- | Resolve a PackageEntry into a list of paths, downloading and cloning as -- necessary.-resolvePackageEntry :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m)- => EnvOverride- -> Path Abs Dir -- ^ project root- -> PackageEntry- -> m [(Path Abs Dir, Bool)]+resolvePackageEntry+ :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m+ ,MonadBaseControl IO m)+ => EnvOverride+ -> Path Abs Dir -- ^ project root+ -> PackageEntry+ -> m [(Path Abs Dir, Bool)] resolvePackageEntry menv projRoot pe = do entryRoot <- resolvePackageLocation menv projRoot (peLocation pe) paths <-@@ -386,11 +395,13 @@ -- | Resolve a PackageLocation into a path, downloading and cloning as -- necessary.-resolvePackageLocation :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m)- => EnvOverride- -> Path Abs Dir -- ^ project root- -> PackageLocation- -> m (Path Abs Dir)+resolvePackageLocation+ :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m+ ,MonadBaseControl IO m)+ => EnvOverride+ -> Path Abs Dir -- ^ project root+ -> PackageLocation+ -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp resolvePackageLocation _ projRoot (PLHttpTarball url) = do let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 url@@ -478,7 +489,7 @@ mstackGlobalConfig <- maybe (return Nothing) (fmap Just . parseAbsFile) $ lookup "STACK_GLOBAL_CONFIG" env- filterM (liftIO . doesFileExist . toFilePath)+ filterM fileExists $ fromMaybe (stackRoot </> stackDotYaml) mstackConfig : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig) @@ -488,7 +499,7 @@ liftIO $ Yaml.decodeFileEither (toFilePath path) >>= either throwM return --- | Get the location of the project config file, if it exists+-- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) => m (Maybe (Path Abs File)) getProjectConfig = do@@ -509,7 +520,7 @@ let fp = dir </> stackDotYaml fp' = toFilePath fp $logDebug $ "Checking for project config at: " <> T.pack fp'- exists <- liftIO $ doesFileExist fp'+ exists <- fileExists fp if exists then return $ Just fp else do
src/Stack/Constants.hs view
@@ -22,6 +22,7 @@ ,stackProgName ,wiredInPackages ,cabalPackageName+ ,implicitGlobalDir ) where @@ -214,3 +215,10 @@ cabalPackageName :: PackageName cabalPackageName = $(mkPackageName "Cabal")++-- | Implicit global directory used when outside of a project.+implicitGlobalDir :: Path Abs Dir -- ^ Stack root.+ -> Path Abs Dir+implicitGlobalDir p =+ p </>+ $(mkRelDir "global")
src/Stack/Docker.hs view
@@ -22,7 +22,7 @@ import Control.Applicative import Control.Exception.Lifted import Control.Monad-import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) import Control.Monad.Writer (execWriter,runWriter,tell)@@ -69,8 +69,9 @@ -- | If Docker is enabled, re-runs the currently running OS command in a Docker container. -- Otherwise, runs the inner action.-rerunWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)- => Config -> Maybe (Path Abs Dir) -> IO () -> m ()+rerunWithOptionalContainer+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)+ => Config -> Maybe (Path Abs Dir) -> IO () -> m () rerunWithOptionalContainer config mprojectRoot = rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs where@@ -89,12 +90,13 @@ -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.-rerunCmdWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)- => Config- -> Maybe (Path Abs Dir)- -> IO (FilePath,[String],Config)- -> IO ()- -> m ()+rerunCmdWithOptionalContainer+ :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m, MonadCatch m)+ => Config+ -> Maybe (Path Abs Dir)+ -> IO (FilePath,[String],Config)+ -> IO ()+ -> m () rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs inner = do inContainer <- getInContainer if inContainer || not (dockerEnable (configDocker config))@@ -104,11 +106,12 @@ -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.-rerunCmdWithRequiredContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)- => Config- -> Maybe (Path Abs Dir)- -> IO (FilePath,[String],Config)- -> m ()+rerunCmdWithRequiredContainer+ :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m, MonadCatch m)+ => Config+ -> Maybe (Path Abs Dir)+ -> IO (FilePath,[String],Config)+ -> m () rerunCmdWithRequiredContainer config mprojectRoot getCmdArgs = do when (not (dockerEnable (configDocker config))) (throwM DockerMustBeEnabledException)@@ -132,12 +135,12 @@ Just _ -> return True -- | Run a command in a new Docker container, then exit the process.-runContainerAndExit :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+runContainerAndExit :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) => Config -> Maybe (Path Abs Dir) -> FilePath -> [String]- -> [(String,String)]+ -> [(String, String)] -> IO () -> m () runContainerAndExit config@@ -272,7 +275,7 @@ docker = configDocker config -- | Clean-up old docker images and containers.-cleanup :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+cleanup :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) => Config -> CleanupOpts -> m () cleanup config opts = do envOverride <- getEnvOverride (configPlatform config)@@ -338,8 +341,9 @@ | otherwise -> throwM (InvalidCleanupCommandException line) e <- try (readDockerProcess envOverride args) case e of- Left (ProcessExitedUnsuccessfully _ _) ->+ Left (ReadProcessException _ _ _ _) -> $logError (concatT ["Could not remove: '",v,"'"])+ Left e' -> throwM e' Right _ -> return () _ -> throwM (InvalidCleanupCommandException line) parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8@@ -496,7 +500,7 @@ containerStr = "container" -- | Inspect Docker image or container.-inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)+inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) => EnvOverride -> String -> m (Maybe Inspect) inspect envOverride image = do results <- inspects envOverride [image]@@ -506,7 +510,7 @@ _ -> throwM (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers.-inspects :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)+inspects :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> [String] -> m (Map String Inspect) inspects _ [] = return Map.empty inspects envOverride images =@@ -518,10 +522,11 @@ case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of Left msg -> throwM (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))- Left (ProcessExitedUnsuccessfully _ _) -> return Map.empty+ Left (ReadProcessException _ _ _ _) -> return Map.empty+ Left e -> throwM e -- | Pull latest version of configured Docker image from registry.-pull :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+pull :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) => Config -> m () pull config = do envOverride <- getEnvOverride (configPlatform config)@@ -551,8 +556,9 @@ Right () -> return () -- | Check docker version (throws exception if incorrect)-checkDockerVersion :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)- => EnvOverride -> m ()+checkDockerVersion+ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => EnvOverride -> m () checkDockerVersion envOverride = do dockerExists <- doesExecutableExist envOverride "docker" unless dockerExists (throwM DockerNotInstalledException)@@ -613,14 +619,13 @@ (removeFile (toFilePath f)))) -- | Produce a strict 'S.ByteString' from the stdout of a--- process. Throws a 'ProcessExitedUnsuccessfully' exception if the+-- process. Throws a 'ReadProcessException' exception if the -- process fails. Logs process's stderr using @$logError@.-readDockerProcess :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)- => EnvOverride- -> [String]- -> m BS.ByteString+readDockerProcess+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => EnvOverride -> [String] -> m BS.ByteString readDockerProcess envOverride args =- readProcessStdoutLogStderr "docker: " Nothing envOverride "docker" args+ readProcessStdout Nothing envOverride "docker" args -- | Subdirectories of the home directory to sandbox between GHC/Stackage versions. sandboxedHomeSubdirectories :: [Path Rel Dir]
+ src/Stack/Exec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Execute commands within the properly configured Stack+-- environment.++module Stack.Exec where++import Control.Monad.Reader+import Control.Monad.Logger+import Control.Monad.Catch+++import Path+import Stack.Types+import System.Exit+import qualified System.Process as P+import System.Process.Read+++-- | Execute a process within the Stack configured environment.+exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m)+ => String -> [String] -> m b+exec cmd args = do+ config <- asks getConfig+ menv <- liftIO (configEnvOverride config+ EnvSettings+ { esIncludeLocals = True+ , esIncludeGhcPackagePath = True+ })+ cmd' <- join $ System.Process.Read.findExecutable menv cmd+ let cp = (P.proc (toFilePath cmd') args)+ { P.env = envHelper menv+ , P.delegate_ctlc = True+ }+ $logProcessRun (toFilePath cmd') args+ (Nothing, Nothing, Nothing, ph) <- liftIO (P.createProcess cp)+ ec <- liftIO (P.waitForProcess ph)+ liftIO (exitWith ec)
src/Stack/Fetch.hs view
@@ -14,6 +14,7 @@ module Stack.Fetch ( unpackPackages , unpackPackageIdents+ , fetchPackages , resolvePackages , ResolvedPackage (..) , withCabalFiles@@ -29,6 +30,7 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar, readTVarIO, writeTVar)+import Control.Exception (assert) import Control.Monad (liftM, when, join, unless, void) import Control.Monad.Catch import Control.Monad.IO.Class@@ -107,8 +109,20 @@ "The following package identifiers were not found in your indices: " ++ intercalate ", " (map packageIdentifierString $ Set.toList idents) +-- | Fetch packages into the cache without unpacking+fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)+ => EnvOverride+ -> Set PackageIdentifier+ -> m ()+fetchPackages menv idents = do+ resolved <- resolvePackages menv idents Set.empty+ ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved+ assert (Map.null alreadyUnpacked) (return ())+ nowUnpacked <- fetchPackages' Nothing toFetch+ assert (Map.null nowUnpacked) (return ())+ -- | Intended to work for the command line command.-unpackPackages :: (MonadIO m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadThrow m,MonadLogger m)+unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) => EnvOverride -> FilePath -- ^ destination -> [String] -- ^ names or identifiers@@ -119,10 +133,10 @@ ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)- ToFetchResult toFetch alreadyUnpacked <- getToFetch dest' resolved+ ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved unless (Map.null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked- unpacked <- fetchPackages Nothing toFetch+ unpacked <- fetchPackages' Nothing toFetch F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> $logInfo $ T.pack $ concat [ "Unpacked " , packageIdentifierString ident@@ -142,7 +156,7 @@ -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents- :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m)+ :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) => EnvOverride -> Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157@@ -150,8 +164,8 @@ -> m (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents menv unpackDir mdistDir idents = do resolved <- resolvePackages menv idents Set.empty- ToFetchResult toFetch alreadyUnpacked <- getToFetch unpackDir resolved- nowUnpacked <- fetchPackages mdistDir toFetch+ ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved+ nowUnpacked <- fetchPackages' mdistDir toFetch return $ alreadyUnpacked <> nowUnpacked data ResolvedPackage = ResolvedPackage@@ -160,7 +174,7 @@ } -- | Resolve a set of package names and identifiers into @FetchPackage@ values.-resolvePackages :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)+resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> Set PackageIdentifier -> Set PackageName@@ -199,7 +213,7 @@ data ToFetch = ToFetch { tfTarball :: !(Path Abs File)- , tfDestDir :: !(Path Abs Dir)+ , tfDestDir :: !(Maybe (Path Abs Dir)) , tfUrl :: !T.Text , tfSize :: !(Maybe Word64) , tfSHA512 :: !(Maybe ByteString)@@ -232,7 +246,7 @@ -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader- :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m)+ :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> ((PackageIdentifier -> IO ByteString) -> m a) -> m a@@ -283,10 +297,10 @@ -- | Figure out where to fetch from. getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)- => Path Abs Dir -- ^ directory to unpack into+ => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> Map PackageIdentifier ResolvedPackage -> m ToFetchResult-getToFetch dest resolvedAll = do+getToFetch mdest resolvedAll = do (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked $ Map.toList resolvedAll toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0 return ToFetchResult@@ -296,18 +310,23 @@ where checkUnpacked (ident, resolved) = do dirRel <- parseRelDir $ packageIdentifierString ident- let destDir = dest </> dirRel- exists <- liftIO $ doesDirectoryExist $ toFilePath destDir- if exists- then return $ Right (ident, destDir)- else do+ let mdestDir = (</> dirRel) <$> mdest+ mexists <-+ case mdestDir of+ Nothing -> return Nothing+ Just destDir -> do+ exists <- liftIO $ doesDirectoryExist $ toFilePath destDir+ return $ if exists then Just destDir else Nothing+ case mexists of+ Just destDir -> return $ Right (ident, destDir)+ Nothing -> do let index = rpIndex resolved d = pcDownload $ rpCache resolved targz = T.pack $ packageIdentifierString ident ++ ".tar.gz" tarball <- configPackageTarball (indexName index) ident return $ Left (indexName index, [(ident, rpCache resolved, ToFetch { tfTarball = tarball- , tfDestDir = destDir+ , tfDestDir = mdestDir , tfUrl = case d of Just d' -> decodeUtf8 $ pdUrl d' Nothing -> indexDownloadPrefix index <> targz@@ -335,11 +354,11 @@ -- @ -- -- Since 0.1.0.0-fetchPackages :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)- => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157- -> Map PackageIdentifier ToFetch- -> m (Map PackageIdentifier (Path Abs Dir))-fetchPackages mdistDir toFetchAll = do+fetchPackages' :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)+ => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157+ -> Map PackageIdentifier ToFetch+ -> m (Map PackageIdentifier (Path Abs Dir))+fetchPackages' mdistDir toFetchAll = do connCount <- asks $ configConnectionCount . getConfig outputVar <- liftIO $ newTVarIO Map.empty @@ -371,49 +390,51 @@ _ <- verifiedDownload downloadReq destpath progressSink let fp = toFilePath destpath- let dest = toFilePath $ parent $ tfDestDir toFetch- innerDest = toFilePath $ tfDestDir toFetch - liftIO $ createDirectoryIfMissing True dest+ F.forM_ (tfDestDir toFetch) $ \destDir -> do+ let dest = toFilePath $ parent destDir+ innerDest = toFilePath destDir - liftIO $ withBinaryFile fp ReadMode $ \h -> do- -- Avoid using L.readFile, which is more likely to leak- -- resources- lbs <- L.hGetContents h- let entries = fmap (either wrap wrap)- $ Tar.checkTarbomb identStr- $ Tar.read $ decompress lbs- wrap :: Exception e => e -> FetchException- wrap = Couldn'tReadPackageTarball fp . toException- identStr = packageIdentifierString ident- Tar.unpack dest entries+ liftIO $ createDirectoryIfMissing True dest - case mdistDir of- Nothing -> return ()- -- See: https://github.com/fpco/stack/issues/157- Just distDir -> do- let inner = dest FP.</> identStr- oldDist = inner FP.</> "dist"- newDist = inner FP.</> toFilePath distDir- exists <- doesDirectoryExist oldDist- when exists $ do- -- Previously used takeDirectory, but that got confused- -- by trailing slashes, see:- -- https://github.com/commercialhaskell/stack/issues/216- --- -- Instead, use Path which is a bit more resilient- newDist' <- parseAbsDir newDist- createDirectoryIfMissing True- $ toFilePath $ parent newDist'- renameDirectory oldDist newDist+ liftIO $ withBinaryFile fp ReadMode $ \h -> do+ -- Avoid using L.readFile, which is more likely to leak+ -- resources+ lbs <- L.hGetContents h+ let entries = fmap (either wrap wrap)+ $ Tar.checkTarbomb identStr+ $ Tar.read $ decompress lbs+ wrap :: Exception e => e -> FetchException+ wrap = Couldn'tReadPackageTarball fp . toException+ identStr = packageIdentifierString ident+ Tar.unpack dest entries - let cabalFP =- innerDest FP.</>- packageNameString (packageIdentifierName ident)- <.> "cabal"- S.writeFile cabalFP $ tfCabal toFetch+ case mdistDir of+ Nothing -> return ()+ -- See: https://github.com/fpco/stack/issues/157+ Just distDir -> do+ let inner = dest FP.</> identStr+ oldDist = inner FP.</> "dist"+ newDist = inner FP.</> toFilePath distDir+ exists <- doesDirectoryExist oldDist+ when exists $ do+ -- Previously used takeDirectory, but that got confused+ -- by trailing slashes, see:+ -- https://github.com/commercialhaskell/stack/issues/216+ --+ -- Instead, use Path which is a bit more resilient+ newDist' <- parseAbsDir newDist+ createDirectoryIfMissing True+ $ toFilePath $ parent newDist'+ renameDirectory oldDist newDist - atomically $ modifyTVar outputVar $ Map.insert ident $ tfDestDir toFetch+ let cabalFP =+ innerDest FP.</>+ packageNameString (packageIdentifierName ident)+ <.> "cabal"+ S.writeFile cabalFP $ tfCabal toFetch++ atomically $ modifyTVar outputVar $ Map.insert ident destDir parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m) => Int
src/Stack/GhcPkg.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -20,14 +21,13 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger+import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.List import Data.Maybe-import Data.Streaming.Process import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Time.Clock import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) import Prelude hiding (FilePath) import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId))@@ -37,9 +37,8 @@ import System.Process.Read -- | Get the global package database-getGlobalDB :: (MonadIO m, MonadLogger m, MonadThrow m)- => EnvOverride- -> m (Path Abs Dir)+getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride -> m (Path Abs Dir) getGlobalDB menv = do -- This seems like a strange way to get the global package database -- location, but I don't know of a better one@@ -54,33 +53,26 @@ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable-ghcPkg :: (MonadIO m, MonadLogger m)+ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> [Path Abs Dir] -> [String]- -> m (Either ProcessExitedUnsuccessfully S8.ByteString)+ -> m (Either ReadProcessException S8.ByteString) ghcPkg menv pkgDbs args = do- start <- liftIO getCurrentTime eres <- go r <- case eres of Left _ -> do mapM_ (createDatabase menv) pkgDbs go Right _ -> return eres- end <- liftIO getCurrentTime- $logDebug $ T.concat- [ "ghc-pkg ("- , T.pack $ show $ diffUTCTime end start- , "s) with args "- , T.pack $ show args'- ] return r where go = tryProcessStdout Nothing menv "ghc-pkg" args' args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist.-createDatabase :: (MonadIO m, MonadLogger m) => EnvOverride -> Path Abs Dir -> m ()+createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride -> Path Abs Dir -> m () createDatabase menv db = do let db' = toFilePath db exists <- liftIO $ doesDirectoryExist db'@@ -99,7 +91,7 @@ : map (\x -> ("--package-db=" ++ toFilePath x)) pkgDbs -- | Get the id of the package e.g. @foo-0.0.0-9c293923c0685761dcff6f8c3ad8f8ec@.-findGhcPkgId :: (MonadIO m, MonadLogger m)+findGhcPkgId :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> [Path Abs Dir] -- ^ package databases -> PackageName@@ -128,7 +120,7 @@ stripCR t = fromMaybe t (T.stripSuffix "\r" t) -unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> Path Abs Dir -- ^ package database -> GhcPkgId@@ -143,7 +135,7 @@ args = ["unregister", "--user", "--force", packageIdentifierString $ ghcPkgIdPackageIdentifier gid] -- | Get the version of Cabal from the global package database.-getCabalPkgVer :: (MonadThrow m,MonadIO m,MonadLogger m)+getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m Version getCabalPkgVer menv = do db <- getGlobalDB menv -- FIXME shouldn't be necessary, just tell ghc-pkg to look in the global DB
+ src/Stack/Init.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.Init+ ( findCabalFiles+ , initProject+ , InitOpts (..)+ , initOptsParser+ , readResolver+ ) where++import Control.Exception (assert)+import Control.Exception.Enclosed (handleIO)+import Control.Monad (liftM, when)+import Control.Monad.Catch (MonadCatch, SomeException,+ catch, throwM)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.IntMap as IntMap+import Data.List (sort)+import Data.List (isSuffixOf)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import qualified Distribution.PackageDescription as C+import Network.HTTP.Client.Conduit (HasHttpManager)+import Options.Applicative+import Options.Applicative.Types (readerAsk)+import Path+import Path.Find+import Path.IO+import Stack.BuildPlan+import Stack.Constants+import Stack.Package+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)+ where+ isCabal path = ".cabal" `isSuffixOf` toFilePath path++ isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs++-- | Special directories that we don't want to traverse for .cabal files+ignoredDirs :: Set FilePath+ignoredDirs = Set.fromList+ [ ".git"+ , "dist"+ , ".stack-work"+ ]++-- | Generate stack.yaml+initProject :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+ => Maybe Resolver -- ^ force this resolver to be used+ -> InitOpts+ -> m ()+initProject mresolver initOpts = do+ currDir <- getWorkingDir+ 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"++ cabalfps <- findCabalFiles currDir+ $logInfo $ "Writing default config file to: " <> T.pack dest'+ $logInfo $ "Basing on cabal files:"+ mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps+ $logInfo ""++ when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"+ gpds <- mapM readPackageUnresolved cabalfps++ (r, flags) <- getDefaultResolver gpds mresolver initOpts+ let p = Project+ { projectPackages = pkgs+ , projectExtraDeps = Map.empty+ , projectFlags = flags+ , projectResolver = r+ }+ pkgs = map toPkg cabalfps+ toPkg fp = PackageEntry+ { peValidWanted = True+ , peLocation = PLFilePath $+ case stripDir currDir $ parent fp of+ Nothing+ | currDir == parent fp -> "."+ | otherwise -> assert False $ toFilePath $ parent fp+ Just rel -> toFilePath rel+ , peSubdirs = []+ }+ $logInfo $ "Selected resolver: " <> renderResolver r+ liftIO $ Yaml.encodeFile dest' p+ $logInfo $ "Wrote project config to: " <> T.pack dest'++getSnapshots' :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+ => m Snapshots+getSnapshots' =+ getSnapshots `catch` \e -> do+ $logError $+ "Unable to download snapshot list, and therefore could " <>+ "not generate a stack.yaml file automatically"+ $logError $+ "This sometimes happens due to missing Certificate Authorities " <>+ "on your system. For more information, see:"+ $logError ""+ $logError " https://github.com/commercialhaskell/stack/issues/234"+ $logError ""+ $logError "You can try again, or create your stack.yaml file by hand. See:"+ $logError ""+ $logError " https://github.com/commercialhaskell/stack/wiki/stack.yaml"+ $logError ""+ throwM (e :: SomeException)++-- | Get the default resolver value+getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+ => [C.GenericPackageDescription] -- ^ cabal files+ -> Maybe Resolver -- ^ resolver override+ -> InitOpts+ -> m (Resolver, Map PackageName (Map FlagName Bool))+getDefaultResolver gpds mresolver initOpts = do+ names <-+ case mresolver of+ Nothing -> do+ snapshots <- getSnapshots'+ getRecommendedSnapshots snapshots initOpts+ Just resolver ->+ return $+ case resolver of+ ResolverSnapshot name -> [name]+ ResolverGhc _ -> []+ mpair <- findBuildPlan gpds names+ case mpair of+ Just (snap, flags) ->+ return (ResolverSnapshot snap, flags)+ Nothing ->+ case mresolver of+ Nothing ->+ case ioFallback initOpts of+ Nothing -> throwM $ NoMatchingSnapshot names+ Just resolver -> return (resolver, Map.empty)+ Just resolver -> return (resolver, Map.empty)++getRecommendedSnapshots :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+ => Snapshots+ -> InitOpts+ -> m [SnapName]+getRecommendedSnapshots snapshots initOpts = do+ -- Get the most recent LTS and Nightly in the snapshots directory and+ -- prefer them over anything else, since odds are high that something+ -- already exists for them.+ existing <-+ liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $+ snapshotsDir >>=+ liftIO . handleIO (const $ return [])+ . getDirectoryContents . toFilePath+ let isLTS LTS{} = True+ isLTS Nightly{} = False+ isNightly Nightly{} = True+ isNightly LTS{} = False++ names = nubOrd $ concat+ [ take 2 $ filter isLTS existing+ , take 2 $ filter isNightly existing+ , map (uncurry LTS)+ (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)+ , [Nightly $ snapshotsNightly snapshots]+ ]++ namesLTS = filter isLTS names+ namesNightly = filter isNightly names++ case ioPref initOpts of+ PrefNone -> return names+ PrefLTS -> return $ namesLTS ++ namesNightly+ PrefNightly -> return $ namesNightly ++ namesLTS++data InitOpts = InitOpts+ { ioPref :: !SnapPref+ -- ^ Preferred snapshots+ , ioFallback :: !(Maybe Resolver)+ }++data SnapPref = PrefNone | PrefLTS | PrefNightly++initOptsParser :: Parser InitOpts+initOptsParser = InitOpts+ <$> pref+ <*> optional fallback+ where+ pref =+ flag' PrefLTS+ (long "prefer-lts" <>+ help "Prefer LTS snapshots over Nightly snapshots") <|>+ flag' PrefNightly+ (long "prefer-nightly" <>+ help "Prefer Nightly snapshots over LTS snapshots") <|>+ pure PrefNone++ fallback = option readResolver+ (long "fallback" <>+ metavar "RESOLVER" <>+ help "Fallback resolver if none of the tested snapshots work")++readResolver :: ReadM Resolver+readResolver = do+ s <- readerAsk+ case parseResolver $ T.pack s of+ Left e -> readerError $ show e+ Right x -> return x++-- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.+nubOrd :: Ord a => [a] -> [a]+nubOrd =+ go Set.empty+ where+ go _ [] = []+ go s (x:xs)+ | x `Set.member` s = go s xs+ | otherwise = x : go (Set.insert x s) xs
+ src/Stack/New.hs view
@@ -0,0 +1,8 @@+module Stack.New+ ( newProject+ ) where++import Control.Monad.IO.Class++newProject :: MonadIO m => m ()+newProject = error "new command not yet implemented, check out https://github.com/commercialhaskell/stack/issues/137 for status and to get involved"
src/Stack/Package.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-}@@ -20,6 +21,7 @@ ,getCabalFileName ,Package(..) ,GetPackageFiles(..)+ ,GetPackageOpts(..) ,PackageConfig(..) ,buildLogPath ,PackageException (..)@@ -53,13 +55,14 @@ import Data.Text.Encoding.Error (lenientDecode) import Distribution.Compiler import Distribution.InstalledPackageInfo (PError)-import qualified Distribution.ModuleName as Cabal import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as Cabal import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import Distribution.PackageDescription hiding (FlagName) import Distribution.PackageDescription.Parse import Distribution.Simple.Utils import Distribution.System (OS, Arch, Platform (..))+import Distribution.Text (display) import Distribution.Version (intersectVersionRanges) import Path as FL import Path.Find@@ -117,11 +120,22 @@ ,packageTests :: !(Set Text) -- ^ names of test suites ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks ,packageExes :: !(Set Text) -- ^ names of executables+ ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. } deriving (Show,Typeable) -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file+newtype GetPackageOpts = GetPackageOpts+ { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m)+ => Path Abs File+ -> m [String]+ }+instance Show GetPackageOpts where+ show _ = "<GetPackageOpts>"++-- | Files that the package depends on, relative to package directory.+-- Argument is the location of the .cabal file newtype GetPackageFiles = GetPackageFiles { getPackageFiles :: forall m. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m) => Path Abs File@@ -227,6 +241,8 @@ , packageTests = S.fromList $ [ T.pack (testName t) | t <- testSuites pkg, buildable (testBuildInfo t)] , packageBenchmarks = S.fromList $ [ T.pack (benchmarkName b) | b <- benchmarks pkg, buildable (benchmarkBuildInfo b)] , packageExes = S.fromList $ [ T.pack (exeName b) | b <- executables pkg, buildable (buildInfo b)]+ , packageOpts = GetPackageOpts $ \cabalfp ->+ generatePkgDescOpts cabalfp pkg } where@@ -235,6 +251,66 @@ pkg = resolvePackageDescription packageConfig gpkg deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg) +-- | Generate GHC options for the package.+generatePkgDescOpts :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)+ => Path Abs File -> PackageDescription -> m [String]+generatePkgDescOpts cabalfp pkg =+ do distDir <- distDirFromDir cabalDir+ let cabalmacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h")+ exists <- fileExists cabalmacros+ let mcabalmacros =+ if exists+ then Just cabalmacros+ else Nothing+ return (nub+ (concatMap+ (concatMap (generateBuildInfoOpts mcabalmacros cabalDir distDir))+ [ maybe+ []+ (return . libBuildInfo)+ (library pkg)+ , map buildInfo (executables pkg)+ , map benchmarkBuildInfo (benchmarks pkg)+ , map testBuildInfo (testSuites pkg)]))+ where cabalDir =+ parent cabalfp++-- | Generate GHC options for the target.+generateBuildInfoOpts :: Maybe (Path Abs File) -> Path Abs Dir -> Path Abs Dir -> BuildInfo -> [String]+generateBuildInfoOpts mcabalmacros cabalDir distDir b =+ nub (concat [ghcOpts b, extOpts b, srcOpts, macros])+ where+ macros =+ case mcabalmacros of+ Nothing ->+ []+ Just cabalmacros ->+ ["-optP-include", "-optP" <> toFilePath cabalmacros]+ ghcOpts =+ concatMap snd .+ filter (isGhc . fst) .+ options+ where+ isGhc GHC =+ True+ isGhc _ =+ False+ extOpts =+ map (("-X" ++) . display) .+ allExtensions+ srcOpts =+ map+ (("-i" <>) . toFilePath)+ (cabalDir :+ map (cabalDir </>) (mapMaybe parseRelDir (hsSourceDirs b)) <>+ [autogenDir distDir])++-- | Make the autogen dir.+autogenDir :: Path Abs Dir -> Path Abs Dir+autogenDir distDir =+ distDir </>+ $(mkRelDir "build/autogen")+ -- | Get all dependencies of the package (buildable targets only). packageDependencies :: PackageDescription -> Map PackageName VersionRange packageDependencies =@@ -286,6 +362,12 @@ liftM concat (mapM executableFiles (executables pkg))+ benchfiles <-+ liftM concat+ (mapM benchmarkFiles (benchmarks pkg))+ testfiles <-+ liftM concat+ (mapM testFiles (testSuites pkg)) dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg)) srcfiles <-@@ -295,7 +377,7 @@ -- don't error out if not present docfiles <- resolveGlobFiles (extraDocFiles pkg)- return (concat [libfiles,exefiles,dfiles,srcfiles,docfiles])+ return (concat [libfiles,exefiles,dfiles,srcfiles,docfiles,benchfiles,testfiles]) -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)@@ -358,6 +440,48 @@ [] -> die $ "filepath wildcard '" ++ filepath ++ "' does not match any files." matches -> return matches++-- | Get all files referenced by the benchmark.+benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)+ => Benchmark -> m [Path Abs File]+benchmarkFiles bench = do+ dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)+ dir <- asks parent+ exposed <-+ resolveFiles+ (dirs ++ [dir])+ (case benchmarkInterface bench of+ BenchmarkExeV10 _ fp ->+ [Right fp]+ BenchmarkUnsupported _ ->+ [])+ haskellFileExts+ bfiles <- buildFiles dir build+ return (mconcat [bfiles, exposed])+ where+ build = benchmarkBuildInfo bench++-- | Get all files referenced by the test.+testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)+ => TestSuite -> m [Path Abs File]+testFiles test = do+ dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)+ dir <- asks parent+ exposed <-+ resolveFiles+ (dirs ++ [dir])+ (case testInterface test of+ TestSuiteExeV10 _ fp ->+ [Right fp]+ TestSuiteLibV09 _ mn ->+ [Left mn]+ TestSuiteUnsupported _ ->+ [])+ haskellFileExts+ bfiles <- buildFiles dir build+ return (mconcat [bfiles, exposed])+ where+ build = testBuildInfo test -- | Get all files referenced by the executable. executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)
src/Stack/PackageDump.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}@@ -21,9 +22,10 @@ import Control.Applicative import Control.Monad (when, liftM)-import Control.Monad.Catch (MonadThrow, Exception, throwM)+import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger, logDebug)+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Control import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile) import Data.ByteString (ByteString) import qualified Data.ByteString as S@@ -37,12 +39,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes)- import qualified Data.Set as Set-import qualified Data.Text as T---import Data.Time.Clock import Data.Typeable (Typeable) import Path import Prelude -- Fix AMP warning@@ -56,22 +53,14 @@ -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump- :: (MonadIO m, MonadLogger m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> Maybe (Path Abs Dir) -- ^ if Nothing, use global -> Sink ByteString IO a -> m a ghcPkgDump menv mpkgDb sink = do F.mapM_ (createDatabase menv) mpkgDb -- TODO maybe use some retry logic instead?- start <- liftIO getCurrentTime a <- sinkProcessStdout Nothing menv "ghc-pkg" args sink- end <- liftIO getCurrentTime- $logDebug $ T.concat- [ "ghc-pkg ("- , T.pack $ show $ diffUTCTime end start- , "s) with args "- , T.pack $ show args- ] return a where args = concat
src/Stack/PackageIndex.hs view
@@ -27,11 +27,12 @@ import Control.Exception (Exception) import Control.Exception.Enclosed (tryIO) import Control.Monad (unless, when, liftM, mzero)-import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logDebug, logInfo, logWarn) import Control.Monad.Reader (asks)+import Control.Monad.Trans.Control import Data.Aeson.Extended import qualified Data.Binary as Binary@@ -67,6 +68,7 @@ import Path (mkRelDir, parent, parseRelDir, toFilePath, (</>))+import Path.IO import Prelude -- Fix AMP warning import Stack.Types import Stack.Types.StackT@@ -99,17 +101,20 @@ instance Binary.Binary PackageCache -- | Stream all of the cabal files from the 00-index tar file.-sourcePackageIndex :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)- => EnvOverride- -> PackageIndex- -> Producer m (Either UnparsedCabalFile (PackageIdentifier, L.ByteString))-sourcePackageIndex menv index = do+withSourcePackageIndex+ :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => EnvOverride+ -> PackageIndex+ -> (Producer m (Either UnparsedCabalFile (PackageIdentifier, L.ByteString)) -> m a)+ -> m a+withSourcePackageIndex menv index cont = do requireIndex menv index -- This uses full on lazy I/O instead of ResourceT to provide some -- protections. Caveat emptor- path <- configPackageIndex (indexName index)- lbs <- liftIO $ L.readFile $ Path.toFilePath path- loop 0 (Tar.read lbs)+ cont $ do+ path <- configPackageIndex (indexName index)+ lbs <- liftIO $ L.readFile $ Path.toFilePath path+ loop 0 (Tar.read lbs) where loop blockNo (Tar.Next e es) = do goE blockNo e@@ -171,20 +176,20 @@ -- | Require that an index be present, updating if it isn't. requireIndex :: (MonadIO m,MonadLogger m ,MonadThrow m,MonadReader env m,HasHttpManager env- ,HasConfig env)+ ,HasConfig env,MonadBaseControl IO m,MonadCatch m) => EnvOverride -> PackageIndex -> m () requireIndex menv index = do tarFile <- configPackageIndex $ indexName index- exists <- liftIO $ doesFileExist $ toFilePath tarFile+ exists <- fileExists tarFile unless exists $ updateIndex menv index -- | Update all of the package indices updateAllIndices :: (MonadIO m,MonadLogger m ,MonadThrow m,MonadReader env m,HasHttpManager env- ,HasConfig env)+ ,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m () updateAllIndices menv =@@ -193,7 +198,7 @@ -- | Update the index tarball updateIndex :: (MonadIO m,MonadLogger m ,MonadThrow m,MonadReader env m,HasHttpManager env- ,HasConfig env)+ ,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> PackageIndex -> m ()@@ -209,7 +214,7 @@ (False, ILGit url) -> logUpdate url >> (throwM $ GitNotAvailable name) -- | Update the index Git repo and the index tarball-updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env)+updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> IndexName -> PackageIndex@@ -256,15 +261,17 @@ $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile) deleteCache indexName'+ let tarFileTmp = toFilePath tarFile ++ ".tmp" readInNull acfDir "git" menv ["archive" ,"--format=tar" ,"-o"- ,toFilePath tarFile+ ,tarFileTmp ,"current-hackage"] Nothing+ liftIO $ renameFile tarFileTmp (toFilePath tarFile) -- | Update the index tarball via HTTP updateIndexHTTP :: (MonadIO m,MonadLogger m@@ -282,7 +289,7 @@ toUnpack <- if wasDownloaded then return True- else liftIO $ fmap not $ doesFileExist $ toFilePath tar+ else liftM not $ fileExists tar when toUnpack $ do let tmp = toFilePath tar <.> "tmp"@@ -341,7 +348,7 @@ } -- | Load the cached package URLs, or created the cache if necessary.-getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env)+getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Map PackageIdentifier (PackageIndex, PackageCache)) getPackageCaches menv = do@@ -353,7 +360,7 @@ return (fmap (index,) pis') -- | Populate the package index caches and return them.-populateCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env)+populateCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> PackageIndex -> m (Map PackageIdentifier PackageCache)@@ -375,20 +382,21 @@ Nothing -> Nothing Just pd -> Just (ident, pd) - (pis, pds) <- sourcePackageIndex menv index $$ getZipSink ((,)- <$> ZipSink (CL.mapMaybe toIdent =$ CL.consume)- <*> ZipSink (Map.fromList <$> (CL.mapMaybe parseDownload =$ CL.consume)))+ withSourcePackageIndex menv index $ \source -> do+ (pis, pds) <- source $$ getZipSink ((,)+ <$> ZipSink (CL.mapMaybe toIdent =$ CL.consume)+ <*> ZipSink (Map.fromList <$> (CL.mapMaybe parseDownload =$ CL.consume))) - pis' <- liftM Map.fromList $ forM pis $ \(ident, pc) ->- case Map.lookup ident pds of- Just d -> return (ident, pc { pcDownload = Just d })- Nothing- | indexRequireHashes index -> throwM $ MissingRequiredHashes (indexName index) ident- | otherwise -> return (ident, pc)+ pis' <- liftM Map.fromList $ forM pis $ \(ident, pc) ->+ case Map.lookup ident pds of+ Just d -> return (ident, pc { pcDownload = Just d })+ Nothing+ | indexRequireHashes index -> throwM $ MissingRequiredHashes (indexName index) ident+ | otherwise -> return (ident, pc) - $logStickyDone "Populated index cache."+ $logStickyDone "Populated index cache." - return pis'+ return pis' --------------- Lifted from cabal-install, Distribution.Client.Tar: -- | Return the number of blocks in an entry.
+ src/Stack/Repl.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- | Run a REPL configured with the user's project(s).++module Stack.Repl where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Path+import Path.IO+import Stack.Build.Source+import Stack.Exec+import Stack.Package+import Stack.Types++-- | Launch a GHCi REPL for the given local project targets with the+-- given options and configure it with the load paths and extensions+-- of those targets.+repl :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)+ => [Text] -- ^ Targets.+ -> [String] -- ^ GHC options.+ -> m ()+repl targets opts = do+ bconfig <- asks getBuildConfig+ pwd <- getWorkingDir+ pkgOpts <-+ 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 = bcGhcVersion bconfig+ , packageConfigPlatform = configPlatform+ (getConfig bconfig)+ }+ pkg <- readPackage config cabalfp+ if validWanted &&+ wanted pwd cabalfp pkg+ then do+ pkgOpts <-+ getPackageOpts+ (packageOpts pkg)+ cabalfp+ return (Just (packageName pkg, pkgOpts))+ else return Nothing+ $logInfo+ ("Configuring GHCi with the following packages: " <>+ T.intercalate+ ", "+ (map packageNameText (map fst pkgOpts)))+ exec+ "ghc"+ ("--interactive" :+ filter (not . badForGhci) (concat (map snd pkgOpts)) <>+ opts)+ where+ wanted pwd cabalfp pkg =+ isInWantedList || targetsEmptyAndInDir+ where+ isInWantedList =+ elem+ (packageNameText+ (packageName pkg))+ targets+ targetsEmptyAndInDir =+ null targets ||+ isParentOf+ (parent cabalfp)+ pwd+ badForGhci = isPrefixOf "-O"
src/Stack/Setup.hs view
@@ -15,21 +15,18 @@ ) where import Control.Applicative-import Control.Exception (Exception) import Control.Monad (liftM, when, join, void)-import Control.Monad.Catch (MonadThrow, throwM, MonadMask)+import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger import Control.Monad.Reader (MonadReader, ReaderT (..), asks) import Control.Monad.State (get, put, modify) import Control.Monad.Trans.Control- import Data.Aeson.Extended import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever) import Data.Conduit.Lift (evalStateC)-import Data.Conduit.Process (ProcessExitedUnsuccessfully) import qualified Data.Conduit.List as CL import Data.IORef import Data.List (intercalate)@@ -45,11 +42,13 @@ import Data.Typeable (Typeable) import qualified Data.Yaml as Yaml import Distribution.System (OS (..), Arch (..), Platform (..))+import Distribution.Text (simpleParse) import Network.HTTP.Client.Conduit import Network.HTTP.Download (verifiedDownload, DownloadRequest(..)) import Path import Path.IO import Prelude -- Fix AMP warning+import Safe (readMay) import Stack.Build.Types import Stack.GhcPkg (getGlobalDB) import Stack.Types@@ -77,7 +76,7 @@ | MissingDependencies [String] | UnknownGHCVersion Version (Set MajorVersion) | UnknownOSKey Text- | GHCSanityCheckCompileFailed ProcessExitedUnsuccessfully (Path Abs File)+ | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) deriving Typeable instance Exception SetupException instance Show SetupException where@@ -87,7 +86,7 @@ , ", please install manually" ] show (MissingDependencies tools) =- "The following executables are missing and must be installed:" +++ "The following executables are missing and must be installed: " ++ intercalate ", " tools show (UnknownGHCVersion version known) = concat [ "No information found for GHC version "@@ -218,12 +217,15 @@ then getSystemGHC menv0 else return Nothing + Platform expectedArch _ <- asks getPlatform+ let needLocal = case msystem of Nothing -> True- Just system ->+ Just (system, arch) -> -- we allow a newer version of GHC within the same major series getMajorVersion system /= getMajorVersion expected ||- expected > system+ expected > system ||+ arch /= expectedArch -- If we need to install a GHC, try to do so mpaths <- if needLocal@@ -254,7 +256,6 @@ installed <- runReaderT listInstalled config idents <- mapM (ensureTool sopts installed getSetupInfo' msystem) tools paths <- runReaderT (mapM binDirs $ catMaybes idents) config- -- TODO: strip the trailing slash for prettier PATH output return $ Just $ map toFilePath $ concat paths else return Nothing @@ -276,19 +277,19 @@ expected = soptsExpected sopts -- | Get the major version of the system GHC, if available-getSystemGHC :: (MonadIO m) => EnvOverride -> m (Maybe Version)+getSystemGHC :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Maybe (Version, Arch)) getSystemGHC menv = do exists <- doesExecutableExist menv "ghc" if exists then do- eres <- liftIO $ tryProcessStdout Nothing menv "ghc" ["--numeric-version"]+ eres <- tryProcessStdout Nothing menv "ghc" ["--info"] return $ do Right bs <- Just eres- parseVersion $ S8.takeWhile isValidChar bs+ pairs <- readMay $ S8.unpack bs :: Maybe [(String, String)]+ version <- lookup "Project version" pairs >>= parseVersionFromString+ arch <- lookup "Target platform" pairs >>= simpleParse . takeWhile (/= '-')+ Just (version, arch) else return Nothing- where- isValidChar '.' = True- isValidChar c = '0' <= c && c <= '9' data DownloadPair = DownloadPair Version Text deriving Show@@ -384,14 +385,16 @@ => SetupOpts -> [PackageIdentifier] -- ^ already installed -> m SetupInfo- -> Maybe Version -- ^ installed GHC+ -> Maybe (Version, Arch) -- ^ installed GHC -> (PackageName, Maybe Version) -> m (Maybe PackageIdentifier) ensureTool sopts installed getSetupInfo' msystem (name, mversion) | not $ null available = return $ Just $ PackageIdentifier name $ maximum available | not $ soptsInstallIfMissing sopts = if name == $(mkPackageName "ghc")- then throwM $ GHCVersionMismatch msystem (soptsExpected sopts) (soptsStackYaml sopts)+ then do+ Platform arch _ <- asks getPlatform+ throwM $ GHCVersionMismatch msystem (soptsExpected sopts, arch) (soptsStackYaml sopts) else do $logWarn $ "Continuing despite missing tool: " <> T.pack (packageNameString name) return Nothing@@ -491,7 +494,7 @@ | TarXz | SevenZ -installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType@@ -677,7 +680,7 @@ -- | Perform a basic sanity check of GHC-sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m)+sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> m () sanityCheck menv = withSystemTempDirectory "stack-sanity-check" $ \dir -> do
src/Stack/Types/Config.hs view
@@ -22,6 +22,8 @@ import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Monoid import Data.Text (Text) import qualified Data.Text as T@@ -87,6 +89,10 @@ -- ^ Require a version of stack within this range. ,configJobs :: !Int -- ^ How many concurrent jobs to run, defaults to number of capabilities+ ,configExtraIncludeDirs :: !(Set Text)+ -- ^ --extra-include-dirs arguments+ ,configExtraLibDirs :: !(Set Text)+ -- ^ --extra-lib-dirs arguments } -- | Information on a single package index@@ -201,7 +207,7 @@ data LoadConfig m = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration.- , lcLoadBuildConfig :: !(NoBuildConfigStrategy -> m BuildConfig)+ , lcLoadBuildConfig :: !(Maybe Resolver -> NoBuildConfigStrategy -> m BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project.@@ -209,7 +215,6 @@ data NoBuildConfigStrategy = ThrowException- | CreateConfig | ExecStrategy deriving (Show, Eq, Ord) @@ -389,6 +394,10 @@ -- ^ Used for overriding the platform ,configMonoidJobs :: !(Maybe Int) -- ^ See: 'configJobs'+ ,configMonoidExtraIncludeDirs :: !(Set Text)+ -- ^ See: 'configExtraIncludeDirs'+ ,configMonoidExtraLibDirs :: !(Set Text)+ -- ^ See: 'configExtraLibDirs' } deriving Show @@ -405,6 +414,8 @@ , configMonoidOS = Nothing , configMonoidArch = Nothing , configMonoidJobs = Nothing+ , configMonoidExtraIncludeDirs = Set.empty+ , configMonoidExtraLibDirs = Set.empty } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r@@ -412,13 +423,14 @@ , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r- , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r- , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r+ , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l) (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r , configMonoidArch = configMonoidArch l <|> configMonoidArch r , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r+ , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)+ , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) } instance FromJSON ConfigMonoid where@@ -438,6 +450,8 @@ configMonoidOS <- obj .:? "os" configMonoidArch <- obj .:? "arch" configMonoidJobs <- obj .:? "jobs"+ configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty+ configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty return ConfigMonoid {..} -- | Newtype for non-orphan FromJSON instance.@@ -452,9 +466,10 @@ data ConfigException = ParseResolverException Text- | NoProjectConfigFound (Path Abs Dir)+ | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange+ | NoMatchingSnapshot [SnapName] deriving Typeable instance Show ConfigException where show (ParseResolverException t) = concat@@ -463,10 +478,13 @@ , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, and ghc-7.10. " , "See https://www.stackage.org/snapshots for a complete list." ]- show (NoProjectConfigFound dir) = concat+ show (NoProjectConfigFound dir mcmd) = concat [ "Unable to find a stack.yaml file in the current directory (" , toFilePath dir , ") or its ancestors"+ , case mcmd of+ Nothing -> ""+ Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd ] show (UnexpectedTarballContents dirs files) = concat [ "When unpacking a tarball specified in your stack.yaml file, "@@ -482,6 +500,18 @@ ,"version range (" , T.unpack (versionRangeText requiredRange) , ") specified in stack.yaml." ]+ show (NoMatchingSnapshot names) = concat+ [ "There was no snapshot found that matched the package "+ , "bounds in your .cabal files.\n"+ , "Please choose one of the following commands to get started.\n\n"+ , unlines $ map+ (\name -> " stack init --resolver " ++ T.unpack (renderSnapName name))+ names+ , "\nYou'll then need to add some extra-deps. See:\n\n"+ , " https://github.com/commercialhaskell/stack/wiki/stack.yaml#extra-deps"+ , "\n\nNote that this will be improved in the future, see:\n\n"+ , " https://github.com/commercialhaskell/stack/issues/116"+ ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig
src/Stack/Types/Internal.hs view
@@ -12,6 +12,7 @@ data Env config = Env {envConfig :: !config ,envLogLevel :: !LogLevel+ ,envTerminal :: !Bool ,envManager :: !Manager ,envSticky :: !Sticky} @@ -37,6 +38,12 @@ instance HasLogLevel LogLevel where getLogLevel = id++class HasTerminal r where+ getTerminal :: r -> Bool++instance HasTerminal (Env config) where+ getTerminal = envTerminal newtype Sticky = Sticky { unSticky :: Maybe (MVar (Maybe Text))
src/Stack/Types/StackT.hs view
@@ -81,10 +81,14 @@ -- | Run a Stack action. runStackT :: (MonadIO m,MonadBaseControl IO m)- => Manager -> LogLevel -> config -> StackT config m a -> m a-runStackT manager logLevel config m =- withSticky (\sticky -> runReaderT (unStackT m)- (Env config logLevel manager sticky))+ => Manager -> LogLevel -> config -> Bool -> StackT config m a -> m a+runStackT manager logLevel config terminal m =+ withSticky+ terminal+ (\sticky ->+ runReaderT+ (unStackT m)+ (Env config logLevel terminal manager sticky)) -------------------------------------------------------------------------------- -- Logging only StackLoggingT monad transformer@@ -122,11 +126,14 @@ -- | Run the logging monad. runStackLoggingT :: MonadIO m- => Manager -> LogLevel -> StackLoggingT m a -> m a-runStackLoggingT manager logLevel m =- withSticky (\sticky ->- runReaderT (unStackLoggingT m)- (logLevel,manager,sticky))+ => Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a+runStackLoggingT manager logLevel terminal m =+ withSticky+ terminal+ (\sticky ->+ runReaderT+ (unStackLoggingT m)+ (logLevel, manager, sticky)) -- | Convenience for getting a 'Manager' newTLSManager :: MonadIO m => m Manager@@ -237,10 +244,9 @@ char = show . snd . loc_start -- | With a sticky state, do the thing.-withSticky :: MonadIO m- => (Sticky -> m b) -> m b-withSticky m = do- terminal <- liftIO (hIsTerminalDevice stdout)+withSticky :: (MonadIO m)+ => Bool -> (Sticky -> m b) -> m b+withSticky terminal m = do if terminal then do state <- liftIO (newMVar Nothing) originalMode <- liftIO (hGetBuffering stdout)
+ src/Stack/Upload.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Provide ability to upload tarballs to Hackage.+module Stack.Upload+ ( -- * Upload+ mkUploader+ , Uploader+ , upload+ , UploadSettings+ , defaultUploadSettings+ , setUploadUrl+ , setGetManager+ , setCredsSource+ , setSaveCreds+ -- * Credentials+ , HackageCreds+ , loadCreds+ , saveCreds+ , FromFile+ -- ** Credentials source+ , HackageCredsSource+ , fromAnywhere+ , fromPrompt+ , fromFile+ , fromMemory+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Exception (bracket)+import qualified Control.Exception as E+import Control.Monad (when)+import Data.Aeson (FromJSON (..),+ ToJSON (..),+ eitherDecode', encode,+ object, withObject,+ (.:), (.=))+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.IO as TIO+import Data.Typeable (Typeable)+import Network.HTTP.Client (BodyReader, Manager,+ Response,+ applyBasicAuth, brRead,+ checkStatus, newManager,+ parseUrl,+ requestHeaders,+ responseBody,+ responseStatus,+ withResponse)+import Network.HTTP.Client.MultipartFormData (formDataBody, partFile)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import Path (toFilePath)+import Stack.Types+import System.Directory (createDirectoryIfMissing,+ doesDirectoryExist,+ doesFileExist,+ getDirectoryContents,+ removeFile)+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath (takeExtension, (</>))+import System.IO (hClose, hFlush,+ hGetEcho, hSetEcho,+ stdin, stdout)+import System.IO.Temp (withSystemTempDirectory)+import System.Process (StdStream (CreatePipe),+ createProcess, cwd,+ proc, std_in,+ waitForProcess)++-- | Username and password to log into Hackage.+--+-- Since 0.1.0.0+data HackageCreds = HackageCreds+ { hcUsername :: !Text+ , hcPassword :: !Text+ }+ deriving Show++instance ToJSON HackageCreds where+ toJSON (HackageCreds u p) = object+ [ "username" .= u+ , "password" .= p+ ]+instance FromJSON HackageCreds where+ parseJSON = withObject "HackageCreds" $ \o -> HackageCreds+ <$> o .: "username"+ <*> o .: "password"++-- | A source for getting Hackage credentials.+--+-- Since 0.1.0.0+newtype HackageCredsSource = HackageCredsSource+ { getCreds :: IO (HackageCreds, FromFile)+ }++-- | Whether the Hackage credentials were loaded from a file.+--+-- This information is useful since, typically, you only want to save the+-- credentials to a file if it wasn't already loaded from there.+--+-- Since 0.1.0.0+type FromFile = Bool++-- | Load Hackage credentials from the given source.+--+-- Since 0.1.0.0+loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile)+loadCreds = getCreds++-- | Save the given credentials to the credentials file.+--+-- Since 0.1.0.0+saveCreds :: Config -> HackageCreds -> IO ()+saveCreds config creds = do+ fp <- credsFile config+ L.writeFile fp $ encode creds++-- | Load the Hackage credentials from the prompt, asking the user to type them+-- in.+--+-- Since 0.1.0.0+fromPrompt :: HackageCredsSource+fromPrompt = HackageCredsSource $ do+ putStr "Hackage username: "+ hFlush stdout+ username <- TIO.getLine+ password <- promptPassword+ return (HackageCreds+ { hcUsername = username+ , hcPassword = password+ }, False)++credsFile :: Config -> IO FilePath+credsFile config = do+ let dir = toFilePath (configStackRoot config) </> "upload"+ createDirectoryIfMissing True dir+ return $ dir </> "credentials.json"++-- | Load the Hackage credentials from the JSON config file.+--+-- Since 0.1.0.0+fromFile :: Config -> HackageCredsSource+fromFile config = HackageCredsSource $ do+ fp <- credsFile config+ lbs <- L.readFile fp+ case eitherDecode' lbs of+ Left e -> E.throwIO $ Couldn'tParseJSON fp e+ Right creds -> return (creds, True)++-- | Load the Hackage credentials from the given arguments.+--+-- Since 0.1.0.0+fromMemory :: Text -> Text -> HackageCredsSource+fromMemory u p = HackageCredsSource $ return (HackageCreds+ { hcUsername = u+ , hcPassword = p+ }, False)++data HackageCredsExceptions = Couldn'tParseJSON FilePath String+ deriving (Show, Typeable)+instance E.Exception HackageCredsExceptions++-- | Try to load the credentials from the config file. If that fails, ask the+-- user to enter them.+--+-- Since 0.1.0.0+fromAnywhere :: Config -> HackageCredsSource+fromAnywhere config = HackageCredsSource $+ getCreds (fromFile config) `E.catches`+ [ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt+ , E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt+ ]++-- | Lifted from cabal-install, Distribution.Client.Upload+promptPassword :: IO Text+promptPassword = do+ putStr "Hackage password: "+ hFlush stdout+ -- save/restore the terminal echoing status+ passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+ hSetEcho stdin False -- no echoing for entering the password+ fmap T.pack getLine+ putStrLn ""+ return passwd++-- | Turn the given settings into an @Uploader@.+--+-- Since 0.1.0.0+mkUploader :: FilePath -- ^ runghc+ -> Config -> UploadSettings -> IO Uploader+mkUploader runghc config us = do+ manager <- usGetManager us+ (creds, fromFile') <- loadCreds $ usCredsSource us config+ when (not fromFile' && usSaveCreds us) $ saveCreds config creds+ req0 <- parseUrl $ usUploadUrl us+ let req1 = req0+ { requestHeaders = [("Accept", "text/plain")]+ , checkStatus = \_ _ _ -> Nothing+ }+ return Uploader+ { upload_ = \fp0 -> withTarball runghc fp0 $ \fp -> do+ let formData = [partFile "package" fp]+ req2 <- formDataBody formData req1+ let req3 = applyBasicAuth+ (encodeUtf8 $ hcUsername creds)+ (encodeUtf8 $ hcPassword creds)+ req2+ putStr $ "Uploading " ++ fp ++ "... "+ hFlush stdout+ withResponse req3 manager $ \res ->+ case statusCode $ responseStatus res of+ 200 -> putStrLn "done!"+ 401 -> do+ putStrLn "authentication failure"+ cfp <- credsFile config+ handleIO (const $ return ()) (removeFile cfp)+ error $ "Authentication failure uploading to server"+ 403 -> do+ putStrLn "forbidden upload"+ putStrLn "Usually means: you've already uploaded this package/version combination"+ putStrLn "Ignoring error and continuing, full message from Hackage below:\n"+ printBody res+ 503 -> do+ putStrLn "service unavailable"+ putStrLn "This error some times gets sent even though the upload succeeded"+ putStrLn "Check on Hackage to see if your pacakge is present"+ printBody res+ code -> do+ putStrLn $ "unhandled status code: " ++ show code+ printBody res+ error $ "Upload failed on " ++ fp+ }++-- | Given either a file, return it. Given a directory, run @cabal sdist@ and+-- get the resulting tarball.+withTarball :: FilePath -- ^ runghc+ -> FilePath -> (FilePath -> IO a) -> IO a+withTarball _runghc fp0 inner = do+ isFile <- doesFileExist fp0+ if isFile then inner fp0 else withSystemTempDirectory "stackage-upload-tarball" $ \dir -> do+ isDir <- doesDirectoryExist fp0+ when (not isDir) $ error $ "Invalid argument: " ++ fp0++ (Just h, Nothing, Nothing, ph) <-+ -- The insanity: the Cabal library seems to sometimes generate tarballs+ -- in the wrong format. For now, just falling back to cabal-install.+ -- Sigh.++ createProcess $ (proc "cabal"+ [ "sdist"+ , "--builddir=" ++ dir+ ])+ { cwd = Just fp0+ , std_in = CreatePipe+ }+ hClose h+ ec <- waitForProcess ph+ when (ec /= ExitSuccess) $+ error $ "Could not create tarball for " ++ fp0+ contents <- getDirectoryContents dir+ case filter ((== ".gz") . takeExtension) contents of+ [x] -> inner (dir </> x)+ _ -> error $ "Unexpected directory contents after cabal sdist: " ++ show contents++printBody :: Response BodyReader -> IO ()+printBody res =+ loop+ where+ loop = do+ bs <- brRead $ responseBody res+ when (not $ S.null bs) $ do+ S.hPut stdout bs+ loop++-- | The computed value from a @UploadSettings@.+--+-- Typically, you want to use this with 'upload'.+--+-- Since 0.1.0.0+data Uploader = Uploader+ { upload_ :: !(FilePath -> IO ())+ }++-- | Upload a single tarball with the given @Uploader@.+--+-- Since 0.1.0.0+upload :: Uploader -> FilePath -> IO ()+upload = upload_++-- | Settings for creating an @Uploader@.+--+-- Since 0.1.0.0+data UploadSettings = UploadSettings+ { usUploadUrl :: !String+ , usGetManager :: !(IO Manager)+ , usCredsSource :: !(Config -> HackageCredsSource)+ , usSaveCreds :: !Bool+ }++-- | Default value for @UploadSettings@.+--+-- Use setter functions to change defaults.+--+-- Since 0.1.0.0+defaultUploadSettings :: UploadSettings+defaultUploadSettings = UploadSettings+ { usUploadUrl = "https://hackage.haskell.org/packages/"+ , usGetManager = newManager tlsManagerSettings+ , usCredsSource = fromAnywhere+ , usSaveCreds = True+ }++-- | Change the upload URL.+--+-- Default: "https://hackage.haskell.org/packages/"+--+-- Since 0.1.0.0+setUploadUrl :: String -> UploadSettings -> UploadSettings+setUploadUrl x us = us { usUploadUrl = x }++-- | How to get an HTTP connection manager.+--+-- Default: @newManager tlsManagerSettings@+--+-- Since 0.1.0.0+setGetManager :: IO Manager -> UploadSettings -> UploadSettings+setGetManager x us = us { usGetManager = x }++-- | How to get the Hackage credentials.+--+-- Default: @fromAnywhere@+--+-- Since 0.1.0.0+setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings+setCredsSource x us = us { usCredsSource = x }++-- | Save new credentials to the config file.+--+-- Default: @True@+--+-- Since 0.1.0.0+setSaveCreds :: Bool -> UploadSettings -> UploadSettings+setSaveCreds x us = us { usSaveCreds = x }++handleIO :: (E.IOException -> IO a) -> IO a -> IO a+handleIO = E.handle
+ src/System/Process/Log.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Separate module because TH.++module System.Process.Log+ (logProcessRun+ ,showProcessArgDebug)+ where++import Control.Monad.Logger+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH++-- | Log running a process with its arguments, for debugging (-v).+logProcessRun :: Q Exp+logProcessRun =+ [|let f :: MonadLogger m => String -> [String] -> m ()+ f name args =+ $logDebug+ ("Run process: " <> T.pack name <> " " <>+ T.intercalate+ " "+ (map showProcessArgDebug args))+ in f|]++-- | Show a process arg including speechmarks when necessary. Just for+-- debugging purposes, not functionally important.+showProcessArgDebug :: [Char] -> Text+showProcessArgDebug x+ | any special x = T.pack (show x)+ | otherwise = T.pack x+ where special '"' = True+ special ' ' = True+ special _ = False
src/System/Process/Read.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,12 +10,10 @@ -- | Reading from external processes. module System.Process.Read- (readProcessStdoutLogStderr- ,readProcessStdout+ (readProcessStdout ,tryProcessStdout- ,sinkProcessStdoutLogStderr ,sinkProcessStdout- ,sinkProcessStderrStdout+ ,readProcess ,EnvOverride ,unEnvOverride ,mkEnvOverride@@ -25,21 +24,25 @@ ,envSearchPath ,preProcess ,readProcessNull- ,readInNull)+ ,readInNull+ ,logProcessRun+ ,ReadProcessException (..)+ ) where import Control.Applicative import Control.Arrow ((***), first) import Control.Concurrent.Async (Concurrently (..))-import Control.Exception-import Control.Monad (join, liftM, void)-import Control.Monad.Catch (MonadThrow, throwM)+import Control.Exception hiding (try, catch)+import Control.Monad (join, liftM)+import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logError)-import Control.Monad.Trans.Control (MonadBaseControl,liftBaseWith)+import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder import Data.Conduit-import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL import Data.Conduit.Process hiding (callProcess) import Data.Foldable (forM_)@@ -47,8 +50,12 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isJust)+import Data.Monoid import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Encoding.Error (lenientDecode)+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 Path (Path, Abs, Dir, toFilePath, File, parseAbsFile)@@ -57,13 +64,14 @@ import System.Environment (getEnvironment) import System.Exit import qualified System.FilePath as FP+import System.Process.Log -- | Override the environment received by a child process data EnvOverride = EnvOverride { eoTextMap :: Map Text Text , eoStringList :: [(String, String)] , eoPath :: [FilePath]- , eoExeCache :: IORef (Map FilePath (Either FindExecutableException (Path Abs File)))+ , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) , eoExeExtension :: String } @@ -107,28 +115,26 @@ envHelper = Just . eoStringList -- | Read from the process, ignoring any output.-readProcessNull- :: (MonadIO m)- => Maybe (Path Abs Dir)- -> EnvOverride- -> String- -> [String]- -> m ()+readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m () readProcessNull wd menv name args = sinkProcessStdout wd menv name args CL.sinkNull -- | Run the given command in the given directory. If it exits with anything -- but success, prints an error and then calls 'exitWith' to exit the program.-readInNull :: forall (m :: * -> *).- (MonadLogger m,MonadIO m)- => Path Abs Dir -- ^ directory to run in- -> FilePath -- ^ command to run- -> EnvOverride- -> [String] -- ^ command line arguments- -> Maybe Text- -> m ()+readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => Path Abs Dir -- ^ directory to run in+ -> FilePath -- ^ command to run+ -> EnvOverride+ -> [String] -- ^ command line arguments+ -> Maybe Text+ -> m () readInNull wd cmd menv args errMsg = do- result <- liftIO (try (readProcessNull (Just wd) menv cmd args))+ result <- try (readProcessNull (Just wd) menv cmd args) case result of Left (ProcessExitedUnsuccessfully _ ec) -> do $logError $@@ -146,19 +152,19 @@ -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process.-tryProcessStdout :: (MonadIO m)+tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> [String]- -> m (Either ProcessExitedUnsuccessfully S.ByteString)-tryProcessStdout wd menv name args = do- liftIO (try (readProcessStdout wd menv name args))+ -> m (Either ReadProcessException S.ByteString)+tryProcessStdout wd menv name args =+ try (readProcessStdout wd menv name args) -- | Produce a strict 'S.ByteString' from the stdout of a -- process. Throws a 'ProcessExitedUnsuccessfully' exception if the -- process fails.-readProcessStdout :: (MonadIO m)+readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Maybe (Path Abs Dir) -> EnvOverride -> String@@ -168,51 +174,74 @@ sinkProcessStdout wd menv name args CL.consume >>= liftIO . evaluate . S.concat --- | Produce a strict 'S.ByteString' from the stdout of a--- process. Throws a 'ProcessExitedUnsuccessfully' exception if the--- process fails. Logs process's stderr using @$logError@.-readProcessStdoutLogStderr :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)- => Text- -> Maybe (Path Abs Dir)- -> EnvOverride- -> String- -> [String]- -> m S.ByteString-readProcessStdoutLogStderr stderrPrefix wd menv name args = do- stdout <- sinkProcessStdoutLogStderr stderrPrefix wd menv name args CL.consume- liftIO (evaluate (S.concat stdout))+data ReadProcessException+ = ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString+ | NoPathFound+ | ExecutableNotFound String [FilePath]+ deriving Typeable+instance Show ReadProcessException where+ show (ReadProcessException cp ec out err) = concat+ [ "Running "+ , showSpec $ cmdspec cp+ , " exited with "+ , show ec+ , "\n"+ , toStr out+ , "\n"+ , toStr err+ ]+ where+ toStr = LT.unpack . LT.decodeUtf8With lenientDecode --- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer.--- Logs process's stderr using @$logError@.-sinkProcessStdoutLogStderr :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)- => Text -- ^ Prefix for any logged stderr message- -> Maybe (Path Abs Dir)- -> EnvOverride- -> String- -> [String]- -> Sink S.ByteString IO a -- ^ Sink for stdout- -> m a-sinkProcessStdoutLogStderr stderrPrefix wd menv name args sinkStdout = do- runInBase <- liftBaseWith $ \run -> return (void . run)- let logSink = CC.mapM_ (liftIO . runInBase . $logError . T.append stderrPrefix)- sinkStderr = CC.decodeUtf8 =$= CC.line logSink- (_,stdout) <- sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout- return stdout+ showSpec (ShellCommand str) = str+ showSpec (RawCommand cmd args) =+ unwords $ cmd : map (T.unpack . showProcessArgDebug) args+ show NoPathFound = "PATH not found in EnvOverride"+ show (ExecutableNotFound name path) = concat+ [ "Executable named "+ , name+ , " not found on path: "+ , show path+ ]+instance Exception ReadProcessException -- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer.-sinkProcessStdout :: (MonadIO m)- => Maybe (Path Abs Dir)- -> EnvOverride- -> String- -> [String]- -> Sink S.ByteString IO a- -> m a-sinkProcessStdout wd menv name args sink = do- (_,stdout) <- sinkProcessStderrStdout wd menv name args CL.sinkNull sink- return stdout+-- If the process fails, spits out stdout and stderr as error log+-- level. Should not be used for long-running processes or ones with+-- lots of output; for that use 'sinkProcessStdoutLogStderr'.+sinkProcessStdout+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> Sink S.ByteString IO a -- ^ Sink for stdout+ -> m a+sinkProcessStdout wd menv name args sinkStdout = do+ stderrBuffer <- liftIO (newIORef mempty)+ stdoutBuffer <- liftIO (newIORef mempty)+ (_,sinkRet) <-+ catch+ (sinkProcessStderrStdout+ wd+ menv+ name+ args+ (CL.mapM_ (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))))+ (CL.iterM (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))) $=+ sinkStdout))+ (\(ProcessExitedUnsuccessfully cp ec) ->+ do stderrBuilder <- liftIO (readIORef stderrBuffer)+ stdoutBuilder <- liftIO (readIORef stdoutBuffer)+ throwM $ ReadProcessException+ cp+ ec+ (toLazyByteString stdoutBuilder)+ (toLazyByteString stderrBuilder))+ return sinkRet -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.-sinkProcessStderrStdout :: (MonadIO m)+sinkProcessStderrStdout :: (MonadIO m, MonadLogger m) => Maybe (Path Abs Dir) -> EnvOverride -> String@@ -221,6 +250,7 @@ -> Sink S.ByteString IO o -- ^ Sink for stdout -> m (e,o) sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do+ $logProcessRun name args name' <- preProcess wd menv name liftIO (withCheckedProcess (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }@@ -232,7 +262,6 @@ where asBSSource :: Source m S.ByteString -> Source m S.ByteString asBSSource = id - -- | Perform pre-call-process tasks. Ensure the working directory exists and find the -- executable path. preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath@@ -285,17 +314,3 @@ getEnvironment >>= mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack)--data FindExecutableException- = NoPathFound- | ExecutableNotFound String [FilePath]- deriving Typeable-instance Exception FindExecutableException-instance Show FindExecutableException where- show NoPathFound = "PATH not found in EnvOverride"- show (ExecutableNotFound name path) = concat- [ "Executable named "- , name- , " not found on path: "- , show path- ]
src/main/Main.hs view
@@ -10,7 +10,7 @@ module Main where import Control.Exception-import Control.Monad (join)+import Control.Monad (join, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger import Control.Monad.Reader (asks, runReaderT)@@ -19,42 +19,49 @@ import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (isJust)+import Data.Maybe import Data.Monoid+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Network.HTTP.Client+import Network.HTTP.Client.Conduit (getHttpManager)+import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Simple import Options.Applicative.Types (readerAsk) import Path (toFilePath) import qualified Paths_stack as Meta import Plugins-import Plugins.Commands import Stack.Build import Stack.Build.Types import Stack.Config import Stack.Constants import qualified Stack.Docker as Docker+import Stack.Exec import Stack.Fetch-import Stack.GhcPkg (envHelper,getCabalPkgVer)+import Stack.GhcPkg (getCabalPkgVer)+import Stack.Init+import Stack.New import qualified Stack.PackageIndex import Stack.Path+import Stack.Repl import Stack.Setup import Stack.Types import Stack.Types.StackT+import qualified Stack.Upload as Upload import System.Environment (getArgs, getProgName) import System.Exit import System.FilePath (searchPathSeparator) import System.IO (stderr)-import qualified System.Process as P import qualified System.Process.Read -- | Commandline dispatcher. main :: IO () main =- do plugins <- findPlugins (T.pack stackProgName)- tryRunPlugin plugins+ do when False $ do -- https://github.com/commercialhaskell/stack/issues/322+ plugins <- findPlugins (T.pack stackProgName)+ tryRunPlugin plugins progName <- getProgName args <- getArgs execExtraHelp args@@ -87,6 +94,14 @@ "Generate haddocks for the project(s) in this directory/configuration" (buildCmd DoHaddock) buildOpts+ addCommand "new"+ "Create a brand new project"+ (\_ _ -> newProject)+ (pure ())+ addCommand "init"+ "Initialize a stack project based on one or more cabal packages"+ initCmd+ initOptsParser addCommand "setup" "Get the appropriate ghc for your project" setupCmd@@ -99,30 +114,39 @@ "Update the package index" updateCmd (pure ())+ addCommand "upload"+ "Upload a package to Hackage"+ uploadCmd+ (many $ strArgument $ metavar "TARBALL/DIR") addCommand "exec" "Execute a command" execCmd ((,)- <$> strArgument (metavar "[--] CMD")- <*> many (strArgument (metavar "ARGS")))+ <$> strArgument (metavar "CMD")+ <*> many (strArgument (metavar "-- ARGS (e.g. stack exec -- ghc --version)"))) addCommand "ghc" "Run ghc" execCmd ((,) <$> pure "ghc"- <*> many (strArgument (metavar "ARGS")))+ <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))) addCommand "ghci"- "Run ghci"- execCmd- ((,)- <$> pure "ghci"- <*> many (strArgument (metavar "ARGS")))+ "Run ghci in the context of project(s)"+ replCmd+ ((,) <$>+ fmap (map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help "If none specified, use all packages defined in current directory"))) <*>+ many (strOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi"))) addCommand "runghc" "Run runghc" execCmd ((,) <$> pure "runghc"- <*> many (strArgument (metavar "ARGS")))+ <*> many (strArgument (metavar "-- ARGS (e.g. stack runghc -- X.hs)"))) addCommand "clean" "Clean the local packages" cleanCmd@@ -163,7 +187,8 @@ dockerExecCmd ((,) <$> strArgument (metavar "[--] CMD") <*> many (strArgument (metavar "ARGS"))))- commandsFromPlugins plugins pluginShouldHaveRun)+ )+ -- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322 run level `catch` \e -> do -- This special handler stops "stack: " from being printed before the -- exception@@ -179,9 +204,9 @@ pathCmd :: PathArg -> GlobalOpts -> IO () pathCmd pathArg go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go- buildConfig <- runStackLoggingT manager globalLogLevel (lcLoadBuildConfig lc ExecStrategy)- runStackT manager globalLogLevel buildConfig (pathString pathArg) >>= putStrLn-+ buildConfig <- runStackLoggingT manager globalLogLevel globalTerminal+ (lcLoadBuildConfig lc globalResolver ExecStrategy)+ runStackT manager globalLogLevel buildConfig globalTerminal (pathString pathArg) >>= putStrLn -- Try to run a plugin tryRunPlugin :: Plugins -> IO ()@@ -229,18 +254,18 @@ setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $+ runStackLoggingT manager globalLogLevel globalTerminal $ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc)- (runStackLoggingT manager globalLogLevel $ do+ (runStackLoggingT manager globalLogLevel globalTerminal $ do (ghc, mstack) <- case scoGhcVersion of Just v -> return (v, Nothing) Nothing -> do- bc <- lcLoadBuildConfig lc ThrowException+ bc <- lcLoadBuildConfig lc globalResolver ThrowException return (bcGhcVersion bc, Just $ bcStackYaml bc)- mpaths <- runStackT manager globalLogLevel (lcConfig lc) $ ensureGHC SetupOpts+ mpaths <- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = (configSystemGHC $ lcConfig lc)@@ -262,13 +287,13 @@ -> IO () withBuildConfig go@GlobalOpts{..} strat inner = do (manager, lc) <- loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $+ runStackLoggingT manager globalLogLevel globalTerminal $ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do- bconfig1 <- runStackLoggingT manager globalLogLevel $- lcLoadBuildConfig lc strat+ bconfig1 <- runStackLoggingT manager globalLogLevel globalTerminal $+ lcLoadBuildConfig lc globalResolver strat (bconfig2,cabalVer) <- runStackT- manager globalLogLevel bconfig1+ manager globalLogLevel bconfig1 globalTerminal (do cfg <- setupEnv menv <- runReaderT getMinimalEnvOverride cfg cabalVer <- getCabalPkgVer menv@@ -277,6 +302,7 @@ manager globalLogLevel (EnvConfig bconfig2 cabalVer)+ globalTerminal inner cleanCmd :: () -> GlobalOpts -> IO ()@@ -313,7 +339,7 @@ -- | Build the project. buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()-buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go CreateConfig $+buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go ThrowException $ Stack.Build.build opts { boptsFinalAction = finalAction } -- | Install@@ -325,9 +351,9 @@ unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $+ runStackLoggingT manager globalLogLevel globalTerminal $ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) $ do+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do menv <- getMinimalEnvOverride Stack.Fetch.unpackPackages menv "." names @@ -335,57 +361,64 @@ updateCmd :: () -> GlobalOpts -> IO () updateCmd () go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $+ runStackLoggingT manager globalLogLevel globalTerminal $ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) $+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices --- | Execute a command+-- | Upload to Hackage+uploadCmd :: [String] -> GlobalOpts -> IO ()+uploadCmd args0 go = withBuildConfig go ExecStrategy $ do+ let args = if null args0 then ["."] else args0+ config <- asks getConfig+ manager <- asks getHttpManager+ menv <- getMinimalEnvOverride+ runghc <- join $ System.Process.Read.findExecutable menv "runghc"+ liftIO $ do+ uploader <- Upload.mkUploader+ (toFilePath runghc)+ config+ $ Upload.setGetManager (return manager)+ Upload.defaultUploadSettings+ mapM_ (Upload.upload uploader) args++-- | Execute a command. execCmd :: (String, [String]) -> GlobalOpts -> IO ()-execCmd (cmd, args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do- config <- asks getConfig- liftIO $ do- menv <- configEnvOverride config- EnvSettings- { esIncludeLocals = True- , esIncludeGhcPackagePath = True- }- cmd' <- join $ System.Process.Read.findExecutable menv cmd- let cp = (P.proc (toFilePath cmd') args)- { P.env = envHelper menv- , P.delegate_ctlc = True- }+execCmd (cmd,args) go@GlobalOpts{..} =+ withBuildConfig go ExecStrategy $+ exec cmd args - (Nothing, Nothing, Nothing, ph) <- P.createProcess cp- ec <- P.waitForProcess ph- exitWith ec+-- | Run the REPL in the context of a project, with+replCmd :: ([Text], [String]) -> GlobalOpts -> IO ()+replCmd (targets,args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do+ repl targets args -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () dockerPullCmd _ go@GlobalOpts{..} = do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ runStackLoggingT manager globalLogLevel globalTerminal $ Docker.preventInContainer $ Docker.pull (lcConfig lc) -- | Reset the Docker sandbox. dockerResetCmd :: Bool -> GlobalOpts -> IO () dockerResetCmd keepHome go@GlobalOpts{..} = do (manager,lc) <- liftIO (loadConfigWithOpts go)- runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome -- | Cleanup Docker images and containers. dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO () dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $ Docker.cleanup (lcConfig lc) cleanupOpts -- | Execute a command dockerExecCmd :: (String, [String]) -> GlobalOpts -> IO () dockerExecCmd (cmd,args) go@GlobalOpts{..} = do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $ Docker.rerunCmdWithRequiredContainer (lcConfig lc) (lcProjectRoot lc) (return (cmd,args,lcConfig lc))@@ -395,7 +428,7 @@ buildOpts = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> optimize <*> finalAction <*> dryRun <*> ghcOpts <*> flags <*>- installExes+ installExes <*> preFetch <*> testArgs <*> onlySnapshot where optimize = maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm target =@@ -435,6 +468,20 @@ <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)" )) + preFetch = flag False True+ (long "prefetch" <>+ help "Fetch packages necessary for the build immediately, useful with --dry-run")+ testArgs =+ fmap (fromMaybe [])+ (optional+ (argsOption+ (long "test-arguments" <> metavar "TEST_ARGS" <>+ help "Arguments passed in to the test suite program")))++ onlySnapshot = flag False True+ (long "only-snapshot" <>+ help "Only build packages for the snapshot database, not the local database")+ -- | Parser for docker cleanup arguments. dockerCleanupOpts :: Parser Docker.CleanupOpts dockerCleanupOpts =@@ -483,9 +530,15 @@ -- | Parser for global command-line options. globalOpts :: Parser GlobalOpts globalOpts =- GlobalOpts- <$> logLevelOpt- <*> configOptsParser False+ GlobalOpts <$> logLevelOpt <*>+ configOptsParser False <*>+ optional resolverParser <*>+ flag+ True+ False+ (long "no-terminal" <>+ help+ "Override terminal detection in the case of running in a false terminal") -- | Parse for a logging level. logLevelOpt :: Parser LogLevel@@ -514,6 +567,13 @@ "error" -> LevelError _ -> LevelOther (T.pack s) +resolverParser :: Parser Resolver+resolverParser =+ option readResolver+ (long "resolver" <>+ metavar "RESOLVER" <>+ help "Override resolver in project file")+ -- | Default logging level should be something useful but not crazy. defaultLogLevel :: LogLevel defaultLogLevel = LevelInfo@@ -522,6 +582,8 @@ data GlobalOpts = GlobalOpts { globalLogLevel :: LogLevel -- ^ Log level , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'+ , globalResolver :: Maybe Resolver -- ^ Resolver override+ , globalTerminal :: Bool -- ^ We're in a terminal? } deriving (Show) -- | Load the configuration with a manager. Convenience function used@@ -532,5 +594,15 @@ lc <- runStackLoggingT manager globalLogLevel+ globalTerminal (loadConfig globalConfigMonoid) return (manager,lc)++-- | Project initialization+initCmd :: InitOpts -> GlobalOpts -> IO ()+initCmd initOpts go@GlobalOpts{..} = do+ (manager,lc) <- loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel globalTerminal $+ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ initProject globalResolver initOpts
src/main/Plugins.hs view
@@ -112,10 +112,20 @@ -- | Things that can go wrong when using `callPlugin`.+-- Note: it may be wiser to catch PluginExitFailure, rather than display it. data PluginException = PluginNotFound !Plugins !Text | PluginExitFailure !Plugin !Int- deriving (Show, Typeable)+ deriving (Typeable)+instance Show PluginException where+ show (PluginNotFound plugins requestedPlugin)+ = "Plugin not found for '" ++ unpack (_pluginsPrefix plugins)+ ++ "': '" ++ unpack requestedPlugin ++ "'"+ show (PluginExitFailure plugin exitCode)+ = "Plugin '" ++ unpack (_pluginName plugin)+ ++ "' for '" ++ unpack (_pluginPrefix plugin)+ ++ "' failed with exit code: "+ ++ show exitCode instance Exception PluginException -- | Look up a particular plugin by name.
+ src/test/Stack/ArgsSpec.hs view
@@ -0,0 +1,31 @@+-- | Args parser test suite.++module Stack.ArgsSpec where++import Control.Monad+import Options.Applicative.Args+import Test.Hspec++-- | Test spec.+spec :: Spec+spec =+ forM_+ tests+ (\(input,output) ->+ it input (parseArgsFromString input == output))++-- | Fairly comprehensive checks.+tests :: [(String, Either String [String])]+tests =+ [ ("x", Right ["x"])+ , ("x y z", Right ["x", "y", "z"])+ , ("aaa bbb ccc", Right ["aaa", "bbb", "ccc"])+ , (" aaa bbb ccc ", Right ["aaa", "bbb", "ccc"])+ , ("aaa\"", Left "unterminated string: endOfInput")+ , ("\"", Left "unterminated string: endOfInput")+ , ("\"\"", Right [""])+ , ("\"aaa", Left "unterminated string: endOfInput")+ , ("\"aaa\" bbb ccc \"ddd\"", Right ["aaa", "bbb", "ccc", "ddd"])+ , ("\"aa\\\"a\" bbb ccc \"ddd\"", Right ["aa\"a", "bbb", "ccc", "ddd"])+ , ("\"aa\\\"a\" bb\\b ccc \"ddd\"", Right ["aa\"a", "bb\\b", "ccc", "ddd"])+ , ("\"\" \"\" c", Right ["","","c"])]
src/test/Stack/BuildPlanSpec.hs view
@@ -39,8 +39,8 @@ spec :: Spec spec = beforeAll setup $ afterAll teardown $ do let logLevel = LevelDebug- let loadConfig' m = runStackLoggingT m logLevel (loadConfig mempty)- let loadBuildConfigRest m = runStackLoggingT m logLevel+ let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)+ let loadBuildConfigRest m = runStackLoggingT m logLevel False let inTempDir action = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do@@ -53,8 +53,8 @@ -- github still depends on failure. writeFile "stack.yaml" "resolver: lts-2.9" LoadConfig{..} <- loadConfig' manager- bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig ThrowException)- runStackT manager logLevel bconfig $ do+ bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing ThrowException)+ runStackT manager logLevel bconfig False $ do menv <- getMinimalEnvOverride mbp <- loadMiniBuildPlan $ LTS 2 9 eres <- try $ resolveBuildPlan
src/test/Stack/ConfigSpec.hs view
@@ -60,8 +60,8 @@ describe "loadConfig" $ do- let loadConfig' m = runStackLoggingT m logLevel (loadConfig mempty)- let loadBuildConfigRest m = runStackLoggingT m logLevel+ let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)+ let loadBuildConfigRest m = runStackLoggingT m logLevel False -- TODO(danburton): make sure parent dirs also don't have config file it "works even if no config file exists" $ \T{..} -> example $ do _config <- loadConfig' manager@@ -80,7 +80,7 @@ setCurrentDirectory childDir LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig ThrowException)+ (lcLoadBuildConfig Nothing ThrowException) bcRoot `shouldBe` parentDir it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do@@ -91,7 +91,7 @@ withEnvVar "STACK_YAML" stackYamlFp $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig ThrowException)+ (lcLoadBuildConfig Nothing ThrowException) bcRoot `shouldBe` dir it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do@@ -104,5 +104,5 @@ withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig ThrowException)+ (lcLoadBuildConfig Nothing ThrowException) bcStackYaml `shouldBe` yamlAbs
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.0.2.1+version: 0.0.3 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@@ -26,17 +26,22 @@ hs-source-dirs: src/ ghc-options: -Wall exposed-modules: Options.Applicative.Builder.Extra+ Options.Applicative.Args Stack.BuildPlan Stack.Config Stack.Constants Stack.Docker Stack.Docker.GlobalDB Stack.Fetch+ Stack.Exec Stack.GhcPkg+ Stack.Init+ Stack.New Stack.Package Stack.PackageDump Stack.PackageIndex Stack.Path+ Stack.Repl Stack.Setup Stack.Types Stack.Types.Internal@@ -57,7 +62,9 @@ Stack.Build.Source Stack.Build.Types Stack.Build.Doc+ Stack.Upload System.Process.Read+ System.Process.Log System.Process.Run Network.HTTP.Download.Verified other-modules: Network.HTTP.Download@@ -104,7 +111,7 @@ , mtl >= 2.1.3.1 , old-locale >= 1.0.0.6 , optparse-applicative- , path >= 0.5.0+ , path >= 0.5.1 , persistent >= 2.1.2 , persistent-sqlite >= 2.1.4 , persistent-template >= 2.1.1@@ -173,6 +180,7 @@ , Stack.BuildPlanSpec , Stack.ConfigSpec , Stack.PackageDumpSpec+ , Stack.ArgsSpec ghc-options: -Wall -threaded build-depends: base >=4.7 && <5 , hspec