hercules-ci-agent 0.7.2 → 0.7.3
raw patch · 14 files changed
+306/−143 lines, 14 filesdep ~hercules-ci-api-agentdep ~hercules-ci-api-core
Dependency ranges changed: hercules-ci-api-agent, hercules-ci-api-core
Files
- CHANGELOG.md +10/−0
- hercules-ci-agent-worker/Hercules/Agent/Worker.hs +126/−97
- hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs +5/−2
- hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs +85/−5
- hercules-ci-agent.cabal +6/−2
- hercules-ci-agent/Hercules/Agent.hs +6/−5
- hercules-ci-agent/Hercules/Agent/Build.hs +1/−15
- hercules-ci-agent/Hercules/Agent/Config.hs +7/−2
- hercules-ci-agent/Hercules/Agent/Evaluate.hs +15/−10
- hercules-ci-agent/Hercules/Agent/Init.hs +3/−3
- hercules-ci-agent/Hercules/Agent/Log.hs +15/−0
- src/Data/Conduit/Katip/Orphans.hs +23/−0
- src/Hercules/Agent/Socket.hs +1/−1
- src/Hercules/Agent/WorkerProtocol/Command/Eval.hs +3/−1
CHANGELOG.md view
@@ -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
hercules-ci-agent-worker/Hercules/Agent/Worker.hs view
@@ -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 <> " : "
hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs view
@@ -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
hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs view
@@ -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+ }
hercules-ci-agent.cabal view
@@ -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:
hercules-ci-agent/Hercules/Agent.hs view
@@ -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
hercules-ci-agent/Hercules/Agent/Build.hs view
@@ -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
hercules-ci-agent/Hercules/Agent/Config.hs view
@@ -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 }
hercules-ci-agent/Hercules/Agent/Evaluate.hs view
@@ -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 =
hercules-ci-agent/Hercules/Agent/Init.hs view
@@ -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 ""
hercules-ci-agent/Hercules/Agent/Log.hs view
@@ -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
+ src/Data/Conduit/Katip/Orphans.hs view
@@ -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)
src/Hercules/Agent/Socket.hs view
@@ -57,7 +57,7 @@ } requiredServiceVersion :: (Int, Int)-requiredServiceVersion = (1, 0)+requiredServiceVersion = (2, 0) ackTimeout :: NominalDiffTime ackTimeout = 60 -- seconds
src/Hercules/Agent/WorkerProtocol/Command/Eval.hs view
@@ -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)