diff --git a/etc/scripts/release.hs b/etc/scripts/release.hs index fe3ddc9ca1..eed17158da 100644 --- a/etc/scripts/release.hs +++ b/etc/scripts/release.hs @@ -194,12 +194,24 @@ rules global@Global{..} args = do releaseCheckDir binaryExeFileName %> \out -> do need [releaseBinDir binaryName stackExeFileName] - -- Run "git diff" so we can see what changes exist, in case things fail below - () <- cmd "git diff" + -- Symlinks in the repo cause a spurious git status change notification + -- on Windows, so we don't run this on Windows. Instead we rely on + -- Linux/Mac testing for that. - Stdout dirty <- cmd "git status --porcelain" - when (not gAllowDirty && not (null (trim dirty))) $ - error ("Working tree is dirty. Use --" ++ allowDirtyOptName ++ " option to continue anyway.") + case platformOS of + Windows -> pure () + _ -> do + -- Run "git diff" so we can see what changes exist, in case things fail below + () <- cmd "git diff" + + Stdout dirty <- cmd "git status --porcelain" + when (not gAllowDirty && not (null (trim dirty))) $ + error $ concat + [ "Working tree is dirty. Use --" + , allowDirtyOptName + , " option to continue anyway. Output:\n" + , show dirty + ] () <- cmd [gProjectRoot releaseBinDir binaryName stackExeFileName] (stackArgs global) diff --git a/package.yaml b/package.yaml index f705752a78..b59459acaa 100644 --- a/package.yaml +++ b/package.yaml @@ -48,6 +48,7 @@ ghc-options: dependencies: - Cabal - aeson +- opentelemetry >= 0.5.0 - annotated-wl-pprint - ansi-terminal - array @@ -275,6 +276,7 @@ executables: ghc-options: - -threaded - -rtsopts + - -eventlog dependencies: - stack when: diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index d4f05de350..b3ef56b3e0 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -47,6 +47,7 @@ import Stack.Types.SourceMap import Stack.Types.Compiler (compilerVersionText, getGhcVersion) import System.Terminal (fixCodePage) +import OpenTelemetry.Eventlog -- | Build. -- @@ -56,7 +57,7 @@ import System.Terminal (fixCodePage) build :: HasEnvConfig env => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files -> RIO env () -build msetLocalFiles = do +build msetLocalFiles = withSpan_ "Build.build" $ do mcp <- view $ configL.to configModifyCodePage ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion fixCodePage mcp ghcVersion $ do @@ -69,26 +70,28 @@ build msetLocalFiles = do checkSubLibraryDependencies (Map.elems $ smProject sourceMap) boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI - -- Set local files, necessary for file watching - stackYaml <- view stackYamlL - for_ msetLocalFiles $ \setLocalFiles -> do - files <- - if boptsCLIWatchAll boptsCli - then sequence [lpFiles lp | lp <- allLocals] - else forM allLocals $ \lp -> do - let pn = packageName (lpPackage lp) - case Map.lookup pn (smtTargets $ smTargets sourceMap) of - Nothing -> - pure Set.empty - Just (TargetAll _) -> - lpFiles lp - Just (TargetComps components) -> - lpFilesForComponents components lp - liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions files + withSpan_ "Build.build_setLocalFiles" $ do + -- Set local files, necessary for file watching + stackYaml <- view stackYamlL + for_ msetLocalFiles $ \setLocalFiles -> do + files <- + if boptsCLIWatchAll boptsCli + then sequence [lpFiles lp | lp <- allLocals] + else forM allLocals $ \lp -> do + let pn = packageName (lpPackage lp) + case Map.lookup pn (smtTargets $ smTargets sourceMap) of + Nothing -> + pure Set.empty + Just (TargetAll _) -> + lpFiles lp + Just (TargetComps components) -> + lpFilesForComponents components lp + liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions files - checkComponentsBuildable allLocals + withSpan_ "Build.build_checkComponentsBuildable" $ do + checkComponentsBuildable allLocals - installMap <- toInstallMap sourceMap + installMap <- withSpan_ "Build.Installed.toInstallMap" $ toInstallMap sourceMap (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled installMap @@ -235,7 +238,7 @@ splitObjsWarning = unwords -- | Get the @BaseConfigOpts@ necessary for constructing configure options mkBaseConfigOpts :: (HasEnvConfig env) => BuildOptsCLI -> RIO env BaseConfigOpts -mkBaseConfigOpts boptsCli = do +mkBaseConfigOpts boptsCli = withSpan_ "Build.mkBaseConfigOpts" $ do bopts <- view buildOptsL snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal @@ -260,7 +263,7 @@ loadPackage -> [Text] -- ^ GHC options -> [Text] -- ^ Cabal configure options -> RIO env Package -loadPackage loc flags ghcOptions cabalConfigOpts = do +loadPackage loc flags ghcOptions cabalConfigOpts = withSpan_ "Build.loadPackage" $ do compiler <- view actualCompilerVersionL platform <- view platformL let pkgConfig = PackageConfig diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index afa51c4d4a..2b31667d3a 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -51,6 +51,8 @@ import System.IO (putStrLn) import RIO.PrettyPrint import RIO.Process (findExecutable, HasProcessContext (..)) +import OpenTelemetry.Eventlog + data PackageInfo = -- | This indicates that the package is already installed, and @@ -173,7 +175,7 @@ constructPlan :: forall env. HasEnvConfig env -> InstalledMap -> Bool -> RIO env Plan -constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do +constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = withSpan_ "Build.ConstructPlan.constructPlan" $ do logDebug "Constructing the build plan" when hasBaseInDeps $ diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index d4675f7059..507de60e8e 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -96,6 +96,8 @@ import RIO.PrettyPrint import RIO.Process import Pantry.Internal.Companion +import OpenTelemetry.Eventlog + -- | Has an executable been built or not? data ExecutableBuildStatus = ExecutableBuilt @@ -247,7 +249,7 @@ getSetupExe :: HasEnvConfig env -> Path Abs File -- ^ SetupShim.hs input file -> Path Abs Dir -- ^ temporary directory -> RIO env (Maybe (Path Abs File)) -getSetupExe setupHs setupShimHs tmpdir = do +getSetupExe setupHs setupShimHs tmpdir = withSpan_ "Build.Execute.getSetupExe" $ do wc <- view $ actualCompilerVersionL.whichCompilerL platformDir <- platformGhcRelDir config <- view configL @@ -480,7 +482,7 @@ executePlan :: HasEnvConfig env -> Map PackageName Target -> Plan -> RIO env () -executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do +executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = withSpan_ "Build.Execute.executePlan" $ do logDebug "Executing the build plan" bopts <- view buildOptsL withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName @@ -510,7 +512,7 @@ copyExecutables => Map Text InstallLocation -> RIO env () copyExecutables exes | Map.null exes = return () -copyExecutables exes = do +copyExecutables exes = withSpan_ "Build.Execute.copyExecutables" $ do snapBin <- ( bindirSuffix) `liftM` installationRootDeps localBin <- ( bindirSuffix) `liftM` installationRootLocal compilerSpecific <- boptsInstallCompilerTool <$> view buildOptsL @@ -669,7 +671,7 @@ unregisterPackages :: -> Path Abs Dir -> NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env () -unregisterPackages cv localDB ids = do +unregisterPackages cv localDB ids = withSpan_ "Build.Execute.unregisterPackages" $ do let logReason ident reason = logInfo $ fromString (packageIdentifierString ident) <> ": unregistering" <> @@ -844,7 +846,7 @@ ensureConfig :: HasEnvConfig env -> Path Abs File -- ^ .cabal file -> Task -> RIO env Bool -ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = do +ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = withSpan_ "Build.Execute.ensureConfig" $ do newCabalMod <- liftIO $ modificationTime <$> getFileStatus (toFilePath cabalfp) setupConfigfp <- setupConfigFromDir pkgDir newSetupConfigMod <- liftIO $ either (const Nothing) (Just . modificationTime) <$> @@ -1129,7 +1131,7 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} mdeps msu -> OutputType -> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a) -> RIO env a - withCabal package pkgDir outputType inner = do + withCabal package pkgDir outputType inner = withSpan_ "Build.Execute.withCabal" $ do config <- view configL unless (configAllowDifferentUser config) $ checkOwnership (pkgDir configWorkDir config) @@ -1478,7 +1480,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap return $ if b then Just pc else Nothing _ -> return Nothing - copyPreCompiled (PrecompiledCache mlib sublibs exes) = do + copyPreCompiled (PrecompiledCache mlib sublibs exes) = withSpan_ "Build.Execute.copyPreCompiled" $ do wc <- view $ actualCompilerVersionL.whichCompilerL announceTask ee task "using precompiled package" @@ -1586,7 +1588,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap -> (Utf8Builder -> RIO env ()) -> Map Text ExecutableBuildStatus -> RIO env Installed - realBuild cache package pkgDir cabal0 announce executableBuildStatuses = do + realBuild cache package pkgDir cabal0 announce executableBuildStatuses = withSpan_ "Build.Execute.realBuild" $ do let cabal = cabal0 CloseOnException wc <- view $ actualCompilerVersionL.whichCompilerL diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 25571e8387..a54442d915 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -29,6 +29,8 @@ import Stack.Types.GhcPkgId import Stack.Types.Package import Stack.Types.SourceMap +import OpenTelemetry.Eventlog + toInstallMap :: MonadIO m => SourceMap -> m InstallMap toInstallMap sourceMap = do projectInstalls <- @@ -53,7 +55,7 @@ getInstalled :: HasEnvConfig env , [DumpPackage] -- snapshot installed , [DumpPackage] -- locally installed ) -getInstalled {-opts-} installMap = do +getInstalled {-opts-} installMap = withSpan_ "Build.Installed.getInstalled" $ do logDebug "Finding out which packages are already installed" snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal @@ -114,7 +116,7 @@ loadDatabase :: HasEnvConfig env -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases -> RIO env ([LoadHelper], [DumpPackage]) -loadDatabase installMap mdb lhs0 = do +loadDatabase installMap mdb lhs0 = withSpan_ "Build.Installed.loadDatabase" $ do pkgexe <- getGhcPkgExe (lhs1', dps) <- ghcPkgDump pkgexe (fmap snd (maybeToList mdb)) $ conduitDumpPackage .| sink diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 0e69ea8a7f..ae82af06f5 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -43,16 +43,18 @@ import System.FilePath (takeFileName) import System.IO.Error (isDoesNotExistError) import System.PosixCompat.Files (modificationTime, getFileStatus) +import OpenTelemetry.Eventlog + -- | loads and returns project packages projectLocalPackages :: HasEnvConfig env => RIO env [LocalPackage] -projectLocalPackages = do +projectLocalPackages = withSpan_ "Build.Source.projectLocalPackages" $ do sm <- view $ envConfigL.to envConfigSourceMap for (toList $ smProject sm) loadLocalPackage -- | loads all local dependencies - project packages and local extra-deps localDependencies :: HasEnvConfig env => RIO env [LocalPackage] -localDependencies = do +localDependencies = withSpan_ "Build.Source.localDependencies" $ do bopts <- view $ configL.to configBuild sourceMap <- view $ envConfigL . to envConfigSourceMap forMaybeM (Map.elems $ smDeps sourceMap) $ \dp -> @@ -69,7 +71,7 @@ loadSourceMap :: HasBuildConfig env -> BuildOptsCLI -> SMActual DumpedGlobalPackage -> RIO env SourceMap -loadSourceMap smt boptsCli sma = do +loadSourceMap smt boptsCli sma = withSpan_ "Build.Source.loadSourceMap" $ do bconfig <- view buildConfigL let compiler = smaCompiler sma project = M.map applyOptsFlagsPP $ smaProject sma @@ -250,7 +252,7 @@ loadCommonPackage :: forall env. (HasBuildConfig env, HasSourceMap env) => CommonPackage -> RIO env Package -loadCommonPackage common = do +loadCommonPackage common = withSpan_ "Build.Source.loadCommonPackage" $ do config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common) gpkg <- liftIO $ cpGPD common return $ resolvePackage config gpkg @@ -261,7 +263,7 @@ loadLocalPackage :: forall env. (HasBuildConfig env, HasSourceMap env) => ProjectPackage -> RIO env LocalPackage -loadLocalPackage pp = do +loadLocalPackage pp = withSpan_ "Build.Source.loadLocalPackage" $ do sm <- view sourceMapL let common = ppCommon pp bopts <- view buildOptsL diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 6db6779650..93ba51634e 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -84,6 +84,8 @@ import RIO.PrettyPrint (stylesUpdateL, useColorL) import RIO.Process import RIO.Time (toGregorian) +import OpenTelemetry.Eventlog + -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. tryDeprecatedPath @@ -145,7 +147,7 @@ makeConcreteResolver => AbstractResolver -> RIO env RawSnapshotLocation makeConcreteResolver (ARResolver r) = pure r -makeConcreteResolver ar = do +makeConcreteResolver ar = withSpan_ "Config.makeConcreteResolver" $ do r <- case ar of ARResolver r -> assert False $ makeConcreteResolver (ARResolver r) @@ -434,7 +436,7 @@ getDefaultLocalProgramsBase configStackRoot configPlatform override = -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. loadConfig :: HasRunner env => (Config -> RIO env a) -> RIO env a -loadConfig inner = do +loadConfig inner = withSpan_ "Config.loadConfig" $ do mstackYaml <- view $ globalOptsL.to globalStackYaml mproject <- loadProjectConfig mstackYaml mresolver <- view $ globalOptsL.to globalResolver @@ -480,7 +482,7 @@ loadConfig inner = do withBuildConfig :: RIO BuildConfig a -> RIO Config a -withBuildConfig inner = do +withBuildConfig inner = withSpan_ "Config.withBuildConfig" $ do config <- ask -- If provided, turn the AbstractResolver from the command line @@ -796,7 +798,7 @@ getExtraConfigs userConfigPath = do loadConfigYaml :: HasLogFunc env => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a -loadConfigYaml parser path = do +loadConfigYaml parser path = withSpan_ "Config.loadConfigYaml" $ do eres <- loadYaml parser path case eres of Left err -> liftIO $ throwM (ParseConfigFileException path err) @@ -851,7 +853,7 @@ loadProjectConfig :: HasLogFunc env => StackYamlLoc -- ^ Override stack.yaml -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid)) -loadProjectConfig mstackYaml = do +loadProjectConfig mstackYaml = withSpan_ "Config.loadProjectConfig" $ do mfp <- getProjectConfig mstackYaml case mfp of PCProject fp -> do diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 642fb804f8..10288880d1 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -24,6 +24,8 @@ import Stack.SourceMap import Stack.Types.Config import Stack.Types.SourceMap +import OpenTelemetry.Eventlog + data LockedLocation a b = LockedLocation { llOriginal :: a , llCompleted :: b @@ -77,7 +79,7 @@ instance FromJSON (WithJSONWarnings (Unresolved Locked)) where loadYamlThrow :: HasLogFunc env => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a -loadYamlThrow parser path = do +loadYamlThrow parser path = withSpan_ "Lock.loadYamlThrow" $ do val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither parser val of Left err -> throwIO $ Yaml.AesonException err @@ -94,7 +96,7 @@ lockCachedWanted :: -> Map PackageName (Bool -> RIO env DepPackage) -> RIO env ( SMWanted, [CompletedPLI])) -> RIO env SMWanted -lockCachedWanted stackFile resolver fillWanted = do +lockCachedWanted stackFile resolver fillWanted = withSpan_ "Lock.lockCacheWanted" $ do lockFile <- liftIO $ addExtension ".lock" stackFile let getLockExists = doesFileExist lockFile lfb <- view lockFileBehaviorL @@ -118,7 +120,7 @@ lockCachedWanted stackFile resolver fillWanted = do slocCache = toMap $ lckSnapshotLocations locked pkgLocCache = toMap $ lckPkgImmutableLocations locked (snap, slocCompleted, pliCompleted) <- - loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache + withSpan_ "Pantry.loadAndCompleteSnapshotRaw" $ loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache let compiler = snapshotCompiler snap snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 8092a3b2f6..bdb8a0bf36 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -32,6 +32,8 @@ import Stack.Types.Config (HasCompiler (..), GhcPkgExe (..), DumpPacka import Stack.Types.GhcPkgId import RIO.Process hiding (readProcess) +import OpenTelemetry.Eventlog + -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump :: (HasProcessContext env, HasLogFunc env) @@ -59,7 +61,9 @@ ghcPkgCmdArgs -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a -ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = do +ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = withSpan "PackageDump.ghcPkgCmdArgs" $ \sp -> do + setTag sp "args" $ fromString (unwords cmd) + setTag sp "dbs" $ fromString (show mpkgDbs) case reverse mpkgDbs of (pkgDb:_) -> createDatabase pkgexe pkgDb -- TODO maybe use some retry logic instead? _ -> return () diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 18483f8ba5..46bd48e600 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -45,6 +45,8 @@ import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, import qualified Data.Text.IO as T import qualified RIO.Text as T +import OpenTelemetry.Eventlog + -- | Path version withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner @@ -66,7 +68,9 @@ sinkProcessStderrStdout -> 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 = +sinkProcessStderrStdout name args sinkStderr sinkStdout = withSpan "sinkProcessStderrStdout" $ \sp -> do + setTag sp "process" (fromString name) + setTag sp "args" $ fromString (show args) proc name args $ \pc0 -> do let pc = setStdout createSource $ setStderr createSource @@ -90,17 +94,19 @@ sinkProcessStdout -> [String] -- ^ Command line arguments -> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout -> RIO env a -sinkProcessStdout name args sinkStdout = +sinkProcessStdout name args sinkStdout = withSpan "sinkProcessStdout" $ \sp -> do + setTag sp "process" (fromString name) + setTag sp "args" $ fromString (show args) proc name args $ \pc -> - withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently - $ Concurrently (runConduit $ getStderr p .| CL.sinkNull) - *> Concurrently (runConduit $ getStdout p .| sinkStdout) + withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently + $ Concurrently (runConduit $ getStderr p .| CL.sinkNull) + *> Concurrently (runConduit $ getStdout p .| sinkStdout) logProcessStderrStdout :: (HasCallStack, HasProcessContext env, HasLogFunc env) => ProcessConfig stdin stdoutIgnored stderrIgnored -> RIO env () -logProcessStderrStdout pc = withLoggedProcess_ pc $ \p -> +logProcessStderrStdout pc = withSpan_ "logProcessStderrStdout" $ withLoggedProcess_ pc $ \p -> let logLines = CB.lines .| CL.mapM_ (logInfo . displayBytesUtf8) in runConcurrently $ Concurrently (runConduit $ getStdout p .| logLines) @@ -113,7 +119,7 @@ readProcessNull :: (HasProcessContext env, HasLogFunc env, HasCallStack) => String -- ^ Command -> [String] -- ^ Command line arguments -> RIO env () -readProcessNull name args = +readProcessNull name args = withSpan_ "readProcessNull" $ -- We want the output to appear in any exceptions, so we capture and drop it void $ proc name args readProcess_ @@ -213,5 +219,5 @@ defaultFirstFalse _ = False -- | Write a @Builder@ to a file and atomically rename. writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m () writeBinaryFileAtomic fp builder = - liftIO $ + liftIO $ withSpan_ "writeBinaryFileAtomic" $ withBinaryFileAtomic (toFilePath fp) WriteMode (`hPutBuilder` builder) diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 22a6766256..c5fe14122f 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -37,6 +37,8 @@ import Stack.Types.Version (stackMinorVersion, minorVersion) import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.Terminal (getTerminalWidth) +import OpenTelemetry.Eventlog + -- | Ensure that no project settings are used when running 'withConfig'. withGlobalProject :: RIO Runner a -> RIO Runner a withGlobalProject inner = do @@ -83,7 +85,7 @@ withConfig -> RIO Config a -> RIO Runner a withConfig shouldReexec inner = - loadConfig $ \config -> do + withSpan_ "Runners.withConfig" $ loadConfig $ \config -> do -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must -- happen ASAP but needs a configuration. diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index ba85f7d67f..9240862ff9 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -94,6 +94,8 @@ import System.Permissions (setFileExecutable) import System.Uname (getRelease) import Data.List.Split (splitOn) +import OpenTelemetry.Eventlog + -- | Default location of the stack-setup.yaml file defaultSetupInfoYaml :: String defaultSetupInfoYaml = @@ -189,7 +191,7 @@ setupEnv :: NeedTargets -> BuildOptsCLI -> Maybe Text -- ^ Message to give user when necessary GHC is not available -> RIO BuildConfig EnvConfig -setupEnv needTargets boptsCLI mResolveMissingGHC = do +setupEnv needTargets boptsCLI mResolveMissingGHC = withSpan_ "setupEnv" $ do config <- view configL bc <- view buildConfigL let stackYaml = bcStackYaml bc diff --git a/src/Stack/Storage/Project.hs b/src/Stack/Storage/Project.hs index 364221656e..4dea89c5a4 100644 --- a/src/Stack/Storage/Project.hs +++ b/src/Stack/Storage/Project.hs @@ -37,6 +37,8 @@ import Stack.Types.Cache import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..)) import Stack.Types.GhcPkgId +import OpenTelemetry.Eventlog + share [ mkPersist sqlSettings , mkDeleteCascade sqlSettings , mkMigrate "migrateAll" @@ -85,7 +87,7 @@ initProjectStorage :: => Path Abs File -- ^ storage file -> (ProjectStorage -> RIO env a) -> RIO env a -initProjectStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage +initProjectStorage fp f = withSpan_ "Storage.Project.initProjectStorage" $ SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage -- | Run an action in a database transaction withProjectStorage :: @@ -136,7 +138,7 @@ loadConfigCache :: => ConfigCacheKey -> RIO env (Maybe ConfigCache) loadConfigCache key = - withProjectStorage $ do + withSpan_ "Storage.Project.loadConfigCache" $ withProjectStorage $ do mparent <- getBy key case mparent of Nothing -> return Nothing diff --git a/src/main/Main.hs b/src/main/Main.hs index bffd937253..b8acfd1b34 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -88,6 +88,8 @@ import qualified System.FilePath as FP import System.IO (hPutStrLn, hGetEncoding, hSetEncoding) import System.Terminal (hIsTerminalDeviceOrMinTTY) +import OpenTelemetry.Eventlog + -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception hSetTranslit :: Handle -> IO () @@ -101,7 +103,7 @@ hSetTranslit h = do _ -> return () main :: IO () -main = do +main = withSpan_ "Main.main" $ do -- Line buffer the output by default, particularly for non-terminal runs. -- See https://github.com/commercialhaskell/stack/pull/360 hSetBuffering stdout LineBuffering @@ -546,12 +548,13 @@ cleanCmd = withConfig NoReexec . withBuildConfig . clean -- | Helper for build and install commands buildCmd :: BuildOptsCLI -> RIO Runner () -buildCmd opts = do - when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do - logError "Error: When building with stack, you should not use the -prof GHC option" - logError "Instead, please use --library-profiling and --executable-profiling" - logError "See: https://github.com/commercialhaskell/stack/issues/1015" - exitFailure +buildCmd opts = withSpan_ "Main.buildCmd" $ do + withSpan_ "Main.buildCmd_before_inner" $ do + when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do + logError "Error: When building with stack, you should not use the -prof GHC option" + logError "Instead, please use --library-profiling and --executable-profiling" + logError "See: https://github.com/commercialhaskell/stack/issues/1015" + exitFailure local (over globalOptsL modifyGO) $ case boptsCLIFileWatch opts of FileWatchPoll -> fileWatchPoll (inner . Just) @@ -561,7 +564,7 @@ buildCmd opts = do inner :: Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner () - inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $ + inner setLocalFiles = withSpan_ "Main.buildCmd_inner" $ withConfig YesReexec $ withEnvConfig NeedTargets opts $ Stack.Build.build setLocalFiles -- Read the build command from the CLI and enable it to run modifyGO = diff --git a/stack-ghc-88.yaml b/stack-ghc-88.yaml index 2621338f9b..4dacd87405 100644 --- a/stack-ghc-88.yaml +++ b/stack-ghc-88.yaml @@ -31,6 +31,7 @@ extra-deps: - pantry-0.5.1.1@rev:0 - casa-client-0.0.1@rev:0 - casa-types-0.0.1@rev:0 +- opentelemetry-0.5.0 drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 diff --git a/stack.cabal b/stack.cabal index a74f7801f6..bec38bc1b9 100644 --- a/stack.cabal +++ b/stack.cabal @@ -4,7 +4,7 @@ cabal-version: 2.0 -- -- see: https://github.com/sol/hpack -- --- hash: 2a288b315557ca9df67fb60c003674a0dd6618aa5f8bc2b04527fb8feae4b16d +-- hash: 89655f87a845cb110657f89477ed6ae2e33adb8ecc6b62075a5281f0e6dc0c80 name: stack version: 2.4.0 @@ -271,6 +271,7 @@ library , neat-interpolation , network-uri , open-browser + , opentelemetry >=0.5.0 , optparse-applicative , pantry , path @@ -346,7 +347,7 @@ executable stack Paths_stack hs-source-dirs: src/main - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -optP-Wno-nonportable-include-path -threaded -rtsopts + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -optP-Wno-nonportable-include-path -threaded -rtsopts -eventlog build-depends: Cabal , aeson @@ -395,6 +396,7 @@ executable stack , neat-interpolation , network-uri , open-browser + , opentelemetry >=0.5.0 , optparse-applicative , pantry , path @@ -517,6 +519,7 @@ executable stack-integration-test , neat-interpolation , network-uri , open-browser + , opentelemetry >=0.5.0 , optparse-applicative , optparse-generic , pantry @@ -646,6 +649,7 @@ test-suite stack-test , neat-interpolation , network-uri , open-browser + , opentelemetry >=0.5.0 , optparse-applicative , pantry , path diff --git a/stack.yaml b/stack.yaml index 7d15934ba3..dc23babd48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ extra-deps: - pantry-0.5.1.1@rev:0 - casa-client-0.0.1@rev:0 - casa-types-0.0.1@rev:0 +- opentelemetry-0.5.0 drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712