diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,16 @@ ## [Unreleased] +### Added + + - Evaluation log + + - Configurable log level via config file or `extraOptions` + +### Changed + + - Default log level is `InfoS` rather than `DebugS` + ## [0.7.2] - 2020-06-18 ### Changed diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker.hs --- a/hercules-ci-agent-worker/Hercules/Agent/Worker.hs +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker.hs @@ -10,10 +10,15 @@ import CNix import qualified CNix.Internal.Raw import Conduit +import Control.Concurrent.Async.Lifted.Safe import Control.Concurrent.STM +import qualified Control.Exception.Lifted as EL +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Control import qualified Data.ByteString as BS import qualified Data.Conduit import Data.Conduit.Extras (sinkChan, sinkChanTerminate, sourceChan) +import Data.Conduit.Katip.Orphans () import Data.Conduit.Serialization.Binary ( conduitDecode, conduitEncode, @@ -37,7 +42,6 @@ import Hercules.Agent.WorkerProtocol.Command ( Command, ) -import Hercules.Agent.WorkerProtocol.Command.Build (Build) import qualified Hercules.Agent.WorkerProtocol.Command.Build as Build import qualified Hercules.Agent.WorkerProtocol.Command.BuildResult as BuildResult import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval @@ -51,14 +55,16 @@ import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as Attribute import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as AttributeError import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings +import Hercules.Error import Katip import qualified Language.C.Inline.Cpp.Exceptions as C import qualified Network.URI -import Protolude hiding (bracket, evalState) +import Protolude hiding (bracket, catch, evalState, wait, withAsync) import qualified System.Environment as Environment import System.IO (BufferMode (LineBuffering), hSetBuffering) +import System.Posix.IO (dup, fdToHandle, stdError) import System.Timeout (timeout) -import UnliftIO.Exception (bracket) +import UnliftIO.Exception (bracket, catch) import Prelude () import qualified Prelude @@ -93,8 +99,8 @@ setOption k v drvsCompleted_ <- newTVarIO mempty drvsInProgress_ <- newIORef mempty - withStore $ \wrappedStore_ -> withHerculesStore wrappedStore_ $ \herculesStore_ -> do - setBuilderCallback herculesStore_ mempty + withStore $ \wrappedStore_ -> withHerculesStore wrappedStore_ $ \herculesStore_ -> withKatip $ do + liftIO $ setBuilderCallback herculesStore_ mempty ch <- liftIO newChan let st = HerculesState { drvsCompleted = drvsCompleted_, @@ -103,10 +109,11 @@ wrappedStore = wrappedStore_, shortcutChannel = ch } - let runner = + let runner :: KatipContextT IO () + runner = ( ( do command <- runConduitRes -- Res shouldn't be necessary - ( sourceHandle stdin + ( transPipe liftIO (sourceHandle stdin) .| conduitDecode .| printCommands .| await @@ -116,33 +123,34 @@ Nothing -> panic "Not a valid starting command" runCommand st ch command ) - `catch` ( \e -> do - writeChan ch (Just $ Exception (renderException (e :: SomeException))) - exitFailure - ) + `safeLiftedCatch` ( \e -> liftIO $ do + writeChan ch (Just $ Exception (renderException (e :: SomeException))) + exitFailure + ) ) - `finally` ( do - writeChan ch Nothing - putErrText "runner done" - ) + `EL.finally` ( do + liftIO $ writeChan ch Nothing + logLocM DebugS "runner done" + ) writer = runConduitRes ( sourceChan ch .| conduitEncode .| concatMapC (\x -> [Chunk x, Flush]) - .| sinkHandleFlush stdout + .| transPipe liftIO (sinkHandleFlush stdout) ) void $ do withAsync runner $ \runnerAsync -> do writer -- runner can stop writer only by passing Nothing in channel (finally) - putErrText "Writer done" + logLocM DebugS "Writer done" wait runnerAsync -- include the potential exception -printCommands :: ConduitT Command Command (ResourceT IO) () +printCommands :: KatipContext m => ConduitT Command Command m () printCommands = mapMC ( \x -> do - liftIO $ hPutStrLn stderr ("Received command: " <> show x :: Text) + katipAddContext (sl "command" (show x :: Text)) $ do + logLocM DebugS "Received command" pure x ) @@ -154,7 +162,11 @@ renderException e | Just (FatalError msg) <- fromException e = msg renderException e = toS $ displayException e -connectCommand :: Chan (Maybe Event) -> ConduitM Command Event (ResourceT IO) () -> IO () +connectCommand :: + (MonadUnliftIO m, KatipContext m, MonadThrow m) => + Chan (Maybe Event) -> + ConduitM Command Event (ResourceT m) () -> + m () connectCommand ch conduit = runConduitRes ( sourceHandle stdin @@ -164,13 +176,14 @@ .| sinkChan ch ) -runCommand :: HerculesState -> Chan (Maybe Event) -> Command -> IO () +runCommand :: (MonadUnliftIO m, MonadBaseControl IO m, KatipContext m, MonadThrow m) => HerculesState -> Chan (Maybe Event) -> Command -> m () -- runCommand' :: HerculesState -> Command -> ConduitM Command Event (ResourceT IO) () runCommand herculesState ch command = do -- TODO don't do this mainThread <- liftIO $ myThreadId + UnliftIO unlift <- askUnliftIO case command of - Command.Eval eval -> connectCommand ch $ do + Command.Eval eval -> Logger.withLoggerConduit (logger $ Eval.logSettings eval) $ Logger.withTappedStderr Logger.tapper $ connectCommand ch $ do void $ liftIO $ flip forkFinally @@ -178,10 +191,10 @@ Left e -> throwIO $ FatalError $ "Failed to fork: " <> show e Right _ -> pure () ) + $ unlift $ runConduitRes ( Data.Conduit.handleC ( \e -> do - hPutStrLn stderr $ "Caught exception: " <> renderException e yield $ Event.Error (renderException e) liftIO $ throwTo mainThread e ) @@ -193,20 +206,22 @@ ) awaitForever $ \case Command.BuildResult (BuildResult.BuildResult path attempt result) -> do - hPutStrLn stderr $ ("BuildResult: " <> show path <> " " <> show result :: Text) + katipAddContext (sl "path" path <> sl "result" (show result :: Text)) + $ logLocM DebugS + $ "Received remote build result" liftIO $ atomically $ modifyTVar (drvsCompleted herculesState) (M.insert path (attempt, result)) _ -> pass Command.Build build -> - Logger.withLoggerConduit (logger build) $ do + Logger.withLoggerConduit (logger $ Build.logSettings build) $ Logger.withTappedStderr Logger.tapper $ do connectCommand ch $ runBuild (wrappedStore herculesState) build _ -> panic "Not a valid starting command" -logger :: Build -> ConduitM () (Vector LogEntry) IO () -> IO () -logger buildCommand entriesSource = do - socketConfig <- makeSocketConfig buildCommand +logger :: (MonadIO m, MonadUnliftIO m, KatipContext m) => LogSettings.LogSettings -> ConduitM () (Vector LogEntry) m () -> m () +logger logSettings_ entriesSource = do + socketConfig <- liftIO $ makeSocketConfig logSettings_ -- TODO integrate katip more - withKatip $ Socket.withReliableSocket socketConfig $ \socket -> katipAddNamespace "Build" do + Socket.withReliableSocket socketConfig $ \socket -> katipAddNamespace "Build" do let conduit = entriesSource .| Logger.unbatch @@ -228,7 +243,7 @@ Chunk e -> do yield $ Chunk e {LogEntry.i = i} renumber (i + 1) - liftIO $ runConduit $ conduit + runConduit $ conduit logLocM DebugS "Syncing" liftIO (timeout 600_000_000 $ Socket.syncIO $ socket) >>= \case Just _ -> pass @@ -254,7 +269,10 @@ withKatip m = do let format :: forall a. LogItem a => ItemFormatter a format = (\_ _ _ -> "@katip ") <> jsonFormat - handleScribe <- liftIO $ mkHandleScribeWithFormatter format (ColorLog False) stderr (permitItem DebugS) V2 + -- Use a duplicate of stderr, to make sure we keep logging there, even after + -- we reassign stderr to catch output from git and other subprocesses of Nix. + dupStderr <- liftIO (fdToHandle =<< dup stdError) + handleScribe <- liftIO $ mkHandleScribeWithFormatter format (ColorLog False) dupStderr (permitItem DebugS) V2 let makeLogEnv = registerScribe "stderr" handleScribe defaultScribeSettings =<< initLogEnv "Worker" "production" initialContext = () extraNs = mempty -- "Worker" is already set in initLogEnv. @@ -262,8 +280,8 @@ bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \logEnv -> runKatipContextT logEnv initialContext extraNs m -makeSocketConfig :: Monad m => Build -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m) -makeSocketConfig Build.Build {logSettings = l} = do +makeSocketConfig :: Monad m => LogSettings.LogSettings -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m) +makeSocketConfig l = do baseURL <- case Network.URI.parseURI $ toS $ LogSettings.baseURL l of Just x -> pure x Nothing -> panic "LogSettings: invalid base url" @@ -283,17 +301,17 @@ Eval.LiteralArg s -> ["--argstr", toS k, s] Eval.ExprArg s -> ["--arg", toS k, s] -withDrvInProgress :: HerculesState -> Text -> IO a -> IO a +withDrvInProgress :: MonadUnliftIO m => HerculesState -> Text -> m a -> m a withDrvInProgress HerculesState {drvsInProgress = ref} drvPath = bracket acquire release . const where acquire = - join $ atomicModifyIORef ref $ \inprg -> + liftIO $ join $ atomicModifyIORef ref $ \inprg -> if drvPath `S.member` inprg then (inprg, throwIO $ FatalError "Refusing to build derivation that should have been built remotely. Presumably, substitution has failed.") else (S.insert drvPath inprg, pass) release _ = - atomicModifyIORef ref $ \inprg -> + liftIO $ atomicModifyIORef ref $ \inprg -> (S.delete drvPath inprg, ()) anyAlternative :: (Foldable l, Alternative f) => l a -> f a @@ -326,76 +344,86 @@ BuildResult.DependencyFailure -> throwIO $ BuildException plainDrvText (Just "A dependency could not be built.") BuildResult.Success -> pass -runEval :: HerculesState -> Eval -> ConduitM i Event (ResourceT IO) () +runEval :: + forall i m. + (MonadResource m, KatipContext m, MonadUnliftIO m) => + HerculesState -> + Eval -> + ConduitM i Event m () runEval st@HerculesState {herculesStore = hStore, shortcutChannel = shortcutChan, drvsCompleted = drvsCompl} eval = do for_ (Eval.extraNixOptions eval) $ liftIO . uncurry setGlobalOption for_ (Eval.extraNixOptions eval) $ liftIO . uncurry setOption - do - let store = nixStore hStore - s <- storeUri store - liftIO $ setBuilderCallback hStore $ \path -> do - hPutStrLn stderr ("Building " <> show path :: Text) - let (plainDrv, bangOut) = BS.span (/= fromIntegral (ord '!')) path - outputName = BS.dropWhile (== fromIntegral (ord '!')) bangOut - plainDrvText = toS plainDrv - withDrvInProgress st plainDrvText $ do - writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) Nothing - derivation <- getDerivation store plainDrv - outputPath <- getDerivationOutputPath derivation outputName - hPutStrLn stderr ("Naive ensurePath " <> outputPath) - ensurePath (wrappedStore st) outputPath `catch` \e0 -> do - hPutStrLn stderr ("Naive wrapped.ensurePath failed: " <> show (e0 :: SomeException) :: Text) - (attempt0, result) <- + let store = nixStore hStore + s <- storeUri store + UnliftIO unlift <- lift askUnliftIO + liftIO $ setBuilderCallback hStore $ \path -> unlift $ katipAddContext (sl "fullpath" (toSL path :: Text)) $ do + logLocM DebugS "Building" + let (plainDrv, bangOut) = BS.span (/= fromIntegral (ord '!')) path + outputName = BS.dropWhile (== fromIntegral (ord '!')) bangOut + plainDrvText = toS plainDrv + withDrvInProgress st plainDrvText $ do + liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) Nothing + derivation <- liftIO $ getDerivation store plainDrv + outputPath <- liftIO $ getDerivationOutputPath derivation outputName + katipAddContext (sl "outputPath" (toSL outputPath :: Text)) $ do + logLocM DebugS "Naively calling ensurePath" + liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e0 -> do + katipAddContext (sl "message" (show (e0 :: SomeException) :: Text)) $ + logLocM DebugS "Recovering from failed wrapped.ensurePath" + (attempt0, result) <- + liftIO $ atomically $ do + c <- readTVar drvsCompl + anyAlternative $ M.lookup plainDrvText c + liftIO $ maybeThrowBuildException result plainDrvText + liftIO $ clearSubstituterCaches + liftIO $ clearPathInfoCache store + liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e1 -> do + katipAddContext (sl "message" (show (e1 :: SomeException) :: Text)) $ + logLocM DebugS "Recovering from fresh ensurePath" + liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) (Just attempt0) + -- TODO sync + result' <- liftIO $ atomically $ do c <- readTVar drvsCompl - anyAlternative $ M.lookup plainDrvText c - maybeThrowBuildException result plainDrvText - clearSubstituterCaches - clearPathInfoCache store - ensurePath (wrappedStore st) outputPath `catch` \e1 -> do - hPutStrLn stderr ("Fresh ensurePath failed: " <> show (e1 :: SomeException) :: Text) - writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) (Just attempt0) - -- TODO sync - result' <- - liftIO $ atomically $ do - c <- readTVar drvsCompl - (attempt1, r) <- anyAlternative $ M.lookup plainDrvText c - guard (attempt1 /= attempt0) - pure r - maybeThrowBuildException result' plainDrvText - clearSubstituterCaches - clearPathInfoCache store - ensurePath (wrappedStore st) outputPath `catch` \e2 -> do - throwIO $ - BuildException - plainDrvText - ( Just $ - "It could not be retrieved on the evaluating agent, despite a successful rebuild. Exception: " - <> show (e2 :: SomeException) - ) - hPutStrLn stderr ("Built " <> show path :: Text) - hPutStrLn stderr ("Store uri: " <> s) - withEvalState store $ \evalState -> do - hPutStrLn stderr ("EvalState loaded." :: Text) - args <- - liftIO $ - evalArgs evalState (autoArgArgs (Eval.autoArguments eval)) - Data.Conduit.handleC (yieldAttributeError []) $ - do - imprt <- liftIO $ evalFile evalState (toS $ Eval.file eval) - applied <- liftIO (autoCallFunction evalState imprt args) - walk evalState args applied - yield Event.EvaluationDone + (attempt1, r) <- anyAlternative $ M.lookup plainDrvText c + guard (attempt1 /= attempt0) + pure r + liftIO $ maybeThrowBuildException result' plainDrvText + liftIO $ clearSubstituterCaches + liftIO $ clearPathInfoCache store + liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e2 -> do + liftIO $ throwIO $ + BuildException + plainDrvText + ( Just $ + "It could not be retrieved on the evaluating agent, despite a successful rebuild. Exception: " + <> show (e2 :: SomeException) + ) + logLocM DebugS ("Built") + withEvalState store $ \evalState -> do + katipAddContext (sl "storeURI" (toSL s :: Text)) $ + logLocM DebugS "EvalState loaded." + args <- + liftIO $ + evalArgs evalState (autoArgArgs (Eval.autoArguments eval)) + Data.Conduit.handleC (yieldAttributeError []) $ + do + imprt <- liftIO $ evalFile evalState (toS $ Eval.file eval) + applied <- liftIO (autoCallFunction evalState imprt args) + walk evalState args applied + yield Event.EvaluationDone walk :: + (MonadUnliftIO m, KatipContext m) => Ptr EvalState -> Bindings -> RawValue -> - ConduitT i Event (ResourceT IO) () + ConduitT i Event m () walk evalState = walk' True [] 10 where handleErrors path = Data.Conduit.handleC (yieldAttributeError path) walk' :: + (MonadUnliftIO m, KatipContext m) => -- | If True, always walk this attribute set. Only True for the root. Bool -> -- | Attribute path @@ -407,9 +435,9 @@ -- | Current node of the walk RawValue -> -- | Program that performs the walk and emits 'Event's - ConduitT i1 Event (ResourceT IO) () + ConduitT i1 Event m () walk' forceWalkAttrset path depthRemaining autoArgs v = - -- liftIO $ hPutStrLn stderr $ "Walking " <> (show path :: Text) + -- logLocM DebugS $ logStr $ "Walking " <> (show path :: Text) handleErrors path $ liftIO (match evalState v) >>= \case @@ -452,15 +480,16 @@ (depthRemaining - 1) autoArgs value - _any -> liftIO $ do - vt <- rawValueType v + _any -> do + vt <- liftIO $ rawValueType v unless ( lastMay path == Just "recurseForDerivations" && vt == CNix.Internal.Raw.Bool ) - $ hPutStrLn stderr + $ logLocM DebugS + $ logStr $ "Ignoring " <> show path <> " : " diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs --- a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs @@ -4,6 +4,7 @@ import CNix.Internal.Context (Derivation) import Cachix.Client.Store (Store, queryPathInfo, validPathInfoNarHash, validPathInfoNarSize) import Conduit +import Data.Conduit.Katip.Orphans () import Foreign (ForeignPtr) import Hercules.Agent.Worker.Build.Prefetched (buildDerivation) import qualified Hercules.Agent.Worker.Build.Prefetched as Build @@ -11,10 +12,11 @@ import Hercules.Agent.WorkerProtocol.Event (Event) import qualified Hercules.Agent.WorkerProtocol.Event as Event import qualified Hercules.Agent.WorkerProtocol.Event.BuildResult as Event.BuildResult +import Katip import Protolude import Unsafe.Coerce -runBuild :: Ptr (Ref NixStore) -> Command.Build.Build -> ConduitT i Event (ResourceT IO) () +runBuild :: (MonadIO m, KatipContext m) => Ptr (Ref NixStore) -> Command.Build.Build -> ConduitT i Event m () runBuild store build = do let extraPaths = Command.Build.inputDerivationOutputPaths build drvPath = toS $ Command.Build.drvPath build @@ -25,7 +27,8 @@ Just drv -> pure drv Nothing -> panic $ "Could not retrieve derivation " <> show drvPath <> " from local store or binary caches." nixBuildResult <- liftIO $ buildDerivation store drvPath derivation (extraPaths <$ guard (not (Command.Build.materializeDerivation build))) - liftIO $ putErrText $ show nixBuildResult + katipAddContext (sl "result" (show nixBuildResult :: Text)) $ + logLocM DebugS "Build result" buildResult <- liftIO $ enrichResult store derivation nixBuildResult yield $ Event.BuildResult buildResult diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs --- a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs @@ -6,7 +6,8 @@ module Hercules.Agent.Worker.Build.Logger where import CNix.Internal.Context -import Conduit (filterC) +import Conduit (MonadUnliftIO, filterC) +import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Unsafe (unsafePackMallocCString) import Data.Conduit (ConduitT, Flush (..), await, awaitForever, yield) import Data.Vector (Vector) @@ -14,10 +15,18 @@ import Foreign (alloca, nullPtr, peek) import Hercules.API.Logs.LogEntry (LogEntry) import qualified Hercules.API.Logs.LogEntry as LogEntry +import Katip import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Cpp.Exceptions as C -import Protolude +import Protolude hiding (bracket, finally, mask_, onException, tryJust, wait, withAsync) +import System.IO (BufferMode (LineBuffering), hSetBuffering) +import System.IO.Error (isEOFError) +import System.Posix.IO (closeFd, createPipe, dup, dupTo, fdToHandle, stdError) +import System.Posix.Internals (setNonBlockingFD) +import System.Posix.Types (Fd) import System.Timeout (timeout) +import UnliftIO.Async +import UnliftIO.Exception C.context context @@ -235,9 +244,9 @@ -- Conduits for logger -- -withLoggerConduit :: MonadIO m => (ConduitT () (Vector LogEntry) m () -> IO ()) -> IO a -> IO a +withLoggerConduit :: (MonadIO m, MonadUnliftIO m) => (ConduitT () (Vector LogEntry) m () -> m ()) -> m a -> m a withLoggerConduit logger io = withAsync (logger popper) $ \popperAsync -> - ((io `finally` close) <* wait popperAsync) `onException` timeout 2_000_000 (wait popperAsync) + ((io `finally` liftIO close) <* wait popperAsync) `onException` liftIO (timeout 2_000_000 (wait popperAsync)) where popper = liftIO popMany >>= \case lns | null lns -> pass @@ -246,7 +255,7 @@ popper -- | Remove spammy progress results. Use 'nubProgress' instead? -filterProgress :: ConduitT (Flush LogEntry) (Flush LogEntry) IO () +filterProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m () filterProgress = filterC \case Chunk (LogEntry.Result {rtype = LogEntry.ResultTypeProgress}) -> False _ -> True @@ -295,3 +304,74 @@ unless (ak == prevKey) do yield a nubSubset1 toKey ak + +tryReadLine :: MonadUnliftIO m => Handle -> m (Either () ByteString) +tryReadLine s = tryJust (\e -> guard $ isEOFError e) (liftIO (BSC.hGetLine s)) + +tapper :: (KatipContext m, MonadUnliftIO m) => TapState -> m () +tapper s = do + tryReadLine (readableStderrEnd s) >>= \case + Left _ -> pass + Right "__%%hercules terminate log%%__" -> pass + Right ln -> do + katipAddContext (sl "line" (toSL ln :: Text)) + $ logLocM DebugS + $ "Intercepted stderr" + liftIO + [C.throwBlock| void { + std::string s = $bs-cstr:ln; + herculesLogger->log(nix::lvlInfo, s); + }|] + tapper s + +-- | Like 'withTappableStderr' but takes care of the forking and waiting of +-- the tapper thread. +withTappedStderr :: (KatipContext m, MonadUnliftIO m) => (TapState -> m ()) -> m a -> m a +withTappedStderr tapperFunction m = do + (r, tapperDone) <- + withTappableStderr + ( \tapState -> do + tapperDone <- UnliftIO.Async.async (tapperFunction tapState) + r <- m + -- EOF doesn't seem to reach tapperFunction, so we simulate it with a magic line + -- The preceding newline clears any unfinished lines but also introduces a needless newline in the final log + hPutStrLn stderr ("\n__%%hercules terminate log%%__" :: ByteString) + pure (r, tapperDone) + ) + liftIO (timeout 30_000_000 $ wait tapperDone) >>= \case + Just x -> pure x + Nothing -> logLocM ErrorS "stderr thread did not finish in time" + pure r + +data TapState = TapState {originalStderrCopy :: Fd, readableStderrEnd :: Handle} + +-- | WARNING: Invoke only once. It leaks probably leaks a file descriptor or two. +-- +-- @withTappedStderr tapper mainAction@ +-- +-- 'readableStderrEnd' receives EOF when your action terminates (unless you 'dup' the write end, aka 'stdError') +withTappableStderr :: MonadUnliftIO m => (TapState -> m a) -> m a +withTappableStderr = bracket (liftIO tapStderrPipe) (liftIO . revertTap) + +revertTap :: TapState -> IO () +revertTap s = do + void $ dupTo (originalStderrCopy s) stdError + closeFd (originalStderrCopy s) + +tapStderrPipe :: IO TapState +tapStderrPipe = do + oldStdError <- dup stdError + (readable, writable) <- createPipe + -- fd 2 := writable pipe + void $ dupTo writable stdError + -- Make sure all fds are set up correctly for the RTS's IO manager + [oldStdError, readable, writable] & traverse_ \fd -> setNonBlockingFD (fromIntegral fd) True + let mkHandle fd = do + h <- fdToHandle fd + hSetBuffering h LineBuffering + pure h + readableHandle <- mkHandle readable + pure TapState + { originalStderrCopy = oldStdError, + readableStderrEnd = readableHandle + } diff --git a/hercules-ci-agent.cabal b/hercules-ci-agent.cabal --- a/hercules-ci-agent.cabal +++ b/hercules-ci-agent.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hercules-ci-agent -version: 0.7.2 +version: 0.7.3 synopsis: Runs Continuous Integration tasks on your machines category: Nix, CI, Testing, DevOps homepage: https://docs.hercules-ci.com @@ -39,6 +39,7 @@ Hercules.Agent.WorkerProtocol.Event.BuildResult Hercules.Agent.WorkerProtocol.LogSettings Data.Conduit.Extras + Data.Conduit.Katip.Orphans other-modules: Paths_hercules_ci_agent @@ -203,7 +204,7 @@ , filepath , hercules-ci-agent , hercules-ci-api-core == 0.1.1.0 - , hercules-ci-api-agent == 0.2.1.0 + , hercules-ci-api-agent == 0.2.2.0 , hostname , http-client , http-client-tls @@ -291,6 +292,7 @@ , exceptions , hercules-ci-agent , hercules-ci-api-agent + , hercules-ci-api-core , internal-ffi , inline-c , inline-c-cpp @@ -305,7 +307,9 @@ , stm , text , transformers-base + , unix , unliftio + , unliftio-core , uuid , vector pkgconfig-depends: diff --git a/hercules-ci-agent/Hercules/Agent.hs b/hercules-ci-agent/Hercules/Agent.hs --- a/hercules-ci-agent/Hercules/Agent.hs +++ b/hercules-ci-agent/Hercules/Agent.hs @@ -79,15 +79,16 @@ import qualified Prelude main :: IO () -main = Init.setupLogging $ \logEnv -> do +main = do Init.initCNix opts <- Options.parse let cfgPath = Options.configFile opts cfg <- Config.finalizeConfig cfgPath =<< Config.readConfig cfgPath - env <- Init.newEnv cfg logEnv - case Options.mode opts of - Options.Run -> run env cfg - Options.Test -> testConfiguration env cfg + Init.setupLogging cfg $ \logEnv -> do + env <- Init.newEnv cfg logEnv + case Options.mode opts of + Options.Run -> run env cfg + Options.Test -> testConfiguration env cfg testConfiguration :: Env.Env -> Config.FinalConfig -> IO () testConfiguration _env _cfg = do diff --git a/hercules-ci-agent/Hercules/Agent/Build.hs b/hercules-ci-agent/Hercules/Agent/Build.hs --- a/hercules-ci-agent/Hercules/Agent/Build.hs +++ b/hercules-ci-agent/Hercules/Agent/Build.hs @@ -1,7 +1,5 @@ module Hercules.Agent.Build where -import qualified Data.Aeson as A -import qualified Data.ByteString as BS import Data.IORef.Lifted import qualified Data.Map as M import qualified Hercules.API.Agent.Build as API.Build @@ -34,7 +32,6 @@ import qualified Hercules.Agent.WorkerProtocol.Event.BuildResult as BuildResult import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings import Hercules.Error (defaultRetry) -import qualified Katip.Core import qualified Network.URI import Protolude import System.Process @@ -72,7 +69,7 @@ }, materializeDerivation = materialize } - exitCode <- runWorker procSpec stderrLineHandler commandChan writeEvent + exitCode <- runWorker procSpec (stderrLineHandler "Builder") commandChan writeEvent logLocM DebugS $ "Worker exit: " <> show exitCode case exitCode of ExitSuccess -> pass @@ -98,17 +95,6 @@ size = fromIntegral $ BuildResult.size oi, hash = toSL $ BuildResult.hash oi } - -stderrLineHandler :: Int -> ByteString -> App () -stderrLineHandler _ ln - | "@katip " `BS.isPrefixOf` ln, - Just item <- A.decode (toS $ BS.drop 7 ln) = - -- "This is the lowest level function [...] useful when implementing centralised logging services." - Katip.Core.logKatipItem (Katip.Core.SimpleLogPayload . M.toList . fmap (Katip.Core.AnyLogPayload :: A.Value -> Katip.Core.AnyLogPayload) <$> item) -stderrLineHandler pid ln = - withNamedContext "worker" (pid :: Int) - $ logLocM InfoS - $ "Builder: " <> logStr (toSL ln :: Text) push :: BuildTask -> Map Text OutputInfo -> App () push buildTask outs = do diff --git a/hercules-ci-agent/Hercules/Agent/Config.hs b/hercules-ci-agent/Hercules/Agent/Config.hs --- a/hercules-ci-agent/Hercules/Agent/Config.hs +++ b/hercules-ci-agent/Hercules/Agent/Config.hs @@ -14,6 +14,7 @@ ) where +import Katip (Severity (..)) import Protolude hiding (to) import qualified System.Environment import System.FilePath (()) @@ -46,7 +47,8 @@ staticSecretsDirectory :: Item purpose 'Required FilePath, workDirectory :: Item purpose 'Required FilePath, clusterJoinTokenPath :: Item purpose 'Required FilePath, - binaryCachesPath :: Item purpose 'Required FilePath + binaryCachesPath :: Item purpose 'Required FilePath, + logLevel :: Item purpose 'Required Severity } deriving (Generic) @@ -71,6 +73,8 @@ .= clusterJoinTokenPath <*> dioptional (Toml.string "binaryCachesPath") .= binaryCachesPath + <*> dioptional (Toml.enumBounded "logLevel") + .= logLevel keyClusterJoinTokenPath :: Key keyClusterJoinTokenPath = "clusterJoinTokenPath" @@ -125,5 +129,6 @@ concurrentTasks = validConcurrentTasks, baseDirectory = baseDir, staticSecretsDirectory = staticSecretsDir, - workDirectory = workDir + workDirectory = workDir, + logLevel = logLevel input & fromMaybe InfoS } diff --git a/hercules-ci-agent/Hercules/Agent/Evaluate.hs b/hercules-ci-agent/Hercules/Agent/Evaluate.hs --- a/hercules-ci-agent/Hercules/Agent/Evaluate.hs +++ b/hercules-ci-agent/Hercules/Agent/Evaluate.hs @@ -41,6 +41,7 @@ import qualified Hercules.Agent.Client import qualified Hercules.Agent.Config as Config import Hercules.Agent.Env +import qualified Hercules.Agent.Env as Env import qualified Hercules.Agent.Evaluate.TraversalQueue as TraversalQueue import Hercules.Agent.Log import qualified Hercules.Agent.Nix as Nix @@ -51,6 +52,7 @@ ( renderSubPath, ) import Hercules.Agent.Producer +import qualified Hercules.Agent.ServiceInfo as ServiceInfo import Hercules.Agent.WorkerProcess () import qualified Hercules.Agent.WorkerProcess as WorkerProcess import qualified Hercules.Agent.WorkerProtocol.Command as Command @@ -59,9 +61,11 @@ import qualified Hercules.Agent.WorkerProtocol.Event as Event import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as WorkerAttribute import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as WorkerAttributeError +import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings import Hercules.Error (defaultRetry, quickRetry) import qualified Network.HTTP.Client.Conduit as HTTP.Conduit import qualified Network.HTTP.Simple as HTTP.Simple +import qualified Network.URI import Protolude hiding (finally, newChan, writeChan) import qualified Servant.Client import qualified System.Directory as Dir @@ -193,6 +197,7 @@ captureAttrDrvAndEmit uploadDrvInfos sync + (EvaluateTask.logToken task) -- process has finished TraversalQueue.waitUntilDone derivationQueue TraversalQueue.close derivationQueue @@ -229,14 +234,21 @@ -- | Upload a derivation, return when done (Text -> App ()) -> App () -> + Text -> App () -runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush = do +runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush logToken = do extraOpts <- Nix.askExtraOptions + baseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo) let eval = Eval.Eval { Eval.cwd = projectDir, Eval.file = toS file, Eval.autoArguments = autoArguments, - Eval.extraNixOptions = extraOpts + Eval.extraNixOptions = extraOpts, + Eval.logSettings = LogSettings.LogSettings + { token = LogSettings.Sensitive logToken, + path = "/api/v1/logs/build/socket", + baseURL = toS $ Network.URI.uriToString identity baseURL "" + } } buildRequiredIndex <- liftIO $ newIORef (0 :: Int) commandChan <- newChan @@ -329,7 +341,7 @@ close_fds = True, -- Disable on Windows? cwd = Just (Eval.cwd eval) } - WorkerProcess.runWorker wps stderrLineHandler commandChan writeEvent + WorkerProcess.runWorker wps (stderrLineHandler "evaluator") commandChan writeEvent drvPoller :: Maybe UUID -> Text -> App (UUID, BuildResult.BuildStatus) drvPoller notAttempt drvPath = do @@ -428,13 +440,6 @@ show a1 <> " " <> connective <> " " <> show a2 englishConjunction connective (a : as) = show a <> ", " <> englishConjunction connective as - -stderrLineHandler :: Int -> ByteString -> App () -stderrLineHandler pid ln = - withNamedContext "worker" (pid :: Int) - $ logLocM InfoS - $ "Evaluator: " - <> logStr (toSL ln :: Text) postBatch :: EvaluateTask.EvaluateTask -> [EvaluateEvent.EvaluateEvent] -> App () postBatch task events = diff --git a/hercules-ci-agent/Hercules/Agent/Init.hs b/hercules-ci-agent/Hercules/Agent/Init.hs --- a/hercules-ci-agent/Hercules/Agent/Init.hs +++ b/hercules-ci-agent/Hercules/Agent/Init.hs @@ -50,9 +50,9 @@ nixEnv = nix } -setupLogging :: (K.LogEnv -> IO ()) -> IO () -setupLogging f = do - handleScribe <- K.mkHandleScribe K.ColorIfTerminal stderr (Compat.katipLevel K.DebugS) K.V2 +setupLogging :: Config.FinalConfig -> (K.LogEnv -> IO ()) -> IO () +setupLogging cfg f = do + handleScribe <- K.mkHandleScribe K.ColorIfTerminal stderr (Compat.katipLevel (Config.logLevel cfg)) K.V2 let mkLogEnv = K.registerScribe "stderr" handleScribe K.defaultScribeSettings =<< K.initLogEnv emptyNamespace "" diff --git a/hercules-ci-agent/Hercules/Agent/Log.hs b/hercules-ci-agent/Hercules/Agent/Log.hs --- a/hercules-ci-agent/Hercules/Agent/Log.hs +++ b/hercules-ci-agent/Hercules/Agent/Log.hs @@ -10,6 +10,9 @@ where import Data.Aeson +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.Map as M import Katip hiding (logLocM) import Katip.Core import Katip.Monadic (logLocM) @@ -32,3 +35,15 @@ panicWithLog msg = do logLocM ErrorS $ toSL msg panic msg + +stderrLineHandler :: KatipContext m => Text -> Int -> ByteString -> m () +stderrLineHandler _processRole _ ln + | "@katip " `BS.isPrefixOf` ln, + Just item <- A.decode (toS $ BS.drop 7 ln) = + -- "This is the lowest level function [...] useful when implementing centralised logging services." + Katip.Core.logKatipItem (Katip.Core.SimpleLogPayload . M.toList . fmap (Katip.Core.AnyLogPayload :: A.Value -> Katip.Core.AnyLogPayload) <$> item) +stderrLineHandler processRole pid ln = + withNamedContext "worker" (pid :: Int) + $ logLocM InfoS + $ logStr + $ processRole <> ": " <> toSL ln diff --git a/src/Data/Conduit/Katip/Orphans.hs b/src/Data/Conduit/Katip/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Katip/Orphans.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Conduit.Katip.Orphans where + +import Control.Monad.Trans +import Data.Conduit +import Katip + +instance Katip m => Katip (ConduitT i o m) where + + getLogEnv = lift getLogEnv + + localLogEnv f = transPipe (localLogEnv f) + +instance KatipContext m => KatipContext (ConduitT i o m) where + + getKatipContext = lift getKatipContext + + getKatipNamespace = lift getKatipNamespace + + localKatipContext f = transPipe (localKatipContext f) + + localKatipNamespace f = transPipe (localKatipNamespace f) diff --git a/src/Hercules/Agent/Socket.hs b/src/Hercules/Agent/Socket.hs --- a/src/Hercules/Agent/Socket.hs +++ b/src/Hercules/Agent/Socket.hs @@ -57,7 +57,7 @@ } requiredServiceVersion :: (Int, Int) -requiredServiceVersion = (1, 0) +requiredServiceVersion = (2, 0) ackTimeout :: NominalDiffTime ackTimeout = 60 -- seconds diff --git a/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs b/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs --- a/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs +++ b/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs @@ -3,6 +3,7 @@ module Hercules.Agent.WorkerProtocol.Command.Eval where import Data.Binary +import Hercules.Agent.WorkerProtocol.LogSettings import Protolude data Eval @@ -13,7 +14,8 @@ -- | NB currently the options will leak from one evaluation to -- the next if you're running them in the same worker! -- (as of now, we use one worker process per evaluation) - extraNixOptions :: [(Text, Text)] + extraNixOptions :: [(Text, Text)], + logSettings :: LogSettings } deriving (Generic, Binary, Show, Eq)