diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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 @@ -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, 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.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 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,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 } diff --git a/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs b/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs --- a/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs +++ b/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs @@ -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 diff --git a/src/Hercules/Effect/Container.hs b/src/Hercules/Effect/Container.hs --- a/src/Hercules/Effect/Container.hs +++ b/src/Hercules/Effect/Container.hs @@ -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,