diff --git a/.travis.yml b/.travis.yml index 89c5467e7e..68dd43d162 100644 --- a/.travis.yml +++ b/.travis.yml @@ -121,9 +121,15 @@ script: hlint test/ --cpp-simple ;; stack) + echo Build stack package first, so that it generates output to stdout. + echo Otherwise Travis thinks we stalled. + stack --no-terminal test --haddock --no-haddock-deps --ghc-options="$GHC_OPTIONS" stack + + echo Build the other, smaller subpackages. stack --no-terminal test --haddock --no-haddock-deps --ghc-options="$GHC_OPTIONS" ;; pedantic) + stack --system-ghc --no-terminal build --pedantic stack stack --system-ghc --no-terminal build --pedantic ;; cabal) diff --git a/package.yaml b/package.yaml index 76d0e085b8..a36ad8f3b4 100644 --- a/package.yaml +++ b/package.yaml @@ -46,7 +46,7 @@ dependencies: - bytestring - clock - conduit -- conduit-extra +- conduit-extra >= 1.2.3.1 - containers - cryptonite - cryptonite-conduit @@ -55,7 +55,6 @@ dependencies: - echo - exceptions - extra -- fast-logger - file-embed - filelock - filepath @@ -74,7 +73,7 @@ dependencies: - microlens - microlens-mtl - mintty -- monad-logger +- monad-logger # TODO remove dep when persistent drops monad-logger - mono-traversable - mtl - neat-interpolation @@ -108,6 +107,7 @@ dependencies: - time - tls - transformers +- typed-process >= 0.2.1.0 - unicode-transforms - unix-compat - unliftio @@ -130,7 +130,9 @@ when: - pid1 - unix library: - source-dirs: src/ + source-dirs: + - src/ + - subs/rio/src/ ghc-options: - -fwarn-identities exposed-modules: @@ -151,6 +153,9 @@ library: - Path.Extra - Path.Find - Paths_stack + - RIO + - RIO.Logger + - RIO.Process - Stack.Build - Stack.Build.Cache - Stack.Build.ConstructPlan @@ -173,7 +178,6 @@ library: - Stack.Docker - Stack.Docker.GlobalDB - Stack.Dot - - Stack.Exec - Stack.Fetch - Stack.FileWatch - Stack.GhcPkg @@ -241,6 +245,7 @@ library: - Stack.Types.FlagName - Stack.Types.GhcPkgId - Stack.Types.Image + - Stack.Types.NamedComponent - Stack.Types.Nix - Stack.Types.Package - Stack.Types.PackageDump @@ -256,13 +261,11 @@ library: - Stack.Upgrade - Stack.Upload - Text.PrettyPrint.Leijen.Extended - - System.Process.Log - System.Process.PagerEditor - - System.Process.Read - - System.Process.Run - System.Terminal other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient + - RIO.Prelude when: - condition: 'os(windows)' then: diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 3c9d925a40..c3e0e996c8 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -100,7 +100,7 @@ unWarningParser wp = do -- | Log JSON warnings. logJSONWarnings - :: MonadLogger m + :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) => FilePath -> [JSONWarning] -> m () logJSONWarnings fp = mapM_ (\w -> logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w))) diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs index f375a6e571..173dc149b5 100644 --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -37,7 +37,7 @@ versionedDecodeFile :: Data a => VersionConfig a -> Q Exp versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |] -- | Write to the given file. -storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a) +storeEncodeFile :: (Store a, MonadIO m, MonadReader env m, HasCallStack, HasLogFunc env, Eq a) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File @@ -55,7 +55,7 @@ storeEncodeFile pokeFunc peekFunc fp x = do -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the -- version tag. -versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m) +versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File @@ -75,7 +75,7 @@ versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do storeEncodeFile pokeFunc peekFunc fp x return x -versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m) +versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env) => Peek a -> Path loc File -> m (Maybe a) diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index 63781b1710..a80d774f78 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -47,10 +47,10 @@ import System.FilePath (takeDirectory, (<.>)) -- appropriate destination. -- -- Throws an exception if things go wrong -download :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +download :: HasRunner env => Request -> Path Abs File -- ^ destination - -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? + -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? download req destpath = do let downloadReq = DownloadRequest { drRequest = req @@ -64,10 +64,10 @@ download req destpath = do -- | Same as 'download', but will download a file a second time if it is already present. -- -- Returns 'True' if the file was downloaded, 'False' otherwise -redownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +redownload :: HasRunner env => Request -> Path Abs File -- ^ destination - -> m Bool + -> RIO env Bool redownload req0 dest = do logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0) let destFilePath = toFilePath dest diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index d23a2bddfd..d56bf4f9f2 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -143,7 +143,7 @@ displayCheckHexDigest (CheckHexDigestHeader h) = sinkCheckHash :: MonadThrow m => Request -> HashCheck - -> Consumer ByteString m () + -> ConduitM ByteString o m () sinkCheckHash req HashCheck{..} = do digest <- sinkHashUsing hashCheckAlgorithm let actualDigestString = show digest @@ -173,7 +173,7 @@ assertLengthSink req expectedStreamLength = ZipSink $ do throwM $ WrongStreamLength req expectedStreamLength actualStreamLength -- | A more explicitly type-guided sinkHash. -sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a) +sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a) sinkHashUsing _ = sinkHash -- | Turns a list of hash checks into a ZipSink that checks all of them. @@ -181,8 +181,7 @@ hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteStr hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req) -- 'Control.Retry.recovering' customized for HTTP failures -recoveringHttp :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) - => RetryPolicy -> m a -> m a +recoveringHttp :: forall env a. HasRunner env => RetryPolicy -> RIO env a -> RIO env a recoveringHttp retryPolicy = #if MIN_VERSION_retry(0,7,0) helper $ \run -> recovering retryPolicy (handlers run) . const @@ -190,15 +189,15 @@ recoveringHttp retryPolicy = helper $ \run -> recovering retryPolicy (handlers run) #endif where - helper :: (MonadUnliftIO m, HasRunner env, MonadReader env m) => (UnliftIO m -> IO a -> IO a) -> m a -> m a + helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action) - handlers :: (MonadLogger m, HasRunner env, MonadReader env m) => UnliftIO m -> [RetryStatus -> Handler IO Bool] - handlers run = [Handler . alwaysRetryHttp (unliftIO run),const $ Handler retrySomeIO] + handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool] + handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO] - alwaysRetryHttp :: (MonadLogger m', Monad m, HasRunner env, MonadReader env m') => (m' () -> m ()) -> RetryStatus -> HttpException -> m Bool - alwaysRetryHttp run rs _ = do - run $ + alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool + alwaysRetryHttp u rs _ = do + unliftIO u $ prettyWarn $ vcat [ flow $ unwords [ "Retry number" @@ -235,17 +234,18 @@ recoveringHttp retryPolicy = -- Throws VerifiedDownloadException. -- Throws IOExceptions related to file system operations. -- Throws HttpException. -verifiedDownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +verifiedDownload + :: HasRunner env => DownloadRequest -> Path Abs File -- ^ destination - -> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress - -> m Bool -- ^ Whether a download was performed + -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress + -> RIO env Bool -- ^ Whether a download was performed verifiedDownload DownloadRequest{..} destpath progressSink = do let req = drRequest whenM' (liftIO getShouldDownload) $ do logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req) liftIO $ createDirectoryIfMissing True dir - recoveringHttp drRetryPolicy $ liftIO $ + recoveringHttp drRetryPolicy $ withSinkFile fptmp $ httpSink req . go liftIO $ renameFile fptmp fp where @@ -274,7 +274,9 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do checkExpectations = withBinaryFile fp ReadMode $ \h -> do for_ drLengthCheck $ checkFileSizeExpectations h - sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks) + runConduit + $ sourceHandle h + .| getZipSink (hashChecksToZipSink drRequest drHashChecks) -- doesn't move the handle checkFileSizeExpectations h expectedFileSize = do @@ -310,7 +312,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do Nothing -> [] ) ++ drHashChecks - maybe id (\len -> (CB.isolate len =$=)) drLengthCheck + maybe id (\len -> (CB.isolate len .|)) drLengthCheck $ getZipSink ( hashChecksToZipSink drRequest hashChecks *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs index 5edb614e14..31c4718e08 100644 --- a/src/Network/HTTP/StackClient.hs +++ b/src/Network/HTTP/StackClient.hs @@ -15,16 +15,16 @@ module Network.HTTP.StackClient , withResponseByManager ) where -import Control.Monad.Catch (MonadMask) import Data.Aeson (FromJSON) import qualified Data.ByteString as Strict import Data.ByteString.Lazy (ByteString) -import Data.Conduit (ConduitM, Sink) +import Data.Conduit (ConduitM, transPipe) +import Data.Void (Void) import qualified Network.HTTP.Client import Network.HTTP.Client (BodyReader, Manager, Request, Response) import Network.HTTP.Simple (setRequestHeader) import qualified Network.HTTP.Simple -import UnliftIO (MonadIO) +import UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO) setUserAgent :: Request -> Request @@ -47,15 +47,22 @@ httpNoBody :: MonadIO m => Request -> m (Response ()) httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent -httpSink :: (MonadIO m, MonadMask m) => Request -> (Response () -> Sink Strict.ByteString m a) -> m a -httpSink = Network.HTTP.Simple.httpSink . setUserAgent +httpSink + :: MonadUnliftIO m + => Request + -> (Response () -> ConduitM Strict.ByteString Void m a) + -> m a +httpSink req inner = withUnliftIO $ \u -> + Network.HTTP.Simple.httpSink (setUserAgent req) (transPipe (unliftIO u) . inner) withResponse - :: (MonadIO m, MonadMask m, MonadIO n) + :: (MonadUnliftIO m, MonadIO n) => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a -withResponse = Network.HTTP.Simple.withResponse . setUserAgent +withResponse req inner = withRunInIO $ \run -> + Network.HTTP.Simple.withResponse (setUserAgent req) (run . inner) -withResponseByManager :: Request -> Manager -> (Response BodyReader -> IO a) -> IO a -withResponseByManager = Network.HTTP.Client.withResponse . setUserAgent +withResponseByManager :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m a) -> m a +withResponseByManager req man inner = withRunInIO $ \run -> + Network.HTTP.Client.withResponse (setUserAgent req) man (run . inner) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 1072f9fe40..0f17d8a4d9 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -14,7 +14,7 @@ module Stack.Build (build - ,withLoadPackage + ,loadPackage ,mkBaseConfigOpts ,queryBuildInfo ,splitObjsWarning @@ -42,13 +42,13 @@ import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target -import Stack.Fetch as Fetch import Stack.Package import Stack.PackageLocation (parseSingleCabalFileIndex) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -77,7 +77,6 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do bopts <- view buildOptsL let profiling = boptsLibProfile bopts || boptsExeProfile bopts let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) - menv <- getMinimalEnvOverride (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli @@ -95,7 +94,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap] (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- - getInstalled menv + getInstalled GetInstalledOpts { getInstalledProfiling = profiling , getInstalledHaddock = shouldHaddockDeps bopts @@ -103,8 +102,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do sourceMap baseConfigOpts <- mkBaseConfigOpts boptsCli - plan <- withLoadPackage $ \loadPackage -> - constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) + plan <- constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) allowLocals <- view $ configL.to configAllowLocals unless allowLocals $ case justLocals plan of @@ -130,7 +128,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do if boptsCLIDryrun boptsCli then printPlan plan - else executePlan menv boptsCli baseConfigOpts locals + else executePlan boptsCli baseConfigOpts locals globalDumpPkgs snapshotDumpPkgs localDumpPkgs @@ -172,7 +170,7 @@ instance Exception CabalVersionException -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten - :: MonadLogger m => [LocalPackage] -> Plan -> m () + :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env () warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do logDebug "Checking if we are going to build multiple executables with the same name" forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do @@ -239,7 +237,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do collect :: Ord k => [(k,v)] -> Map k (NonEmpty v) collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort -warnAboutSplitObjs :: MonadLogger m => BuildOpts -> m () +warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env () warnAboutSplitObjs bopts | boptsSplitObjs bopts = do logWarn $ "Building with --split-objs is enabled. " <> T.pack splitObjsWarning warnAboutSplitObjs _ = return () @@ -273,29 +271,25 @@ mkBaseConfigOpts boptsCli = do } -- | Provide a function for loading package information from the package index -withLoadPackage :: HasEnvConfig env - => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> RIO env a) - -> RIO env a -withLoadPackage inner = do - econfig <- view envConfigL - root <- view projectRootL - run <- askRunInIO - withCabalLoader $ \loadFromIndex -> - inner $ \loc flags ghcOptions -> run $ - resolvePackage - (depPackageConfig econfig flags ghcOptions) - <$> parseSingleCabalFileIndex loadFromIndex root loc - where - -- | Package config to be used for dependencies - depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig - depPackageConfig econfig flags ghcOptions = PackageConfig +loadPackage + :: HasEnvConfig env + => PackageLocationIndex FilePath + -> Map FlagName Bool + -> [Text] + -> RIO env Package +loadPackage loc flags ghcOptions = do + compiler <- view actualCompilerVersionL + platform <- view platformL + root <- view projectRootL + let pkgConfig = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags , packageConfigGhcOptions = ghcOptions - , packageConfigCompilerVersion = view actualCompilerVersionL econfig - , packageConfigPlatform = view platformL econfig + , packageConfigCompilerVersion = compiler + , packageConfigPlatform = platform } + resolvePackage pkgConfig <$> parseSingleCabalFileIndex root loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 16e2e6c098..d6c6c1003f 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -108,23 +108,23 @@ markExeNotInstalled loc ident = do liftIO $ ignoringAbsence (removeFile $ dir ident') -- | Try to read the dirtiness cache for the given package directory. -tryGetBuildCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env) - => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo)) +tryGetBuildCache :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir -- | Try to read the dirtiness cache for the given package directory. -tryGetConfigCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> m (Maybe ConfigCache) +tryGetConfigCache :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe ConfigCache) tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir -- | Try to read the mod time of the cabal file from the last build -tryGetCabalMod :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> m (Maybe ModTime) +tryGetCabalMod :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe ModTime) tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir -- | Write the dirtiness cache for this package's files. -writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> Map FilePath FileCacheInfo -> m () +writeBuildCache :: HasEnvConfig env + => Path Abs Dir -> Map FilePath FileCacheInfo -> RIO env () writeBuildCache dir times = do fp <- buildCacheFile dir $(versionedEncodeFile buildCacheVC) fp BuildCache @@ -132,19 +132,19 @@ writeBuildCache dir times = do } -- | Write the dirtiness cache for this package's configuration. -writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) +writeConfigCache :: HasEnvConfig env => Path Abs Dir -> ConfigCache - -> m () + -> RIO env () writeConfigCache dir x = do fp <- configCacheFile dir $(versionedEncodeFile configCacheVC) fp x -- | See 'tryGetCabalMod' -writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) +writeCabalMod :: HasEnvConfig env => Path Abs Dir -> ModTime - -> m () + -> RIO env () writeCabalMod dir x = do fp <- configCabalMod dir $(versionedEncodeFile modTimeVC) fp x @@ -172,42 +172,42 @@ flagCacheFile installed = do return $ dir rel -- | Loads the flag cache for the given installed extra-deps -tryGetFlagCache :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +tryGetFlagCache :: HasEnvConfig env => Installed - -> m (Maybe ConfigCache) + -> RIO env (Maybe ConfigCache) tryGetFlagCache gid = do fp <- flagCacheFile gid $(versionedDecodeFile configCacheVC) fp -writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m) +writeFlagCache :: HasEnvConfig env => Installed -> ConfigCache - -> m () + -> RIO env () writeFlagCache gid cache = do file <- flagCacheFile gid ensureDir (parent file) $(versionedEncodeFile configCacheVC) file cache -- | Mark a test suite as having succeeded -setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +setTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m () + -> RIO env () setTestSuccess dir = do fp <- testSuccessFile dir $(versionedEncodeFile testSuccessVC) fp True -- | Mark a test suite as not having succeeded -unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +unsetTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m () + -> RIO env () unsetTestSuccess dir = do fp <- testSuccessFile dir $(versionedEncodeFile testSuccessVC) fp False -- | Check if the test suite already passed -checkTestSuccess :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +checkTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m Bool + -> RIO env Bool checkTestSuccess dir = liftM (fromMaybe False) @@ -230,11 +230,11 @@ checkTestSuccess dir = -- -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory. -precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +precompiledCacheFile :: HasEnvConfig env => PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> m (Maybe (Path Abs File)) + -> RIO env (Maybe (Path Abs File)) precompiledCacheFile loc copts installedPackageIDs = do ec <- view envConfigL @@ -297,14 +297,14 @@ precompiledCacheFile loc copts installedPackageIDs = do | otherwise -> return longPath -- | Write out information about a newly built package -writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) +writePrecompiledCache :: HasEnvConfig env => BaseConfigOpts -> PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> Installed -- ^ library -> Set Text -- ^ executables - -> m () + -> RIO env () writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId exes = do mfile <- precompiledCacheFile loc copts depIDs forM_ mfile $ \file -> do diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 4a4b99404e..675dcae415 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -52,13 +52,14 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.IO (putStrLn) -import System.Process.Read (findExecutable) +import RIO.Process (findExecutable, HasEnvOverride (..)) data PackageInfo = @@ -127,7 +128,7 @@ type M = RWST -- TODO replace with more efficient WS stack on top of StackT data Ctx = Ctx { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) + , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> M Package) , combinedMap :: !CombinedMap , toolToPackages :: !(ExeName -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig @@ -145,6 +146,10 @@ instance HasLogFunc Ctx where instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasCabalLoader Ctx where + cabalLoaderL = configL.cabalLoaderL +instance HasEnvOverride Ctx where + envOverrideL = configL.envOverrideL instance HasBuildConfig Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -171,14 +176,13 @@ constructPlan :: forall env. HasEnvConfig env -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package + -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool -> RIO env Plan constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do logDebug "Constructing the build plan" - u <- askUnliftIO econfig <- view envConfigL let onWanted = void . addDep False . packageName . lpPackage @@ -186,7 +190,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 lp <- getLocalPackages - let ctx = mkCtx econfig (unliftIO u . getPackageVersions) lp + let ctx = mkCtx econfig lp ((), m, W efinals installExes dirtyReason deps warnings parents) <- liftIO $ runRWST inner ctx M.empty mapM_ logWarn (warnings []) @@ -221,10 +225,10 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage prettyErrorNoIndent $ pprintExceptions errs stackYaml parents (wanted ctx) throwM $ ConstructPlanFailed "Plan construction failed." where - mkCtx econfig getVersions0 lp = Ctx + mkCtx econfig lp = Ctx { ls = ls0 , baseConfigOpts = baseConfigOpts0 - , loadPackage = loadPackage0 + , loadPackage = \x y z -> runRIO econfig $ loadPackage0 x y z , combinedMap = combineMap sourceMap installedMap , toolToPackages = \name -> maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $ @@ -232,7 +236,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = getVersions0 + , getVersions = runRIO econfig . getPackageVersions , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } @@ -433,7 +437,7 @@ tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map F tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- liftIO $ loadPackage ctx (PLIndex pir) flags [] + p <- loadPackage ctx (PLIndex pir) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -470,7 +474,7 @@ installPackage treatAsDep name ps minstalled = do case ps of PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- liftIO $ loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + package <- loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! resolveDepsAndInstall True treatAsDep ps package minstalled PSFiles lp _ -> case lpTestBench lp of @@ -844,8 +848,9 @@ packageDepsWithTools p = do map (\dep -> toEither dep (toolToPackages ctx dep)) (Map.keys (packageTools p)) -- Check whether the tool is on the PATH before warning about it. warnings <- fmap catMaybes $ forM warnings0 $ \warning@(ToolWarning (ExeName toolName) _ _) -> do + let settings = minimalEnvSettings { esIncludeLocals = True } config <- view configL - menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True } + menv <- liftIO $ configEnvOverrideSettings config settings mfound <- findExecutable menv $ T.unpack toolName case mfound of Nothing -> return (Just warning) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index c67b9d19a9..f0c5302840 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -35,6 +35,11 @@ import Data.Char (isSpace) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed + (ExitCodeException (..), waitExitCode, + useHandleOpen, setStdin, setStdout, setStderr, getStdin, + createPipe, runProcess_, getStdout, + getStderr, createSource) import qualified Data.Conduit.Text as CT import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.IORef.RunOnce (runOnce) @@ -42,7 +47,6 @@ import Data.List hiding (any) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Data.Streaming.Process hiding (callProcess, env) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (getCurrentTime) @@ -52,7 +56,6 @@ import qualified Distribution.Simple.Build.Macros as C import Distribution.System (OS (Windows), Platform (Platform)) import qualified Distribution.Text as C -import Language.Haskell.TH as TH (location) import Path import Path.CheckInstall import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) @@ -75,6 +78,7 @@ import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -82,17 +86,11 @@ import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath) -import System.Exit (ExitCode (ExitSuccess)) +import System.Exit (ExitCode (..)) import qualified System.FilePath as FP import System.IO (hPutStr, stderr, stdout) import System.PosixCompat.Files (createLink) -import System.Process.Log (showProcessArgDebug, withProcessTimeLog) -import System.Process.Read -import System.Process.Run - -#if !MIN_VERSION_process(1,2,1) -import System.Process.Internals (createProcess_) -#endif +import RIO.Process -- | Has an executable been built or not? data ExecutableBuildStatus @@ -192,8 +190,7 @@ displayTask task = T.pack $ concat missing = tcoMissing $ taskConfigOpts task data ExecuteEnv = ExecuteEnv - { eeEnvOverride :: !EnvOverride - , eeConfigureLock :: !(MVar ()) + { eeConfigureLock :: !(MVar ()) , eeInstallLock :: !(MVar ()) , eeBuildOpts :: !BuildOpts , eeBuildOptsCLI :: !BuildOptsCLI @@ -280,7 +277,7 @@ getSetupExe setupHs setupShimHs tmpdir = do jsExeNameS = baseNameS ++ ".jsexe" setupDir = - configStackRoot config + view stackRootL config $(mkRelDir "setup-exe-cache") platformDir @@ -296,7 +293,6 @@ getSetupExe setupHs setupShimHs tmpdir = do tmpOutputPath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ outputNameS tmpJsExePath <- fmap (setupDir ) $ parseRelDir $ "tmp-" ++ jsExeNameS ensureDir setupDir - menv <- getMinimalEnvOverride let args = buildSetupArgs ++ [ "-package" , "Cabal-" ++ cabalVersionString @@ -306,18 +302,19 @@ getSetupExe setupHs setupShimHs tmpdir = do , toFilePath tmpOutputPath ] ++ ["-build-runner" | wc == Ghcjs] - callProcess' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) - `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + withWorkingDir tmpdir (withProc (compilerExeName wc) args $ \pc0 -> do + let pc = setStdout (useHandleOpen stderr) pc0 + runProcess_ pc) + `catch` \ece -> do compilerPath <- getCompilerPath wc - throwM $ SetupHsBuildFailure ec Nothing compilerPath args Nothing [] + throwM $ SetupHsBuildFailure (eceExitCode ece) Nothing compilerPath args Nothing [] when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath renameFile tmpExePath exePath return $ Just exePath -- | Execute a function that takes an 'ExecuteEnv'. withExecuteEnv :: forall env a. HasEnvConfig env - => EnvOverride - -> BuildOpts + => BuildOpts -> BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] @@ -326,7 +323,7 @@ withExecuteEnv :: forall env a. HasEnvConfig env -> [DumpPackage () () ()] -- ^ local packages -> (ExecuteEnv -> RIO env a) -> RIO env a -withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = +withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = withSystemTempDir stackProgName $ \tmpdir -> do configLock <- liftIO $ newMVar () installLock <- liftIO $ newMVar () @@ -339,7 +336,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot -- Create files for simple setup and setup shim, if necessary let setupSrcDir = - configStackRoot config + view stackRootL config $(mkRelDir "setup-exe-src") ensureDir setupSrcDir setupFileName <- parseRelFile ("setup-" ++ simpleSetupHash ++ ".hs") @@ -353,15 +350,14 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot setupExe <- getSetupExe setupHs setupShimHs tmpdir cabalPkgVer <- view cabalVersionL - globalDB <- getGlobalDB menv =<< view (actualCompilerVersionL.whichCompilerL) + globalDB <- getGlobalDB =<< view (actualCompilerVersionL.whichCompilerL) snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages) localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) logFilesTChan <- liftIO $ atomically newTChan let totalWanted = length $ filter lpWanted locals env <- ask inner ExecuteEnv - { eeEnvOverride = menv - , eeBuildOpts = bopts + { eeBuildOpts = bopts , eeBuildOptsCLI = boptsCli -- Uncertain as to why we cannot run configures in parallel. This appears -- to be a Cabal library bug. Original issue: @@ -429,12 +425,13 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env () dumpLogIfWarning (pkgDir, filepath) = do firstWarning <- withSourceFile (toFilePath filepath) $ \src -> - src - $$ CT.decodeUtf8Lenient - =$ CT.lines - =$ CL.map stripCR - =$ CL.filter isWarning - =$ CL.take 1 + runConduit + $ src + .| CT.decodeUtf8Lenient + .| CT.lines + .| CL.map stripCR + .| CL.filter isWarning + .| CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) isWarning :: Text -> Bool @@ -446,10 +443,11 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] compilerVer <- view actualCompilerVersionL withSourceFile (toFilePath filepath) $ \src -> - src - $$ CT.decodeUtf8Lenient - =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer - =$ CL.mapM_ logInfo + runConduit + $ src + .| CT.decodeUtf8Lenient + .| mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer + .| CL.mapM_ logInfo logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" stripColors :: Path Abs File -> IO () @@ -476,8 +474,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot -- | Perform the actual plan executePlan :: HasEnvConfig env - => EnvOverride - -> BuildOptsCLI + => BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] -> [DumpPackage () () ()] -- ^ global packages @@ -487,24 +484,24 @@ executePlan :: HasEnvConfig env -> Map PackageName Target -> Plan -> RIO env () -executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do +executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do logDebug "Executing the build plan" bopts <- view buildOptsL - withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) + withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) copyExecutables (planInstallExes plan) config <- view configL - menv' <- liftIO $ configEnvOverride config EnvSettings + menv' <- liftIO $ configEnvOverrideSettings config EnvSettings { esIncludeLocals = True , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False , esKeepGhcRts = False } - forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> - withProcessTimeLog cmd args $ - callProcess (Cmd Nothing cmd menv' args) + withEnvOverride menv' $ + forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> + withProc cmd args runProcess_ copyExecutables :: HasEnvConfig env @@ -609,7 +606,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do , ")" ] ] - unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident + unregisterGhcPkgId wc cv localDB id' ident liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) @@ -652,9 +649,9 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (boptsHaddock eeBuildOpts) $ do snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs) localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs) - generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals - generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals - generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs + generateLocalHaddockIndex wc eeBaseConfigOpts localDumpPkgs eeLocals + generateDepsHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals + generateSnapHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs when (boptsOpenHaddocks eeBuildOpts) $ do let planPkgs, localPkgs, installedPkgs, availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation) @@ -690,7 +687,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = { actionId = ActionId taskProvides ATBuild , actionDeps = Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False + , actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap False , actionConcurrency = ConcurrencyAllowed } ] @@ -703,7 +700,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = { actionId = ActionId taskProvides ATBuildFinal , actionDeps = addBuild (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True + , actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap True , actionConcurrency = ConcurrencyAllowed }) $ -- These are the "final" actions - running tests and benchmarks. @@ -712,7 +709,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = { actionId = ActionId taskProvides ATRunTests , actionDeps = finalDeps , actionDo = \ac -> withLock mtestLock $ runInBase $ do - singleTest runInBase topts (Set.toList tests) ac ee task installedMap + singleTest topts (Set.toList tests) ac ee task installedMap -- Always allow tests tasks to run concurrently with -- other tasks, particularly build tasks. Note that -- 'mtestLock' can optionally make it so that only @@ -724,7 +721,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = { actionId = ActionId taskProvides ATRunBenchmarks , actionDeps = finalDeps , actionDo = \ac -> runInBase $ do - singleBench runInBase beopts (Set.toList benches) ac ee task installedMap + singleBench beopts (Set.toList benches) ac ee task installedMap -- Never run benchmarks concurrently with any other task, see #3663 , actionConcurrency = ConcurrencyDisallowed }) @@ -837,7 +834,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce - menv <- getMinimalEnvOverride + menv <- view envOverrideL let programNames = if eeCabalPkgVer < $(mkVersion "1.22") then ["ghc", "ghc-pkg"] @@ -868,11 +865,10 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = exists <- doesFileExist fp unless exists $ do logInfo $ "Trying to generate configure with autoreconf in " <> T.pack (toFilePath pkgDir) - menv <- getMinimalEnvOverride - readProcessNull (Just pkgDir) menv "autoreconf" ["-i"] `catchAny` \ex -> + withWorkingDir pkgDir $ readProcessNull "autoreconf" ["-i"] `catchAny` \ex -> logWarn $ "Unable to run autoreconf: " <> T.pack (show ex) -announceTask :: MonadLogger m => Task -> Text -> m () +announceTask :: HasLogFunc env => Task -> Text -> RIO env () announceTask task x = logInfo $ T.concat [ T.pack $ packageIdentifierString $ taskProvides task , ": " @@ -891,8 +887,7 @@ announceTask task x = logInfo $ T.concat -- -- * Provides the user a function with which run the Cabal process. withSingleContext :: forall env a. HasEnvConfig env - => (RIO env () -> IO ()) - -> ActionContext + => ActionContext -> ExecuteEnv -> Task -> Maybe (Map PackageIdentifier GhcPkgId) @@ -910,7 +905,7 @@ withSingleContext :: forall env a. HasEnvConfig env -> Maybe (Path Abs File, Handle) -- Log file -> RIO env a) -> RIO env a -withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = +withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile pkgDir package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal -> @@ -983,7 +978,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md , esLocaleUtf8 = True , esKeepGhcRts = False } - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configEnvOverrideSettings config envSettings distRelativeDir' <- distRelativeDir esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build @@ -1112,7 +1107,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md runExe :: Path Abs File -> [String] -> RIO env () runExe exeName fullArgs = do compilerVer <- view actualCompilerVersionL - runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + runAndOutput compilerVer `catch` \ece -> do bss <- case mlogFile of Nothing -> return [] @@ -1125,7 +1120,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md .| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer .| CL.consume throwM $ SetupHsBuildFailure - ec + (eceExitCode ece) (Just taskProvides) exeName fullArgs @@ -1133,22 +1128,27 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md bss where runAndOutput :: CompilerVersion 'CVActual -> RIO env () - runAndOutput compilerVer = case mlogFile of + runAndOutput compilerVer = withWorkingDir pkgDir $ withEnvOverride menv $ case mlogFile of Just (_, h) -> - sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h + withProc (toFilePath exeName) fullArgs + $ runProcess_ + . setStdin closed + . setStdout (useHandleOpen h) + . setStderr (useHandleOpen h) Nothing -> - void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs + void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs (outputSink KeepTHLoading LevelWarn compilerVer) (outputSink stripTHLoading LevelInfo compilerVer) outputSink - :: ExcludeTHLoading + :: HasCallStack + => ExcludeTHLoading -> LogLevel -> CompilerVersion 'CVActual - -> Sink S.ByteString IO () + -> ConduitM S.ByteString Void (RIO env) () outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient - =$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer - =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level) + .| mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer + .| CL.mapM_ (logGeneric "" level) -- If users want control, we should add a config option for this makeAbsolute :: ConvertPathsToAbsolute makeAbsolute = case stripTHLoading of @@ -1210,14 +1210,13 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md -- with @copy@, and not the copying done by @stack install@ - that is -- handled by 'copyExecutables'. singleBuild :: forall env. (HasEnvConfig env, HasRunner env) - => (RIO env () -> IO ()) - -> ActionContext + => ActionContext -> ExecuteEnv -> Task -> InstalledMap -> Bool -- ^ Is this a final build? -> RIO env () -singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do +singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks mprecompiled <- getPrecompiled cache minstalled <- @@ -1296,36 +1295,33 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in wc <- view $ actualCompilerVersionL.whichCompilerL announceTask task "using precompiled package" forM_ mlib $ \libpath -> do - menv <- getMinimalEnvOverride withMVar eeInstallLock $ \() -> do -- We want to ignore the global and user databases. -- Unfortunately, ghc-pkg doesn't take such arguments on the -- command line. Instead, we'll set GHC_PACKAGE_PATH. See: -- https://github.com/commercialhaskell/stack/issues/1146 - menv' <- modifyEnvOverride menv - $ Map.insert - (ghcPkgPathEnvVar wc) - (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) - - -- In case a build of the library with different flags already exists, unregister it - -- before copying. - let ghcPkgExe = ghcPkgExeName wc - catch - (readProcessNull Nothing menv' ghcPkgExe - [ "unregister" - , "--force" - , packageIdentifierString taskProvides - ]) - (\ex -> case ex of - ProcessFailed{} -> return () - _ -> throwM ex) - - readProcessNull Nothing menv' ghcPkgExe - [ "register" - , "--force" - , libpath - ] + let modifyEnv = Map.insert + (ghcPkgPathEnvVar wc) + (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) + + withModifyEnvOverride modifyEnv $ do + -- In case a build of the library with different flags already exists, unregister it + -- before copying. + let ghcPkgExe = ghcPkgExeName wc + catchAny + (readProcessNull ghcPkgExe + [ "unregister" + , "--force" + , packageIdentifierString taskProvides + ]) + (const (return ())) + + readProcessNull ghcPkgExe + [ "register" + , "--force" + , libpath + ] liftIO $ forM_ exes $ \exe -> do D.createDirectoryIfMissing True bindir let dst = bindir FP. FP.takeFileName exe @@ -1340,7 +1336,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in case mlib of Nothing -> return $ Just $ Executable taskProvides Just _ -> do - mpkgid <- loadInstalledPkg eeEnvOverride wc pkgDbs eeSnapshotDumpPkgs pname + mpkgid <- loadInstalledPkg wc pkgDbs eeSnapshotDumpPkgs pname return $ Just $ case mpkgid of @@ -1349,7 +1345,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in where bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix - realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing + realConfigAndBuild cache allDepsMap = withSingleContext ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do executableBuildStatuses <- getExecutableBuildStatuses package pkgDir when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) @@ -1449,14 +1445,22 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in announce "haddock" sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do -- See #2429 for why the temp dir is used - hyped <- tryProcessStdout (Just eeTempDir) eeEnvOverride "haddock" ["--hyperlinked-source"] - case hyped of + ec + <- withWorkingDir eeTempDir + $ withProc "haddock" ["--hyperlinked-source"] + $ \pc -> withProcess + (setStdout createSource $ setStderr createSource pc) $ \p -> + runConcurrently + $ Concurrently (runConduit $ getStdout p .| CL.sinkNull) + *> Concurrently (runConduit $ getStderr p .| CL.sinkNull) + *> Concurrently (waitExitCode p) + case ec of -- Fancy crosslinked source - Right _ -> do - return ["--haddock-option=--hyperlinked-source"] + ExitSuccess -> return ["--haddock-option=--hyperlinked-source"] -- Older hscolour colouring - Left _ -> do - hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" + ExitFailure _ -> do + menv <- view envOverrideL + hscolourExists <- doesExecutableExist menv "HsColour" unless hscolourExists $ logWarn ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") @@ -1494,7 +1498,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in let ident = PackageIdentifier (packageName package) (packageVersion package) mpkgid <- case packageLibraries package of HasLibraries _ -> do - mpkgid <- loadInstalledPkg eeEnvOverride wc [installedPkgDb] installedDumpPkgsTVar (packageName package) + mpkgid <- loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar (packageName package) case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package Just pkgid -> return $ Library ident pkgid Nothing @@ -1523,8 +1527,8 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in return mpkgid - loadInstalledPkg menv wc pkgDbs tvar name = do - dps <- ghcPkgDescribe name menv wc pkgDbs $ conduitDumpPackage =$ CL.consume + loadInstalledPkg wc pkgDbs tvar name = do + dps <- ghcPkgDescribe name wc pkgDbs $ conduitDumpPackage .| CL.consume case dps of [] -> return Nothing [dp] -> do @@ -1551,12 +1555,12 @@ getExecutableBuildStatuses package pkgDir = do -- | Check whether the given executable is defined in the given dist directory. checkExeStatus - :: (MonadLogger m, MonadIO m, MonadThrow m) + :: HasLogFunc env => WhichCompiler -> Platform -> Path b Dir -> Text - -> m (Text, ExecutableBuildStatus) + -> RIO env (Text, ExecutableBuildStatus) checkExeStatus compiler platform distDir name = do exename <- parseRelDir (T.unpack name) exists <- checkPath (distDir $(mkRelDir "build") exename) @@ -1610,19 +1614,18 @@ depsPresent installedMap deps = all -- | Implements running a package's tests. Also handles producing -- coverage reports if coverage is enabled. singleTest :: HasEnvConfig env - => (RIO env () -> IO ()) - -> TestOpts + => TestOpts -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> RIO env () -singleTest runInBase topts testsToRun ac ee task installedMap = do +singleTest topts testsToRun ac ee task installedMap = do -- FIXME: Since this doesn't use cabal, we should be able to avoid using a -- fullblown 'withSingleContext'. (allDepsMap, _cache) <- getConfigCache ee task installedMap True False - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do + withSingleContext ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do config <- view configL let needHpc = toCoverage topts @@ -1668,14 +1671,14 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do tixPath <- liftM (pkgDir ) $ parseRelFile $ exeName ++ ".tix" exePath <- liftM (buildDir ) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName exists <- doesFileExist exePath - menv <- liftIO $ configEnvOverride config EnvSettings + menv <- liftIO $ configEnvOverrideSettings config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False , esKeepGhcRts = False } - if exists + withEnvOverride menv $ if exists then do -- We clear out the .tix files before doing a run. when needHpc $ do @@ -1697,22 +1700,23 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do liftIO $ hFlush stdout liftIO $ hFlush stderr - let output = + let output setter = case mlogFile of - Nothing -> Inherit - Just (_, h) -> UseHandle h - - -- Use createProcess_ to avoid the log file being closed afterwards - (Just inH, Nothing, Nothing, ph) <- createProcess' - stestName - (\cp -> cp { std_in = CreatePipe, std_out = output, std_err = output }) - (Cmd (Just pkgDir) (toFilePath exePath) menv args) - when isTestTypeLib $ do - logPath <- buildLogPath package (Just stestName) - ensureDir (parent logPath) - liftIO $ hPutStr inH $ show (logPath, testName) - liftIO $ hClose inH - ec <- liftIO $ waitForProcess ph + Nothing -> id + Just (_, h) -> setter (useHandleOpen h) + + ec <- withWorkingDir pkgDir $ + withProc (toFilePath exePath) args $ \pc0 -> do + let pc = setStdin createPipe + $ output setStdout + $ output setStderr + pc0 + withProcess pc $ \p -> do + when isTestTypeLib $ do + logPath <- buildLogPath package (Just stestName) + ensureDir (parent logPath) + liftIO $ hPutStr (getStdin p) $ show (logPath, testName) + waitExitCode p -- Add a trailing newline, incase the test -- output didn't finish with a newline. when (isNothing mlogFile) (logInfo "") @@ -1760,17 +1764,16 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do -- | Implements running a package's benchmarks. singleBench :: HasEnvConfig env - => (RIO env () -> IO ()) - -> BenchmarkOpts + => BenchmarkOpts -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> RIO env () -singleBench runInBase beopts benchesToRun ac ee task installedMap = do +singleBench beopts benchesToRun ac ee task installedMap = do (allDepsMap, _cache) <- getConfigCache ee task installedMap False True - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do + withSingleContext ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do let args = map T.unpack benchesToRun <> maybe [] ((:[]) . ("--benchmark-options=" <>)) (beoAdditionalArgs beopts) @@ -1799,10 +1802,10 @@ mungeBuildOutput :: forall m. MonadIO m -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines - =$ CL.map stripCR - =$ CL.filter (not . isTHLoading) - =$ filterLinkerWarnings - =$ toAbsolute + .| CL.map stripCR + .| CL.filter (not . isTHLoading) + .| filterLinkerWarnings + .| toAbsolute where -- | Is this line a Template Haskell "Loading package" line -- ByteString diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index ce183a70c9..33fc95ea0c 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -39,7 +39,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import qualified System.FilePath as FP -import System.Process.Read +import RIO.Process import Web.Browser (openBrowser) openHaddocksInBrowser @@ -104,14 +104,13 @@ shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local package dump -> [LocalPackage] - -> m () -generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do + -> RIO env () +generateLocalHaddockIndex wc bco localDumpPkgs locals = do let dumpPackages = mapMaybe (\LocalPackage{lpPackage = Package{..}} -> @@ -121,7 +120,6 @@ generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do locals generateHaddockIndex "local packages" - envOverride wc bco dumpPackages @@ -130,21 +128,19 @@ generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global dump information -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot dump information -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local dump information -> [LocalPackage] - -> m () -generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do + -> RIO env () +generateDepsHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals depDocDir = localDepsDocDir bco generateHaddockIndex "local packages and dependencies" - envOverride wc bco deps @@ -175,17 +171,15 @@ generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs loca -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global package dump -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot package dump - -> m () -generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = + -> RIO env () +generateSnapHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex "snapshot packages" - envOverride wc bco (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) @@ -194,16 +188,15 @@ generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) + :: HasEnvOverride env => Text - -> EnvOverride -> WhichCompiler -> BaseConfigOpts -> [DumpPackage () () ()] -> FilePath -> Path Abs Dir - -> m () -generateHaddockIndex descr envOverride wc bco dumpPackages docRelFP destDir = do + -> RIO env () +generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do @@ -220,9 +213,7 @@ generateHaddockIndex descr envOverride wc bco dumpPackages docRelFP destDir = do (T.concat ["Updating Haddock index for ", descr, " in\n", T.pack (toFilePath destIndexFile)]) liftIO (mapM_ copyPkgDocs interfaceOpts) - readProcessNull - (Just destDir) - envOverride + withWorkingDir destDir $ readProcessNull (haddockExeName wc) (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep) [bcoSnapDB bco, bcoLocalDB bco] ++ diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 38818df85a..1656f4412d 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -33,7 +33,6 @@ import Stack.Types.PackageDump import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read (EnvOverride) -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts @@ -47,8 +46,7 @@ data GetInstalledOpts = GetInstalledOpts -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: HasEnvConfig env - => EnvOverride - -> GetInstalledOpts + => GetInstalledOpts -> Map PackageName PackageSource -- ^ does not contain any installed information -> RIO env ( InstalledMap @@ -56,7 +54,7 @@ getInstalled :: HasEnvConfig env , [DumpPackage () () ()] -- snapshot installed , [DumpPackage () () ()] -- locally installed ) -getInstalled menv opts sourceMap = do +getInstalled opts sourceMap = do logDebug "Finding out which packages are already installed" snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal @@ -67,7 +65,7 @@ getInstalled menv opts sourceMap = do then configInstalledCache >>= liftM Just . loadInstalledCache else return Nothing - let loadDatabase' = loadDatabase menv opts mcache sourceMap + let loadDatabase' = loadDatabase opts mcache sourceMap (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing [] (installedLibs1, _extraInstalled) <- @@ -118,17 +116,16 @@ getInstalled menv opts sourceMap = do -- that it has profiling if necessary, and that it matches the version and -- location needed by the SourceMap loadDatabase :: HasEnvConfig env - => EnvOverride - -> GetInstalledOpts + => GetInstalledOpts -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required -> Map PackageName PackageSource -- ^ to determine which installed things we should include -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases -> RIO env ([LoadHelper], [DumpPackage () () ()]) -loadDatabase menv opts mcache sourceMap mdb lhs0 = do +loadDatabase opts mcache sourceMap mdb lhs0 = do wc <- view $ actualCompilerVersionL.to whichCompiler - (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) - $ conduitDumpPackage =$ sink + (lhs1', dps) <- ghcPkgDump wc (fmap snd (maybeToList mdb)) + $ conduitDumpPackage .| sink let ghcjsHack = wc == Ghcjs && isNothing mdb lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1' let lhs = pruneDeps @@ -159,19 +156,19 @@ loadDatabase menv opts mcache sourceMap mdb lhs0 = do _ -> CL.map (\dp -> dp { dpSymbols = False }) mloc = fmap fst mdb sinkDP = conduitProfilingCache - =$ conduitHaddockCache - =$ conduitSymbolsCache - =$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) - =$ CL.consume + .| conduitHaddockCache + .| conduitSymbolsCache + .| CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) + .| CL.consume sink = getZipSink $ (,) <$> ZipSink sinkDP <*> ZipSink CL.consume -processLoadResult :: MonadLogger m +processLoadResult :: HasLogFunc env => Maybe (InstalledPackageLocation, Path Abs Dir) -> Bool -> (Allowed, LoadHelper) - -> m (Maybe LoadHelper) + -> RIO env (Maybe LoadHelper) processLoadResult _ _ (Allowed, lh) = return (Just lh) processLoadResult _ True (WrongVersion actual wanted, lh) -- Allow some packages in the ghcjs global DB to have the wrong diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index d659ca91da..36f2b0a981 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -37,6 +37,7 @@ import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageName import qualified System.Directory as D diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index e591f1e119..2848be76d8 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -79,11 +79,11 @@ import Path import Path.Extra (rejectMissingDir) import Path.IO import Stack.Config (getLocalPackages) -import Stack.Fetch (withCabalLoader) import Stack.PackageIndex import Stack.PackageLocation import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version @@ -413,9 +413,9 @@ data PackageType = ProjectPackage | Dependency deriving (Eq, Show) combineResolveResults - :: forall m. MonadLogger m + :: forall env. HasLogFunc env => [ResolveResult] - -> m ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) + -> RIO env ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) combineResolveResults results = do addedDeps <- fmap Map.unions $ forM results $ \result -> case rrAddedDep result of @@ -509,9 +509,9 @@ parseTargets needTargets boptscli = do drops = Set.empty -- not supported to add drops - (globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do + (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseSingleCabalFileIndex loadFromIndex root loc + gpd <- parseSingleCabalFileIndex root loc return (name, (gpd, loc, Nothing)) -- Calculate a list of all of the locals, based on the project @@ -532,7 +532,7 @@ parseTargets needTargets boptscli = do ] calculatePackagePromotion - loadFromIndex root ls0 (Map.elems allLocals) + root ls0 (Map.elems allLocals) flags hides options drops let ls = LoadedSnapshot diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 3a001930c7..0191745325 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -48,6 +48,7 @@ import Stack.Package import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index ccf6784b6b..02c2bed826 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -61,7 +61,7 @@ import Distribution.System (OS (..), Platform (..), buildPlatform, Arc import qualified Distribution.Text import Distribution.Version (simplifyVersionRange, mkVersion') import GHC.Conc (getNumProcessors) -import Lens.Micro (lens) +import Lens.Micro (lens, set) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.StackClient (httpJSON) import Network.HTTP.Simple (getResponseBody) @@ -76,9 +76,9 @@ import Stack.Config.Docker import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants -import Stack.Fetch import qualified Stack.Image as Image import Stack.PackageLocation +import Stack.PackageIndex (CabalLoader (..), HasCabalLoader (..)) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -95,17 +95,17 @@ import Stack.Types.Version import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) -import System.Process.Read +import RIO.Process -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. tryDeprecatedPath - :: (MonadIO m, MonadLogger m) + :: HasLogFunc env => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed) - -> (Path Abs a -> m Bool) -- ^ Test for existence + -> (Path Abs a -> RIO env Bool) -- ^ Test for existence -> Path Abs a -- ^ New path -> Path Abs a -- ^ Deprecated path - -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) + -> RIO env (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) tryDeprecatedPath mWarningDesc exists new old = do newExists <- exists new if newExists @@ -130,8 +130,8 @@ tryDeprecatedPath mWarningDesc exists new old = do -- If the directory already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getImplicitGlobalProjectDir - :: (MonadIO m, MonadLogger m) - => Config -> m (Path Abs Dir) + :: HasLogFunc env + => Config -> RIO env (Path Abs Dir) getImplicitGlobalProjectDir config = --TEST no warning printed liftM fst $ tryDeprecatedPath @@ -140,7 +140,7 @@ getImplicitGlobalProjectDir config = (implicitGlobalProjectDir stackRoot) (implicitGlobalProjectDirDeprecated stackRoot) where - stackRoot = configStackRoot config + stackRoot = view stackRootL config -- | This is slightly more expensive than @'asks' ('bcStackYaml' '.' 'getBuildConfig')@ -- and should only be used when no 'BuildConfig' is at hand. @@ -206,11 +206,11 @@ getLatestResolver = do -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) configNoLocalConfig - :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) + :: HasRunner env => Path Abs Dir -- ^ stack root -> Maybe AbstractResolver -> ConfigMonoid - -> m Config + -> RIO env Config configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig configNoLocalConfig stackRoot (Just resolver) configMonoid = do userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver @@ -224,16 +224,16 @@ configNoLocalConfig stackRoot (Just resolver) configMonoid = do -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) + :: HasRunner env => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Bool -- ^ allow locals? -> Maybe AbstractResolver -> Maybe (Project, Path Abs File) -> ConfigMonoid - -> m Config + -> RIO env Config configFromConfigMonoid - configStackRoot configUserConfigPath configAllowLocals mresolver + clStackRoot configUserConfigPath configAllowLocals mresolver mproject ConfigMonoid{..} = do -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" @@ -246,9 +246,9 @@ configFromConfigMonoid logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration" return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url } _ -> return (urlsFromMonoid configMonoidUrls) - let configConnectionCount = fromFirst 8 configMonoidConnectionCount + let clConnectionCount = fromFirst 8 configMonoidConnectionCount configHideTHLoading = fromFirst True configMonoidHideTHLoading - configPackageIndices = fromFirst + clIndices = fromFirst [PackageIndex { indexName = IndexName "Hackage" , indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/" @@ -305,7 +305,7 @@ configFromConfigMonoid let configBuild = buildOptsFromMonoid configMonoidBuildOpts configDocker <- - dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts + dockerOptsFromMonoid (fmap fst mproject) clStackRoot mresolver configMonoidDockerOpts configNix <- nixOptsFromMonoid configMonoidNixOpts os configSystemGHC <- @@ -324,11 +324,11 @@ configFromConfigMonoid rawEnv <- liftIO getEnvironment pathsEnv <- augmentPathMap configMonoidExtraPath (Map.fromList (map (T.pack *** T.pack) rawEnv)) - origEnv <- mkEnvOverride configPlatform pathsEnv - let configEnvOverride _ = return origEnv + origEnv <- mkEnvOverride pathsEnv + let configEnvOverrideSettings _ = return origEnv configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of - Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv + Nothing -> getDefaultLocalProgramsBase clStackRoot configPlatform origEnv Just path -> return path platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant) let configLocalPrograms = configLocalProgramsBase platformOnlyDir @@ -370,18 +370,22 @@ configFromConfigMonoid configDefaultTemplate = getFirst configMonoidDefaultTemplate configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds - configIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch + clIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of Just True -> return True _ -> getInContainer - configPackageCache <- liftIO $ newIORef Nothing - let configMaybeProject = mproject - configRunner <- view runnerL + configRunner' <- view runnerL + + clCache <- newIORef Nothing + clUpdateRef <- newMVar True + + let configRunner = set envOverrideL origEnv configRunner' + configCabalLoader = CabalLoader {..} return Config {..} @@ -416,6 +420,10 @@ data MiniConfig = MiniConfig -- TODO do we really need a whole extra data type? } instance HasConfig MiniConfig where configL = lens mcConfig (\x y -> x { mcConfig = y }) +instance HasEnvOverride MiniConfig where + envOverrideL = configL.envOverrideL +instance HasCabalLoader MiniConfig where + cabalLoaderL = configL.cabalLoaderL instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y }) @@ -648,7 +656,7 @@ getLocalPackages = do mcached <- liftIO $ readIORef cacheRef case mcached of Just cached -> return cached - Nothing -> withCabalLoader $ \loadFromIndex -> do + Nothing -> do root <- view projectRootL bc <- view buildConfigL @@ -663,7 +671,7 @@ getLocalPackages = do $ C.packageDescription gpd in (name, (gpd, loc)) deps <- (map wrapGPD . concat) - <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (bcDependencies bc) + <$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc) checkDuplicateNames $ map (second (PLOther . lpvLoc)) packages ++ @@ -778,9 +786,9 @@ getInNixShell = liftIO (isJust <$> lookupEnv inNixShellEnvVar) -- | Determine the extra config file locations which exist. -- -- Returns most local first -getExtraConfigs :: (MonadIO m, MonadLogger m) +getExtraConfigs :: HasLogFunc env => Path Abs File -- ^ use config path - -> m [Path Abs File] + -> RIO env [Path Abs File] getExtraConfigs userConfigPath = do defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath liftIO $ do @@ -798,8 +806,8 @@ getExtraConfigs userConfigPath = do -- | Load and parse YAML from the given config file. Throws -- 'ParseConfigFileException' when there's a decoding error. loadConfigYaml - :: (MonadIO m, MonadLogger m) - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m a + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a loadConfigYaml parser path = do eres <- loadYaml parser path case eres of @@ -808,8 +816,8 @@ loadConfigYaml parser path = do -- | Load and parse YAML from the given file. loadYaml - :: (MonadIO m, MonadLogger m) - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m (Either Yaml.ParseException a) + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env (Either Yaml.ParseException a) loadYaml parser path = do eres <- liftIO $ Yaml.decodeFileEither (toFilePath path) case eres of @@ -822,10 +830,10 @@ loadYaml parser path = do return (Right res) -- | Get the location of the project config file, if it exists. -getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) +getProjectConfig :: HasLogFunc env => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (LocalConfigStatus (Path Abs File)) + -> RIO env (LocalConfigStatus (Path Abs File)) getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml getProjectConfig SYLDefault = do env <- liftIO getEnvironment @@ -857,10 +865,10 @@ data LocalConfigStatus a -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. -loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) +loadProjectConfig :: HasLogFunc env => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (LocalConfigStatus (Project, Path Abs File, ConfigMonoid)) + -> RIO env (LocalConfigStatus (Project, Path Abs File, ConfigMonoid)) loadProjectConfig mstackYaml = do mfp <- getProjectConfig mstackYaml case mfp of @@ -884,8 +892,8 @@ loadProjectConfig mstackYaml = do -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultGlobalConfigPath - :: (MonadIO m, MonadLogger m) - => m (Maybe (Path Abs File)) + :: HasLogFunc env + => RIO env (Maybe (Path Abs File)) getDefaultGlobalConfigPath = case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of (Just new,Just old) -> @@ -902,8 +910,8 @@ getDefaultGlobalConfigPath = -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultUserConfigPath - :: (MonadIO m, MonadLogger m) - => Path Abs Dir -> m (Path Abs File) + :: HasLogFunc env + => Path Abs Dir -> RIO env (Path Abs File) getDefaultUserConfigPath stackRoot = do (path, exists) <- tryDeprecatedPath (Just "non-project configuration file") diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs index 7882ff55ba..1b6b63f757 100644 --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -106,7 +106,7 @@ workDirFromDir fp = view $ workDirL.to (fp ) -- | Directory for project templates. templatesDir :: Config -> Path Abs Dir -templatesDir config = configStackRoot config $(mkRelDir "templates") +templatesDir config = view stackRootL config $(mkRelDir "templates") -- | Relative location of build artifacts. distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index cda22ec394..fd6eaed54b 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -19,6 +19,7 @@ module Stack.Coverage import Stack.Prelude import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T @@ -35,13 +36,14 @@ import Stack.Package import Stack.PrettyPrint import Stack.Types.Compiler import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.FilePath (isPathSeparator) -import System.Process.Read +import RIO.Process import Text.Hastache (htmlEscape) import Trace.Hpc.Tix import Web.Browser (openBrowser) @@ -167,14 +169,14 @@ generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArg concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++ -- Look for index files in the correct dir (relative to each pkgdir). ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"] - menv <- getMinimalEnvOverride logInfo $ "Generating " <> report - outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $ - readProcessStdout Nothing menv "hpc" + outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict) $ + withProc "hpc" ( "report" : toFilePath tixSrc : (args ++ extraReportArgs) ) + readProcessStdout_ if all ("(0/0)" `S8.isSuffixOf`) outputLines then do let msg html = T.concat @@ -197,12 +199,13 @@ generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArg -- Print output, stripping @\r@ characters because Windows. forM_ outputLines (logInfo . T.decodeUtf8) -- Generate the markup. - void $ readProcessStdout Nothing menv "hpc" + void $ withProc "hpc" ( "markup" : toFilePath tixSrc : ("--destdir=" ++ toFilePathNoTrailingSep reportDir) : (args ++ extraMarkupArgs) ) + readProcessStdout_ return (Just reportPath) data HpcReportOpts = HpcReportOpts @@ -312,7 +315,7 @@ generateUnionReport report reportDir tixFiles = do liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] -readTixOrLog :: (MonadLogger m, MonadUnliftIO m) => Path b File -> m (Maybe Tix) +readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix) readTixOrLog path = do mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do logError $ "Error while reading tix: " <> T.pack (show errorCall) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index e5ed6a84b3..c119bff9f3 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -27,9 +27,11 @@ import qualified Crypto.Hash as Hash (Digest, MD5, hash) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) +import Data.Conduit.Process.Typed import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf) import Data.List.Extra (trim, nubOrd) import qualified Data.Map.Strict as Map @@ -40,6 +42,7 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Version (showVersion) import GHC.Exts (sortWith) +import Lens.Micro (set) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (canonicalizePath) @@ -48,6 +51,7 @@ import Stack.Config (getInContainer) import Stack.Constants import Stack.Constants.Config import Stack.Docker.GlobalDB +import Stack.PackageIndex import Stack.Types.PackageIndex import Stack.Types.Runner import Stack.Types.Version @@ -63,10 +67,8 @@ import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO) import qualified System.PosixCompat.User as User import qualified System.PosixCompat.Files as Files -import System.Process (CreateProcess(..), StdStream(..), waitForProcess) import System.Process.PagerEditor (editByteString) -import System.Process.Read -import System.Process.Run +import RIO.Process import Text.Printf (printf) #ifndef WINDOWS @@ -93,7 +95,7 @@ reexecWithOptionalContainer reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where - getCmdArgs docker envOverride imageInfo isRemoteDocker = do + getCmdArgs docker imageInfo isRemoteDocker = do config <- view configL deUser <- if fromMaybe (not isRemoteDocker) (dockerSetUser docker) @@ -146,8 +148,6 @@ reexecWithOptionalContainer mprojectRoot = e <- try $ sinkProcessStderrStdout - Nothing - envOverride "docker" [ "run" , "-v" @@ -237,11 +237,12 @@ runContainerAndExit runContainerAndExit getCmdArgs mprojectRoot before - after = - do config <- view configL - let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker + after = do + config <- view configL + let docker = configDocker config + envOverride <- getEnvOverride -- FIXME do we actually want to be changing the envOverride, or just using the one in RIO? + withEnvOverride envOverride $ do + checkDockerVersion docker (env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $ (,,,) <$> getEnvironment @@ -260,13 +261,13 @@ runContainerAndExit getCmdArgs when (isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath) (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") - maybeImageInfo <- inspect envOverride image + maybeImageInfo <- inspect image imageInfo@Inspect{..} <- case maybeImageInfo of Just ii -> return ii Nothing | dockerAutoPull docker -> - do pullImage envOverride docker image - mii2 <- inspect envOverride image + do pullImage docker image + mii2 <- inspect image case mii2 of Just ii2 -> return ii2 Nothing -> throwM (InspectFailedException image) @@ -275,7 +276,7 @@ runContainerAndExit getCmdArgs let ImageConfig {..} = iiConfig imageEnvVars = map (break (== '=')) icEnv platformVariant = show $ hashRepoName image - stackRoot = configStackRoot config + stackRoot = view stackRootL config sandboxHomeDir = sandboxDir homeDirName isTerm = not (dockerDetach docker) && isStdinTerminal && @@ -291,7 +292,7 @@ runContainerAndExit getCmdArgs [ hostBinDirPath , sandboxHomeDir $(mkRelDir ".local/bin")] (T.pack <$> lookupImageEnv "PATH" imageEnvVars) - (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker + (cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker pwd <- getCurrentDir liftIO (do updateDockerImageLastUsed config iiId (toFilePath projectRoot) @@ -309,9 +310,7 @@ runContainerAndExit getCmdArgs (Files.createSymbolicLink (toFilePathNoTrailingSep sshDir) (toFilePathNoTrailingSep (sandboxHomeDir sshRelDir)))) - containerID <- (trim . decodeUtf8) <$> readDockerProcess - envOverride - (Just projectRoot) + containerID <- withWorkingDir projectRoot $ (trim . decodeUtf8) <$> readDockerProcess (concat [["create" ,"--net=host" @@ -356,30 +355,23 @@ runContainerAndExit getCmdArgs run <- askRunInIO oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do let sigHandler = run $ do - readProcessNull Nothing envOverride "docker" - ["kill","--signal=" ++ show sig,containerID] + readProcessNull "docker" ["kill","--signal=" ++ show sig,containerID] when (sig `elem` [sigTERM,sigABRT]) $ do -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it liftIO $ threadDelay 30000000 - readProcessNull Nothing envOverride "docker" ["kill",containerID] + readProcessNull "docker" ["kill",containerID] oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing return (sig, oldHandler) #endif - let cmd = Cmd Nothing - "docker" - envOverride - (concat [["start"] - ,["-a" | not (dockerDetach docker)] - ,["-i" | keepStdinOpen] - ,[containerID]]) - e <- finally - (try $ callProcess' - (\cp -> cp { delegate_ctlc = False }) - cmd) + let args' = concat [["start"] + ,["-a" | not (dockerDetach docker)] + ,["-i" | keepStdinOpen] + ,[containerID]] + e <- try (withProc "docker" args' $ runProcess_ . setDelegateCtlc False) + `finally` (do unless (dockerPersist docker || dockerDetach docker) $ - catch - (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID]) - (\(_::ReadProcessException) -> return ()) + readProcessNull "docker" ["rm","-f",containerID] + `catch` (\(_::ExitCodeException) -> return ()) #ifndef WINDOWS forM_ oldHandlers $ \(sig,oldHandler) -> liftIO $ installHandler sig oldHandler Nothing @@ -404,26 +396,25 @@ runContainerAndExit getCmdArgs -- | Clean-up old docker images and containers. cleanup :: HasConfig env => CleanupOpts -> RIO env () -cleanup opts = - do config <- view configL - let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker - let runDocker = readDockerProcess envOverride Nothing - imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] - danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] - runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"] - restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"] - exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"] - pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"] +cleanup opts = do + config <- view configL + let docker = configDocker config + envOverride <- getEnvOverride + withEnvOverride envOverride $ do + checkDockerVersion docker + imagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=false"] + danglingImagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=true"] + runningContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=running"] + restartingContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=restarting"] + exitedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=exited"] + pausedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=paused"] let imageRepos = parseImagesOut imagesOut danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut) runningContainers = parseContainersOut runningContainersOut ++ parseContainersOut restartingContainersOut stoppedContainers = parseContainersOut exitedContainersOut ++ parseContainersOut pausedContainersOut - inspectMap <- inspects envOverride - (Map.keys imageRepos ++ + inspectMap <- inspects (Map.keys imageRepos ++ danglingImageHashes ++ map fst stoppedContainers ++ map fst runningContainers) @@ -448,16 +439,16 @@ cleanup opts = CleanupImmediate -> return plan CleanupDryRun -> do liftIO (LBS.hPut stdout plan) return LBS.empty - mapM_ (performPlanLine envOverride) + mapM_ performPlanLine (reverse (filter filterPlanLine (lines (LBS.unpack plan')))) - allImageHashesOut <- runDocker ["images","-aq","--no-trunc"] + allImageHashesOut <- readDockerProcess ["images","-aq","--no-trunc"] liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut))) where filterPlanLine line = case line of c:_ | isSpace c -> False _ -> True - performPlanLine envOverride line = + performPlanLine line = case filter (not . null) (words (takeWhile (/= '#') line)) of [] -> return () (c:_):t:v:_ -> @@ -468,11 +459,10 @@ cleanup opts = do logInfo (concatT ["Removing container: '",v,"'"]) return ["rm","-f",v] | otherwise -> throwM (InvalidCleanupCommandException line) - e <- try (readDockerProcess envOverride Nothing args) + e <- try (readDockerProcess args) case e of - Left ex@ProcessFailed{} -> - logError (concatT ["Could not remove: '",v,"': ", show ex]) - Left e' -> throwM e' + Left ex -> + logError (concatT ["Could not remove: '",v,"': ", show (ex :: ExitCodeException)]) Right _ -> return () _ -> throwM (InvalidCleanupCommandException line) parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8 @@ -629,30 +619,29 @@ cleanup opts = containerStr = "container" -- | Inspect Docker image or container. -inspect :: (MonadUnliftIO m,MonadLogger m) - => EnvOverride -> String -> m (Maybe Inspect) -inspect envOverride image = - do results <- inspects envOverride [image] +inspect :: HasEnvOverride env + => String -> RIO env (Maybe Inspect) +inspect image = + do results <- inspects [image] case Map.toList results of [] -> return Nothing [(_,i)] -> return (Just i) _ -> throwIO (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers. -inspects :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> [String] -> m (Map String Inspect) -inspects _ [] = return Map.empty -inspects envOverride images = - do maybeInspectOut <- - try (readDockerProcess envOverride Nothing ("inspect" : images)) +inspects :: HasEnvOverride env + => [String] -> RIO env (Map String Inspect) +inspects [] = return Map.empty +inspects images = + do maybeInspectOut <- try (readDockerProcess ("inspect" : images)) case maybeInspectOut of Right inspectOut -> -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8 case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of Left msg -> throwIO (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) - Left (ProcessFailed _ _ _ err) - | any (`LBS.isPrefixOf` err) missingImagePrefixes -> return Map.empty + Left ece + | any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> return Map.empty Left e -> throwIO e where missingImagePrefixes = ["Error: No such image", "Error: No such object:"] @@ -661,50 +650,48 @@ pull :: HasConfig env => RIO env () pull = do config <- view configL let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker - pullImage envOverride docker (dockerImage docker) + envOverride <- getEnvOverride + withEnvOverride envOverride $ do + checkDockerVersion docker + pullImage docker (dockerImage docker) -- | Pull Docker image from registry. -pullImage :: (MonadLogger m,MonadIO m,MonadThrow m) - => EnvOverride -> DockerOpts -> String -> m () -pullImage envOverride docker image = +pullImage :: HasEnvOverride env + => DockerOpts -> String -> RIO env () +pullImage docker image = do logInfo (concatT ["Pulling image from registry: '",image,"'"]) when (dockerRegistryLogin docker) (do logInfo "You may need to log in." - callProcess $ Cmd - Nothing + withProc "docker" - envOverride (concat [["login"] ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) - ,[takeWhile (/= '/') image]])) + ,[takeWhile (/= '/') image]]) + runProcess_) -- We redirect the stdout of the process to stderr so that the output -- of @docker pull@ will not interfere with the output of other -- commands when using --auto-docker-pull. See issue #2733. - let stdoutToStderr cp = cp - { std_out = UseHandle stderr - , std_err = UseHandle stderr - , std_in = CreatePipe - } - (Just hin, _, _, ph) <- createProcess' "pullImage" stdoutToStderr $ - Cmd Nothing "docker" envOverride ["pull",image] - liftIO (hClose hin) - ec <- liftIO (waitForProcess ph) + ec <- withProc "docker" ["pull", image] $ \pc0 -> do + let pc = setStdout (useHandleOpen stderr) + $ setStderr (useHandleOpen stderr) + $ setStdin closed + pc0 + runProcess pc case ec of ExitSuccess -> return () ExitFailure _ -> throwIO (PullFailedException image) -- | Check docker version (throws exception if incorrect) checkDockerVersion - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> DockerOpts -> m () -checkDockerVersion envOverride docker = - do dockerExists <- doesExecutableExist envOverride "docker" + :: HasEnvOverride env + => DockerOpts -> RIO env () +checkDockerVersion docker = + do envOverride <- view envOverrideL + dockerExists <- doesExecutableExist envOverride "docker" unless dockerExists (throwIO DockerNotInstalledException) - dockerVersionOut <- readDockerProcess envOverride Nothing ["--version"] + dockerVersionOut <- readDockerProcess ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> case parseVersionFromString (stripVersion v) of @@ -736,13 +723,13 @@ reset maybeProjectRoot keepHome = do -- | The Docker container "entrypoint": special actions performed when first entering -- a container, such as switching the UID/GID to the "outside-Docker" user's. -entrypoint :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) - => Config -> DockerEntrypoint -> m () +entrypoint :: HasEnvOverride env + => Config -> DockerEntrypoint -> RIO env () entrypoint config@Config{..} DockerEntrypoint{..} = modifyMVar_ entrypointMVar $ \alreadyRan -> do -- Only run the entrypoint once unless alreadyRan $ do - envOverride <- getEnvOverride configPlatform + envOverride <- getEnvOverride homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME" -- Get the UserEntry for the 'stack' user in the image, if it exists estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ @@ -751,7 +738,7 @@ entrypoint config@Config{..} DockerEntrypoint{..} = case deUser of Nothing -> return () Just (DockerUser 0 _ _ _) -> return () - Just du -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir du + Just du -> withEnvOverride envOverride $ updateOrCreateStackUser estackUserEntry0 homeDir du case estackUserEntry0 of Left _ -> return () Right ue -> do @@ -763,13 +750,13 @@ entrypoint config@Config{..} DockerEntrypoint{..} = when buildPlanDirExists $ do (_, buildPlans) <- listDir (buildPlanDir origStackRoot) forM_ buildPlans $ \srcBuildPlan -> do - let destBuildPlan = buildPlanDir configStackRoot filename srcBuildPlan + let destBuildPlan = buildPlanDir (view stackRootL config) filename srcBuildPlan exists <- doesFileExist destBuildPlan unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan - forM_ configPackageIndices $ \pkgIdx -> do - msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do + forM_ clIndices $ \pkgIdx -> do + msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do srcIndex <- configPackageIndex (indexName pkgIdx) exists <- doesFileExist srcIndex return $ if exists @@ -777,8 +764,8 @@ entrypoint config@Config{..} DockerEntrypoint{..} = else Nothing case msrcIndex of Nothing -> return () - Just srcIndex -> do - flip runReaderT config $ do + Just srcIndex -> + runRIO config $ do destIndex <- configPackageIndex (indexName pkgIdx) exists <- doesFileExist destIndex unless exists $ do @@ -786,15 +773,16 @@ entrypoint config@Config{..} DockerEntrypoint{..} = copyFile srcIndex destIndex return True where - updateOrCreateStackUser envOverride estackUserEntry homeDir DockerUser{..} = do + CabalLoader {..} = configCabalLoader + updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do case estackUserEntry of Left _ -> do -- If no 'stack' user in image, create one with correct UID/GID and home directory - readProcessNull Nothing envOverride "groupadd" + readProcessNull "groupadd" ["-o" ,"--gid",show duGid ,stackUserName] - readProcessNull Nothing envOverride "useradd" + readProcessNull "useradd" ["-oN" ,"--uid",show duUid ,"--gid",show duGid @@ -802,17 +790,17 @@ entrypoint config@Config{..} DockerEntrypoint{..} = ,stackUserName] Right _ -> do -- If there is already a 'stack' user in the image, adjust its UID/GID and home directory - readProcessNull Nothing envOverride "usermod" + readProcessNull "usermod" ["-o" ,"--uid",show duUid ,"--home",toFilePathNoTrailingSep homeDir ,stackUserName] - readProcessNull Nothing envOverride "groupmod" + readProcessNull "groupmod" ["-o" ,"--gid",show duGid ,stackUserName] forM_ duGroups $ \gid -> do - readProcessNull Nothing envOverride "groupadd" + readProcessNull "groupadd" ["-o" ,"--gid",show gid ,"group" ++ show gid] @@ -854,9 +842,9 @@ removeDirectoryContents path excludeDirs excludeFiles = -- process. Throws a 'ReadProcessException' exception if the -- process fails. Logs process's stderr using @logError@. readDockerProcess - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> Maybe (Path Abs Dir) -> [String] -> m BS.ByteString -readDockerProcess envOverride mpwd = readProcessStdout mpwd envOverride "docker" + :: HasEnvOverride env + => [String] -> RIO env BS.ByteString +readDockerProcess args = BL.toStrict <$> withProc "docker" args readProcessStdout_ -- FIXME stderr isn't logged with logError, should it be? -- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir @@ -933,7 +921,6 @@ instance FromJSON ImageConfig where -- | Function to get command and arguments to run in Docker container type GetCmdArgs env = DockerOpts - -> EnvOverride -> Inspect -> Bool -> RIO env (FilePath,[String],[(String,String)],[Mount]) diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs index 4409866e62..7b8789bc4b 100644 --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -16,7 +16,7 @@ module Stack.Docker.GlobalDB ,DockerImageExeId) where -import Control.Monad.Logger (NoLoggingT) +import Control.Monad.Logger (NoLoggingT) -- TODO remove dep when persistent drops monad-logger import Control.Monad.Trans.Resource (ResourceT) import Stack.Prelude import Data.List (sortBy, isInfixOf, stripPrefix) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index f58f1a8eea..6f34cce79c 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -24,7 +24,7 @@ import qualified Data.Text.IO as Text import qualified Data.Traversable as T import Distribution.Text (display) import Distribution.License (License(BSD3)) -import Stack.Build (withLoadPackage) +import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source import Stack.Build.Target @@ -116,23 +116,20 @@ createDependencyGraph dotOpts = do , boptsCLIFlags = dotFlags dotOpts } let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals)) - menv <- getMinimalEnvOverride - (installedMap, globalDump, _, _) <- getInstalled menv - (GetInstalledOpts False False False) + (installedMap, globalDump, _, _) <- getInstalled (GetInstalledOpts False False False) sourceMap -- TODO: Can there be multiple entries for wired-in-packages? If so, -- this will choose one arbitrarily.. let globalDumpMap = Map.fromList $ map (\dp -> (packageIdentifierName (dpPackageIdent dp), dp)) globalDump globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump - withLoadPackage (\loader -> do - let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps - loadPackageDeps name version loc flags ghcOptions - -- Skip packages that can't be loaded - see - -- https://github.com/commercialhaskell/stack/issues/2967 - | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] = - return (Set.empty, DotPayload (Just version) (Just BSD3)) - | otherwise = fmap (packageAllDeps &&& makePayload) (loader loc flags ghcOptions) - liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) + let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps + loadPackageDeps name version loc flags ghcOptions + -- Skip packages that can't be loaded - see + -- https://github.com/commercialhaskell/stack/issues/2967 + | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] = + return (Set.empty, DotPayload (Just version) (Just BSD3)) + | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions) + resolveDependencies (dotDependencyDepth dotOpts) graph depLoader where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) listDependencies :: HasEnvConfig env @@ -263,8 +260,8 @@ printGraph dotOpts locals graph = do printLeaves graph void (Map.traverseWithKey printEdges (fst <$> graph)) liftIO $ Text.putStrLn "}" - where filteredLocals = Set.filter (\local -> - packageNameString local `Set.notMember` dotPrune dotOpts) locals + where filteredLocals = Set.filter (\local' -> + packageNameString local' `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m) diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs deleted file mode 100644 index f937b003c0..0000000000 --- a/src/Stack/Exec.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - --- | Execute commands within the properly configured Stack --- environment. - -module Stack.Exec where - -import Stack.Prelude -import Stack.Types.Config -import System.Process.Log - -import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) -import System.Exit -import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) -#ifdef WINDOWS -import System.Process.Read (EnvOverride) -#else -import qualified System.Process.PID1 as PID1 -import System.Process.Read (EnvOverride, envHelper, preProcess) -#endif - --- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH. --- --- Note that this also passes through the GHCRTS environment variable. --- See https://github.com/commercialhaskell/stack/issues/3444 -defaultEnvSettings :: EnvSettings -defaultEnvSettings = EnvSettings - { esIncludeLocals = True - , esIncludeGhcPackagePath = True - , esStackExe = True - , esLocaleUtf8 = False - , esKeepGhcRts = True - } - --- | Environment settings which do not embellish the environment --- --- Note that this also passes through the GHCRTS environment variable. --- See https://github.com/commercialhaskell/stack/issues/3444 -plainEnvSettings :: EnvSettings -plainEnvSettings = EnvSettings - { esIncludeLocals = False - , esIncludeGhcPackagePath = False - , esStackExe = False - , esLocaleUtf8 = False - , esKeepGhcRts = True - } - --- | Execute a process within the Stack configured environment. --- --- Execution will not return, because either: --- --- 1) On non-windows, execution is taken over by execv of the --- sub-process. This allows signals to be propagated (#527) --- --- 2) On windows, an 'ExitCode' exception will be thrown. -exec :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m b -#ifdef WINDOWS -exec = execSpawn -#else -exec menv cmd0 args = do - cmd <- preProcess Nothing menv cmd0 - withProcessTimeLog cmd args $ - liftIO $ PID1.run cmd args (envHelper menv) -#endif - --- | Like 'exec', but does not use 'execv' on non-windows. This way, there --- is a sub-process, which is helpful in some cases (#1306) --- --- This function only exits by throwing 'ExitCode'. -execSpawn :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m b -execSpawn menv cmd0 args = do - e <- withProcessTimeLog cmd0 args $ - try (callProcess (Cmd Nothing cmd0 menv args)) - liftIO $ case e of - Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec - Right () -> exitSuccess - -execObserve :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m String -execObserve menv cmd0 args = do - e <- withProcessTimeLog cmd0 args $ - try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) - case e of - Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec - Right s -> return s diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index ac9ff41d0d..959506d4eb 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} -- | Functionality for downloading packages securely for cabal's usage. @@ -26,7 +27,7 @@ module Stack.Fetch , resolvePackagesAllowMissing , ResolvedPackage (..) , withCabalFiles - , withCabalLoader + , loadFromIndex ) where import qualified Codec.Archive.Tar as Tar @@ -47,17 +48,16 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Text.Metrics +import Lens.Micro (to) import Network.HTTP.Download import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Stack.PackageIndex import Stack.Types.BuildPlan -import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName -import Stack.Types.Runner import Stack.Types.Version import qualified System.FilePath as FP import System.IO (SeekMode (AbsoluteSeek)) @@ -103,7 +103,7 @@ instance Show FetchException where (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "") -- | Fetch packages into the cache without unpacking -fetchPackages :: HasConfig env => Set PackageIdentifier -> RIO env () +fetchPackages :: HasCabalLoader env => Set PackageIdentifier -> RIO env () fetchPackages idents' = do resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved @@ -116,7 +116,7 @@ fetchPackages idents' = do idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents' -- | Intended to work for the command line command. -unpackPackages :: HasConfig env +unpackPackages :: HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers @@ -151,7 +151,7 @@ unpackPackages mSnapshotDef dest input = do -- | Same as 'unpackPackageIdents', but for a single package. unpackPackageIdent - :: HasConfig env + :: HasCabalLoader env => Path Abs Dir -- ^ unpack directory -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> PackageIdentifierRevision @@ -169,7 +169,7 @@ unpackPackageIdent unpackDir distDir (PackageIdentifierRevision ident mcfi) = do -- | 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 - :: HasConfig env + :: HasCabalLoader env => Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> [PackageIdentifierRevision] @@ -189,7 +189,7 @@ data ResolvedPackage = ResolvedPackage deriving Show -- | Resolve a set of package names and identifiers into @FetchPackage@ values. -resolvePackages :: HasConfig env +resolvePackages :: HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> [PackageIdentifierRevision] -> Set PackageName @@ -210,9 +210,9 @@ resolvePackages mSnapshotDef idents0 names0 = do -- | Does the configuration use a 00-index.tar.gz file for indices? -- See -getUses00Index :: HasConfig env => RIO env Bool +getUses00Index :: HasCabalLoader env => RIO env Bool getUses00Index = - any is00 <$> view packageIndicesL + any is00 <$> view (cabalLoaderL.to clIndices) where is00 :: PackageIndex -> Bool is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index @@ -225,7 +225,7 @@ getUses00Index = -- a warning, that's no longer necessary or desirable since all info -- should be present and checked). resolvePackagesAllowMissing - :: forall env. HasConfig env + :: forall env. HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> [PackageIdentifierRevision] -> Set PackageName @@ -265,15 +265,19 @@ resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do (missingNames, idents1) = partitionEithers $ map (\name -> maybe (Left name) Right (getNamed name)) (Set.toList names0) - config <- view configL + cl <- view cabalLoaderL let (missingIdents, resolved) = partitionEithers - $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage config pir cache)) + $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage cl pir cache)) $ idents0 <> idents1 return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved) -lookupResolvedPackage :: Config -> PackageIdentifierRevision -> PackageCache PackageIndex -> Maybe ResolvedPackage -lookupResolvedPackage config (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do +lookupResolvedPackage + :: CabalLoader + -> PackageIdentifierRevision + -> PackageCache PackageIndex + -> Maybe ResolvedPackage +lookupResolvedPackage cl (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version let moffsetSize = case cfi of @@ -287,7 +291,7 @@ lookupResolvedPackage config (PackageIdentifierRevision ident@(PackageIdentifier case moffsetSize of Just x -> Just x Nothing - | configIgnoreRevisionMismatch config -> Just $ snd $ NE.last files + | clIgnoreRevisionMismatch cl -> Just $ snd $ NE.last files | otherwise -> Nothing Just ResolvedPackage { rpIdent = ident @@ -313,11 +317,11 @@ data ToFetchResult = ToFetchResult -- | Add the cabal files to a list of idents with their caches. withCabalFiles - :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + :: HasCabalLoader env => IndexName -> [(ResolvedPackage, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) - -> m [b] + -> RIO env [b] withCabalFiles name pkgs f = do indexPath <- configPackageIndex name withBinaryFile (toFilePath indexPath) ReadMode @@ -330,71 +334,52 @@ withCabalFiles name pkgs f = do cabalBS <- S.hGet h $ fromIntegral size f ident tf cabalBS --- | Provide a function which will load up a cabal @ByteString@ from the --- package indices. -withCabalLoader - :: HasConfig env - => ((PackageIdentifierRevision -> IO ByteString) -> RIO env a) - -> RIO env a -withCabalLoader inner = do - -- Want to try updating the index once during a single run for missing - -- package identifiers. We also want to ensure we only update once at a - -- time - -- - -- TODO: probably makes sense to move this concern into getPackageCaches - updateRef <- newMVar True - - u <- askUnliftIO - - -- TODO in the future, keep all of the necessary @Handle@s open - let doLookup :: PackageIdentifierRevision - -> IO ByteString - doLookup ident = do - bothCaches <- unliftIO u getPackageCaches - mres <- unliftIO u $ lookupPackageIdentifierExact ident bothCaches - case mres of - Just bs -> return bs - -- Update the cache and try again - Nothing -> do - let fuzzy = fuzzyLookupCandidates ident bothCaches - suggestions = case fuzzy of - FRNameNotFound Nothing -> "" - FRNameNotFound (Just cs) -> - "Perhaps you meant " <> orSeparated cs <> "?" - FRVersionNotFound cs -> "Possible candidates: " <> - commaSeparated (NE.map packageIdentifierText cs) - <> "." - FRRevisionNotFound cs -> - "The specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) - <> "." - join $ modifyMVar updateRef $ \toUpdate -> - if toUpdate then do - unliftIO u $ do - logInfo $ T.concat - [ "Didn't see " - , T.pack $ packageIdentifierRevisionString ident - , " in your package indices.\n" - , "Updating and trying again." - ] - updateAllIndices - _ <- getPackageCaches - return () - return (False, doLookup ident) - else do - uses00Index <- unliftIO u getUses00Index - return (toUpdate, throwIO $ UnknownPackageIdentifiers - (HashSet.singleton ident) (T.unpack suggestions) uses00Index) - inner doLookup +loadFromIndex :: HasCabalLoader env => PackageIdentifierRevision -> RIO env ByteString +loadFromIndex ident = do + -- TODO in the future, keep all of the necessary @Handle@s open + bothCaches <- getPackageCaches + mres <- lookupPackageIdentifierExact ident bothCaches + case mres of + Just bs -> return bs + -- Update the cache and try again + Nothing -> do + let fuzzy = fuzzyLookupCandidates ident bothCaches + suggestions = case fuzzy of + FRNameNotFound Nothing -> "" + FRNameNotFound (Just cs) -> + "Perhaps you meant " <> orSeparated cs <> "?" + FRVersionNotFound cs -> "Possible candidates: " <> + commaSeparated (NE.map packageIdentifierText cs) + <> "." + FRRevisionNotFound cs -> + "The specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) + <> "." + cl <- view cabalLoaderL + join $ modifyMVar (clUpdateRef cl) $ \toUpdate -> + if toUpdate then do + logInfo $ T.concat + [ "Didn't see " + , T.pack $ packageIdentifierRevisionString ident + , " in your package indices.\n" + , "Updating and trying again." + ] + updateAllIndices + _ <- getPackageCaches + return (False, loadFromIndex ident) + else do + uses00Index <- getUses00Index + return (toUpdate, throwIO $ UnknownPackageIdentifiers + (HashSet.singleton ident) (T.unpack suggestions) uses00Index) lookupPackageIdentifierExact - :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + :: HasCabalLoader env => PackageIdentifierRevision -> PackageCache PackageIndex - -> m (Maybe ByteString) + -> RIO env (Maybe ByteString) lookupPackageIdentifierExact identRev cache = do - config <- view configL - forM (lookupResolvedPackage config identRev cache) $ \rp -> do + cl <- view cabalLoaderL + forM (lookupResolvedPackage cl identRev cache) $ \rp -> do [bs] <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs return bs @@ -449,7 +434,7 @@ typoCorrectionCandidates name' (PackageCache cache) = $ cache -- | Figure out where to fetch from. -getToFetch :: HasConfig env +getToFetch :: HasCabalLoader env => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> [ResolvedPackage] -> RIO env ToFetchResult @@ -508,28 +493,25 @@ getToFetch mdest resolvedAll = do -- @ -- -- Since 0.1.0.0 -fetchPackages' :: HasConfig env +fetchPackages' :: forall env. HasCabalLoader env => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> Map PackageIdentifier ToFetch -> RIO env (Map PackageIdentifier (Path Abs Dir)) fetchPackages' mdistDir toFetchAll = do - connCount <- view $ configL.to configConnectionCount - outputVar <- liftIO $ newTVarIO Map.empty + connCount <- view $ cabalLoaderL.to clConnectionCount + outputVar <- newTVarIO Map.empty - run <- askRunInIO parMapM_ connCount - (go outputVar run) + (go outputVar) (Map.toList toFetchAll) - liftIO $ readTVarIO outputVar + readTVarIO outputVar where - go :: (MonadUnliftIO m,MonadThrow m,MonadLogger m,HasRunner env, MonadReader env m) - => TVar (Map PackageIdentifier (Path Abs Dir)) - -> (m () -> IO ()) + go :: TVar (Map PackageIdentifier (Path Abs Dir)) -> (PackageIdentifier, ToFetch) - -> m () - go outputVar run (ident, toFetch) = do + -> RIO env () + go outputVar (ident, toFetch) = do req <- parseUrlThrow $ T.unpack $ tfUrl toFetch let destpath = tfTarball toFetch @@ -541,7 +523,7 @@ fetchPackages' mdistDir toFetchAll = do , drRetryPolicy = drRetryPolicyDefault } let progressSink _ = - liftIO $ run $ logInfo $ packageIdentifierText ident <> ": download" + logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink identStrP <- parseRelDir $ packageIdentifierString ident @@ -666,3 +648,12 @@ orSeparated xs commaSeparated :: NonEmpty T.Text -> T.Text commaSeparated = F.fold . NE.intersperse ", " + +-- | Location of a package tarball +configPackageTarball :: HasCabalLoader env => IndexName -> PackageIdentifier -> RIO env (Path Abs File) +configPackageTarball iname ident = do + root <- configPackageIndexRoot iname + name <- parseRelDir $ packageNameString $ packageIdentifierName ident + ver <- parseRelDir $ versionString $ packageIdentifierVersion ident + base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" + return (root $(mkRelDir "packages") name ver base) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index b38a00fb95..6bba4a42f9 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -23,6 +23,7 @@ module Stack.GhcPkg import Stack.Prelude import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -37,16 +38,16 @@ import Stack.Types.Compiler import Stack.Types.PackageName import Stack.Types.Version import System.FilePath (searchPathSeparator) -import System.Process.Read +import RIO.Process -- | Get the global package database -getGlobalDB :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> m (Path Abs Dir) -getGlobalDB menv wc = do +getGlobalDB :: HasEnvOverride env + => WhichCompiler -> RIO env (Path Abs Dir) +getGlobalDB wc = do logDebug "Getting global package database location" -- This seems like a strange way to get the global package database -- location, but I don't know of a better one - bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwIO return + bs <- ghcPkg wc [] ["list", "--global"] >>= either throwIO return let fp = S8.unpack $ stripTrailingColon $ firstLine bs liftIO $ resolveDir' fp where @@ -57,27 +58,29 @@ getGlobalDB menv wc = do firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable -ghcPkg :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +ghcPkg :: HasEnvOverride env + => WhichCompiler -> [Path Abs Dir] -> [String] - -> m (Either ReadProcessException S8.ByteString) -ghcPkg menv wc pkgDbs args = do + -> RIO env (Either SomeException S8.ByteString) +ghcPkg wc pkgDbs args = do eres <- go case eres of - Left _ -> do - mapM_ (createDatabase menv wc) pkgDbs - go - Right _ -> return eres + Left _ -> do + mapM_ (createDatabase wc) pkgDbs + go + Right _ -> return eres where - go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args' + go = fmap (fmap BL.toStrict) + $ tryAny + $ withProc (ghcPkgExeName wc) args' readProcessStdout_ args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. -createDatabase :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () -createDatabase menv wc db = do +createDatabase + :: HasEnvOverride env + => WhichCompiler -> Path Abs Dir -> RIO env () +createDatabase wc db = do exists <- doesFileExist (db $(mkRelFile "package.cache")) unless exists $ do -- ghc-pkg requires that the database directory does not exist @@ -99,12 +102,9 @@ createDatabase menv wc db = do -- finding out it isn't the hard way ensureDir (parent db) return ["init", toFilePath db] - eres <- tryProcessStdout Nothing menv (ghcPkgExeName wc) args - case eres of - Left e -> do - logError $ T.pack $ "Unable to create package database at " ++ toFilePath db - throwIO e - Right _ -> return () + void $ withProc (ghcPkgExeName wc) args $ \pc -> + readProcessStdout_ pc `onException` + logError (T.pack $ "Unable to create package database at " ++ toFilePath db) -- | Get the name to use for "ghc-pkg", given the compiler version. ghcPkgExeName :: WhichCompiler -> String @@ -124,49 +124,45 @@ packageDbFlags pkgDbs = -- | Get the value of a field of the package. findGhcPkgField - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> String -- ^ package identifier, or GhcPkgId -> Text - -> m (Maybe Text) -findGhcPkgField menv wc pkgDbs name field = do + -> RIO env (Maybe Text) +findGhcPkgField wc pkgDbs name field = do result <- ghcPkg - menv wc pkgDbs ["field", "--simple-output", name, T.unpack field] return $ case result of Left{} -> Nothing - Right lbs -> - fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs + Right bs -> + fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs -- | Get the version of the package -findGhcPkgVersion :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +findGhcPkgVersion :: HasEnvOverride env + => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageName - -> m (Maybe Version) -findGhcPkgVersion menv wc pkgDbs name = do - mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version" + -> RIO env (Maybe Version) +findGhcPkgVersion wc pkgDbs name = do + mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version" case mv of Just !v -> return (parseVersion v) _ -> return Nothing -unregisterGhcPkgId :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +unregisterGhcPkgId :: HasEnvOverride env + => WhichCompiler -> CompilerVersion 'CVActual -> Path Abs Dir -- ^ package database -> GhcPkgId -> PackageIdentifier - -> m () -unregisterGhcPkgId menv wc cv pkgDb gid ident = do - eres <- ghcPkg menv wc [pkgDb] args + -> RIO env () +unregisterGhcPkgId wc cv pkgDb gid ident = do + eres <- ghcPkg wc [pkgDb] args case eres of Left e -> logWarn $ T.pack $ show e Right _ -> return () @@ -179,12 +175,11 @@ unregisterGhcPkgId menv wc cv pkgDb gid ident = do _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. -getCabalPkgVer :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> m Version -getCabalPkgVer menv wc = do +getCabalPkgVer :: HasEnvOverride env + => WhichCompiler -> RIO env Version +getCabalPkgVer wc = do logDebug "Getting Cabal package version" mres <- findGhcPkgVersion - menv wc [] -- global DB cabalPackageName diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 7d97b41af2..eee9bc6a31 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -36,7 +36,6 @@ import Stack.Build.Source import Stack.Build.Target import Stack.Config (getLocalPackages) import Stack.Constants.Config -import Stack.Exec import Stack.Ghci.Script import Stack.Package import Stack.PrettyPrint @@ -44,11 +43,13 @@ import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import System.IO (putStrLn, putStr, getLine) +import RIO.Process (withEnvOverride, execSpawn, execObserve) #ifndef WINDOWS import qualified System.Posix.Files as Posix @@ -355,8 +356,8 @@ runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles exposePackages = do ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) let execGhci extras = do - menv <- liftIO $ configEnvOverride config defaultEnvSettings - execSpawn menv + menv <- liftIO $ configEnvOverrideSettings config defaultEnvSettings + withEnvOverride menv $ execSpawn (fromMaybe (compilerExeName wc) ghciGhcCommand) (("--interactive" : ) $ -- This initial "-i" resets the include directories to @@ -372,8 +373,9 @@ runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles exposePackages = do -- multiple packages. case pkgs of [_] -> do - menv <- liftIO $ configEnvOverride config defaultEnvSettings - output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] + menv <- liftIO $ configEnvOverrideSettings config defaultEnvSettings + output <- withEnvOverride menv + $ execObserve (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] return $ "Intero" `isPrefixOf` output _ -> return False withSystemTempDir "ghci" $ \tmpDirectory -> do @@ -526,9 +528,7 @@ getGhciPkgInfos -> [(PackageName, (Path Abs File, Target))] -> RIO env [GhciPkgInfo] getGhciPkgInfos buildOptsCLI sourceMap addPkgs mfileTargets localTargets = do - menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled - menv GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False @@ -624,7 +624,7 @@ wantedPackageComponents bopts (TargetAll ProjectPackage) pkg = S.fromList $ (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) wantedPackageComponents _ _ _ = S.empty -checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForIssues :: HasLogFunc env => [GhciPkgInfo] -> RIO env () checkForIssues pkgs = do unless (null issues) $ borderedWarning $ do logWarn "Warning: There are cabal settings for this project which may prevent GHCi from loading your code properly." @@ -687,7 +687,7 @@ checkForIssues pkgs = do , (c, bio) <- ghciPkgOpts pkg ] -borderedWarning :: MonadLogger m => m a -> m a +borderedWarning :: HasLogFunc env => RIO env a -> RIO env a borderedWarning f = do logWarn "" logWarn "* * * * * * * *" @@ -696,7 +696,7 @@ borderedWarning f = do logWarn "" return x -checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForDuplicateModules :: HasLogFunc env => [GhciPkgInfo] -> RIO env () checkForDuplicateModules pkgs = do unless (null duplicates) $ do borderedWarning $ do diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index db7215a2f5..c4a3842c33 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -9,7 +9,7 @@ module Stack.Hoogle ) where import Stack.Prelude -import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) import Data.List (find) import qualified Data.Set as Set @@ -24,8 +24,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Exit -import System.Process.Read (resetExeCache, tryProcessStdout, findExecutable) -import System.Process.Run +import RIO.Process -- | Hoogle command. hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO () @@ -115,7 +114,7 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do packageIdentifierText ident <> " in your index, installing it.") config <- view configL - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configEnvOverrideSettings config envSettings liftIO (catch (withBuildConfigAndLock @@ -138,17 +137,13 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do runHoogle :: Path Abs File -> [String] -> RIO EnvConfig () runHoogle hooglePath hoogleArgs = do config <- view configL - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configEnvOverrideSettings config envSettings dbpath <- hoogleDatabasePath let databaseArg = ["--database=" ++ toFilePath dbpath] - runCmd - Cmd - { cmdDirectoryToRunIn = Nothing - , cmdCommandToRun = toFilePath hooglePath - , cmdEnvOverride = menv - , cmdCommandLineArguments = hoogleArgs ++ databaseArg - } - Nothing + withEnvOverride menv $ withProc + (toFilePath hooglePath) + (hoogleArgs ++ databaseArg) + runProcess_ bail :: RIO EnvConfig a bail = liftIO (exitWith (ExitFailure (-1))) checkDatabaseExists = do @@ -157,12 +152,14 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do ensureHoogleInPath :: RIO EnvConfig (Path Abs File) ensureHoogleInPath = do config <- view configL - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configEnvOverrideSettings config envSettings mhooglePath <- findExecutable menv "hoogle" eres <- case mhooglePath of Nothing -> return $ Left "Hoogle isn't installed." Just hooglePath -> do - result <- tryProcessStdout Nothing menv (toFilePath hooglePath) ["--numeric-version"] + result <- withEnvOverride menv + $ withProc (toFilePath hooglePath) ["--numeric-version"] + $ tryAny . readProcessStdout_ let unexpectedResult got = Left $ T.concat [ "'" , T.pack (toFilePath hooglePath) @@ -171,8 +168,8 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do ] return $ case result of Left err -> unexpectedResult $ T.pack (show err) - Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (S8.unpack bs)) of - Nothing -> unexpectedResult $ T.pack (S8.unpack bs) + Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (BL8.unpack bs)) of + Nothing -> unexpectedResult $ T.pack (BL8.unpack bs) Just ver | ver >= hoogleMinVersion -> Right hooglePath | otherwise -> Left $ T.concat diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index 1763a7bdd6..fe4e28f4ac 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -17,7 +17,7 @@ import Stack.Config (getLocalPackages) import Stack.Package (readPackageUnresolvedDir, gpdPackageName) import Stack.Prelude import Stack.Types.Config -import Stack.Types.Package +import Stack.Types.NamedComponent import Stack.Types.PackageName -- | List the packages inside the current project. diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index 9e89204800..4099ab9ff3 100644 --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -25,7 +25,7 @@ import Stack.Constants.Config import Stack.PrettyPrint import Stack.Types.Config import Stack.Types.Image -import System.Process.Run +import RIO.Process -- | Stages the executables & additional content in a staging -- directory under '.stack-work' @@ -130,8 +130,7 @@ imageName = map toLower . toFilePathNoTrailingSep . dirname createDockerImage :: HasConfig env => ImageDockerOpts -> Path Abs Dir -> RIO env () -createDockerImage dockerConfig dir = do - menv <- getMinimalEnvOverride +createDockerImage dockerConfig dir = case imgDockerBase dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do @@ -146,14 +145,13 @@ createDockerImage dockerConfig dir = do (imageName (parent . parent . parent $ dir)) (imgDockerImageName dockerConfig) , toFilePathNoTrailingSep dir] - callProcess (Cmd Nothing "docker" menv args) + withProc "docker" args runProcess_ -- | Extend the general purpose docker image with entrypoints (if specified). extendDockerImageWithEntrypoint :: HasConfig env => ImageDockerOpts -> Path Abs Dir -> RIO env () extendDockerImageWithEntrypoint dockerConfig dir = do - menv <- getMinimalEnvOverride let dockerImageName = fromMaybe (imageName (parent . parent . parent $ dir)) @@ -174,15 +172,13 @@ extendDockerImageWithEntrypoint dockerConfig dir = do , "ENTRYPOINT [\"/usr/local/bin/" ++ ep ++ "\"]" , "CMD []"])))) - callProcess - (Cmd - Nothing + withProc "docker" - menv [ "build" , "-t" , dockerImageName ++ "-" ++ ep - , toFilePathNoTrailingSep dir])) + , toFilePathNoTrailingSep dir] + runProcess_) -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir diff --git a/src/Stack/New.hs b/src/Stack/New.hs index fcffc1cc89..7f4df13ecf 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -47,7 +47,7 @@ import Stack.Constants.Config import Stack.Types.Config import Stack.Types.PackageName import Stack.Types.TemplateName -import System.Process.Run +import RIO.Process import Text.Hastache import Text.Hastache.Context import Text.Printf @@ -196,8 +196,8 @@ applyTemplate project template nonceParams dir templateText = do unless (S.null missingKeys) (logInfo ("\n" <> T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))) <> "\n")) files :: Map FilePath LB.ByteString <- - catch (execWriterT $ - yield (T.encodeUtf8 (LT.toStrict applied)) $$ + catch (execWriterT $ runConduit $ + yield (T.encodeUtf8 (LT.toStrict applied)) .| unpackTemplate receiveMem id ) (\(e :: ProjectTemplateException) -> @@ -252,16 +252,16 @@ writeTemplateFiles files = -- | Run any initialization functions, such as Git. runTemplateInits :: HasConfig env - => Path Abs Dir -> RIO env () + => Path Abs Dir + -> RIO env () runTemplateInits dir = do - menv <- getMinimalEnvOverride config <- view configL case configScmInit config of Nothing -> return () Just Git -> - catch (callProcess $ Cmd (Just dir) "git" menv ["init"]) - (\(_ :: ProcessExitedUnsuccessfully) -> - logInfo "git init failed to run, ignoring ...") + withWorkingDir dir $ + catchAny (withProc "git" ["init"] runProcess_) + (\_ -> logInfo "git init failed to run, ignoring ...") -- | Display the set of templates accompanied with description if available. listTemplates :: HasLogFunc env => RIO env () diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index bb8c6b81f1..0d36602403 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -15,12 +15,12 @@ module Stack.Nix import Stack.Prelude import qualified Data.Text as T import Data.Version (showVersion) +import Lens.Micro (set) import Path.IO import qualified Paths_stack as Meta import Stack.Config (getInNixShell, getInContainer) import Stack.Config.Nix (nixCompiler) import Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) -import Stack.Exec (exec) import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix @@ -28,7 +28,7 @@ import Stack.Types.Runner import Stack.Types.Compiler import System.Environment (getArgs,getExecutablePath,lookupEnv) import qualified System.FilePath as F -import System.Process.Read (getEnvOverride) +import RIO.Process (getEnvOverride, envOverrideL, exec) -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. @@ -63,8 +63,9 @@ runShellAndExit -> RIO env (String, [String]) -> RIO env () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do - config <- view configL - envOverride <- getEnvOverride (configPlatform config) + config <- view configL + envOverride <- getEnvOverride + local (set envOverrideL envOverride) $ do (cmnd,args) <- fmap (escape *** map escape) getCmdArgs mshellFile <- traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $ @@ -118,7 +119,7 @@ runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do "Using a nix-shell environment " <> (case mshellFile of Just path -> "from file: " <> T.pack (toFilePath path) Nothing -> "with nix packages: " <> T.intercalate ", " pkgs) - exec envOverride "nix-shell" fullArgs + exec "nix-shell" fullArgs -- | Shell-escape quotes inside the string and enclose it in quotes. escape :: String -> String diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index af26b2efac..b726b11742 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -28,7 +28,7 @@ import Stack.Prelude hiding (lift) import Stack.Setup import Stack.Types.Config import Stack.Types.FlagName -import Stack.Types.Package +import Stack.Types.NamedComponent import Stack.Types.PackageName import System.Process (readProcess) import Language.Haskell.TH.Syntax (runIO, lift) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index cec33da759..d2ed9b55d6 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -79,6 +79,8 @@ import Path.IO hiding (findFiles) import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config +import Stack.Fetch (loadFromIndex) +import Stack.PackageIndex (HasCabalLoader (..)) import Stack.Prelude import Stack.PrettyPrint import Stack.Types.Build @@ -87,6 +89,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -96,7 +99,7 @@ import qualified System.Directory as D import System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error -import System.Process.Run (runCmd, Cmd(..)) +import RIO.Process data Ctx = Ctx { ctxFile :: !(Path Abs File) , ctxDir :: !(Path Abs Dir) @@ -110,6 +113,10 @@ instance HasLogFunc Ctx where instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasCabalLoader Ctx where + cabalLoaderL = configL.cabalLoaderL +instance HasEnvOverride Ctx where + envOverrideL = configL.envOverrideL instance HasBuildConfig Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -187,17 +194,16 @@ gpdVersion = packageIdentifierVersion . gpdPackageIdentifier -- | Read the 'GenericPackageDescription' from the given -- 'PackageIdentifierRevision'. readPackageUnresolvedIndex - :: forall env. HasRunner env - => (PackageIdentifierRevision -> IO ByteString) -- ^ load the raw bytes - -> PackageIdentifierRevision + :: forall env. HasCabalLoader env + => PackageIdentifierRevision -> RIO env GenericPackageDescription -readPackageUnresolvedIndex loadFromIndex pir@(PackageIdentifierRevision pi' _) = do +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' _) = do ref <- view $ runnerL.to runnerParsedCabalFiles (m, _) <- readIORef ref case M.lookup pir m of Just gpd -> return gpd Nothing -> do - bs <- liftIO $ loadFromIndex pir + bs <- loadFromIndex pir (_warnings, gpd) <- rawParseGPD (Left pir) bs let foundPI = fromCabalPackageIdentifier @@ -335,9 +341,9 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg distDir <- distDirFromDir pkgDir env <- view envConfigL (componentModules,componentFiles,dataFiles',warnings) <- - runReaderT - (packageDescModulesAndFiles pkg) + runRIO (Ctx cabalfp (buildDir distDir) env) + (packageDescModulesAndFiles pkg) setupFiles <- if buildType pkg `elem` [Nothing, Just Custom] then do @@ -666,9 +672,8 @@ allBuildInfo' pkg = allBuildInfo pkg ++ -- | Get all files referenced by the package. packageDescModulesAndFiles - :: (MonadLogger m, MonadUnliftIO m, MonadReader Ctx m, MonadThrow m) - => PackageDescription - -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) + :: PackageDescription + -> RIO Ctx (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do (libraryMods,libDotCabalFiles,libWarnings) <- -- FIXME add in sub libraries maybe @@ -711,8 +716,7 @@ packageDescModulesAndFiles pkg = do foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. -resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader Ctx m) - => [String] -> m (Set (Path Abs File)) +resolveGlobFiles :: [String] -> RIO Ctx (Set (Path Abs File)) resolveGlobFiles = liftM (S.fromList . catMaybes . concat) . mapM resolve @@ -758,7 +762,7 @@ resolveGlobFiles = -- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"] -- @ -- -matchDirFileGlob_ :: (MonadLogger m, MonadIO m, HasRunner env, MonadReader env m) => String -> String -> m [String] +matchDirFileGlob_ :: HasRunner env => String -> String -> RIO env [String] matchDirFileGlob_ dir filepath = case parseFileGlob filepath of Nothing -> liftIO $ throwString $ "invalid file glob '" ++ filepath @@ -787,8 +791,7 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of -- | Get all files referenced by the benchmark. benchmarkFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: Benchmark -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -810,9 +813,8 @@ benchmarkFiles bench = do -- | Get all files referenced by the test. testFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => TestSuite - -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: TestSuite + -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -835,9 +837,8 @@ testFiles test = do -- | Get all files referenced by the executable. executableFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Executable - -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: Executable + -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -855,8 +856,7 @@ executableFiles exe = do -- | Get all files referenced by the library. libraryFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: Library -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -875,8 +875,7 @@ libraryFiles lib = do build = libBuildInfo lib -- | Get all C sources and extra source files in a build. -buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader Ctx m) - => BuildInfo -> m (Set DotCabalPath) +buildOtherSources :: BuildInfo -> RIO Ctx (Set DotCabalPath) buildOtherSources build = do csources <- liftM (S.map DotCabalCFilePath . S.fromList) @@ -1067,12 +1066,11 @@ depRange (Dependency _ r) = r -- extensions, plus find any of their module and TemplateHaskell -- dependencies. resolveFilesAndDeps - :: (MonadIO m, MonadLogger m, MonadReader Ctx m, MonadThrow m) - => Maybe String -- ^ Package component name + :: Maybe String -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. - -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) + -> RIO Ctx (Set ModuleName,Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules) @@ -1134,8 +1132,7 @@ resolveFilesAndDeps component dirs names0 exts = do -- | Get the dependencies of a Haskell module file. getDependencies - :: (MonadReader Ctx m, MonadIO m, MonadLogger m) - => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File]) + :: Maybe String -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File]) getDependencies component dotCabalPath = case dotCabalPath of DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile @@ -1163,8 +1160,7 @@ getDependencies component dotCabalPath = -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI - :: (MonadReader Ctx m, MonadIO m, MonadLogger m) - => FilePath -> m (Set ModuleName, [Path Abs File]) + :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do dir <- asks (parent . ctxFile) dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath) @@ -1201,22 +1197,20 @@ parseDumpHI dumpHIPath = do -- looking for unique instances of base names applied with the given -- extensions. resolveFiles - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) - => [Path Abs Dir] -- ^ Directories to look in. + :: [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. - -> m [(DotCabalDescriptor, Maybe DotCabalPath)] + -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)] resolveFiles dirs names exts = forM names (\name -> liftM (name, ) (findCandidate dirs exts name)) -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) - => [Path Abs Dir] + :: [Path Abs Dir] -> [Text] -> DotCabalDescriptor - -> m (Maybe DotCabalPath) + -> RIO Ctx (Maybe DotCabalPath) findCandidate dirs exts name = do pkg <- asks ctxFile >>= parsePackageNameFromFilePath candidates <- liftIO makeNameCandidates @@ -1267,8 +1261,7 @@ findCandidate dirs exts name = do -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. warnMultiple - :: (MonadLogger m, HasRunner env, MonadReader env m) - => DotCabalDescriptor -> Path b t -> [Path b t] -> m () + :: DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx () warnMultiple name candidate rest = -- TODO: figure out how to style 'name' and the dispOne stuff prettyWarnL @@ -1292,9 +1285,8 @@ warnMultiple name candidate rest = -- For example: .erb for a Ruby file might exist in one of the -- directories. logPossibilities - :: (MonadIO m, MonadThrow m, MonadLogger m, HasRunner env, - MonadReader env m) - => [Path Abs Dir] -> ModuleName -> m () + :: HasRunner env + => [Path Abs Dir] -> ModuleName -> RIO env () logPossibilities dirs mn = do possibilities <- liftM concat (makePossibilities mn) unless (null possibilities) $ prettyWarnL @@ -1328,18 +1320,17 @@ logPossibilities dirs mn = do -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile - :: forall m env. - (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) + :: forall env. HasConfig env => Path Abs Dir -- ^ package directory - -> m (Path Abs File) + -> RIO env (Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir findCabalFile where - findCabalFile :: m (Path Abs File) + findCabalFile :: RIO env (Path Abs File) findCabalFile = findCabalFile' >>= either throwIO return - findCabalFile' :: m (Either PackageException (Path Abs File)) + findCabalFile' :: RIO env (Either PackageException (Path Abs File)) findCabalFile' = do files <- liftIO $ findFiles pkgDir @@ -1358,8 +1349,7 @@ findOrGenerateCabalFile pkgDir = do where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate .cabal file from package.yaml, if necessary. -hpack :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) - => Path Abs Dir -> m () +hpack :: HasConfig env => Path Abs Dir -> RIO env () hpack pkgDir = do let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) exists <- liftIO $ doesFileExist hpackFile @@ -1389,10 +1379,8 @@ hpack pkgDir = do , flow "If you want to use package.yaml instead of the cabal file, " , flow "then please delete the cabal file." ] - HpackCommand command -> do - envOverride <- getMinimalEnvOverride - let cmd = Cmd (Just pkgDir) command envOverride [] - runCmd cmd Nothing + HpackCommand command -> + withWorkingDir pkgDir $ withProc command [] runProcess_ -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) @@ -1406,11 +1394,10 @@ buildLogPath package' msuffix = do return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn -resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader Ctx m) - => Text - -> (Path Abs Dir -> String -> m (Maybe a)) +resolveOrWarn :: Text + -> (Path Abs Dir -> String -> RIO Ctx (Maybe a)) -> FilePath.FilePath - -> m (Maybe a) + -> RIO Ctx (Maybe a) resolveOrWarn subject resolver path = do cwd <- liftIO getCurrentDir file <- asks ctxFile @@ -1428,17 +1415,15 @@ resolveOrWarn subject resolver path = -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m) - => FilePath.FilePath - -> m (Maybe (Path Abs File)) +resolveFileOrWarn :: FilePath.FilePath + -> RIO Ctx (Maybe (Path Abs File)) resolveFileOrWarn = resolveOrWarn "File" f where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveDirOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m) - => FilePath.FilePath - -> m (Maybe (Path Abs Dir)) +resolveDirOrWarn :: FilePath.FilePath + -> RIO Ctx (Maybe (Path Abs Dir)) resolveDirOrWarn = resolveOrWarn "Directory" f where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index ebdbd08d36..e7d17fa733 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -48,43 +48,41 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Directory (getDirectoryContents, doesFileExist) -import System.Process.Read +import System.Process (readProcess) -- FIXME confirm that this is correct +import RIO.Process hiding (readProcess) -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a + -> ConduitM Text Void (RIO env) a + -> RIO env a ghcPkgDump = ghcPkgCmdArgs ["dump"] -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe - :: (MonadUnliftIO m, MonadLogger m) + :: HasEnvOverride env => PackageName - -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a + -> ConduitM Text Void (RIO env) a + -> RIO env a ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName] -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs - :: (MonadUnliftIO m, MonadLogger m) + :: HasEnvOverride env => [String] - -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a -ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do + -> ConduitM Text Void (RIO env) a + -> RIO env a +ghcPkgCmdArgs cmd wc mpkgDbs sink = do case reverse mpkgDbs of - (pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead? + (pkgDb:_) -> createDatabase wc pkgDb -- TODO maybe use some retry logic instead? _ -> return () - sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink' + sinkProcessStdout (ghcPkgExeName wc) args sink' where args = concat [ case mpkgDbs of @@ -94,7 +92,7 @@ ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do , cmd , ["--expand-pkgroot"] ] - sink' = CT.decodeUtf8 =$= sink + sink' = CT.decodeUtf8 .| sink -- | Create a new, empty @InstalledCache@ newInstalledCache :: MonadIO m => m InstalledCache @@ -102,14 +100,13 @@ newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Ma -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: (MonadLogger m, MonadUnliftIO m) - => Path Abs File -> m InstalledCache +loadInstalledCache :: HasLogFunc env => Path Abs File -> RIO env InstalledCache loadInstalledCache path = do m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty) liftIO $ InstalledCache <$> newIORef m -- | Save a @InstalledCache@ to disk -saveInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> InstalledCache -> m () +saveInstalledCache :: HasLogFunc env => Path Abs File -> InstalledCache -> RIO env () saveInstalledCache path (InstalledCache ref) = liftIO (readIORef ref) >>= $(versionedEncodeFile installedCacheVC) path @@ -160,7 +157,7 @@ sinkMatching :: Monad m -> Bool -- ^ require haddock? -> Bool -- ^ require debugging symbols? -> Map PackageName Version -- ^ allowed versions - -> Consumer (DumpPackage Bool Bool Bool) + -> ConduitM (DumpPackage Bool Bool Bool) o m (Map PackageName (DumpPackage Bool Bool Bool)) sinkMatching reqProfiling reqHaddock reqSymbols allowed = do @@ -168,7 +165,7 @@ sinkMatching reqProfiling reqHaddock reqSymbols allowed = do (not reqProfiling || dpProfiling dp) && (not reqHaddock || dpHaddock dp) && (not reqSymbols || dpSymbols dp)) - =$= CL.consume + .| CL.consume return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps id dpGhcPkgId @@ -184,7 +181,7 @@ sinkMatching reqProfiling reqHaddock reqSymbols allowed = do -- | Add profiling information to the stream of @DumpPackage@s addProfiling :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage Bool b c) + -> ConduitM (DumpPackage a b c) (DumpPackage Bool b c) m () addProfiling (InstalledCache ref) = CL.mapM go where @@ -219,7 +216,7 @@ isProfiling content lib = -- | Add haddock information to the stream of @DumpPackage@s addHaddock :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage a Bool c) + -> ConduitM (DumpPackage a b c) (DumpPackage a Bool c) m () addHaddock (InstalledCache ref) = CL.mapM go where @@ -242,7 +239,7 @@ addHaddock (InstalledCache ref) = -- | Add debugging symbol information to the stream of @DumpPackage@s addSymbols :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage a b Bool) + -> ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m () addSymbols (InstalledCache ref) = CL.mapM go where @@ -313,9 +310,9 @@ instance Show PackageDumpException where -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m - => Conduit Text m (DumpPackage () () ()) -conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do - pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume + => ConduitM Text (DumpPackage () () ()) m () +conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do + pairs <- eachPair (\k -> (k, ) <$> CL.consume) .| CL.consume let m = Map.fromList pairs let parseS k = case Map.lookup k m of @@ -397,10 +394,10 @@ type Line = Text -- | Apply the given Sink to each section of output, broken by a single line containing --- eachSection :: Monad m - => Sink Line m a - -> Conduit Text m a + => ConduitM Line Void m a + -> ConduitM Text a m () eachSection inner = - CL.map (T.filter (/= '\r')) =$= CT.lines =$= start + CL.map (T.filter (/= '\r')) .| CT.lines .| start where peekText = await >>= maybe (return Nothing) (\bs -> @@ -411,22 +408,22 @@ eachSection inner = start = peekText >>= maybe (return ()) (const go) go = do - x <- toConsumer $ takeWhileC (/= "---") =$= inner + x <- toConsumer $ takeWhileC (/= "---") .| inner yield x CL.drop 1 start -- | Grab each key/value pair eachPair :: Monad m - => (Text -> Sink Line m a) - -> Conduit Line m a + => (Text -> ConduitM Line Void m a) + -> ConduitM Line a m () eachPair inner = start where start = await >>= maybe (return ()) start' start' bs1 = - toConsumer (valSrc =$= inner key) >>= yield >> start + toConsumer (valSrc .| inner key) >>= yield >> start where (key, bs2) = T.break (== ':') bs1 (spaces, bs3) = T.span (== ' ') $ T.drop 1 bs2 @@ -461,7 +458,7 @@ eachPair inner = (spaces, val) = T.splitAt i bs -- | General purpose utility -takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a +takeWhileC :: Monad m => (a -> Bool) -> ConduitM a a m () takeWhileC f = loop where diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 50defcc483..c74cd740d3 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -24,11 +24,16 @@ module Stack.PackageIndex , getPackageCaches , getPackageVersions , lookupPackageVersions + , CabalLoader (..) + , HasCabalLoader (..) + , configPackageIndex + , configPackageIndexRoot ) where import qualified Codec.Archive.Tar as Tar import Stack.Prelude import Data.Aeson.Extended +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import Data.Conduit.Zlib (ungzip) import qualified Data.List.NonEmpty as NE @@ -48,19 +53,19 @@ import qualified Hackage.Security.Util.Pretty as HS import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Download import Network.URI (parseURI) -import Path (toFilePath, parseAbsFile) +import Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (), parseRelDir) import Path.Extra (tryGetModificationTime) import Path.IO -import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName +import Stack.Types.Runner (HasRunner) import Stack.Types.Version import qualified System.Directory as D import System.FilePath ((<.>)) -- | Populate the package index caches and return them. -populateCache :: HasConfig env => PackageIndex -> RIO env (PackageCache ()) +populateCache :: HasCabalLoader env => PackageIndex -> RIO env (PackageCache ()) populateCache index = do requireIndex index -- This uses full on lazy I/O instead of ResourceT to provide some @@ -222,20 +227,21 @@ instance Show PackageIndexException where ] -- | Require that an index be present, updating if it isn't. -requireIndex :: HasConfig env => PackageIndex -> RIO env () +requireIndex :: HasCabalLoader env => PackageIndex -> RIO env () requireIndex index = do tarFile <- configPackageIndex $ indexName index exists <- doesFileExist tarFile unless exists $ updateIndex index -- | Update all of the package indices -updateAllIndices :: HasConfig env => RIO env () +updateAllIndices :: HasCabalLoader env => RIO env () updateAllIndices = do clearPackageCaches - view packageIndicesL >>= mapM_ updateIndex + cl <- view cabalLoaderL + mapM_ updateIndex (clIndices cl) -- | Update the index tarball -updateIndex :: HasConfig env => PackageIndex -> RIO env () +updateIndex :: HasCabalLoader env => PackageIndex -> RIO env () updateIndex index = do let name = indexName index url = indexLocation index @@ -260,7 +266,7 @@ updateIndex index = runConduit $ src .| sink -- | Update the index tarball via HTTP -updateIndexHTTP :: HasConfig env +updateIndexHTTP :: HasCabalLoader env => IndexName -> Text -- ^ url -> RIO env () @@ -285,13 +291,13 @@ updateIndexHTTP indexName' url = do liftIO $ do withSourceFile (toFilePath gz) $ \input -> - withSinkFile tmp $ \output -> + withSinkFile tmp $ \output -> -- FIXME use withSinkFileCautious runConduit $ input .| ungzip .| output renameFile tmpPath tar -- | Update the index tarball via Hackage Security updateIndexHackageSecurity - :: HasConfig env + :: HasCabalLoader env => IndexName -> Text -- ^ base URL -> HackageSecurity @@ -348,7 +354,7 @@ updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = d -- but exited before deleting the cache. -- -- See https://github.com/commercialhaskell/stack/issues/3033 -packageIndexNotUpdated :: HasConfig env => IndexName -> RIO env () +packageIndexNotUpdated :: HasCabalLoader env => IndexName -> RIO env () packageIndexNotUpdated indexName' = do mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName' mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName' @@ -362,7 +368,7 @@ packageIndexNotUpdated indexName' = do _ -> logInfo "No updates to your package index were found" -- | Delete the package index cache -deleteCache :: HasConfig env => IndexName -> RIO env () +deleteCache :: HasCabalLoader env => IndexName -> RIO env () deleteCache indexName' = do fp <- configPackageIndexCache indexName' eres <- liftIO $ tryIO $ removeFile fp @@ -373,8 +379,8 @@ deleteCache indexName' = do -- | Get the known versions for a given package from the package caches. -- -- See 'getPackageCaches' for performance notes. -getPackageVersions :: HasConfig env => PackageName -> RIO env (Set Version) -getPackageVersions pkgName = fmap (lookupPackageVersions pkgName) getPackageCaches +getPackageVersions :: HasCabalLoader env => PackageName -> RIO env (Set Version) +getPackageVersions pkgName = lookupPackageVersions pkgName <$> getPackageCaches lookupPackageVersions :: PackageName -> PackageCache index -> Set Version lookupPackageVersions pkgName (PackageCache m) = @@ -384,14 +390,14 @@ lookupPackageVersions pkgName (PackageCache m) = -- -- This has two levels of caching: in memory, and the on-disk cache. So, -- feel free to call this function multiple times. -getPackageCaches :: HasConfig env => RIO env (PackageCache PackageIndex) +getPackageCaches :: HasCabalLoader env => RIO env (PackageCache PackageIndex) getPackageCaches = do - config <- view configL - mcached <- liftIO $ readIORef (configPackageCache config) + cl <- view cabalLoaderL + mcached <- readIORef (clCache cl) case mcached of Just cached -> return cached Nothing -> do - result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do + result <- liftM mconcat $ forM (clIndices cl) $ \index -> do fp <- configPackageIndexCache (indexName index) PackageCache pis <- $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8=" @@ -399,15 +405,81 @@ getPackageCaches = do fp (populateCache index) return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis) - liftIO $ writeIORef (configPackageCache config) (Just result) + liftIO $ writeIORef (clCache cl) (Just result) return result -- | Clear the in-memory hackage index cache. This is needed when the -- hackage index is updated. -clearPackageCaches :: HasConfig env => RIO env () +clearPackageCaches :: HasCabalLoader env => RIO env () clearPackageCaches = do - cacheRef <- view $ configL.to configPackageCache - liftIO $ writeIORef cacheRef Nothing + cl <- view cabalLoaderL + writeIORef (clCache cl) Nothing + +class HasRunner env => HasCabalLoader env where + cabalLoaderL :: Lens' env CabalLoader + +data CabalLoader = CabalLoader + { clCache :: !(IORef (Maybe (PackageCache PackageIndex))) + , clIndices :: ![PackageIndex] + -- ^ Information on package indices. This is left biased, meaning that + -- packages in an earlier index will shadow those in a later index. + -- + -- Warning: if you override packages in an index vs what's available + -- upstream, you may correct your compiled snapshots, as different + -- projects may have different definitions of what pkg-ver means! This + -- feature is primarily intended for adding local packages, not + -- overriding. Overriding is better accomplished by adding to your + -- list of packages. + -- + -- Note that indices specified in a later config file will override + -- previous indices, /not/ extend them. + -- + -- Using an assoc list instead of a Map to keep track of priority + , clStackRoot :: !(Path Abs Dir) + -- ^ ~/.stack more often than not + , clUpdateRef :: !(MVar Bool) + -- ^ Want to try updating the index once during a single run for missing + -- package identifiers. We also want to ensure we only update once at a + -- time. Start at @True@. + -- + -- TODO: probably makes sense to move this concern into getPackageCaches + , clConnectionCount :: !Int + -- ^ How many concurrent connections are allowed when downloading + , clIgnoreRevisionMismatch :: !Bool + -- ^ Ignore a revision mismatch when loading up cabal files, + -- and fall back to the latest revision. See: + -- + } + +-- | Root for a specific package index +configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir) +configPackageIndexRoot (IndexName name) = do + cl <- view cabalLoaderL + let root = clStackRoot cl + dir <- parseRelDir $ B8.unpack name + return (root $(mkRelDir "indices") dir) + +-- | Location of the 01-index.tar file +configPackageIndex :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndex name = ( $(mkRelFile "01-index.tar")) <$> configPackageIndexRoot name + +-- | Location of the 01-index.cache file +configPackageIndexCache :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexCache name = ( $(mkRelFile "01-index.cache")) <$> configPackageIndexRoot name + +-- | Location of the 00-index.cache file +configPackageIndexCacheOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot + +-- | Location of the 00-index.tar file. This file is just a copy of +-- the 01-index.tar file, provided for tools which still look for the +-- 00-index.tar file. +configPackageIndexOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot + +-- | Location of the 01-index.tar.gz file +configPackageIndexGz :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot --------------- Lifted from cabal-install, Distribution.Client.Tar: -- | Return the number of blocks in an entry. diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs index dada157aad..954e6baaa9 100644 --- a/src/Stack/PackageLocation.hs +++ b/src/Stack/PackageLocation.hs @@ -38,8 +38,7 @@ import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.PackageIdentifier import qualified System.Directory as Dir -import System.Process.Read -import System.Process.Run +import RIO.Process -- | Same as 'resolveMultiPackageLocation', but works on a -- 'SinglePackageLocation'. @@ -202,31 +201,24 @@ cloneRepo projRoot url commit repoType' = do exists <- doesDirExist dir unless exists $ do liftIO $ ignoringAbsence (removeDirRecur dir) - menv <- getMinimalEnvOverride - let cloneAndExtract commandName cloneArgs resetCommand = do + let cloneAndExtract commandName cloneArgs resetCommand = withWorkingDir root $ do ensureDir root logInfo $ "Cloning " <> commit <> " from " <> url - callProcessInheritStderrStdout Cmd - { cmdDirectoryToRunIn = Just root - , cmdCommandToRun = commandName - , cmdEnvOverride = menv - , cmdCommandLineArguments = - "clone" : + withProc commandName + ("clone" : cloneArgs ++ [ T.unpack url , toFilePathNoTrailingSep dir - ] - } + ]) runProcess_ created <- doesDirExist dir unless created $ throwM $ FailedToCloneRepo commandName - readProcessNull (Just dir) menv commandName + withWorkingDir dir $ readProcessNull commandName (resetCommand ++ [T.unpack commit, "--"]) - `catch` \case - ex@ProcessFailed{} -> do + `catchAny` \case + ex -> do logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url throwM ex - ex -> throwM ex case repoType' of RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] @@ -239,15 +231,14 @@ cloneRepo projRoot url commit repoType' = do parseSingleCabalFileIndex :: forall env. HasConfig env - => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index - -> Path Abs Dir -- ^ project root, used for checking out necessary files + => Path Abs Dir -- ^ project root, used for checking out necessary files -> PackageLocationIndex FilePath -> RIO env GenericPackageDescription -- Need special handling of PLIndex for efficiency (just read from the -- index tarball) and correctness (get the cabal file from the index, -- not the package tarball itself, yay Hackage revisions). -parseSingleCabalFileIndex loadFromIndex _ (PLIndex pir) = readPackageUnresolvedIndex loadFromIndex pir -parseSingleCabalFileIndex _ root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc +parseSingleCabalFileIndex _ (PLIndex pir) = readPackageUnresolvedIndex pir +parseSingleCabalFileIndex root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc parseSingleCabalFile :: forall env. HasConfig env @@ -284,13 +275,12 @@ parseMultiCabalFiles root printWarnings loc0 = -- | 'parseMultiCabalFiles' but supports 'PLIndex' parseMultiCabalFilesIndex :: forall env. HasConfig env - => (PackageIdentifierRevision -> IO ByteString) - -> Path Abs Dir -- ^ project root, used for checking out necessary files + => Path Abs Dir -- ^ project root, used for checking out necessary files -> PackageLocationIndex Subdirs -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)] -parseMultiCabalFilesIndex loadFromIndex _root (PLIndex pir) = +parseMultiCabalFilesIndex _root (PLIndex pir) = (pure . (, PLIndex pir)) <$> - readPackageUnresolvedIndex loadFromIndex pir -parseMultiCabalFilesIndex _ root (PLOther loc0) = + readPackageUnresolvedIndex pir +parseMultiCabalFilesIndex root (PLOther loc0) = map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$> parseMultiCabalFiles root False loc0 diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index d0ea3583b3..922954682a 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -20,19 +20,19 @@ import Path.Extra import Stack.Constants import Stack.Constants.Config import Stack.GhcPkg as GhcPkg +import Stack.PackageIndex (HasCabalLoader (..)) import Stack.Types.Config import Stack.Types.Runner import qualified System.FilePath as FP import System.IO (stderr) -import System.Process.Read (EnvOverride(eoPath)) +import RIO.Process (EnvOverride(eoPath), HasEnvOverride (..)) -- | Print out useful path information in a human-readable format (and -- support others later). path - :: (MonadUnliftIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, - MonadLogger m) + :: HasEnvConfig env => [Text] - -> m () + -> RIO env () path keys = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. @@ -42,12 +42,11 @@ path keys = -- global GHC. -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. -- So it's not the *minimal* override path. - menv <- getMinimalEnvOverride snap <- packageDatabaseDeps plocal <- packageDatabaseLocal extra <- packageDatabaseExtra whichCompiler <- view $ actualCompilerVersionL.whichCompilerL - global <- GhcPkg.getGlobalDB menv whichCompiler + global <- GhcPkg.getGlobalDB whichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal toolsDir <- bindirCompilerTools @@ -78,7 +77,6 @@ path keys = path' (PathInfo bc - menv snap plocal global @@ -103,7 +101,6 @@ pathParser = -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo { piBuildConfig :: BuildConfig - , piEnvOverride :: EnvOverride , piSnapDb :: Path Abs Dir , piLocalDb :: Path Abs Dir , piGlobalDb :: Path Abs Dir @@ -122,6 +119,10 @@ instance HasLogFunc PathInfo where instance HasRunner PathInfo where runnerL = configL.runnerL instance HasConfig PathInfo +instance HasCabalLoader PathInfo where + cabalLoaderL = configL.cabalLoaderL +instance HasEnvOverride PathInfo where + envOverrideL = configL.envOverrideL instance HasBuildConfig PathInfo where buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y }) . buildConfigL @@ -148,7 +149,7 @@ paths = , view $ stackYamlL.to toFilePath.to T.pack) , ( "PATH environment variable" , "bin-path" - , T.pack . intercalate [FP.searchPathSeparator] . eoPath . piEnvOverride ) + , T.pack . intercalate [FP.searchPathSeparator] . eoPath . view envOverrideL ) , ( "Install location for GHC and other core tools" , "programs" , view $ configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack) diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 9164dd9a8c..538e6afc9c 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -1,150 +1,34 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stack.Prelude - ( mapLeft - , withSourceFile + ( withSourceFile , withSinkFile , withSinkFileCautious - , withLazyFile - , NoLogging (..) , withSystemTempDir - , fromFirst - , mapMaybeA - , mapMaybeM - , forMaybeA - , forMaybeM - , stripCR - , logSticky - , logStickyDone - , RIO (..) - , runRIO - , HasLogFunc (..) + , sinkProcessStderrStdout + , sinkProcessStdout + , logProcessStderrStdout , module X ) where -import Control.Applicative as X (Alternative, Applicative (..), - liftA, liftA2, liftA3, many, - optional, some, (<|>)) -import Control.Arrow as X (first, second, (&&&), (***)) -import Control.DeepSeq as X (NFData (..), force, ($!!)) -import Control.Monad as X (Monad (..), MonadPlus (..), filterM, - foldM, foldM_, forever, guard, join, - liftM, liftM2, replicateM_, unless, - when, zipWithM, zipWithM_, (<$!>), - (<=<), (=<<), (>=>)) -import Control.Monad.Catch as X (MonadThrow (..)) -import Control.Monad.Logger.CallStack - as X (Loc, LogLevel (..), LogSource, - LogStr, MonadLogger (..), - MonadLoggerIO (..), liftLoc, - logDebug, logError, logInfo, - logOther, logWarn, toLogStr) -import Control.Monad.Reader as X (MonadReader, MonadTrans (..), - ReaderT (..), ask, asks) -import Data.Bool as X (Bool (..), not, otherwise, (&&), - (||)) -import Data.ByteString as X (ByteString) -import Data.Char as X (Char) -import Data.Conduit as X (ConduitM, runConduit, (.|)) -import Data.Data as X (Data (..)) -import Data.Either as X (Either (..), either, isLeft, - isRight, lefts, partitionEithers, - rights) -import Data.Eq as X (Eq (..)) -import Data.Foldable as X (Foldable, all, and, any, asum, - concat, concatMap, elem, fold, - foldMap, foldl', foldr, forM_, for_, - length, mapM_, msum, notElem, null, - or, product, sequenceA_, sequence_, - sum, toList, traverse_) -import Data.Function as X (const, fix, flip, id, on, ($), (&), - (.)) -import Data.Functor as X (Functor (..), void, ($>), (<$), - (<$>)) -import Data.Hashable as X (Hashable) -import Data.HashMap.Strict as X (HashMap) -import Data.HashSet as X (HashSet) -import Data.Int as X -import Data.IntMap.Strict as X (IntMap) -import Data.IntSet as X (IntSet) -import Data.List as X (break, drop, dropWhile, filter, - lines, lookup, map, replicate, - reverse, span, take, takeWhile, - unlines, unwords, words, zip, (++)) -import Data.Map.Strict as X (Map) -import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe, - isJust, isNothing, listToMaybe, - mapMaybe, maybe, maybeToList) -import Data.Monoid as X (All (..), Any (..), Endo (..), - First (..), Last (..), Monoid (..), - Product (..), Sum (..), (<>)) -import Data.Ord as X (Ord (..), Ordering (..), comparing) -import Data.Set as X (Set) -import Data.Store as X (Store) -import Data.String as X (IsString (..)) -import Data.Text as X (Text) -import Data.Traversable as X (Traversable (..), for, forM) -import Data.Vector as X (Vector) -import Data.Void as X (Void, absurd) -import Data.Word as X -import GHC.Generics as X (Generic) -import GHC.Stack as X (HasCallStack) -import Lens.Micro as X (Getting) -import Lens.Micro.Mtl as X (view) +import RIO as X import Path as X (Abs, Dir, File, Path, Rel, toFilePath) -import Prelude as X (Bounded (..), Double, Enum, - FilePath, Float, Floating (..), - Fractional (..), IO, Integer, - Integral (..), Num (..), Rational, - Real (..), RealFloat (..), - RealFrac (..), Show, String, - asTypeOf, curry, error, even, - fromIntegral, fst, gcd, lcm, odd, - realToFrac, seq, show, snd, - subtract, uncurry, undefined, ($!), - (^), (^^)) -import Text.Read as X (Read, readMaybe) -import UnliftIO as X - -import qualified Data.Text as T import qualified Path.IO -import Data.Conduit.Binary (sourceHandle, sinkHandle) -import qualified Data.ByteString.Lazy as BL - import qualified System.IO as IO import qualified System.Directory as Dir import qualified System.FilePath as FP import System.IO.Error (isDoesNotExistError) -mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b -mapLeft f (Left a1) = Left (f a1) -mapLeft _ (Right b) = Right b - -fromFirst :: a -> First a -> a -fromFirst x = fromMaybe x . getFirst - --- | Applicative 'mapMaybe'. -mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] -mapMaybeA f = fmap catMaybes . traverse f - --- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@ -forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b] -forMaybeA = flip mapMaybeA - --- | Monadic 'mapMaybe'. -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = liftM catMaybes . mapM f - --- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@ -forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] -forMaybeM = flip mapMaybeM - --- | Strip trailing carriage return from Text -stripCR :: T.Text -> T.Text -stripCR t = fromMaybe t (T.stripSuffix "\r" t) +import Data.Conduit.Binary (sourceHandle, sinkHandle) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed (withLoggedProcess_, createSource) +import RIO.Process (HasEnvOverride, setStdin, closed, getStderr, getStdout, withProc, withProcess_, setStdout, setStderr) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) -- | Get a source for a file. Unlike @sourceFile@, doesn't require -- @ResourceT@. Unlike explicit @withBinaryFile@ and @sourceHandle@ @@ -176,73 +60,54 @@ withSinkFileCautious fp inner = then return () else throwIO e --- | Lazily get the contents of a file. Unlike 'BL.readFile', this --- ensures that if an exception is thrown, the file handle is closed --- immediately. -withLazyFile :: MonadUnliftIO m => FilePath -> (BL.ByteString -> m a) -> m a -withLazyFile fp inner = withBinaryFile fp ReadMode $ inner <=< liftIO . BL.hGetContents - --- | Avoid orphan messes -newtype NoLogging a = NoLogging { runNoLogging :: IO a } - deriving (Functor, Applicative, Monad, MonadIO) -instance MonadUnliftIO NoLogging where - askUnliftIO = NoLogging $ - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . runNoLogging)) -instance MonadLogger NoLogging where - monadLoggerLog _ _ _ _ = return () - -- | Path version withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner --- | Write a "sticky" line to the terminal. Any subsequent lines will --- overwrite this one, and that same line will be repeated below --- again. In other words, the line sticks at the bottom of the output --- forever. Running this function again will replace the sticky line --- with a new sticky line. When you want to get rid of the sticky --- line, run 'logStickyDone'. --- -logSticky :: MonadLogger m => Text -> m () -logSticky = - logOther (LevelOther "sticky") - --- | This will print out the given message with a newline and disable --- any further stickiness of the line until a new call to 'logSticky' --- happens. --- --- It might be better at some point to have a 'runSticky' function --- that encompasses the logSticky->logStickyDone pairing. -logStickyDone :: MonadLogger m => Text -> m () -logStickyDone = - logOther (LevelOther "sticky-done") - --- | The Reader+IO monad. This is different from a 'ReaderT' because: +-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers. -- --- * It's not a transformer, it hardcodes IO for simpler usage and --- error messages. +-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. +sinkProcessStderrStdout + :: forall e o env. HasEnvOverride env + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> ConduitM ByteString Void (RIO env) e -- ^ Sink for stderr + -> ConduitM ByteString Void (RIO env) o -- ^ Sink for stdout + -> RIO env (e,o) +sinkProcessStderrStdout name args sinkStderr sinkStdout = + withProc name args $ \pc0 -> do + let pc = setStdin closed + $ setStdout createSource + $ setStderr createSource + pc0 + withProcess_ pc $ \p -> + runConduit (getStderr p .| sinkStderr) `concurrently` + runConduit (getStdout p .| sinkStdout) + +-- | Consume the stdout of a process feeding strict 'ByteString's to a consumer. +-- 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'. -- --- * Instances of typeclasses like 'MonadLogger' are implemented using --- classes defined on the environment, instead of using an --- underlying monad. -newtype RIO env a = RIO { unRIO :: ReaderT env IO a } - deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow) - -runRIO :: MonadIO m => env -> RIO env a -> m a -runRIO env (RIO (ReaderT f)) = liftIO (f env) - -class HasLogFunc env where - logFuncL :: Getting r env (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -instance HasLogFunc env => MonadLogger (RIO env) where - monadLoggerLog a b c d = do - f <- view logFuncL - liftIO $ f a b c $ toLogStr d - -instance HasLogFunc env => MonadLoggerIO (RIO env) where - askLoggerIO = view logFuncL - -instance MonadUnliftIO (RIO env) where - askUnliftIO = RIO $ ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unRIO)) +-- Throws a 'ReadProcessException' if unsuccessful. +sinkProcessStdout + :: HasEnvOverride env + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout + -> RIO env a +sinkProcessStdout name args sinkStdout = + withProc name args $ \pc -> + withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently + $ Concurrently (runConduit $ getStderr p .| CL.sinkNull) + *> Concurrently (runConduit $ getStdout p .| sinkStdout) + +logProcessStderrStdout + :: (HasCallStack, HasEnvOverride env) + => String + -> [String] + -> RIO env () +logProcessStderrStdout name args = do + let logLines = CB.lines .| CL.mapM_ (logInfo . decodeUtf8With lenientDecode) + ((), ()) <- sinkProcessStderrStdout name args logLines logLines + return () diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index 91dfb08a05..2aaa536113 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -37,8 +37,7 @@ module Stack.PrettyPrint import Stack.Prelude import Data.List (intersperse) import qualified Data.Text as T -import Stack.Types.Config -import Stack.Types.Package +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner @@ -48,7 +47,7 @@ import Text.PrettyPrint.Leijen.Extended displayWithColor :: (HasRunner env, Display a, HasAnsiAnn (Ann a), - MonadReader env m, MonadLogger m) + MonadReader env m, HasLogFunc env, HasCallStack) => a -> m T.Text displayWithColor x = do useAnsi <- liftM logUseColor $ view logOptionsL @@ -58,15 +57,15 @@ displayWithColor x = do -- TODO: switch to using implicit callstacks once 7.8 support is dropped prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b), - MonadReader env m, MonadLogger m) + MonadReader env m, MonadIO m) => LogLevel -> (a -> b) -> a -> m () -prettyWith level f = logOther level <=< displayWithColor . f +prettyWith level f = logGeneric "" level <=< displayWithColor . f -- Note: I think keeping this section aligned helps spot errors, might be -- worth keeping the alignment in place. prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => (a -> Doc AnsiAnn) -> a -> m () prettyDebugWith = prettyWith LevelDebug prettyInfoWith = prettyWith LevelInfo @@ -82,7 +81,7 @@ prettyErrorNoIndentWith f = prettyWith LevelWarn ((line <>) . (styleError "Error:" <+>) . f) prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => Doc AnsiAnn -> m () prettyDebug = prettyDebugWith id prettyInfo = prettyInfoWith id @@ -92,7 +91,7 @@ prettyWarnNoIndent = prettyWarnNoIndentWith id prettyErrorNoIndent = prettyErrorNoIndentWith id prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => [Doc AnsiAnn] -> m () prettyDebugL = prettyDebugWith fillSep prettyInfoL = prettyInfoWith fillSep @@ -102,7 +101,7 @@ prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => String -> m () prettyDebugS = prettyDebugWith flow prettyInfoS = prettyInfoWith flow @@ -128,7 +127,7 @@ wordDocs = map fromString . words flow :: String -> Doc a flow = fillSep . wordDocs -debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m, +debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> m a -> m a debugBracket msg f = do let output = logDebug <=< displayWithColor diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 000145fc2e..d580d2ae75 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -87,7 +87,7 @@ withConfigAndLock -> RIO Config () -> IO () withConfigAndLock go@GlobalOpts{..} inner = loadConfigWithOpts go $ \lc -> do - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> + withUserFileLock go (view stackRootL lc) $ \lk -> runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) @@ -108,7 +108,7 @@ withGlobalConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner globalConfigMonoid Nothing LCSNoProject - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> + withUserFileLock go (view stackRootL lc) $ \_lk -> runRIO (lcConfig lc) inner -- For now the non-locking version just unlocks immediately. @@ -155,7 +155,7 @@ withBuildConfigExt -- installed on the host OS. -> IO () withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = loadConfigWithOpts go $ \lc -> do - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do + withUserFileLock go (view stackRootL lc) $ \lk0 -> do -- A local bit of state for communication between callbacks: curLk <- newIORef lk0 let inner' lk = diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index c92f6ff014..8e89cfea47 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -173,8 +173,7 @@ getCabalLbs pvpBounds mrev cabalfp = do unless (cabalfp == cabalfp') $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp') (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI - menv <- getMinimalEnvOverride - (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts + (installedMap, _, _, _) <- getInstalled GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False , getInstalledSymbols = False @@ -319,16 +318,14 @@ readLocalPackage pkgDir = do getSDistFileList :: HasEnvConfig env => LocalPackage -> RIO env (String, Path Abs File) getSDistFileList lp = withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do - menv <- getMinimalEnvOverride let bopts = defaultBuildOpts let boptsCli = defaultBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli (locals, _) <- loadSourceMap NeedTargets boptsCli - run <- askRunInIO - withExecuteEnv menv bopts boptsCli baseConfigOpts locals + withExecuteEnv bopts boptsCli baseConfigOpts locals [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files $ \ee -> - withSingleContext run ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do + withSingleContext ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal KeepTHLoading ["sdist", "--list-sources", outFile] contents <- liftIO (S.readFile outFile) diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 615861e34d..1990942b08 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -16,7 +16,6 @@ import qualified Data.Text as T import Path import Path.IO import qualified Stack.Build -import Stack.Exec import Stack.GhcPkg (ghcPkgExeName) import Stack.Options.ScriptParser import Stack.Runners @@ -25,7 +24,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.PackageName import System.FilePath (dropExtension, replaceExtension) -import System.Process.Read +import RIO.Process -- | Run a Stack Script scriptCmd :: ScriptOpts -> GlobalOpts -> IO () @@ -38,19 +37,20 @@ scriptCmd opts go' = do , globalStackYaml = SYLNoConfig $ parent file } withBuildConfigAndLock go $ \lk -> do - -- Some warnings in case the user somehow tries to set a - -- stack.yaml location. Note that in this functions we use - -- logError instead of logWarn because, when using the - -- interpreter mode, only error messages are shown. See: - -- https://github.com/commercialhaskell/stack/issues/3007 - case globalStackYaml go' of - SYLOverride fp -> logError $ T.pack - $ "Ignoring override stack.yaml file for script command: " ++ fp - SYLDefault -> return () - SYLNoConfig _ -> assert False (return ()) + -- Some warnings in case the user somehow tries to set a + -- stack.yaml location. Note that in this functions we use + -- logError instead of logWarn because, when using the + -- interpreter mode, only error messages are shown. See: + -- https://github.com/commercialhaskell/stack/issues/3007 + case globalStackYaml go' of + SYLOverride fp -> logError $ T.pack + $ "Ignoring override stack.yaml file for script command: " ++ fp + SYLDefault -> return () + SYLNoConfig _ -> assert False (return ()) - config <- view configL - menv <- liftIO $ configEnvOverride config defaultEnvSettings + config <- view configL + menv <- liftIO $ configEnvOverrideSettings config defaultEnvSettings + withEnvOverride menv $ do wc <- view $ actualCompilerVersionL.whichCompilerL colorFlag <- appropriateGhcColorFlag @@ -71,7 +71,7 @@ scriptCmd opts go' = do -- already. If all needed packages are available, we can -- skip the (rather expensive) build call below. bss <- sinkProcessStdout - Nothing menv (ghcPkgExeName wc) + (ghcPkgExeName wc) ["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy? let installed = Set.fromList $ map toPackageName @@ -101,19 +101,17 @@ scriptCmd opts go' = do ] munlockFile lk -- Unlock before transferring control away. case soCompile opts of - SEInterpret -> exec menv ("run" ++ compilerExeName wc) + SEInterpret -> exec ("run" ++ compilerExeName wc) (ghcArgs ++ toFilePath file : soArgs opts) _ -> do let dir = parent file -- use sinkProcessStdout to ensure a ProcessFailed -- exception is generated for better error messages - sinkProcessStdout - (Just dir) - menv + withWorkingDir dir $ sinkProcessStdout (compilerExeName wc) (ghcArgs ++ [toFilePath file]) CL.sinkNull - exec menv (toExeName $ toFilePath file) (soArgs opts) + exec (toExeName $ toFilePath file) (soArgs opts) where toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d21a8ad1a9..1d69fe0a1d 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -39,13 +39,14 @@ import Control.Monad.State (get, put, modify) import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..)) import Data.Aeson.Extended import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) -import Data.Conduit (Conduit, (=$), await, yield, awaitForever) +import Data.Conduit (await, yield, awaitForever) import Data.Conduit.Lazy (lazyConsume) import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed (eceStderr) import Data.Conduit.Zlib (ungzip) import Data.Foldable (maximumBy) import qualified Data.HashMap.Strict as HashMap @@ -73,7 +74,6 @@ import Stack.Build (build) import Stack.Config (loadConfig) import Stack.Constants (stackProgName) import Stack.Constants.Config (distRelativeDir) -import Stack.Exec (defaultEnvSettings) import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) import Stack.Prelude @@ -96,10 +96,8 @@ import System.IO (stdout) import System.IO.Error (isPermissionError) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP -import System.Process (rawSystem) -import System.Process.Log (withProcessTimeLog) -import System.Process.Read -import System.Process.Run (runCmd, Cmd(..)) +import System.Process (rawSystem) -- FIXME remove usage +import RIO.Process import Text.Printf (printf) #if !WINDOWS @@ -147,7 +145,7 @@ data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] | UnknownCompilerVersion (Set.Set Text) (CompilerVersion 'CVWanted) (Set.Set (CompilerVersion 'CVActual)) | UnknownOSKey Text - | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) + | GHCSanityCheckCompileFailed SomeException (Path Abs File) | WantedMustBeGHC | RequireCustomGHCVariant | ProblemWhileDecompressing (Path Abs File) @@ -242,15 +240,15 @@ setupEnv mResolveMissingGHC = do -- Modify the initial environment to include the GHC path, if a local GHC -- is being used - menv0 <- getMinimalEnvOverride + menv0 <- view envOverrideL env <- removeHaskellEnvVars <$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0) - menv <- mkEnvOverride platform env + menv <- mkEnvOverride env - (compilerVer, cabalVer, globaldb) <- runConcurrently $ (,,) - <$> Concurrently (getCompilerVersion menv wc) - <*> Concurrently (getCabalPkgVer menv wc) - <*> Concurrently (getGlobalDB menv wc) + (compilerVer, cabalVer, globaldb) <- withEnvOverride menv $ runConcurrently $ (,,) + <$> Concurrently (getCompilerVersion wc) + <*> Concurrently (getCabalPkgVer wc) + <*> Concurrently (getGlobalDB wc) logDebug "Resolving package entries" packagesRef <- liftIO $ newIORef Nothing @@ -260,7 +258,7 @@ setupEnv mResolveMissingGHC = do -- that GHC can be found on. This is needed for looking up global -- package information in loadSnapshot. let bcPath :: BuildConfig - bcPath = set envOverrideL (const (return menv)) bc + bcPath = set envOverrideL menv bc ls <- runRIO bcPath $ loadSnapshot (Just compilerVer) @@ -282,9 +280,9 @@ setupEnv mResolveMissingGHC = do localsPath <- augmentPath (mkDirs True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 - createDatabase menv wc deps + withEnvOverride menv $ createDatabase wc deps localdb <- runReaderT packageDatabaseLocal envConfig0 - createDatabase menv wc localdb + withEnvOverride menv $ createDatabase wc localdb extras <- runReaderT packageDatabaseExtra envConfig0 let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb @@ -292,7 +290,7 @@ setupEnv mResolveMissingGHC = do executablePath <- liftIO getExecutablePath - utf8EnvVars <- getUtf8EnvVars menv compilerVer + utf8EnvVars <- withEnvOverride menv $ getUtf8EnvVars compilerVer mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS" @@ -302,7 +300,7 @@ setupEnv mResolveMissingGHC = do case Map.lookup es m of Just eo -> return eo Nothing -> do - eo <- mkEnvOverride platform + eo <- mkEnvOverride $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath) $ (if esIncludeGhcPackagePath es then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es)) @@ -347,11 +345,14 @@ setupEnv mResolveMissingGHC = do (Map.insert es eo m', ()) return eo + envOverride <- liftIO $ getEnvOverride' minimalEnvSettings return EnvConfig { envConfigBuildConfig = bconfig { bcConfig = maybe id addIncludeLib mghcBin - (view configL bconfig) - { configEnvOverride = getEnvOverride' } + $ set envOverrideL envOverride + (view configL bconfig) + { configEnvOverrideSettings = getEnvOverride' + } } , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer @@ -383,14 +384,11 @@ ensureCompiler sopts = do logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" logWarn "" - -- Check the available GHCs - menv0 <- getMinimalEnvOverride - msystem <- if soptsUseSystem sopts then do logDebug "Getting system compiler version" - getSystemCompiler menv0 wc + getSystemCompiler wc else return Nothing Platform expectedArch _ <- view platformL @@ -443,7 +441,7 @@ ensureCompiler sopts = do possibleCompilers <- case wc of Ghc -> do - ghcBuilds <- getGhcBuilds menv0 + ghcBuilds <- getGhcBuilds forM ghcBuilds $ \ghcBuild -> do ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild) @@ -472,7 +470,7 @@ ensureCompiler sopts = do if soptsUseSystem sopts then return False else do - msystemGhc <- getSystemCompiler menv0 wc + msystemGhc <- getSystemCompiler wc return (any (uncurry canUseCompiler) msystemGhc) let suggestion = fromMaybe (mconcat @@ -513,30 +511,32 @@ ensureCompiler sopts = do menv <- case mpaths of - Nothing -> return menv0 + Nothing -> view envOverrideL Just ed -> do - config <- view configL + menv0 <- view envOverrideL m <- augmentPathMap (edBins ed) (unEnvOverride menv0) - mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) + mkEnvOverride (removeHaskellEnvVars m) forM_ (soptsUpgradeCabal sopts) $ \version -> do unless needLocal $ do logWarn "Trying to change a Cabal library on a GHC not installed by stack." logWarn "This may fail, caveat emptor!" - upgradeCabal menv wc version + withEnvOverride menv $ upgradeCabal wc version case mtools of - Just (Just (ToolGhcjs cv), _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) + Just (Just (ToolGhcjs cv), _) -> + withEnvOverride menv + $ ensureGhcjsBooted cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) _ -> return () - when (soptsSanityCheck sopts) $ sanityCheck menv wc + when (soptsSanityCheck sopts) $ withEnvOverride menv $ sanityCheck wc return (mpaths, compilerBuild, needLocal) -- | Determine which GHC builds to use depending on which shared libraries are available -- on the system. -getGhcBuilds :: HasConfig env => EnvOverride -> RIO env [CompilerBuild] -getGhcBuilds menv = do +getGhcBuilds :: HasConfig env => RIO env [CompilerBuild] +getGhcBuilds = do config <- view configL case configGHCBuild config of @@ -566,14 +566,18 @@ getGhcBuilds menv = do case platform of Platform _ Cabal.Linux -> do -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well - sbinEnv <- modifyEnvOverride menv $ - Map.insert "PATH" $ - "/sbin:/usr/sbin" <> - maybe "" (":" <>) (Map.lookup "PATH" (eoTextMap menv)) - eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"] + let sbinEnv m = Map.insert + "PATH" + ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m)) + m + eldconfigOut + <- withModifyEnvOverride sbinEnv + $ withProc "ldconfig" ["-p"] + $ tryAny . readProcessStdout_ let firstWords = case eldconfigOut of Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $ - T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut + T.lines $ T.decodeUtf8With T.lenientDecode + $ LBS.toStrict ldconfigOut Left _ -> [] checkLib lib | libT `elem` firstWords = do @@ -636,7 +640,7 @@ mungeRelease = intercalate "-" . prefixMaj . splitOn "." prefixMaj = prefixFst "maj" prefixMin prefixMin = prefixFst "min" (map ('r':)) -sysRelease :: (MonadUnliftIO m, MonadLogger m) => m String +sysRelease :: HasLogFunc env => RIO env String sysRelease = handleIO (\e -> do logWarn $ T.concat [ T.pack "Could not query OS version" @@ -668,19 +672,18 @@ ensureDockerStackExe containerPlatform = do -- | Install the newest version or a specific version of Cabal globally upgradeCabal :: (HasConfig env, HasGHCVariant env) - => EnvOverride - -> WhichCompiler + => WhichCompiler -> UpgradeTo -> RIO env () -upgradeCabal menv wc upgradeTo = do +upgradeCabal wc upgradeTo = do logInfo "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") rmap <- resolvePackages Nothing mempty (Set.singleton name) - installed <- getCabalPkgVer menv wc + installed <- getCabalPkgVer wc case upgradeTo of Specific wantedVersion -> do if installed /= wantedVersion then - doCabalInstall menv wc installed wantedVersion + doCabalInstall wc installed wantedVersion else logInfo $ T.concat ["No install necessary. Cabal " , T.pack $ versionString installed @@ -689,7 +692,7 @@ upgradeCabal menv wc upgradeTo = do [] -> throwString "No Cabal library found in index, cannot upgrade" [PackageIdentifier name' latestVersion] | name == name' -> do if installed < latestVersion then - doCabalInstall menv wc installed latestVersion + doCabalInstall wc installed latestVersion else logInfo $ T.concat [ "No upgrade necessary: Cabal-" @@ -701,12 +704,11 @@ upgradeCabal menv wc upgradeTo = do -- Configure and run the necessary commands for a cabal install doCabalInstall :: (HasConfig env, HasGHCVariant env) - => EnvOverride - -> WhichCompiler + => WhichCompiler -> Version -> Version -> RIO env () -doCabalInstall menv wc installed wantedVersion = do +doCabalInstall wc installed wantedVersion = do withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do logInfo $ T.concat [ "Installing Cabal-" @@ -717,6 +719,7 @@ doCabalInstall menv wc installed wantedVersion = do let name = $(mkPackageName "Cabal") ident = PackageIdentifier name wantedVersion m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest] + menv <- view envOverrideL compilerPath <- join $ findExecutable menv (compilerExeName wc) versionDir <- parseRelDir $ versionString wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) @@ -725,7 +728,7 @@ doCabalInstall menv wc installed wantedVersion = do dir <- case Map.lookup ident m of Nothing -> error "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir - runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing + withWorkingDir dir $ withProc (compilerExeName wc) ["Setup.hs"] runProcess_ platform <- view platformL let setupExe = toFilePath $ dir case platform of Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") @@ -736,35 +739,36 @@ doCabalInstall menv wc installed wantedVersion = do , installRoot FP. name' ] args = "configure" : map dirArgument (words "lib bin data doc") - runCmd (Cmd (Just dir) setupExe menv args) Nothing - runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing - runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing + withWorkingDir dir $ do + withProc setupExe args runProcess_ + withProc setupExe ["build"] runProcess_ + withProc setupExe ["install"] runProcess_ logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available getSystemCompiler - :: HasLogFunc env - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> RIO env (Maybe (CompilerVersion 'CVActual, Arch)) -getSystemCompiler menv wc = do +getSystemCompiler wc = do let exeName = case wc of Ghc -> "ghc" Ghcjs -> "ghcjs" + menv <- view envOverrideL exists <- doesExecutableExist menv exeName if exists then do - eres <- tryProcessStdout Nothing menv exeName ["--info"] + eres <- withProc exeName ["--info"] $ tryAny . readProcessStdout_ let minfo = do - Right bs <- Just eres - pairs_ <- readMaybe $ S8.unpack bs :: Maybe [(String, String)] + Right lbs <- Just eres + pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)] version <- lookup "Project version" pairs_ >>= parseVersionFromString arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) case (wc, minfo) of (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch)) (Ghcjs, Just (_, arch)) -> do - eversion <- tryAny $ getCompilerVersion menv Ghcjs + eversion <- tryAny $ getCompilerVersion Ghcjs case eversion of Left _ -> return Nothing Right version -> return (Just (version, arch)) @@ -1050,8 +1054,8 @@ installGHCPosix :: HasConfig env -> RIO env () installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do platform <- view platformL - menv0 <- getMinimalEnvOverride - menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0)) + menv0 <- view envOverrideL + menv <- mkEnvOverride (removeHaskellEnvVars (unEnvOverride menv0)) logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) (zipTool', compOpt) <- case archiveType of @@ -1081,7 +1085,7 @@ installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = let runStep step wd env cmd args = do menv' <- modifyEnvOverride menv (Map.union env) - result <- try (readProcessNull (Just wd) menv' cmd args) + result <- withWorkingDir wd $ withEnvOverride menv' $ try $ readProcessNull cmd args case result of Right _ -> return () Left ex -> do @@ -1123,11 +1127,11 @@ installGHCJS :: HasConfig env -> RIO env () installGHCJS si archiveFile archiveType _tempDir destDir = do platform <- view platformL - menv0 <- getMinimalEnvOverride + menv0 <- view envOverrideL -- This ensures that locking is disabled for the invocations of -- stack below. let removeLockVar = Map.delete "STACK_LOCK" - menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0))) + menv <- mkEnvOverride (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0))) logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) -- NOTE: this is a bit of a hack - instead of using the temp @@ -1160,7 +1164,7 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do return $ do liftIO $ ignoringAbsence (removeDirRecur destDir) liftIO $ ignoringAbsence (removeDirRecur unpackDir) - readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile] + withEnvOverride menv $ withWorkingDir destDir $ readProcessNull tarTool ["xf", toFilePath archiveFile] innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir @@ -1194,15 +1198,15 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do logStickyDone "Installed GHCJS." ensureGhcjsBooted :: HasConfig env - => EnvOverride -> CompilerVersion 'CVActual -> Bool -> [String] + => CompilerVersion 'CVActual -> Bool -> [String] -> RIO env () -ensureGhcjsBooted menv cv shouldBoot bootOpts = do - eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) +ensureGhcjsBooted cv shouldBoot bootOpts = do + eres <- try $ sinkProcessStdout "ghcjs" [] (return ()) case eres of Right () -> return () - Left (ProcessFailed _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err -> + Left ece | "no input files" `S.isInfixOf` LBS.toStrict (eceStderr ece) -> return () - Left (ProcessFailed _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err -> + Left ece | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict (eceStderr ece) -> if not shouldBoot then throwM GHCJSNotBooted else do config <- view configL destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv) @@ -1227,15 +1231,15 @@ ensureGhcjsBooted menv cv shouldBoot bootOpts = do unless actualStackYamlExists $ throwString "Error: Couldn't find GHCJS stack.yaml in old or new location." bootGhcjs ghcjsVersion actualStackYaml destDir bootOpts - Left err -> throwM err + Left ece -> throwIO ece -bootGhcjs :: HasRunner env +bootGhcjs :: (HasRunner env, HasEnvOverride env) => Version -> Path Abs File -> Path Abs Dir -> [String] -> RIO env () bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) - menv <- liftIO $ configEnvOverride (view configL envConfig) defaultEnvSettings + menv <- liftIO $ configEnvOverrideSettings (view configL envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. - mcabal <- getCabalInstallVersion menv + mcabal <- withEnvOverride menv getCabalInstallVersion shouldInstallCabal <- case mcabal of Nothing -> do logInfo "No cabal-install binary found for use with GHCJS." @@ -1270,7 +1274,7 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do , esLocaleUtf8 = True , esKeepGhcRts = False } - menv' <- liftIO $ configEnvOverride (view configL envConfig) envSettings + menv' <- liftIO $ configEnvOverrideSettings (view configL envConfig) envSettings shouldInstallAlex <- not <$> doesExecutableExist menv "alex" shouldInstallHappy <- not <$> doesExecutableExist menv "happy" let bootDepsToInstall = @@ -1284,7 +1288,7 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do logError "This shouldn't happen, because it gets built to the snapshot bin directory, which should be treated as being on the PATH." liftIO exitFailure when shouldInstallCabal $ do - mcabal' <- getCabalInstallVersion menv' + mcabal' <- withEnvOverride menv' getCabalInstallVersion case mcabal' of Nothing -> do logError "Failed to get cabal-install version after installing it." @@ -1306,7 +1310,7 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do logError "Failed to find 'happy' executable after installing it." failedToFindErr logSticky "Booting GHCJS (this will take a long time) ..." - logProcessStderrStdout Nothing "ghcjs-boot" menv' bootOpts + withEnvOverride menv' $ logProcessStderrStdout "ghcjs-boot" bootOpts logStickyDone "GHCJS booted." loadGhcjsEnvConfig :: HasRunner env @@ -1328,45 +1332,43 @@ buildInGhcjsEnv envConfig boptsCli = do set (buildOptsL.buildOptsHaddockL) False envConfig) $ build (\_ -> return ()) Nothing boptsCli -getCabalInstallVersion :: HasLogFunc env => EnvOverride -> RIO env (Maybe Version) -getCabalInstallVersion menv = do - ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] - liftIO $ case ebs of +getCabalInstallVersion :: HasEnvOverride env => RIO env (Maybe Version) +getCabalInstallVersion = do + ebs <- withProc "cabal" ["--numeric-version"] $ tryAny . readProcessStdout_ + case ebs of Left _ -> return Nothing - Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs)) + Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs))) -- | Check if given processes appear to be present, throwing an exception if -- missing. -checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env) - => CheckDependency a -> m a -checkDependencies (CheckDependency f) = do - menv <- getMinimalEnvOverride - liftIO (f menv) >>= either (throwM . MissingDependencies) return - -checkDependency :: String -> CheckDependency String -checkDependency tool = CheckDependency $ \menv -> do +checkDependencies :: CheckDependency env a -> RIO env a +checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return + +checkDependency :: HasEnvOverride env => String -> CheckDependency env String +checkDependency tool = CheckDependency $ do + menv <- view envOverrideL exists <- doesExecutableExist menv tool return $ if exists then Right tool else Left [tool] -newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a)) +newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a)) deriving Functor -instance Applicative CheckDependency where - pure x = CheckDependency $ \_ -> return (Right x) - CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do - f' <- f menv - x' <- x menv +instance Applicative (CheckDependency env) where + pure x = CheckDependency $ return (Right x) + CheckDependency f <*> CheckDependency x = CheckDependency $ do + f' <- f + x' <- x return $ case (f', x') of (Left e1, Left e2) -> Left $ e1 ++ e2 (Left e, Right _) -> Left e (Right _, Left e) -> Left e (Right f'', Right x'') -> Right $ f'' x'' -instance Alternative CheckDependency where - empty = CheckDependency $ \_ -> return $ Left [] - CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do - res1 <- x menv +instance Alternative (CheckDependency env) where + empty = CheckDependency $ return $ Left [] + CheckDependency x <|> CheckDependency y = CheckDependency $ do + res1 <- x case res1 of - Left _ -> y menv + Left _ -> y Right x' -> return $ Right x' installGHCWindows :: HasConfig env @@ -1405,13 +1407,13 @@ installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do -- I couldn't find this officially documented anywhere, but you need to run -- the MSYS shell once in order to initialize some pacman stuff. Once that -- run happens, you can just run commands as usual. - platform <- view platformL - menv0 <- getMinimalEnvOverride + menv0 <- view envOverrideL newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS" newEnv <- augmentPathMap [destDir $(mkRelDir "usr") $(mkRelDir "bin")] (unEnvOverride newEnv0) - menv <- mkEnvOverride platform newEnv - runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing + menv <- mkEnvOverride newEnv + withWorkingDir destDir $ withEnvOverride menv + $ withProc "sh" ["--login", "-c", "true"] runProcess_ -- No longer installing git, it's unreliable -- (https://github.com/commercialhaskell/stack/issues/1046) and the @@ -1483,7 +1485,7 @@ setup7z si = do , "-y" , toFilePath archive ] - ec <- withProcessTimeLog cmd args $ + ec <- withProcessTimeLog Nothing cmd args $ liftIO $ rawSystem cmd args when (ec /= ExitSuccess) $ liftIO $ throwM (ProblemWhileDecompressing archive) @@ -1545,8 +1547,8 @@ chattyDownload label downloadInfo path = do _ <- liftIO $ runInBase $ logSticky $ label <> ": download has begun" CL.map (Sum . S.length) - =$ chunksOverTime 1 - =$ go + .| chunksOverTime 1 + .| go where go = evalStateC 0 $ awaitForever $ \(Sum size) -> do modify (+ size) @@ -1595,7 +1597,7 @@ bytesfmt formatter bs = printf (formatter <> " %s") -- The final yield may come sooner, and may be a superfluous mempty. -- Note that Integer and Float literals can be turned into NominalDiffTime -- (these literals are interpreted as "seconds") -chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> Conduit a m a +chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> ConduitM a a m () chunksOverTime diff = do currentTime <- liftIO getCurrentTime evalStateC (currentTime, mempty) go @@ -1617,23 +1619,23 @@ chunksOverTime diff = do go -- | Perform a basic sanity check of GHC -sanityCheck :: HasLogFunc env - => EnvOverride - -> WhichCompiler +sanityCheck :: HasEnvOverride env + => WhichCompiler -> RIO env () -sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do +sanityCheck wc = withSystemTempDir "stack-sanity-check" $ \dir -> do let fp = toFilePath $ dir $(mkRelFile "Main.hs") liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present , "main = putStrLn \"Hello World\"" ] let exeName = compilerExeName wc + menv <- view envOverrideL ghc <- liftIO $ join $ findExecutable menv exeName logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc) - eres <- tryProcessStdout (Just dir) menv exeName + eres <- withWorkingDir dir $ withProc exeName [ fp , "-no-user-package-db" - ] + ] $ try . readProcessStdout_ case eres of Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct @@ -1653,17 +1655,17 @@ removeHaskellEnvVars = -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars - :: (HasLogFunc env, HasPlatform env) - => EnvOverride - -> CompilerVersion 'CVActual + :: (HasEnvOverride env, HasPlatform env) + => CompilerVersion 'CVActual -> RIO env (Map Text Text) -getUtf8EnvVars menv compilerVer = +getUtf8EnvVars compilerVer = if getGhcVersion compilerVer >= $(mkVersion "7.10.3") -- GHC_CHARENC supported by GHC >=7.10.3 then return $ Map.singleton "GHC_CHARENC" "UTF-8" else legacyLocale where legacyLocale = do + menv <- view envOverrideL Platform _ os <- view platformL if os == Cabal.Windows then @@ -1689,7 +1691,7 @@ getUtf8EnvVars menv compilerVer = Map.empty else do -- Get a list of known locales by running @locale -a@. - elocales <- tryProcessStdout Nothing menv "locale" ["-a"] + elocales <- tryAny $ withProc "locale" ["-a"] readProcessStdout_ let -- Filter the list to only include locales with UTF-8 encoding. utf8Locales = @@ -1700,8 +1702,8 @@ getUtf8EnvVars menv compilerVer = isUtf8Locale (T.lines $ T.decodeUtf8With - T.lenientDecode - locales) + T.lenientDecode $ + LBS.toStrict locales) mfallback = getFallbackLocale utf8Locales when (isNothing mfallback) @@ -1712,7 +1714,7 @@ getUtf8EnvVars menv compilerVer = changes = Map.unions $ map - (adjustedVarValue utf8Locales mfallback) + (adjustedVarValue menv utf8Locales mfallback) needChangeVars -- Get the values of variables to add. adds @@ -1742,8 +1744,8 @@ getUtf8EnvVars menv compilerVer = -- same language /and/ territory, then with same language, and finally the first UTF-8 locale -- returned by @locale -a@. adjustedVarValue - :: [Text] -> Maybe Text -> Text -> Map Text Text - adjustedVarValue utf8Locales mfallback k = + :: EnvOverride -> [Text] -> Maybe Text -> Text -> Map Text Text + adjustedVarValue menv utf8Locales mfallback k = case Map.lookup k (eoTextMap menv) of Nothing -> Map.empty Just v -> @@ -1978,7 +1980,7 @@ performPathChecking newFile = do toSudo <- prompt "Try using sudo? (y/n) " when toSudo $ do let run cmd args = do - ec <- withProcessTimeLog cmd args $ + ec <- withProcessTimeLog Nothing cmd args $ liftIO $ rawSystem cmd args when (ec /= ExitSuccess) $ error $ concat [ "Process exited with " diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index eba0ec7a5c..d06376625e 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -26,6 +26,7 @@ module Stack.Setup.Installed import Stack.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List hiding (concat, elem, maximumBy) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -39,7 +40,7 @@ import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read +import RIO.Process data Tool = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512 @@ -88,16 +89,15 @@ listInstalled programsPath = do parseToolText x getCompilerVersion - :: HasLogFunc env - => EnvOverride - -> WhichCompiler + :: HasEnvOverride env + => WhichCompiler -> RIO env (CompilerVersion 'CVActual) -getCompilerVersion menv wc = +getCompilerVersion wc = case wc of Ghc -> do logDebug "Asking GHC for its version" - bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] - let (_, ghcVersion) = versionFromEnd bs + bs <- withProc "ghc" ["--numeric-version"] readProcessStdout_ + let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) logDebug $ "GHC version is: " <> compilerVersionText x return x @@ -106,8 +106,8 @@ getCompilerVersion menv wc = -- Output looks like -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) - bs <- readProcessStdout Nothing menv "ghcjs" ["--version"] - let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd bs + bs <- withProc "ghcjs" ["--version"] readProcessStdout_ + let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) (_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion where diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs index 6ec077369f..322c286369 100644 --- a/src/Stack/Sig/GPG.hs +++ b/src/Stack/Sig/GPG.hs @@ -29,8 +29,8 @@ import System.Process (ProcessHandle, runInteractiveProcess, -- | Sign a file path with GPG, returning the @Signature@. gpgSign - :: (MonadIO m, MonadLogger m, MonadThrow m) - => Path Abs File -> m Signature + :: HasLogFunc env + => Path Abs File -> RIO env Signature gpgSign path = do gpgWarnTTY (_hIn,hOut,hErr,process) <- @@ -97,7 +97,7 @@ gpg args = do -- | `man gpg-agent` shows that you need GPG_TTY environment variable set to -- properly deal with interactions with gpg-agent. (Doesn't apply to Windows -- though) -gpgWarnTTY :: (MonadIO m, MonadLogger m) => m () +gpgWarnTTY :: HasLogFunc env => RIO env () gpgWarnTTY = unless ("ming" `isPrefixOf` os) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index 423a9d4429..6f43eb5643 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -36,12 +36,8 @@ import qualified System.FilePath as FP -- | Sign a haskell package with the given url of the signature -- service and a path to a tarball. sign -#if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) -#else - :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) -#endif - => String -> Path Abs File -> m Signature + :: HasLogFunc env + => String -> Path Abs File -> RIO env Signature sign url filePath = withRunInIO $ \run -> withSystemTempDir @@ -82,12 +78,8 @@ sign url filePath = -- function will write the bytes to the path in a temp dir and sign -- the tarball with GPG. signTarBytes -#if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) -#else - :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) -#endif - => String -> Path Rel File -> L.ByteString -> m Signature + :: HasLogFunc env + => String -> Path Rel File -> L.ByteString -> RIO env Signature signTarBytes url tarPath bs = withSystemTempDir "stack" @@ -99,8 +91,8 @@ signTarBytes url tarPath bs = -- | Sign a haskell package given the url to the signature service, a -- @PackageIdentifier@ and a file path to the package on disk. signPackage - :: (MonadIO m, MonadLogger m, MonadThrow m) - => String -> PackageIdentifier -> Path Abs File -> m Signature + :: HasLogFunc env + => String -> PackageIdentifier -> Path Abs File -> RIO env Signature signPackage url pkg filePath = do sig@(Signature signature) <- gpgSign filePath let (PackageIdentifier name version) = pkg diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index b14a845bb6..a8bd958322 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -47,7 +47,6 @@ import Network.HTTP.Download import Path import Path.IO import Stack.Constants -import Stack.Fetch import Stack.Package import Stack.PackageDump import Stack.PackageLocation @@ -346,18 +345,7 @@ loadSnapshot -> Path Abs Dir -- ^ project root, used for checking out necessary files -> SnapshotDef -> RIO env LoadedSnapshot -loadSnapshot mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader mcompiler root sd - --- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' -loadSnapshot' - :: forall env. - (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) -- ^ load a cabal file's contents from the index - -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints - -> Path Abs Dir -- ^ project root, used for checking out necessary files - -> SnapshotDef - -> RIO env LoadedSnapshot -loadSnapshot' loadFromIndex mcompiler root = +loadSnapshot mcompiler root = start where start (snapshotDefFixes -> sd) = do @@ -381,7 +369,7 @@ loadSnapshot' loadFromIndex mcompiler root = Right sd' -> start sd' gpds <- - (concat <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (sdLocations sd)) + (concat <$> mapM (parseMultiCabalFilesIndex root) (sdLocations sd)) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of @@ -403,7 +391,7 @@ loadSnapshot' loadFromIndex mcompiler root = _ -> return () (globals, snapshot, locals) <- - calculatePackagePromotion loadFromIndex root ls0 + calculatePackagePromotion root ls0 (map (\(x, y) -> (x, y, ())) gpds) (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd) @@ -424,8 +412,7 @@ loadSnapshot' loadFromIndex mcompiler root = calculatePackagePromotion :: forall env localLocation. (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) -- ^ load from index - -> Path Abs Dir -- ^ project root + => Path Abs Dir -- ^ project root -> LoadedSnapshot -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot -> Map PackageName (Map FlagName Bool) -- ^ flags @@ -438,7 +425,7 @@ calculatePackagePromotion , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals ) calculatePackagePromotion - loadFromIndex root (LoadedSnapshot compilerVersion globals0 parentPackages0) + root (LoadedSnapshot compilerVersion globals0 parentPackages0) gpds flags0 hides0 options0 drops0 = do platform <- view platformL @@ -500,7 +487,7 @@ calculatePackagePromotion -- ... so recalculate based on new values upgraded <- fmap Map.fromList - $ mapM (recalculate loadFromIndex root compilerVersion flags hide ghcOptions) + $ mapM (recalculate root compilerVersion flags hide ghcOptions) $ Map.toList allToUpgrade -- Could be nice to check snapshot early... but disabling @@ -526,22 +513,21 @@ calculatePackagePromotion -- hide values, and GHC options. recalculate :: forall env. (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) - -> Path Abs Dir -- ^ root + => Path Abs Dir -- ^ root -> CompilerVersion 'CVActual -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options -> (PackageName, LoadedPackageInfo SinglePackageLocation) -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation) -recalculate loadFromIndex root compilerVersion allFlags allHide allOptions (name, lpi0) = do +recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) case Map.lookup name allFlags of Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization Just flags -> do let loc = lpiLocation lpi0 - gpd <- parseSingleCabalFileIndex loadFromIndex root loc + gpd <- parseSingleCabalFileIndex root loc platform <- view platformL let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" @@ -606,8 +592,7 @@ loadCompiler :: forall env. => CompilerVersion 'CVActual -> RIO env LoadedSnapshot loadCompiler cv = do - menv <- getMinimalEnvOverride - m <- ghcPkgDump menv (whichCompiler cv) [] + m <- ghcPkgDump (whichCompiler cv) [] (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)) return LoadedSnapshot { lsCompilerVersion = cv diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 2ec90e8404..75ecc0606e 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -22,7 +22,9 @@ module Stack.Solver import Stack.Prelude import Data.Aeson.Extended (object, (.=), toJSON) import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) +import Data.Conduit.Process.Typed (eceStderr) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import Data.List ( (\\), isSuffixOf, intercalate @@ -40,7 +42,6 @@ import qualified Data.Yaml as Yaml import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C -import Lens.Micro (set) import Path import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles, withSystemTempDir) @@ -49,6 +50,7 @@ import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Package (readPackageUnresolvedDir, gpdPackageName) +import Stack.PackageIndex import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed @@ -61,11 +63,10 @@ import Stack.Types.FlagName import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import qualified System.FilePath as FP -import System.Process.Read +import RIO.Process import Text.Regex.Applicative.Text (match, sym, psym, anySym, few) import qualified Data.Text.Normalize as T ( normalize , NormalizationMode(NFC) ) @@ -111,12 +112,12 @@ cabalSolver cabalfps constraintType toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps - menv <- getMinimalEnvOverride - catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args)) - (\ex -> case ex of - ProcessFailed _ _ _ err -> return $ Left err - _ -> throwM ex) - >>= either parseCabalErrors parseCabalOutput + try ( withWorkingDir tmpdir + $ withProc "cabal" args readProcessStdout_ + ) + >>= either + (parseCabalErrors . eceStderr) + (parseCabalOutput . BL.toStrict) where errCheck = T.isInfixOf "Could not resolve dependencies" @@ -226,7 +227,7 @@ getCabalConfig :: HasConfig env -> Map PackageName Version -- ^ constraints -> RIO env [Text] getCabalConfig dir constraintType constraints = do - indices <- view $ configL.to configPackageIndices + indices <- view $ cabalLoaderL.to clIndices remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir return $ cache : remotes ++ map goConstraint (Map.toList constraints) @@ -300,15 +301,14 @@ setupCabalEnv -> (CompilerVersion 'CVActual -> RIO env a) -> RIO env a setupCabalEnv compiler inner = do - mpaths <- setupCompiler compiler - menv0 <- getMinimalEnvOverride - envMap <- removeHaskellEnvVars - <$> augmentPathMap (maybe [] edBins mpaths) - (unEnvOverride menv0) - platform <- view platformL - menv <- mkEnvOverride platform envMap - - mcabal <- getCabalInstallVersion menv + mpaths <- setupCompiler compiler + menv0 <- view envOverrideL + envMap <- removeHaskellEnvVars + <$> augmentPathMap (maybe [] edBins mpaths) + (unEnvOverride menv0) + menv <- mkEnvOverride envMap + withEnvOverride menv $ do + mcabal <- getCabalInstallVersion case mcabal of Nothing -> throwM SolverMissingCabalInstall Just version @@ -323,7 +323,7 @@ setupCabalEnv compiler inner = do ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () - mver <- getSystemCompiler menv (whichCompiler compiler) + mver <- getSystemCompiler (whichCompiler compiler) version <- case mver of Just (version, _) -> do logInfo $ "Using compiler: " <> compilerVersionText version @@ -331,8 +331,7 @@ setupCabalEnv compiler inner = do Nothing -> error "Failed to determine compiler version. \ \This is most likely a bug." - env <- set envOverrideL (const (return menv)) <$> ask - runRIO env (inner version) + inner version -- | Merge two separate maps, one defining constraints on package versions and -- the other defining package flagmap, into a single map of version and flagmap @@ -501,8 +500,8 @@ getResolverConstraints mcompilerVersion stackYaml sd = do -- package.yaml. Subdirectories can be included depending on the -- @recurse@ parameter. findCabalDirs - :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m, HasConfig env) - => Bool -> Path Abs Dir -> m (Set (Path Abs Dir)) + :: HasConfig env + => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir)) findCabalDirs recurse dir = (Set.fromList . map parent) <$> liftIO (findFiles dir isHpackOrCabal subdirFilter) @@ -598,11 +597,10 @@ formatGroup :: [String] -> String formatGroup = concatMap (\path -> "- " <> path <> "\n") reportMissingCabalFiles - :: (MonadIO m, MonadUnliftIO m, MonadThrow m, MonadLogger m, - HasRunner env, MonadReader env m, HasConfig env) + :: HasConfig env => [Path Abs File] -- ^ Directories to scan -> Bool -- ^ Whether to scan sub-directories - -> m () + -> RIO env () reportMissingCabalFiles cabalfps includeSubdirs = do allCabalDirs <- findCabalDirs includeSubdirs =<< getCurrentDir diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 68339af115..1e54a7fc42 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -74,13 +74,14 @@ import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Exit (ExitCode (ExitFailure)) import System.FilePath (pathSeparator) -import System.Process.Log (showProcessArgDebug) +import RIO.Process (showProcessArgDebug) ---------------------------------------------- -- Exceptions diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index dd95814863..ab24c19f0a 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -35,7 +35,6 @@ module Stack.Types.Config ,HasConfig(..) ,askLatestSnapshotUrl ,explicitSetupDeps - ,getMinimalEnvOverride -- ** BuildConfig & HasBuildConfig ,BuildConfig(..) ,LocalPackages(..) @@ -44,7 +43,6 @@ module Stack.Types.Config ,lpvName ,lpvVersion ,lpvComponents - ,NamedComponent(..) ,stackYamlL ,projectRootL ,HasBuildConfig(..) @@ -77,6 +75,8 @@ module Stack.Types.Config -- ** EnvSettings ,EnvSettings(..) ,minimalEnvSettings + ,defaultEnvSettings + ,plainEnvSettings -- ** GlobalOpts & GlobalOptsMonoid ,GlobalOpts(..) ,GlobalOptsMonoid(..) @@ -90,14 +90,6 @@ module Stack.Types.Config ,PackageIndex(..) ,IndexName(..) ,indexNameText - -- Config fields - ,configPackageIndex - ,configPackageIndexOld - ,configPackageIndexCache - ,configPackageIndexCacheOld - ,configPackageIndexGz - ,configPackageIndexRoot - ,configPackageTarball -- ** Project & ProjectAndConfigMonoid ,Project(..) ,ProjectAndConfigMonoid(..) @@ -163,12 +155,11 @@ module Stack.Types.Config ,buildOptsMonoidInstallExesL ,buildOptsHaddockL ,globalOptsBuildOptsMonoidL - ,packageIndicesL ,stackRootL ,configUrlsL ,cabalVersionL ,whichCompilerL - ,envOverrideL + ,envOverrideSettingsL ,loadedSnapshotL ,shouldForceGhcColorFlag ,appropriateGhcColorFlag @@ -213,12 +204,14 @@ import qualified Options.Applicative.Types as OA import Path import qualified Paths_stack as Meta import Stack.Constants +import Stack.PackageIndex (HasCabalLoader (..), CabalLoader (clStackRoot)) import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker import Stack.Types.FlagName import Stack.Types.Image +import Stack.Types.NamedComponent import Stack.Types.Nix import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex @@ -230,16 +223,14 @@ import Stack.Types.Urls import Stack.Types.Version import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) -import System.Process.Read (EnvOverride, findExecutable) +import RIO.Process (EnvOverride, HasEnvOverride (..), findExecutable) -- Re-exports import Stack.Types.Config.Build as X -- | The top-level Stackage configuration. data Config = - Config {configStackRoot :: !(Path Abs Dir) - -- ^ ~/.stack more often than not - ,configWorkDir :: !(Path Rel Dir) + Config {configWorkDir :: !(Path Rel Dir) -- ^ this allows to override .stack-work directory ,configUserConfigPath :: !(Path Abs File) -- ^ Path to user configuration file (usually ~/.stack/config.yaml) @@ -249,14 +240,12 @@ data Config = -- ^ Docker configuration ,configNix :: !NixOpts -- ^ Execution environment (e.g nix-shell) configuration - ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) + ,configEnvOverrideSettings :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools ,configLocalProgramsBase :: !(Path Abs Dir) -- ^ Non-platform-specific path containing local installations ,configLocalPrograms :: !(Path Abs Dir) -- ^ Path containing local installations (mainly GHC) - ,configConnectionCount :: !Int - -- ^ How many concurrent connections are allowed when downloading ,configHideTHLoading :: !Bool -- ^ Hide the Template Haskell "Loading package ..." messages from the -- console @@ -276,21 +265,6 @@ data Config = -- e.g. The latest snapshot file. -- A build plan name (e.g. lts5.9.yaml) is appended when downloading -- the build plan actually. - ,configPackageIndices :: ![PackageIndex] - -- ^ Information on package indices. This is left biased, meaning that - -- packages in an earlier index will shadow those in a later index. - -- - -- Warning: if you override packages in an index vs what's available - -- upstream, you may correct your compiled snapshots, as different - -- projects may have different definitions of what pkg-ver means! This - -- feature is primarily intended for adding local packages, not - -- overriding. Overriding is better accomplished by adding to your - -- list of packages. - -- - -- Note that indices specified in a later config file will override - -- previous indices, /not/ extend them. - -- - -- Using an assoc list instead of a Map to keep track of priority ,configSystemGHC :: !Bool -- ^ Should we use the system-installed GHC (on the PATH) if -- available? Can be overridden by command line options. @@ -349,8 +323,6 @@ data Config = ,configAllowDifferentUser :: !Bool -- ^ Allow users other than the stack root owner to use the stack -- installation. - ,configPackageCache :: !(IORef (Maybe (PackageCache PackageIndex))) - -- ^ In memory cache of hackage index. ,configDumpLogs :: !DumpLogs -- ^ Dump logs of local non-dependencies when doing a build. ,configMaybeProject :: !(Maybe (Project, Path Abs File)) @@ -362,10 +334,7 @@ data Config = ,configSaveHackageCreds :: !Bool -- ^ Should we save Hackage credentials to a file? ,configRunner :: !Runner - ,configIgnoreRevisionMismatch :: !Bool - -- ^ Ignore a revision mismatch when loading up cabal files, - -- and fall back to the latest revision. See: - -- + ,configCabalLoader :: !CabalLoader } data HpackExecutable @@ -620,14 +589,6 @@ lpvVersion lpv = $ lpvGPD lpv in version --- | A single, fully resolved component of a package -data NamedComponent - = CLib - | CExe !Text - | CTest !Text - | CBench !Text - deriving (Show, Eq, Ord) - -- | Value returned by 'Stack.Config.loadConfig'. data LoadConfig = LoadConfig { lcConfig :: !Config @@ -715,7 +676,7 @@ instance ToJSON Project where data ConfigMonoid = ConfigMonoid { configMonoidStackRoot :: !(First (Path Abs Dir)) - -- ^ See: 'configStackRoot' + -- ^ See: 'clStackRoot' , configMonoidWorkDir :: !(First (Path Rel Dir)) -- ^ See: 'configWorkDir'. , configMonoidBuildOpts :: !BuildOptsMonoid @@ -733,7 +694,7 @@ data ConfigMonoid = , configMonoidUrls :: !UrlsMonoid -- ^ See: 'configUrls , configMonoidPackageIndices :: !(First [PackageIndex]) - -- ^ See: 'configPackageIndices' + -- ^ See: @picIndices@ , configMonoidSystemGHC :: !(First Bool) -- ^ See: 'configSystemGHC' ,configMonoidInstallGHC :: !(First Bool) @@ -1211,44 +1172,6 @@ data SuggestSolver = SuggestSolver | Don'tSuggestSolver askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text askLatestSnapshotUrl = view $ configL.to configUrls.to urlsLatestSnapshot --- | Root for a specific package index -configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir) -configPackageIndexRoot (IndexName name) = do - root <- view stackRootL - dir <- parseRelDir $ S8.unpack name - return (root $(mkRelDir "indices") dir) - --- | Location of the 01-index.cache file -configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexCache = liftM ( $(mkRelFile "01-index.cache")) . configPackageIndexRoot - --- | Location of the 00-index.cache file -configPackageIndexCacheOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot - --- | Location of the 01-index.tar file -configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndex = liftM ( $(mkRelFile "01-index.tar")) . configPackageIndexRoot - --- | Location of the 00-index.tar file. This file is just a copy of --- the 01-index.tar file, provided for tools which still look for the --- 00-index.tar file. -configPackageIndexOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot - --- | Location of the 01-index.tar.gz file -configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot - --- | Location of a package tarball -configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File) -configPackageTarball iname ident = do - root <- configPackageIndexRoot iname - name <- parseRelDir $ packageNameString $ packageIdentifierName ident - ver <- parseRelDir $ versionString $ packageIdentifierVersion ident - base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" - return (root $(mkRelDir "packages") name ver base) - -- | @".stack-work"@ workDirL :: HasConfig env => Lens' env (Path Rel Dir) workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y }) @@ -1303,7 +1226,7 @@ bindirCompilerTools = do compilerVersion <- envConfigCompilerVersion <$> view envConfigL compiler <- parseRelDir $ compilerVersionString compilerVersion return $ - configStackRoot config + view stackRootL config $(mkRelDir "compiler-tools") platform compiler @@ -1468,19 +1391,12 @@ extraBinDirs :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Bool -> [Path Abs Dir]) extraBinDirs = do deps <- installationRootDeps - local <- installationRootLocal + local' <- installationRootLocal tools <- bindirCompilerTools return $ \locals -> if locals - then [local bindirSuffix, deps bindirSuffix, tools] + then [local' bindirSuffix, deps bindirSuffix, tools] else [deps bindirSuffix, tools] --- | Get the minimal environment override, useful for just calling external --- processes like git or ghc -getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride -getMinimalEnvOverride = do - config' <- view configL - liftIO $ configEnvOverride config' minimalEnvSettings - minimalEnvSettings :: EnvSettings minimalEnvSettings = EnvSettings @@ -1491,6 +1407,32 @@ minimalEnvSettings = , esKeepGhcRts = False } +-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH. +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 +defaultEnvSettings :: EnvSettings +defaultEnvSettings = EnvSettings + { esIncludeLocals = True + , esIncludeGhcPackagePath = True + , esStackExe = True + , esLocaleUtf8 = False + , esKeepGhcRts = True + } + +-- | Environment settings which do not embellish the environment +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 +plainEnvSettings :: EnvSettings +plainEnvSettings = EnvSettings + { esIncludeLocals = False + , esIncludeGhcPackagePath = False + , esStackExe = False + , esLocaleUtf8 = False + , esKeepGhcRts = True + } + -- | Get the path for the given compiler ignoring any local binaries. -- -- https://github.com/commercialhaskell/stack/issues/1052 @@ -1501,7 +1443,7 @@ getCompilerPath getCompilerPath wc = do config' <- view configL eoWithoutLocals <- liftIO $ - configEnvOverride config' minimalEnvSettings { esLocaleUtf8 = True } + configEnvOverrideSettings config' minimalEnvSettings { esLocaleUtf8 = True } join (findExecutable eoWithoutLocals (compilerExeName wc)) data ProjectAndConfigMonoid @@ -1887,7 +1829,7 @@ class HasGHCVariant env where {-# INLINE ghcVariantL #-} -- | Class for environment values that can provide a 'Config'. -class (HasPlatform env, HasRunner env) => HasConfig env where +class (HasPlatform env, HasEnvOverride env, HasCabalLoader env) => HasConfig env where configL :: Lens' env Config default configL :: HasBuildConfig env => Lens' env Config configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) @@ -1924,6 +1866,24 @@ instance HasGHCVariant BuildConfig where ghcVariantL = lens bcGHCVariant (\x y -> x { bcGHCVariant = y }) instance HasGHCVariant EnvConfig +instance HasEnvOverride Config where + envOverrideL = runnerL.envOverrideL +instance HasEnvOverride LoadConfig where + envOverrideL = configL.envOverrideL +instance HasEnvOverride BuildConfig where + envOverrideL = configL.envOverrideL +instance HasEnvOverride EnvConfig where + envOverrideL = configL.envOverrideL + +instance HasCabalLoader Config where + cabalLoaderL = lens configCabalLoader (\x y -> x { configCabalLoader = y }) +instance HasCabalLoader LoadConfig where + cabalLoaderL = configL.cabalLoaderL +instance HasCabalLoader BuildConfig where + cabalLoaderL = configL.cabalLoaderL +instance HasCabalLoader EnvConfig where + cabalLoaderL = configL.cabalLoaderL + instance HasConfig Config where configL = id {-# INLINE configL #-} @@ -1964,8 +1924,8 @@ instance HasLogFunc EnvConfig where -- Helper lenses ----------------------------------- -stackRootL :: HasConfig s => Lens' s (Path Abs Dir) -stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) +stackRootL :: HasCabalLoader s => Lens' s (Path Abs Dir) +stackRootL = cabalLoaderL.lens clStackRoot (\x y -> x { clStackRoot = y }) -- | The compiler specified by the @MiniBuildPlan@. This may be -- different from the actual compiler used! @@ -1985,11 +1945,6 @@ snapshotDefL = buildConfigL.lens bcSnapshotDef (\x y -> x { bcSnapshotDef = y }) -packageIndicesL :: HasConfig s => Lens' s [PackageIndex] -packageIndicesL = configL.lens - configPackageIndices - (\x y -> x { configPackageIndices = y }) - buildOptsL :: HasConfig s => Lens' s BuildOpts buildOptsL = configL.lens configBuild @@ -2046,10 +2001,10 @@ loadedSnapshotL = envConfigL.lens whichCompilerL :: Getting r (CompilerVersion a) WhichCompiler whichCompilerL = to whichCompiler -envOverrideL :: HasConfig env => Lens' env (EnvSettings -> IO EnvOverride) -envOverrideL = configL.lens - configEnvOverride - (\x y -> x { configEnvOverride = y }) +envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO EnvOverride) +envOverrideSettingsL = configL.lens + configEnvOverrideSettings + (\x y -> x { configEnvOverrideSettings = y }) shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env) => RIO env Bool diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs new file mode 100644 index 0000000000..1199727d03 --- /dev/null +++ b/src/Stack/Types/NamedComponent.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.Types.NamedComponent + ( NamedComponent (..) + , renderComponent + , renderPkgComponents + , renderPkgComponent + , exeComponents + , testComponents + , benchComponents + , isCLib + , isCExe + , isCTest + , isCBench + ) where + +import Stack.Prelude +import Stack.Types.PackageName +import qualified Data.Set as Set +import Data.ByteString (ByteString) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) + +-- | A single, fully resolved component of a package +data NamedComponent + = CLib + | CExe !Text + | CTest !Text + | CBench !Text + deriving (Show, Eq, Ord) + +renderComponent :: NamedComponent -> ByteString +renderComponent CLib = "lib" +renderComponent (CExe x) = "exe:" <> encodeUtf8 x +renderComponent (CTest x) = "test:" <> encodeUtf8 x +renderComponent (CBench x) = "bench:" <> encodeUtf8 x + +renderPkgComponents :: [(PackageName, NamedComponent)] -> Text +renderPkgComponents = T.intercalate " " . map renderPkgComponent + +renderPkgComponent :: (PackageName, NamedComponent) -> Text +renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp) + +exeComponents :: Set NamedComponent -> Set Text +exeComponents = Set.fromList . mapMaybe mExeName . Set.toList + where + mExeName (CExe name) = Just name + mExeName _ = Nothing + +testComponents :: Set NamedComponent -> Set Text +testComponents = Set.fromList . mapMaybe mTestName . Set.toList + where + mTestName (CTest name) = Just name + mTestName _ = Nothing + +benchComponents :: Set NamedComponent -> Set Text +benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList + where + mBenchName (CBench name) = Just name + mBenchName _ = Nothing + +isCLib :: NamedComponent -> Bool +isCLib CLib{} = True +isCLib _ = False + +isCExe :: NamedComponent -> Bool +isCExe CExe{} = True +isCExe _ = False + +isCTest :: NamedComponent -> Bool +isCTest CTest{} = True +isCTest _ = False + +isCBench :: NamedComponent -> Bool +isCBench CBench{} = True +isCBench _ = False diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 070f1ea5e5..ea1c165377 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -13,11 +13,8 @@ import Stack.Prelude import qualified Data.ByteString as S import Data.List import qualified Data.Map as M -import qualified Data.Set as Set import Data.Store.Version (VersionConfig) import Data.Store.VersionTagged (storeVersionConfig) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Distribution.InstalledPackageInfo (PError) import Distribution.License (License) import Distribution.ModuleName (ModuleName) @@ -29,6 +26,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version @@ -257,52 +255,6 @@ data LocalPackage = LocalPackage } deriving Show -renderComponent :: NamedComponent -> S.ByteString -renderComponent CLib = "lib" -renderComponent (CExe x) = "exe:" <> encodeUtf8 x -renderComponent (CTest x) = "test:" <> encodeUtf8 x -renderComponent (CBench x) = "bench:" <> encodeUtf8 x - -renderPkgComponents :: [(PackageName, NamedComponent)] -> Text -renderPkgComponents = T.intercalate " " . map renderPkgComponent - -renderPkgComponent :: (PackageName, NamedComponent) -> Text -renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp) - -exeComponents :: Set NamedComponent -> Set Text -exeComponents = Set.fromList . mapMaybe mExeName . Set.toList - where - mExeName (CExe name) = Just name - mExeName _ = Nothing - -testComponents :: Set NamedComponent -> Set Text -testComponents = Set.fromList . mapMaybe mTestName . Set.toList - where - mTestName (CTest name) = Just name - mTestName _ = Nothing - -benchComponents :: Set NamedComponent -> Set Text -benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList - where - mBenchName (CBench name) = Just name - mBenchName _ = Nothing - -isCLib :: NamedComponent -> Bool -isCLib CLib{} = True -isCLib _ = False - -isCExe :: NamedComponent -> Bool -isCExe CExe{} = True -isCExe _ = False - -isCTest :: NamedComponent -> Bool -isCTest CTest{} = True -isCTest _ = False - -isCBench :: NamedComponent -> Bool -isCBench CBench{} = True -isCBench _ = False - -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local deriving (Show, Eq) diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index 4a2e49fd79..6bb6e26ba7 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -32,12 +32,11 @@ import qualified Data.ByteString.Char8 as S8 import Data.Char import Data.List (stripPrefix) import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T import qualified Data.Text.IO as T import Data.Time import Distribution.PackageDescription (GenericPackageDescription) import GHC.Foreign (peekCString, withCString) +import GHC.Stack (CallStack, SrcLoc (..), getCallStack) import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) import Lens.Micro @@ -47,7 +46,7 @@ import Stack.Types.PackageIdentifier (PackageIdentifierRevision) import System.Console.ANSI import System.FilePath import System.IO (localeEncoding) -import System.Log.FastLogger +import RIO.Process (HasEnvOverride (..), EnvOverride, getEnvOverride) import System.Terminal -- | Monadic environment. @@ -56,6 +55,7 @@ data Runner = Runner , runnerLogOptions :: !LogOptions , runnerTerminal :: !Bool , runnerSticky :: !Sticky + , runnerEnvOverride :: !EnvOverride , runnerParsedCabalFiles :: !(IORef ( Map PackageIdentifierRevision GenericPackageDescription , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) @@ -70,8 +70,10 @@ data Runner = Runner -- . } -class HasLogFunc env => HasRunner env where +class HasEnvOverride env => HasRunner env where runnerL :: Lens' env Runner +instance HasEnvOverride Runner where + envOverrideL = lens runnerEnvOverride (\x y -> x { runnerEnvOverride = y }) instance HasRunner Runner where runnerL = id @@ -106,11 +108,11 @@ data LogOptions = LogOptions instance HasLogFunc Runner where logFuncL = to $ \env -> stickyLoggerFuncImpl (view stickyL env) (view logOptionsL env) +-- FIXME move into RIO.Logger? stickyLoggerFuncImpl - :: ToLogStr msg - => Sticky -> LogOptions - -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) -stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = + :: Sticky -> LogOptions + -> (CallStack -> LogSource -> LogLevel -> LogStr -> IO ()) +stickyLoggerFuncImpl (Sticky mref) lo loc src level msgTextRaw = case mref of Nothing -> loggerFunc @@ -122,7 +124,7 @@ stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = LevelOther "sticky-done" -> LevelInfo LevelOther "sticky" -> LevelInfo _ -> level) - msg + msgTextRaw Just ref -> modifyMVar_ ref $ \sticky -> do let backSpaceChar = '\8' repeating = S8.replicate (maybe 0 T.length sticky) @@ -150,7 +152,7 @@ stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = _ | level >= logMinLevel lo -> do clear - loggerFunc lo out loc src level $ toLogStr msgText + loggerFunc lo out loc src level msgText case sticky of Nothing -> return Nothing @@ -161,8 +163,6 @@ stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = return sticky where out = stderr - msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes - msgBytes = fromLogStr (toLogStr msg) -- | Replace Unicode characters with non-Unicode equivalents replaceUnicode :: Char -> Char @@ -171,9 +171,8 @@ replaceUnicode '\x2019' = '\'' replaceUnicode c = c -- | Logging function takes the log level into account. -loggerFunc :: ToLogStr msg - => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () -loggerFunc lo outputChannel loc _src level msg = +loggerFunc :: LogOptions -> Handle -> CallStack -> Text -> LogLevel -> LogStr -> IO () +loggerFunc lo outputChannel cs _src level msg = when (level >= logMinLevel lo) (liftIO (do out <- getOutput T.hPutStrLn outputChannel out)) @@ -186,7 +185,7 @@ loggerFunc lo outputChannel loc _src level msg = [ T.pack timestamp , T.pack l , T.pack (ansi [Reset]) - , T.decodeUtf8 (fromLogStr (toLogStr msg)) + , msg , T.pack lc , T.pack (ansi [Reset]) ] @@ -222,16 +221,18 @@ loggerFunc lo outputChannel loc _src level msg = "\n@(" ++ fileLocStr ++ ")" | otherwise = return "" fileLocStr = - fromMaybe file (stripPrefix dirRoot file) ++ - ':' : - line loc ++ - ':' : - char loc - where - file = loc_filename loc - line = show . fst . loc_start - char = show . snd . loc_start - dirRoot = $(lift . T.unpack . fromMaybe undefined . T.stripSuffix (T.pack $ "Stack" "Types" "Runner.hs") . T.pack . loc_filename =<< location) + case reverse $ getCallStack cs of + [] -> "" + (_desc, loc):_ -> + let file = srcLocFile loc + line = show $ srcLocStartLine loc + char = show $ srcLocStartCol loc + dirRoot = $(lift . T.unpack . fromMaybe undefined . T.stripSuffix (T.pack $ "Stack" "Types" "Runner.hs") . T.pack . loc_filename =<< location) + in fromMaybe file (stripPrefix dirRoot file) ++ + ':' : + line ++ + ':' : + char -- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ". -- This definition is top-level in order to avoid multiple reevaluation at runtime. @@ -274,6 +275,7 @@ withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do pure widthOverride canUseUnicode <- liftIO getCanUseUnicode ref <- newIORef mempty + menv <- getEnvOverride withSticky terminal $ \sticky -> inner Runner { runnerReExec = reExec , runnerLogOptions = LogOptions @@ -287,6 +289,7 @@ withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do , runnerTerminal = terminal , runnerSticky = sticky , runnerParsedCabalFiles = ref + , runnerEnvOverride = menv } where clipWidth w | w < minTerminalWidth = minTerminalWidth diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 7e9bb662c1..aa1f6b3a82 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -36,7 +36,7 @@ import Stack.Types.Config import Stack.Types.Resolver import System.Exit (ExitCode (ExitSuccess)) import System.Process (rawSystem, readProcess) -import System.Process.Run +import RIO.Process upgradeOpts :: Parser UpgradeOpts upgradeOpts = UpgradeOpts @@ -187,10 +187,9 @@ sourceUpgrade -> RIO env () sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = withSystemTempDir "stack-upgrade" $ \tmp -> do - menv <- getMinimalEnvOverride mdir <- case gitRepo of Just (repo, branch) -> do - remote <- liftIO $ readProcess "git" ["ls-remote", repo, branch] [] + remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] [] latestCommit <- case words remote of [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo @@ -212,7 +211,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = -- the stack repo until we're comfortable with "stack upgrade -- --git" not working for earlier versions. let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch] - runCmd (Cmd (Just tmp) "git" menv args) Nothing + withProc "git" args runProcess_ return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 334ed820e0..c32cf5934b 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -124,7 +124,7 @@ loadCreds config = do credsFile :: Config -> IO FilePath credsFile config = do - let dir = toFilePath (configStackRoot config) "upload" + let dir = toFilePath (view stackRootL config) "upload" createDirectoryIfMissing True dir return $ dir "credentials.json" diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs deleted file mode 100644 index e29fe15f74..0000000000 --- a/src/System/Process/Log.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Separate module because TH. - -module System.Process.Log - (logCreateProcess - ,withProcessTimeLog - ,showProcessArgDebug) - where - -import qualified Data.Text as T -import Stack.Prelude -import qualified System.Clock as Clock -import System.Process (CreateProcess(..), CmdSpec(..)) - --- | Log running a process with its arguments, for debugging (-v). -logCreateProcess :: MonadLogger m => CreateProcess -> m () -logCreateProcess CreateProcess { cmdspec = ShellCommand shellCmd } = - logDebug ("Creating shell process: " <> T.pack shellCmd) -logCreateProcess CreateProcess { cmdspec = RawCommand name args } = - logDebug - ("Creating process: " <> T.pack name <> " " <> - T.intercalate - " " - (map showProcessArgDebug args)) - --- | Log running a process with its arguments, for debugging (-v). --- --- This logs one message before running the process and one message after. -withProcessTimeLog :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a -withProcessTimeLog name args proc = do - let cmdText = - T.intercalate - " " - (T.pack name : map showProcessArgDebug args) - logDebug ("Run process: " <> cmdText) - start <- liftIO $ Clock.getTime Clock.Monotonic - x <- proc - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end - -- useAnsi <- asks getAnsiTerminal - let useAnsi = True - logDebug - ("Process finished in " <> - (if useAnsi then "\ESC[92m" else "") <> -- green - timeSpecMilliSecondText diff <> - (if useAnsi then "\ESC[0m" else "") <> -- reset - ": " <> cmdText) - return x - -timeSpecMilliSecondText :: Clock.TimeSpec -> Text -timeSpecMilliSecondText t = - (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" - --- | Show a process arg including speechmarks when necessary. Just for --- debugging purposes, not functionally important. -showProcessArgDebug :: String -> Text -showProcessArgDebug x - | any special x || null x = T.pack (show x) - | otherwise = T.pack x - where special '"' = True - special ' ' = True - special _ = False diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs deleted file mode 100644 index 5322cce6d9..0000000000 --- a/src/System/Process/Read.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Reading from external processes. - -module System.Process.Read - (readProcessStdout - ,readProcessStderrStdout - ,tryProcessStdout - ,tryProcessStderrStdout - ,sinkProcessStdout - ,sinkProcessStderrStdout - ,sinkProcessStderrStdoutHandle - ,logProcessStderrStdout - ,readProcess - ,EnvOverride(..) - ,unEnvOverride - ,mkEnvOverride - ,modifyEnvOverride - ,envHelper - ,doesExecutableExist - ,findExecutable - ,getEnvOverride - ,envSearchPath - ,preProcess - ,readProcessNull - ,ReadProcessException (..) - ,augmentPath - ,augmentPathMap - ,resetExeCache - ) - where - -import Stack.Prelude -import qualified Data.ByteString as S -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as L -import Data.Conduit -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.Process hiding (callProcess) -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Distribution.System (OS (Windows), Platform (Platform)) -import Path -import Path.Extra -import Path.IO hiding (findExecutable) -import qualified System.Directory as D -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 -- ^ Environment variables as map - , eoStringList :: [(String, String)] -- ^ Environment variables as association list - , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@) - , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) - , eoExeExtensions :: [String] -- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows - , eoPlatform :: Platform - } - --- | Get the environment variables from an 'EnvOverride'. -unEnvOverride :: EnvOverride -> Map Text Text -unEnvOverride = eoTextMap - --- | Get the list of directories searched (@PATH@). -envSearchPath :: EnvOverride -> [FilePath] -envSearchPath = eoPath - --- | Modify the environment variables of an 'EnvOverride'. -modifyEnvOverride :: MonadIO m - => EnvOverride - -> (Map Text Text -> Map Text Text) - -> m EnvOverride -modifyEnvOverride eo f = mkEnvOverride - (eoPlatform eo) - (f $ eoTextMap eo) - --- | Create a new 'EnvOverride'. -mkEnvOverride :: MonadIO m - => Platform - -> Map Text Text - -> m EnvOverride -mkEnvOverride platform tm' = do - ref <- liftIO $ newIORef Map.empty - return EnvOverride - { eoTextMap = tm - , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm - , eoPath = - (if isWindows then (".":) else id) - (maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)) - , eoExeCache = ref - , eoExeExtensions = - if isWindows - then let pathext = fromMaybe - ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC" - (Map.lookup "PATHEXT" tm) - in map T.unpack $ "" : T.splitOn ";" pathext - else [""] - , eoPlatform = platform - } - where - -- Fix case insensitivity of the PATH environment variable on Windows. - tm - | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm' - | otherwise = tm' - - -- Don't use CPP so that the Windows code path is at least type checked - -- regularly - isWindows = - case platform of - Platform _ Windows -> True - _ -> False - --- | Helper conversion function. -envHelper :: EnvOverride -> Maybe [(String, String)] -envHelper = Just . eoStringList - --- | Read from the process, ignoring any output. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessNull :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional working directory - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m () -readProcessNull wd menv name args = - sinkProcessStdout wd menv name args CL.sinkNull - --- | Try to produce a strict 'S.ByteString' from the stdout of a --- process. -tryProcessStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (Either ReadProcessException S.ByteString) -tryProcessStdout wd menv name args = - try (readProcessStdout wd menv name args) - --- | Try to produce strict 'S.ByteString's from the stderr and stdout of a --- process. -tryProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (Either ReadProcessException (S.ByteString, S.ByteString)) -tryProcessStderrStdout wd menv name args = - try (readProcessStderrStdout wd menv name args) - --- | Produce a strict 'S.ByteString' from the stdout of a process. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m S.ByteString -readProcessStdout wd menv name args = - sinkProcessStdout wd menv name args CL.consume >>= - liftIO . evaluate . S.concat - --- | Produce strict 'S.ByteString's from the stderr and stdout of a process. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (S.ByteString, S.ByteString) -readProcessStderrStdout wd menv name args = do - (e, o) <- sinkProcessStderrStdout wd menv name args CL.consume CL.consume - liftIO $ (,) <$> evaluate (S.concat e) <*> evaluate (S.concat o) - --- | An exception while trying to read from process. -data ReadProcessException - = ProcessFailed CreateProcess ExitCode L.ByteString L.ByteString - -- ^ @'ProcessFailed' createProcess exitCode stdout stderr@ - | NoPathFound - | ExecutableNotFound String [FilePath] - | ExecutableNotFoundAt FilePath - deriving Typeable -instance Show ReadProcessException where - show (ProcessFailed cp ec out err) = concat $ - [ "Running " - , showSpec $ cmdspec cp] ++ - maybe [] (\x -> [" in directory ", x]) (cwd cp) ++ - [ " exited with " - , show ec - , "\n\n" - , toStr out - , "\n" - , toStr err - ] - where - toStr = LT.unpack . LT.decodeUtf8With lenientDecode - - 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 - ] - show (ExecutableNotFoundAt name) = - "Did not find executable at specified path: " ++ name -instance Exception ReadProcessException - --- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer. --- 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'. --- --- Throws a 'ReadProcessException' if unsuccessful. -sinkProcessStdout - :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> 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' stderrBuffer (<> byteString bytes)))) - (CL.iterM (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))) $= - sinkStdout)) - (\(ProcessExitedUnsuccessfully cp ec) -> - do stderrBuilder <- liftIO (readIORef stderrBuffer) - stdoutBuilder <- liftIO (readIORef stdoutBuffer) - liftIO $ throwM $ ProcessFailed - cp - ec - (toLazyByteString stdoutBuilder) - (toLazyByteString stderrBuilder)) - return sinkRet - -logProcessStderrStdout - :: (HasCallStack, MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) - -> String - -> EnvOverride - -> [String] - -> m () -logProcessStderrStdout mdir name menv args = withUnliftIO $ \u -> do - let logLines = CB.lines =$ CL.mapM_ (unliftIO u . logInfo . decodeUtf8With lenientDecode) - ((), ()) <- unliftIO u $ sinkProcessStderrStdout mdir menv name args logLines logLines - return () - --- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers. --- --- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. -sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> Sink S.ByteString IO e -- ^ Sink for stderr - -> Sink S.ByteString IO o -- ^ Sink for stdout - -> m (e,o) -sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do - name' <- preProcess wd menv name - withProcessTimeLog name' args $ - liftIO $ withCheckedProcess - (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd } - (\ClosedStream out err -> f err out) - where - - -- There is a bug in streaming-commons or conduit-extra which - -- leads to a file descriptor leak. Ideally, we should be able to - -- simply use the following code. Instead, we're using the code - -- below it, which is explicit in closing Handles. When the - -- upstream bug is fixed, we can consider moving back to the - -- simpler code, though there's really no downside to the more - -- complex version used here. - -- - -- f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o) - -- f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout) - - f :: Handle -> Handle -> IO (e, o) - f err out = ((CB.sourceHandle err $$ sinkStderr) `concurrently` (CB.sourceHandle out $$ sinkStdout)) - `finally` hClose err `finally` hClose out - --- | Like sinkProcessStderrStdout, but receives Handles for stderr and stdout instead of 'Sink's. --- --- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. -sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> Handle - -> Handle - -> m () -sinkProcessStderrStdoutHandle wd menv name args err out = do - name' <- preProcess wd menv name - withProcessTimeLog name' args $ - liftIO $ withCheckedProcess - (proc name' args) - { env = envHelper menv - , cwd = fmap toFilePath wd - , std_err = UseHandle err - , std_out = UseHandle out - } - (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ()) - --- | Perform pre-call-process tasks. Ensure the working directory exists and find the --- executable path. --- --- Throws a 'ReadProcessException' if unsuccessful. -preProcess :: (MonadIO m) - => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary - -> EnvOverride -- ^ How to override environment - -> String -- ^ Command name - -> m FilePath -preProcess wd menv name = do - name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name - maybe (return ()) ensureDir wd - return name' - --- | Check if the given executable exists on the given PATH. -doesExecutableExist :: (MonadIO m) - => EnvOverride -- ^ How to override environment - -> String -- ^ Name of executable - -> m Bool -doesExecutableExist menv name = liftM isJust $ findExecutable menv name - --- | Find the complete path for the executable. --- --- Throws a 'ReadProcessException' if unsuccessful. -findExecutable :: (MonadIO m, MonadThrow n) - => EnvOverride -- ^ How to override environment - -> String -- ^ Name of executable - -> m (n (Path Abs File)) -- ^ Full path to that executable on success -findExecutable eo name0 | any FP.isPathSeparator name0 = do - let names0 = map (name0 ++) (eoExeExtensions eo) - testNames [] = return $ throwM $ ExecutableNotFoundAt name0 - testNames (name:names) = do - exists <- liftIO $ D.doesFileExist name - if exists - then do - path <- liftIO $ resolveFile' name - return $ return path - else testNames names - testNames names0 -findExecutable eo name = liftIO $ do - m <- readIORef $ eoExeCache eo - epath <- case Map.lookup name m of - Just epath -> return epath - Nothing -> do - let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo) - loop (dir:dirs) = do - let fp0 = dir FP. name - fps0 = map (fp0 ++) (eoExeExtensions eo) - testFPs [] = loop dirs - testFPs (fp:fps) = do - exists <- D.doesFileExist fp - existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False - if existsExec - then do - fp' <- D.makeAbsolute fp >>= parseAbsFile - return $ return fp' - else testFPs fps - testFPs fps0 - epath <- loop $ eoPath eo - () <- atomicModifyIORef (eoExeCache eo) $ \m' -> - (Map.insert name epath m', ()) - return epath - return $ either throwM return epath - --- | Reset the executable cache. -resetExeCache :: MonadIO m => EnvOverride -> m () -resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty)) - --- | Load up an 'EnvOverride' from the standard environment. -getEnvOverride :: MonadIO m => Platform -> m EnvOverride -getEnvOverride platform = - liftIO $ - getEnvironment >>= - mkEnvOverride platform - . Map.fromList . map (T.pack *** T.pack) - -newtype InvalidPathException = PathsInvalidInPath [FilePath] - deriving Typeable - -instance Exception InvalidPathException -instance Show InvalidPathException where - show (PathsInvalidInPath paths) = unlines $ - [ "Would need to add some paths to the PATH environment variable \ - \to continue, but they would be invalid because they contain a " - ++ show FP.searchPathSeparator ++ "." - , "Please fix the following paths and try again:" - ] ++ paths - --- | Augment the PATH environment variable with the given extra paths. -augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text -augmentPath dirs mpath = - do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs) - unless (null illegal) (throwM $ PathsInvalidInPath illegal) - return $ T.intercalate (T.singleton FP.searchPathSeparator) - $ map (T.pack . toFilePathNoTrailingSep) dirs - ++ maybeToList mpath - --- | Apply 'augmentPath' on the PATH value in the given Map. -augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text - -> m (Map Text Text) -augmentPathMap dirs origEnv = - do path <- augmentPath dirs mpath - return $ Map.insert "PATH" path origEnv - where - mpath = Map.lookup "PATH" origEnv diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs deleted file mode 100644 index 6505e0803a..0000000000 --- a/src/System/Process/Run.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} --- | Run sub-processes. - -module System.Process.Run - (runCmd - ,runCmd' - ,callProcess - ,callProcess' - ,callProcessInheritStderrStdout - ,callProcessObserveStdout - ,createProcess' - ,ProcessExitedUnsuccessfully - ,Cmd(..) - ) - where - -import Stack.Prelude -import Data.Conduit.Process hiding (callProcess) -import qualified Data.Text as T -import System.Exit (exitWith, ExitCode (..)) -import System.IO (hGetLine) -import qualified System.Process -import System.Process.Log -import System.Process.Read - --- | Cmd holds common infos needed to running a process in most cases -data Cmd = Cmd - { cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in - , cmdCommandToRun :: FilePath -- ^ command to run - , cmdEnvOverride :: EnvOverride - , cmdCommandLineArguments :: [String] -- ^ command line arguments - } - --- | Run the given command in the given directory, inheriting stdout and stderr. --- --- If it exits with anything but success, prints an error --- and then calls 'exitWith' to exit the program. -runCmd :: forall (m :: * -> *). - (MonadLogger m, MonadUnliftIO m) - => Cmd - -> Maybe Text -- ^ optional additional error message - -> m () -runCmd = runCmd' id - -runCmd' :: forall (m :: * -> *). - (MonadLogger m, MonadUnliftIO m) - => (CreateProcess -> CreateProcess) - -> Cmd - -> Maybe Text -- ^ optional additional error message - -> m () -runCmd' modCP cmd@Cmd{..} mbErrMsg = do - result <- try (callProcess' modCP cmd) - case result of - Left (ProcessExitedUnsuccessfully _ ec) -> do - logError $ - T.pack $ - concat $ - [ "Exit code " - , show ec - , " while running " - , show (cmdCommandToRun : cmdCommandLineArguments) - ] ++ (case cmdDirectoryToRunIn of - Nothing -> [] - Just mbDir -> [" in ", toFilePath mbDir] - ) - forM_ mbErrMsg logError - liftIO (exitWith ec) - Right () -> return () - --- | Like 'System.Process.callProcess', but takes an optional working directory and --- environment override, and throws 'ProcessExitedUnsuccessfully' if the --- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. --- --- Inherits stdout and stderr. -callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m () -callProcess = callProcess' id - --- | Like 'System.Process.callProcess', but takes an optional working directory and --- environment override, and throws 'ProcessExitedUnsuccessfully' if the --- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. --- --- Inherits stdout and stderr. -callProcess' :: (MonadIO m, MonadLogger m) - => (CreateProcess -> CreateProcess) -> Cmd -> m () -callProcess' modCP cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ do - (_, _, _, p) <- System.Process.createProcess c - exit_code <- waitForProcess p - case exit_code of - ExitSuccess -> return () - ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) - -callProcessInheritStderrStdout :: (MonadIO m, MonadLogger m) => Cmd -> m () -callProcessInheritStderrStdout cmd = do - let inheritOutput cp = cp { std_in = CreatePipe, std_out = Inherit, std_err = Inherit } - callProcess' inheritOutput cmd - -callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String -callProcessObserveStdout cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ do - (_, Just hStdout, _, p) <- System.Process.createProcess c - hSetBuffering hStdout NoBuffering - exit_code <- waitForProcess p - case exit_code of - ExitSuccess -> hGetLine hStdout - ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) - where - modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } - --- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'. --- Note that the 'Handle's provided by 'UseHandle' are not closed --- automatically. -createProcess' :: (MonadIO m, MonadLogger m) - => String - -> (CreateProcess -> CreateProcess) - -> Cmd - -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess' tag modCP cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ System.Process.createProcess_ tag c - --- Throws a 'ReadProcessException' if process is not found. -cmdToCreateProcess :: MonadIO m => Cmd -> m CreateProcess -cmdToCreateProcess (Cmd wd cmd0 menv args) = do - cmd <- preProcess wd menv cmd0 - return $ (proc cmd args) { delegate_ctlc = True - , cwd = fmap toFilePath wd - , env = envHelper menv } diff --git a/src/main/Main.hs b/src/main/Main.hs index 4b7da5001f..7e92984adc 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -30,11 +30,11 @@ import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Version (showVersion) -import System.Process.Read +import RIO.Process #ifdef USE_GIT_INFO import Development.GitRev (gitCommitCount, gitHash) #endif -import Distribution.System (buildArch, buildPlatform) +import Distribution.System (buildArch) import qualified Distribution.Text as Cabal (display) import Distribution.Version (mkVersion') import GHC.IO.Encoding (mkTextEncoding, textEncodingName) @@ -59,7 +59,6 @@ import Stack.Constants.Config import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot -import Stack.Exec import Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix import Stack.Fetch @@ -507,12 +506,11 @@ secondaryCommandHandler args f = else do mExternalExec <- D.findExecutable cmd case mExternalExec of - Just ex -> do - menv <- getEnvOverride buildPlatform + Just ex -> runEnvNoLogging $ do -- TODO show the command in verbose mode -- hPutStrLn stderr $ unwords $ -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"] - _ <- runNoLogging (exec menv ex (tail args)) + _ <- exec ex (tail args) return f Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f where @@ -587,7 +585,7 @@ setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do when (isJust scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do throwIO UpgradeCabalUnusable - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do + withUserFileLock go (view stackRootL lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer @@ -775,7 +773,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = (ExecGhc, args) -> return ("ghc", args) (ExecRunGhc, args) -> return ("runghc", args) loadConfigWithOpts go $ \lc -> - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do + withUserFileLock go (view stackRootL lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer @@ -784,42 +782,43 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = (Just $ munlockFile lk) (runRIO (lcConfig lc) $ do config <- view configL - menv <- liftIO $ configEnvOverride config plainEnvSettings - Nix.reexecWithOptionalShell + menv <- liftIO $ configEnvOverrideSettings config plainEnvSettings + withEnvOverride menv $ Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (runRIO (lcConfig lc) $ - exec menv cmd args)) + exec cmd args)) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do - let targets = concatMap words eoPackages - unless (null targets) $ - Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI - { boptsCLITargets = map T.pack targets - } - - config <- view configL - menv <- liftIO $ configEnvOverride config eoEnvSettings + let targets = concatMap words eoPackages + unless (null targets) $ + Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + { boptsCLITargets = map T.pack targets + } + + config <- view configL + menv <- liftIO $ configEnvOverrideSettings config eoEnvSettings + withEnvOverride menv $ do -- Add RTS options to arguments let argsWithRts args = if null eoRtsOptions then args :: [String] else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"] (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) - (ExecGhc, args) -> getGhcCmd "" menv eoPackages args + (ExecGhc, args) -> getGhcCmd "" eoPackages args -- NOTE: this won't currently work for GHCJS, because it doesn't have -- a runghcjs binary. It probably will someday, though. (ExecRunGhc, args) -> - getGhcCmd "run" menv eoPackages args + getGhcCmd "run" eoPackages args munlockFile lk -- Unlock before transferring control away. - runWithPath eoCwd $ exec menv cmd args + runWithPath eoCwd $ exec cmd args where -- return the package-id of the first package in GHC_PACKAGE_PATH - getPkgId menv wc name = do - mId <- findGhcPkgField menv wc [] name "id" + getPkgId wc name = do + mId <- findGhcPkgField wc [] name "id" case mId of Just i -> return (head $ words (T.unpack i)) -- should never happen as we have already installed the packages @@ -827,13 +826,13 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = hPutStrLn stderr ("Could not find package id of package " ++ name) exitFailure - getPkgOpts menv wc pkgs = do - ids <- mapM (getPkgId menv wc) pkgs + getPkgOpts wc pkgs = do + ids <- mapM (getPkgId wc) pkgs return $ map ("-package-id=" ++) ids - getGhcCmd prefix menv pkgs args = do + getGhcCmd prefix pkgs args = do wc <- view $ actualCompilerVersionL.whichCompilerL - pkgopts <- getPkgOpts menv wc pkgs + pkgopts <- getPkgOpts wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig () @@ -881,7 +880,7 @@ dockerPullCmd :: () -> GlobalOpts -> IO () dockerPullCmd _ go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer Docker.pull @@ -890,7 +889,7 @@ dockerResetCmd :: Bool -> GlobalOpts -> IO () dockerResetCmd keepHome go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome @@ -899,7 +898,7 @@ dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO () dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.cleanup cleanupOpts diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs index cd43deb139..4715020ba5 100644 --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -6,7 +6,7 @@ module Stack.Build.TargetSpec (main, spec) where import qualified Data.Text as T import Stack.Build.Target import Stack.Prelude -import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 0ef0d84398..b1dde1a409 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -9,8 +9,8 @@ import qualified Data.Conduit.List as CL import Data.Conduit.Text (decodeUtf8) import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.System (buildPlatform) import Distribution.License (License(..)) +import Lens.Micro (to) import Stack.PackageDump import Stack.Prelude import Stack.Types.Compiler @@ -18,7 +18,7 @@ import Stack.Types.GhcPkgId import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read +import RIO.Process hiding (runEnvNoLogging) import Test.Hspec import Test.Hspec.QuickCheck @@ -29,7 +29,7 @@ spec :: Spec spec = do describe "eachSection" $ do let test name content expected = it name $ do - actual <- yield content $$ eachSection CL.consume =$ CL.consume + actual <- runConduit $ yield content .| eachSection CL.consume .| CL.consume actual `shouldBe` expected test "unix line endings" @@ -55,7 +55,7 @@ spec = do , " val4b" ] sink k = fmap (k, ) CL.consume - actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume + actual <- runConduit $ mapM_ yield bss .| eachPair sink .| CL.consume actual `shouldBe` [ ("key1", ["val1"]) , ("key2", ["val2a", "val2b"]) @@ -214,32 +214,29 @@ spec = do } - it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLogging $ do - menv' <- getEnvOverride buildPlatform - menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' + it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runEnvNoLogging $ do icache <- newInstalledCache - ghcPkgDump menv Ghc [] + ghcPkgDump Ghc [] $ conduitDumpPackage - =$ addProfiling icache - =$ addHaddock icache - =$ fakeAddSymbols - =$ CL.sinkNull + .| addProfiling icache + .| addHaddock icache + .| fakeAddSymbols + .| CL.sinkNull - it "sinkMatching" $ do - menv' <- getEnvOverride buildPlatform - menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' + it "sinkMatching" $ runEnvNoLogging $ do icache <- newInstalledCache - m <- runNoLogging $ ghcPkgDump menv Ghc [] + m <- ghcPkgDump Ghc [] $ conduitDumpPackage - =$ addProfiling icache - =$ addHaddock icache - =$ fakeAddSymbols - =$ sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) + .| addProfiling icache + .| addHaddock icache + .| fakeAddSymbols + .| sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) case Map.lookup $(mkPackageName "base") m of Nothing -> error "base not present" Just _ -> return () - Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing - Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing + liftIO $ do + Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing + Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing describe "pruneDeps" $ do it "sanity check" $ do @@ -283,5 +280,17 @@ checkDepsPresent prunes selected = Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds -- addSymbols can't be reasonably tested like this -fakeAddSymbols :: Monad m => Conduit (DumpPackage a b c) m (DumpPackage a b Bool) +fakeAddSymbols :: Monad m => ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m () fakeAddSymbols = CL.map (\dp -> dp { dpSymbols = False }) + +runEnvNoLogging :: RIO EnvNoLogging a -> IO a +runEnvNoLogging inner = do + menv' <- getEnvOverride + menv <- mkEnvOverride $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' + runRIO (EnvNoLogging menv) inner + +newtype EnvNoLogging = EnvNoLogging EnvOverride +instance HasLogFunc EnvNoLogging where + logFuncL = to (\_ _ _ _ _ -> return ()) +instance HasEnvOverride EnvNoLogging where + envOverrideL = lens (\(EnvNoLogging x) -> x) (const EnvNoLogging) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index b5314d9df3..c95ea57df4 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,8 @@ resolver: nightly-2017-12-20 +packages: +- . +- subs/rio + nix: # --nix on the command-line to enable. enable: false @@ -7,3 +11,5 @@ nix: - http-client-tls-0.3.4 extra-deps: - bindings-uname-0.1 +- conduit-extra-1.2.3.1 +- typed-process-0.2.1.0 diff --git a/stack.yaml b/stack.yaml index 3371af5b98..ba708a1e77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,8 @@ resolver: lts-9.14 +packages: +- . +- subs/rio + # docker: # enable: true # repo: fpco/stack-full @@ -30,3 +34,5 @@ extra-deps: - ansi-terminal-0.7.1.1 - ansi-wl-pprint-0.6.8.1 - smallcheck-1.1.3 +- conduit-extra-1.2.3.1 +- typed-process-0.2.1.0 diff --git a/subs/rio/.gitignore b/subs/rio/.gitignore new file mode 100644 index 0000000000..6d48759e99 --- /dev/null +++ b/subs/rio/.gitignore @@ -0,0 +1 @@ +/rio.cabal diff --git a/subs/rio/package.yaml b/subs/rio/package.yaml new file mode 100644 index 0000000000..5ddc885ad8 --- /dev/null +++ b/subs/rio/package.yaml @@ -0,0 +1,43 @@ +name: rio +version: 0.0.0.0 + +dependencies: +- base +- bytestring +- clock # FIXME perhaps drop +- conduit # FIXME drop +- conduit-extra # FIXME drop +- containers +- deepseq +- directory +- exceptions +- filepath +- hashable +- microlens # FIXME perhaps drop +- microlens-mtl # FIXME perhaps drop +- mtl +- path # FIXME drop +- path-io # FIXME drop +- store # FIXME drop +- text +- time +- typed-process >= 0.2.1.0 +- unliftio +- unordered-containers +- vector + +when: +- condition: os(windows) + then: + cpp-options: -DWINDOWS + dependencies: + - Win32 + else: + dependencies: + - pid1 # FIXME drop, likely move code in here or typed-process + - unix + +library: + source-dirs: src/ + other-modules: + - RIO.Prelude diff --git a/src/Path/Extra.hs b/subs/rio/src/Path/Extra.hs similarity index 99% rename from src/Path/Extra.hs rename to subs/rio/src/Path/Extra.hs index ac82295a75..4d209fac70 100644 --- a/src/Path/Extra.hs +++ b/subs/rio/src/Path/Extra.hs @@ -22,7 +22,7 @@ import Data.Time (UTCTime) import Path import Path.IO import Path.Internal (Path(..)) -import Stack.Prelude +import RIO.Prelude import System.IO.Error (isDoesNotExistError) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL diff --git a/subs/rio/src/RIO.hs b/subs/rio/src/RIO.hs new file mode 100644 index 0000000000..f2932e6ab0 --- /dev/null +++ b/subs/rio/src/RIO.hs @@ -0,0 +1,4 @@ +module RIO (module X) where + +import RIO.Prelude as X +import RIO.Logger as X diff --git a/subs/rio/src/RIO/Logger.hs b/subs/rio/src/RIO/Logger.hs new file mode 100644 index 0000000000..8a74680105 --- /dev/null +++ b/subs/rio/src/RIO/Logger.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NoImplicitPrelude #-} +module RIO.Logger + ( LogLevel (..) + , LogSource + , LogStr + , HasLogFunc (..) + , logGeneric + , logDebug + , logInfo + , logWarn + , logError + , logOther + , logSticky + , logStickyDone + , runNoLogging + , NoLogging (..) + ) where + +import RIO.Prelude +import Data.Text (Text) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) +import Lens.Micro (Getting, to) +import Lens.Micro.Mtl (view) +import GHC.Stack (HasCallStack, CallStack) + +data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther !Text + deriving (Eq, Show, Read, Ord) + +type LogSource = Text +type LogStr = Text +class HasLogFunc env where + logFuncL :: Getting r env (CallStack -> LogSource -> LogLevel -> LogStr -> IO ()) + +logGeneric + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => LogSource + -> LogLevel + -> LogStr + -> m () +logGeneric src level str = do + logFunc <- view logFuncL + liftIO $ logFunc ?callStack src level str + +logDebug + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => LogStr + -> m () +logDebug = logGeneric "" LevelDebug + +logInfo + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => LogStr + -> m () +logInfo = logGeneric "" LevelInfo + +logWarn + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => LogStr + -> m () +logWarn = logGeneric "" LevelWarn + +logError + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => LogStr + -> m () +logError = logGeneric "" LevelError + +logOther + :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) + => Text -- ^ level + -> LogStr + -> m () +logOther = logGeneric "" . LevelOther + +runNoLogging :: MonadIO m => ReaderT NoLogging m a -> m a +runNoLogging = flip runReaderT NoLogging + +data NoLogging = NoLogging +instance HasLogFunc NoLogging where + logFuncL = to (\_ _ _ _ _ -> return ()) + +-- | Write a "sticky" line to the terminal. Any subsequent lines will +-- overwrite this one, and that same line will be repeated below +-- again. In other words, the line sticks at the bottom of the output +-- forever. Running this function again will replace the sticky line +-- with a new sticky line. When you want to get rid of the sticky +-- line, run 'logStickyDone'. +-- +logSticky :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Text -> m () +logSticky = logOther "sticky" + +-- | This will print out the given message with a newline and disable +-- any further stickiness of the line until a new call to 'logSticky' +-- happens. +-- +-- It might be better at some point to have a 'runSticky' function +-- that encompasses the logSticky->logStickyDone pairing. +logStickyDone :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Text -> m () +logStickyDone = logOther "sticky-done" diff --git a/subs/rio/src/RIO/Prelude.hs b/subs/rio/src/RIO/Prelude.hs new file mode 100644 index 0000000000..16170fd52d --- /dev/null +++ b/subs/rio/src/RIO/Prelude.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module RIO.Prelude + ( mapLeft + , withLazyFile + , fromFirst + , mapMaybeA + , mapMaybeM + , forMaybeA + , forMaybeM + , stripCR + , RIO (..) + , runRIO + , module X + ) where + +import Control.Applicative as X (Alternative, Applicative (..), + liftA, liftA2, liftA3, many, + optional, some, (<|>)) +import Control.Arrow as X (first, second, (&&&), (***)) +import Control.DeepSeq as X (NFData (..), force, ($!!)) +import Control.Monad as X (Monad (..), MonadPlus (..), filterM, + foldM, foldM_, forever, guard, join, + liftM, liftM2, replicateM_, unless, + when, zipWithM, zipWithM_, (<$!>), + (<=<), (=<<), (>=>)) +import Control.Monad.Catch as X (MonadThrow (..)) +import Control.Monad.Reader as X (MonadReader, MonadTrans (..), + ReaderT (..), ask, asks, local) +import Data.Bool as X (Bool (..), not, otherwise, (&&), + (||)) +import Data.ByteString as X (ByteString) +import Data.Char as X (Char) +import Data.Conduit as X (ConduitM, runConduit, (.|)) +import Data.Data as X (Data (..)) +import Data.Either as X (Either (..), either, isLeft, + isRight, lefts, partitionEithers, + rights) +import Data.Eq as X (Eq (..)) +import Data.Foldable as X (Foldable, all, and, any, asum, + concat, concatMap, elem, fold, + foldMap, foldl', foldr, forM_, for_, + length, mapM_, msum, notElem, null, + or, product, sequenceA_, sequence_, + sum, toList, traverse_) +import Data.Function as X (const, fix, flip, id, on, ($), (&), + (.)) +import Data.Functor as X (Functor (..), void, ($>), (<$), + (<$>)) +import Data.Hashable as X (Hashable) +import Data.HashMap.Strict as X (HashMap) +import Data.HashSet as X (HashSet) +import Data.Int as X +import Data.IntMap.Strict as X (IntMap) +import Data.IntSet as X (IntSet) +import Data.List as X (break, drop, dropWhile, filter, + lines, lookup, map, replicate, + reverse, span, take, takeWhile, + unlines, unwords, words, zip, (++)) +import Data.Map.Strict as X (Map) +import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe, + isJust, isNothing, listToMaybe, + mapMaybe, maybe, maybeToList) +import Data.Monoid as X (All (..), Any (..), Endo (..), + First (..), Last (..), Monoid (..), + Product (..), Sum (..), (<>)) +import Data.Ord as X (Ord (..), Ordering (..), comparing) +import Data.Set as X (Set) +import Data.Store as X (Store) +import Data.String as X (IsString (..)) +import Data.Text as X (Text) +import Data.Traversable as X (Traversable (..), for, forM) +import Data.Vector as X (Vector) +import Data.Void as X (Void, absurd) +import Data.Word as X +import GHC.Generics as X (Generic) +import GHC.Stack as X (HasCallStack) +import Lens.Micro as X (Getting, Lens', lens) +import Lens.Micro.Mtl as X (view) +import Prelude as X (Bounded (..), Double, Enum, + FilePath, Float, Floating (..), + Fractional (..), IO, Integer, + Integral (..), Num (..), Rational, + Real (..), RealFloat (..), + RealFrac (..), Show, String, + asTypeOf, curry, error, even, + fromIntegral, fst, gcd, lcm, odd, + realToFrac, seq, show, snd, + subtract, uncurry, undefined, ($!), + (^), (^^)) +import System.Exit as X (ExitCode (..)) +import Text.Read as X (Read, readMaybe) +import UnliftIO as X + +import qualified Data.Text as T + +import qualified Data.ByteString.Lazy as BL + +mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b +mapLeft f (Left a1) = Left (f a1) +mapLeft _ (Right b) = Right b + +fromFirst :: a -> First a -> a +fromFirst x = fromMaybe x . getFirst + +-- | Applicative 'mapMaybe'. +mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] +mapMaybeA f = fmap catMaybes . traverse f + +-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@ +forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b] +forMaybeA = flip mapMaybeA + +-- | Monadic 'mapMaybe'. +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + +-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@ +forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] +forMaybeM = flip mapMaybeM + +-- | Strip trailing carriage return from Text +stripCR :: T.Text -> T.Text +stripCR t = fromMaybe t (T.stripSuffix "\r" t) + +-- | Lazily get the contents of a file. Unlike 'BL.readFile', this +-- ensures that if an exception is thrown, the file handle is closed +-- immediately. +withLazyFile :: MonadUnliftIO m => FilePath -> (BL.ByteString -> m a) -> m a +withLazyFile fp inner = withBinaryFile fp ReadMode $ inner <=< liftIO . BL.hGetContents + +-- | The Reader+IO monad. This is different from a 'ReaderT' because: +-- +-- * It's not a transformer, it hardcodes IO for simpler usage and +-- error messages. +-- +-- * Instances of typeclasses like 'MonadLogger' are implemented using +-- classes defined on the environment, instead of using an +-- underlying monad. +newtype RIO env a = RIO { unRIO :: ReaderT env IO a } + deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow) + +runRIO :: MonadIO m => env -> RIO env a -> m a +runRIO env (RIO (ReaderT f)) = liftIO (f env) + +instance MonadUnliftIO (RIO env) where + askUnliftIO = RIO $ ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r . unRIO)) diff --git a/subs/rio/src/RIO/Process.hs b/subs/rio/src/RIO/Process.hs new file mode 100644 index 0000000000..49c2c31ebc --- /dev/null +++ b/subs/rio/src/RIO/Process.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Reading from external processes. + +module RIO.Process + (withProcess + ,withProcess_ + ,EnvOverride(..) + ,unEnvOverride + ,mkEnvOverride + ,modifyEnvOverride + ,envHelper + ,doesExecutableExist + ,findExecutable + ,getEnvOverride + ,envSearchPath + ,preProcess + ,readProcessNull + ,ReadProcessException (..) + ,augmentPath + ,augmentPathMap + ,resetExeCache + ,HasEnvOverride (..) + ,workingDirL + ,withProc + ,withEnvOverride + ,withModifyEnvOverride + ,withWorkingDir + ,runEnvNoLogging + ,withProcessTimeLog + ,showProcessArgDebug + ,exec + ,execSpawn + ,execObserve + ,module System.Process.Typed + ) + where + +import RIO.Prelude +import RIO.Logger +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Text.Encoding.Error (lenientDecode) +import Lens.Micro (set, to) +import Path +import Path.Extra +import Path.IO hiding (findExecutable) +import qualified System.Directory as D +import System.Environment (getEnvironment) +import System.Exit (exitWith) +import qualified System.FilePath as FP +import qualified System.Clock as Clock +import qualified System.Process.Typed as P +import System.Process.Typed hiding (withProcess, withProcess_) + +#ifndef WINDOWS +import qualified System.Process.PID1 as PID1 +#endif + +class HasLogFunc env => HasEnvOverride env where + envOverrideL :: Lens' env EnvOverride + +data EnvVarFormat = EVFWindows | EVFNotWindows + +currentEnvVarFormat :: EnvVarFormat +currentEnvVarFormat = +#if WINDOWS + EVFWindows +#else + EVFNotWindows +#endif + +-- | Override the environment received by a child process. +data EnvOverride = EnvOverride + { eoTextMap :: Map Text Text -- ^ Environment variables as map + , eoStringList :: [(String, String)] -- ^ Environment variables as association list + , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@) + , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) + , eoExeExtensions :: [String] -- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows + , eoWorkingDir :: !(Maybe (Path Abs Dir)) + } + +workingDirL :: HasEnvOverride env => Lens' env (Maybe (Path Abs Dir)) +workingDirL = envOverrideL.lens eoWorkingDir (\x y -> x { eoWorkingDir = y }) + +-- | Get the environment variables from an 'EnvOverride'. +unEnvOverride :: EnvOverride -> Map Text Text +unEnvOverride = eoTextMap + +-- | Get the list of directories searched (@PATH@). +envSearchPath :: EnvOverride -> [FilePath] +envSearchPath = eoPath + +-- | Modify the environment variables of an 'EnvOverride'. +modifyEnvOverride :: MonadIO m + => EnvOverride + -> (Map Text Text -> Map Text Text) + -> m EnvOverride +modifyEnvOverride eo f = mkEnvOverride (f $ eoTextMap eo) + +-- | Create a new 'EnvOverride'. +mkEnvOverride :: MonadIO m + => Map Text Text + -> m EnvOverride +mkEnvOverride tm' = do + ref <- liftIO $ newIORef Map.empty + return EnvOverride + { eoTextMap = tm + , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm + , eoPath = + (if isWindows then (".":) else id) + (maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)) + , eoExeCache = ref + , eoExeExtensions = + if isWindows + then let pathext = fromMaybe + ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC" + (Map.lookup "PATHEXT" tm) + in map T.unpack $ "" : T.splitOn ";" pathext + else [""] + , eoWorkingDir = Nothing + } + where + -- Fix case insensitivity of the PATH environment variable on Windows. + tm + | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm' + | otherwise = tm' + + -- Don't use CPP so that the Windows code path is at least type checked + -- regularly + isWindows = + case currentEnvVarFormat of + EVFWindows -> True + EVFNotWindows -> False + +-- | Helper conversion function. +envHelper :: EnvOverride -> [(String, String)] +envHelper = eoStringList + +-- | Read from the process, ignoring any output. +-- +-- Throws a 'ReadProcessException' exception if the process fails. +readProcessNull :: HasEnvOverride env -- FIXME remove + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> RIO env () +readProcessNull name args = + -- We want the output to appear in any exceptions, so we capture and drop it + void $ withProc name args readProcessStdout_ + +-- | An exception while trying to read from process. +data ReadProcessException + = NoPathFound + | ExecutableNotFound String [FilePath] + | ExecutableNotFoundAt FilePath + deriving Typeable +instance Show ReadProcessException where + show NoPathFound = "PATH not found in EnvOverride" + show (ExecutableNotFound name path) = concat + [ "Executable named " + , name + , " not found on path: " + , show path + ] + show (ExecutableNotFoundAt name) = + "Did not find executable at specified path: " ++ name +instance Exception ReadProcessException + +-- | Provide a 'ProcessConfig' based on the 'EnvOverride' in +-- scope. Deals with resolving the full path, setting the child +-- process's environment variables, setting the working directory, and +-- wrapping the call with 'withProcessTimeLog' for debugging output. +withProc + :: HasEnvOverride env + => FilePath -- ^ command to run + -> [String] -- ^ command line arguments + -> (ProcessConfig () () () -> RIO env a) + -> RIO env a +withProc name0 args inner = do + menv <- view envOverrideL + name <- preProcess name0 + + withProcessTimeLog (toFilePath <$> eoWorkingDir menv) name args + $ inner + $ setDelegateCtlc True + $ setEnv (envHelper menv) + $ maybe id (setWorkingDir . toFilePath) (eoWorkingDir menv) + + -- sensible default in Stack: we do not want subprocesses to be + -- able to interact with the user by default. If a specific case + -- requires interaction, we can override with `setStdin + -- (useHandleOpen stdin)`. + $ setStdin closed + + $ proc name args + +-- | Apply the given function to the modified environment +-- variables. For more details, see 'withEnvOverride'. +withModifyEnvOverride :: HasEnvOverride env => (Map Text Text -> Map Text Text) -> RIO env a -> RIO env a +withModifyEnvOverride f inner = do + menv <- view envOverrideL + menv' <- modifyEnvOverride menv f + withEnvOverride menv' inner + +-- | Set a new 'EnvOverride' in the child reader. Note that this will +-- keep the working directory set in the parent with 'withWorkingDir'. +withEnvOverride :: HasEnvOverride env => EnvOverride -> RIO env a -> RIO env a +withEnvOverride newEnv = local $ \r -> + let newEnv' = newEnv { eoWorkingDir = eoWorkingDir $ view envOverrideL r } + in set envOverrideL newEnv' r + +-- | Set the working directory to be used by child processes. +withWorkingDir :: HasEnvOverride env => Path Abs Dir -> RIO env a -> RIO env a +withWorkingDir = local . set workingDirL . Just + +-- | Perform pre-call-process tasks. Ensure the working directory exists and find the +-- executable path. +-- +-- Throws a 'ReadProcessException' if unsuccessful. +preProcess + :: HasEnvOverride env + => String -- ^ Command name + -> RIO env FilePath +preProcess name = do + menv <- view envOverrideL + let wd = eoWorkingDir menv + name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name + maybe (return ()) ensureDir wd + return name' + +-- | Check if the given executable exists on the given PATH. +doesExecutableExist :: (MonadIO m) + => EnvOverride -- ^ How to override environment + -> String -- ^ Name of executable + -> m Bool +doesExecutableExist menv name = liftM isJust $ findExecutable menv name + +-- | Find the complete path for the executable. +-- +-- Throws a 'ReadProcessException' if unsuccessful. +findExecutable :: (MonadIO m, MonadThrow n) + => EnvOverride -- ^ How to override environment + -> String -- ^ Name of executable + -> m (n (Path Abs File)) -- ^ Full path to that executable on success +findExecutable eo name0 | any FP.isPathSeparator name0 = do + let names0 = map (name0 ++) (eoExeExtensions eo) + testNames [] = return $ throwM $ ExecutableNotFoundAt name0 + testNames (name:names) = do + exists <- liftIO $ D.doesFileExist name + if exists + then do + path <- liftIO $ resolveFile' name + return $ return path + else testNames names + testNames names0 +findExecutable eo name = liftIO $ do + m <- readIORef $ eoExeCache eo + epath <- case Map.lookup name m of + Just epath -> return epath + Nothing -> do + let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo) + loop (dir:dirs) = do + let fp0 = dir FP. name + fps0 = map (fp0 ++) (eoExeExtensions eo) + testFPs [] = loop dirs + testFPs (fp:fps) = do + exists <- D.doesFileExist fp + existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False + if existsExec + then do + fp' <- D.makeAbsolute fp >>= parseAbsFile + return $ return fp' + else testFPs fps + testFPs fps0 + epath <- loop $ eoPath eo + () <- atomicModifyIORef (eoExeCache eo) $ \m' -> + (Map.insert name epath m', ()) + return epath + return $ either throwM return epath + +-- | Reset the executable cache. +resetExeCache :: MonadIO m => EnvOverride -> m () +resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty)) + +-- | Load up an 'EnvOverride' from the standard environment. +getEnvOverride :: MonadIO m => m EnvOverride +getEnvOverride = + liftIO $ + getEnvironment >>= + mkEnvOverride + . Map.fromList . map (T.pack *** T.pack) + +newtype InvalidPathException = PathsInvalidInPath [FilePath] + deriving Typeable + +instance Exception InvalidPathException +instance Show InvalidPathException where + show (PathsInvalidInPath paths) = unlines $ + [ "Would need to add some paths to the PATH environment variable \ + \to continue, but they would be invalid because they contain a " + ++ show FP.searchPathSeparator ++ "." + , "Please fix the following paths and try again:" + ] ++ paths + +-- | Augment the PATH environment variable with the given extra paths. +augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text +augmentPath dirs mpath = + do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs) + unless (null illegal) (throwM $ PathsInvalidInPath illegal) + return $ T.intercalate (T.singleton FP.searchPathSeparator) + $ map (T.pack . toFilePathNoTrailingSep) dirs + ++ maybeToList mpath + +-- | Apply 'augmentPath' on the PATH value in the given Map. +augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text + -> m (Map Text Text) +augmentPathMap dirs origEnv = + do path <- augmentPath dirs mpath + return $ Map.insert "PATH" path origEnv + where + mpath = Map.lookup "PATH" origEnv + +runEnvNoLogging :: RIO EnvNoLogging a -> IO a +runEnvNoLogging inner = do + menv <- getEnvOverride + runRIO (EnvNoLogging menv) inner + +newtype EnvNoLogging = EnvNoLogging EnvOverride +instance HasLogFunc EnvNoLogging where + logFuncL = to (\_ _ _ _ _ -> return ()) +instance HasEnvOverride EnvNoLogging where + envOverrideL = lens (\(EnvNoLogging x) -> x) (const EnvNoLogging) + +-- | Log running a process with its arguments, for debugging (-v). +-- +-- This logs one message before running the process and one message after. +withProcessTimeLog :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Maybe FilePath -> String -> [String] -> m a -> m a +withProcessTimeLog mdir name args proc' = do + let cmdText = + T.intercalate + " " + (T.pack name : map showProcessArgDebug args) + dirMsg = + case mdir of + Nothing -> "" + Just dir -> " within " <> T.pack dir + logDebug ("Run process" <> dirMsg <> ": " <> cmdText) + start <- liftIO $ Clock.getTime Clock.Monotonic + x <- proc' + end <- liftIO $ Clock.getTime Clock.Monotonic + let diff = Clock.diffTimeSpec start end + -- useAnsi <- asks getAnsiTerminal + let useAnsi = True + logDebug + ("Process finished in " <> + (if useAnsi then "\ESC[92m" else "") <> -- green + timeSpecMilliSecondText diff <> + (if useAnsi then "\ESC[0m" else "") <> -- reset + ": " <> cmdText) + return x + +timeSpecMilliSecondText :: Clock.TimeSpec -> Text +timeSpecMilliSecondText t = + (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" + +-- | Show a process arg including speechmarks when necessary. Just for +-- debugging purposes, not functionally important. +showProcessArgDebug :: String -> Text +showProcessArgDebug x + | any special x || null x = T.pack (show x) + | otherwise = T.pack x + where special '"' = True + special ' ' = True + special _ = False + +-- | Execute a process within the Stack configured environment. +-- +-- Execution will not return, because either: +-- +-- 1) On non-windows, execution is taken over by execv of the +-- sub-process. This allows signals to be propagated (#527) +-- +-- 2) On windows, an 'ExitCode' exception will be thrown. +exec :: HasEnvOverride env => String -> [String] -> RIO env b +#ifdef WINDOWS +exec = execSpawn +#else +exec cmd0 args = do + menv <- view envOverrideL + cmd <- preProcess cmd0 + withProcessTimeLog Nothing cmd args $ + liftIO $ PID1.run cmd args $ Just $ envHelper menv +#endif + +-- | Like 'exec', but does not use 'execv' on non-windows. This way, there +-- is a sub-process, which is helpful in some cases (#1306) +-- +-- This function only exits by throwing 'ExitCode'. +execSpawn :: HasEnvOverride env => String -> [String] -> RIO env a +execSpawn cmd args = withProc cmd args (runProcess . setStdin inherit) >>= liftIO . exitWith + +execObserve :: HasEnvOverride env => String -> [String] -> RIO env String +execObserve cmd0 args = + withProc cmd0 args $ \pc -> do + (out, _err) <- readProcess_ pc + return + $ TL.unpack + $ TL.filter (/= '\r') + $ TL.concat + $ take 1 + $ TL.lines + $ TLE.decodeUtf8With lenientDecode out + +-- | Same as 'P.withProcess', but generalized to 'MonadUnliftIO'. +withProcess + :: MonadUnliftIO m + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess pc f = withRunInIO $ \run -> P.withProcess pc (run . f) + +-- | Same as 'P.withProcess_', but generalized to 'MonadUnliftIO'. +withProcess_ + :: MonadUnliftIO m + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess_ pc f = withRunInIO $ \run -> P.withProcess_ pc (run . f)