hercules-ci-agent 0.8.0 → 0.8.1
raw patch · 6 files changed
+126/−19 lines, 6 filesdep +scientificdep ~hercules-ci-api-agent
Dependencies added: scientific
Dependency ranges changed: hercules-ci-api-agent
Files
- CHANGELOG.md +13/−1
- hercules-ci-agent-worker/Hercules/Agent/Worker.hs +40/−9
- hercules-ci-agent.cabal +4/−2
- hercules-ci-agent/Hercules/Agent/Config.hs +52/−2
- hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs +8/−2
- src/Hercules/Effect/Container.hs +9/−3
CHANGELOG.md view
@@ -5,6 +5,17 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.8.1]++### Added++ - Attach user-defined labels to the agent, for retrieval via the API.++### Fixed++ - Fix an issue where long-runnin nix methods weren't interrupted+ - Fix error `mkdir /run/runc: permission denied`+ ## [0.8.0] ### Added@@ -59,7 +70,7 @@ - Attributes can now be marked to require or ignore a build failure in the derivation it references directly.- ([support#34](https://github.com/hercules-ci/support/issues/34))+ (see [support#34](https://github.com/hercules-ci/support/issues/34)) - `concurrentTasks` now has a default, `"auto"` for ease of setup and to help avoid underutilization.@@ -401,6 +412,7 @@ - Initial release +[0.8.1]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.8.0...hercules-ci-agent-0.8.1 [0.8.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.5...hercules-ci-agent-0.8.0 [0.7.5]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.4...hercules-ci-agent-0.7.5 [0.7.4]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.3...hercules-ci-agent-0.7.4
hercules-ci-agent-worker/Hercules/Agent/Worker.hs view
@@ -31,6 +31,7 @@ import qualified Hercules.API.Agent.LifeCycle.ServiceInfo import Hercules.API.Logs.LogEntry (LogEntry) import qualified Hercules.API.Logs.LogEntry as LogEntry+import Hercules.API.Logs.LogHello (LogHello (LogHello, clientProtocolVersion, storeProtocolVersion)) import Hercules.API.Logs.LogMessage (LogMessage) import qualified Hercules.API.Logs.LogMessage as LogMessage import Hercules.Agent.Sensitive@@ -63,6 +64,7 @@ import Hercules.CNix.Expr.Context (EvalState) import qualified Hercules.CNix.Expr.Raw import Hercules.CNix.Expr.Typed (Value)+import Hercules.CNix.Util (triggerInterrupt) import Hercules.Error import Katip import qualified Language.C.Inline.Cpp.Exceptions as C@@ -70,6 +72,7 @@ import Protolude hiding (bracket, catch, evalState, wait, withAsync, yield) import qualified System.Environment as Environment import System.IO (BufferMode (LineBuffering), hSetBuffering)+import System.Mem.Weak (deRefWeak) import System.Posix.IO (dup, fdToHandle, stdError) import System.Posix.Signals (Handler (Catch), installHandler, raiseSignal, sigINT, sigTERM) import System.Timeout (timeout)@@ -94,11 +97,30 @@ instance Exception BuildException +extendSigINT :: IO ()+extendSigINT = do+ mainThread <- myThreadId+ weakId <- mkWeakThreadId mainThread+ _oldHandler <-+ installHandler+ sigINT+ ( Catch do+ -- GHC RTS default behavior+ mt <- deRefWeak weakId+ for_ mt \t -> do+ throwTo t (toException UserInterrupt)+ -- Nix+ triggerInterrupt+ )+ Nothing+ pass+ main :: IO () main = do hSetBuffering stderr LineBuffering Hercules.CNix.Expr.init _ <- installHandler sigTERM (Catch $ raiseSignal sigINT) Nothing+ extendSigINT Logger.initLogger [options] <- Environment.getArgs let allOptions =@@ -200,8 +222,10 @@ -- TODO don't do this mainThread <- liftIO myThreadId UnliftIO unlift <- askUnliftIO+ protocolVersion <- liftIO do+ getStoreProtocolVersion (wrappedStore herculesState) case command of- Command.Eval eval -> Logger.withLoggerConduit (logger $ Eval.logSettings eval) $+ Command.Eval eval -> Logger.withLoggerConduit (logger (Eval.logSettings eval) protocolVersion) $ Logger.withTappedStderr Logger.tapper $ connectCommand ch $ do void $@@ -232,12 +256,12 @@ _ -> pass Command.Build build -> katipAddNamespace "Build" $- Logger.withLoggerConduit (logger $ Build.logSettings build) $+ Logger.withLoggerConduit (logger (Build.logSettings build) protocolVersion) $ Logger.withTappedStderr Logger.tapper $ connectCommand ch $ runBuild (wrappedStore herculesState) build Command.Effect effect -> katipAddNamespace "Effect" $- Logger.withLoggerConduit (logger $ Effect.logSettings effect) $+ Logger.withLoggerConduit (logger (Effect.logSettings effect) protocolVersion) $ Logger.withTappedStderr Logger.tapper $ connectCommand ch $ do runEffect (wrappedStore herculesState) effect >>= \case@@ -246,9 +270,9 @@ _ -> panic "Not a valid starting command" -logger :: (MonadIO m, MonadUnliftIO m, KatipContext m) => LogSettings.LogSettings -> ConduitM () (Vector LogEntry) m () -> m ()-logger logSettings_ entriesSource = do- socketConfig <- liftIO $ makeSocketConfig logSettings_+logger :: (MonadIO m, MonadUnliftIO m, KatipContext m) => LogSettings.LogSettings -> Int -> ConduitM () (Vector LogEntry) m () -> m ()+logger logSettings_ storeProtocolVersionValue entriesSource = do+ socketConfig <- liftIO $ makeSocketConfig logSettings_ storeProtocolVersionValue let withPings socket m = withAsync ( liftIO $ forever do@@ -318,14 +342,21 @@ bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \logEnv -> runKatipContextT logEnv initialContext extraNs m -makeSocketConfig :: Monad m => LogSettings.LogSettings -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m)-makeSocketConfig l = do+makeSocketConfig :: MonadIO m => LogSettings.LogSettings -> Int -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m)+makeSocketConfig l storeProtocolVersionValue = do+ clientProtocolVersionValue <- liftIO getClientProtocolVersion baseURL <- case Network.URI.parseURI $ toS $ LogSettings.baseURL l of Just x -> pure x Nothing -> panic "LogSettings: invalid base url" pure Socket.SocketConfig- { makeHello = pure (LogMessage.LogEntries mempty),+ { makeHello =+ pure $+ LogMessage.Hello+ LogHello+ { clientProtocolVersion = clientProtocolVersionValue,+ storeProtocolVersion = storeProtocolVersionValue+ }, checkVersion = Socket.checkVersion', baseURL = baseURL, path = LogSettings.path l,
hercules-ci-agent.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: hercules-ci-agent-version: 0.8.0+version: 0.8.1 synopsis: Runs Continuous Integration tasks on your machines category: Nix, CI, Testing, DevOps homepage: https://docs.hercules-ci.com@@ -184,7 +184,7 @@ , filepath , hercules-ci-agent , hercules-ci-api-core == 0.1.2.0- , hercules-ci-api-agent == 0.3.0.0+ , hercules-ci-api-agent == 0.3.1.0 , hostname , http-client , http-client-tls@@ -203,6 +203,7 @@ , process-extras , protolude , safe-exceptions+ , scientific , servant >=0.14.1 , servant-auth-client , servant-client@@ -219,6 +220,7 @@ , unliftio , unordered-containers , uuid+ , vector , websockets , wuss default-language: Haskell2010
hercules-ci-agent/Hercules/Agent/Config.hs view
@@ -14,6 +14,9 @@ ) where +import qualified Data.Aeson as A+import Data.Scientific (floatingOrInteger, fromFloatDigits)+import qualified Data.Vector as V import GHC.Conc (getNumProcessors) import Katip (Severity (..)) import Protolude hiding (to)@@ -50,7 +53,8 @@ workDirectory :: Item purpose 'Required FilePath, clusterJoinTokenPath :: Item purpose 'Required FilePath, binaryCachesPath :: Item purpose 'Required FilePath,- logLevel :: Item purpose 'Required Severity+ logLevel :: Item purpose 'Required Severity,+ labels :: Item purpose 'Required (Map Text A.Value) } deriving (Generic) @@ -80,7 +84,52 @@ .= binaryCachesPath <*> dioptional (Toml.enumBounded "logLevel") .= logLevel+ <*> dioptional (Toml.tableMap _KeyText embedJson "labels")+ .= labels +embedJson :: Key -> TomlCodec A.Value+embedJson key =+ Codec+ { codecRead =+ codecRead (match (embedJsonBiMap key) key)+ <!> codecRead (A.Object <$> Toml.tableHashMap _KeyText embedJson key),+ codecWrite = panic "embedJson.write: not implemented" $ \case+ A.String s -> A.String <$> codecWrite (Toml.text key) s+ A.Number sci -> A.Number . fromRational . toRational <$> codecWrite (Toml.double key) (fromRational $ toRational sci)+ A.Bool b -> A.Bool <$> codecWrite (Toml.bool key) b+ A.Array a -> A.Array . V.fromList <$> codecWrite (Toml.arrayOf (embedJsonBiMap key) key) (Protolude.toList a)+ A.Object o -> A.Object <$> codecWrite (Toml.tableHashMap _KeyText embedJson key) o+ A.Null -> eitherToTomlState (Left ("null is not supported in TOML" :: Text))+ }++embedJsonBiMap :: Key -> TomlBiMap A.Value AnyValue+embedJsonBiMap _key =+ -- TODO: use key for error reporting+ BiMap+ { forward = panic "embedJsonBiMap.forward: not implemented" $ \case+ A.String s -> pure $ AnyValue $ Text s+ A.Number sci -> case floatingOrInteger sci of+ Left fl -> pure $ AnyValue $ Double fl -- lossy+ Right i -> pure $ AnyValue $ Integer i+ A.Bool b -> pure $ AnyValue $ Bool b+ A.Array _a -> Left $ ArbitraryError "Conversion from JSON array of arrays to TOML not implemented yet"+ A.Object _o -> Left $ ArbitraryError "Conversion from JSON array of objects to TOML is not supported"+ A.Null -> Left $ ArbitraryError "JSON null is not supported in TOML",+ backward = anyValueToJSON+ }++anyValueToJSON :: AnyValue -> Either TomlBiMapError A.Value+anyValueToJSON = \case+ AnyValue (Bool b) -> pure (A.Bool b)+ AnyValue (Integer i) -> pure (A.Number $ fromIntegral i)+ AnyValue (Double d) -> pure (A.Number $ fromFloatDigits d)+ AnyValue (Text t) -> pure (A.String t)+ AnyValue (Zoned _zt) -> Left (ArbitraryError "Conversion from TOML zoned time to JSON not implemented yet. Use a string.")+ AnyValue (Local _zt) -> Left (ArbitraryError "Conversion from TOML local time to JSON not implemented yet. Use a string.")+ AnyValue (Day _d) -> Left (ArbitraryError "Conversion from TOML day to JSON not implemented yet. Use a string.")+ AnyValue (Hours _h) -> Left (ArbitraryError "Conversion from TOML hours to JSON not implemented yet. Use a string.")+ AnyValue (Array a) -> A.Array <$> sequence (V.fromList (a <&> AnyValue <&> anyValueToJSON))+ matchLeft :: Either a b -> Maybe a matchLeft (Left a) = Just a matchLeft _ = Nothing@@ -152,5 +201,6 @@ baseDirectory = baseDir, staticSecretsDirectory = staticSecretsDir, workDirectory = workDir,- logLevel = logLevel input & fromMaybe InfoS+ logLevel = logLevel input & fromMaybe InfoS,+ labels = fromMaybe mempty $ labels input }
hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs view
@@ -20,28 +20,34 @@ import qualified Hercules.Agent.Config as Config import Hercules.Agent.Env as Env import Hercules.Agent.Log+import qualified Hercules.CNix.Store as Store import Network.HostName (getHostName) import Protolude hiding (to) import qualified System.Process as Process extractAgentInfo :: App AgentInfo.AgentInfo extractAgentInfo = do+ cfg <- asks Env.config hostname <- liftIO getHostName nix <- liftIO getNixInfo cachixPushCaches <- Cachix.Info.activePushCaches pushCaches <- Env.activePushCaches- concurrentTasks <- asks (Config.concurrentTasks . Env.config)+ nixClientProtocolVersion <- liftIO Store.getClientProtocolVersion+ nixStoreProtocolVersion <- liftIO $ Store.withStore Store.getStoreProtocolVersion let s = AgentInfo.AgentInfo { hostname = toS hostname, agentVersion = CabalInfo.herculesAgentVersion, -- TODO: Add git revision nixVersion = nixExeVersion nix,+ nixClientProtocolVersion = nixClientProtocolVersion,+ nixDaemonProtocolVersion = nixStoreProtocolVersion, platforms = nixPlatforms nix, cachixPushCaches = cachixPushCaches, pushCaches = pushCaches, systemFeatures = nixSystemFeatures nix, substituters = nixSubstituters nix, -- TODO: Add cachix substituters- concurrentTasks = fromIntegral concurrentTasks+ concurrentTasks = fromIntegral $ Config.concurrentTasks cfg,+ labels = Config.labels cfg } logLocM DebugS $ "Determined environment info: " <> logStr (show s :: Text) pure s
src/Hercules/Effect/Container.hs view
@@ -76,6 +76,11 @@ { cwd = Just dir } configJsonPath = dir </> "config.json"+ runcRootPath = dir </> "runc-root"+ -- Although runc run --root says+ -- root directory for storage of container state (this should be located in tmpfs)+ -- this is not a requirement. See https://github.com/opencontainers/runc/issues/2054+ rootfsPath = dir </> "rootfs" (exit, _out, err) <- readCreateProcessWithExitCode createConfigJsonSpec "" case exit of ExitSuccess -> pass@@ -87,8 +92,9 @@ Right a -> pure a Left e -> throwIO (FatalError $ "decoding runc config.json template: " <> show e) let configJson = effectToRuncSpec config template- BS.writeFile (dir </> "config.json") (BL.toStrict $ encode configJson)- createDirectory (dir </> "rootfs")+ BS.writeFile (configJsonPath) (BL.toStrict $ encode configJson)+ createDirectory rootfsPath+ createDirectory runcRootPath name <- do uuid <- UUID.nextRandom pure $ "hercules-ci-" <> show uuid@@ -103,7 +109,7 @@ ( do terminalHandle <- fdToHandle terminal let createProcSpec =- (System.Process.proc runcExe ["run", name])+ (System.Process.proc runcExe ["--root", runcRootPath, "run", name]) { std_in = UseHandle terminalHandle, -- can't pass /dev/null :( std_out = UseHandle terminalHandle, std_err = UseHandle terminalHandle,