hercules-ci-agent 0.9.7 → 0.9.8

raw patch · 15 files changed

+550/−177 lines, 15 filesdep ~hercules-ci-api-agentdep ~hercules-ci-api-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: hercules-ci-api-agent, hercules-ci-api-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• data/default-herculesCI-for-flake.nix +14/−2
• hercules-ci-agent-worker/Hercules/Agent/Worker/Effect.hs +2/−0
• hercules-ci-agent-worker/Hercules/Agent/Worker/Evaluate.hs +134/−17
• hercules-ci-agent.cabal +4/−3
• hercules-ci-agent/Hercules/Agent/Effect.hs +2/−0
• hercules-ci-agent/Hercules/Agent/Evaluate.hs +128/−53
• src/Hercules/Agent/NixFile.hs +112/−26
• src/Hercules/Agent/NixFile/GitSource.hs +15/−11
• src/Hercules/Agent/Sensitive.hs +1/−1
• src/Hercules/Agent/WorkerProtocol/Command/Effect.hs +3/−0
• src/Hercules/Agent/WorkerProtocol/Command/Eval.hs +1/−1
• src/Hercules/Agent/WorkerProtocol/Event.hs +8/−20
• src/Hercules/Agent/WorkerProtocol/ViaJSON.hs +16/−0
• src/Hercules/Effect.hs +88/−43

@@ -5,6 +5,28 @@ 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). +## Unreleased++### Added++ - `herculesCI.onSchedule` jobs, which a created at set times. These can be used+   to automate work that doesn't start with a code change, such as automatic+   updates or impure periodic deployments.++ - Secret types and the `GitToken` type, to be provided by the Hercules CI GitHub+   App. As of writing this requires a permission approval in the GitHub UI. This+   has to be initiated on the Hercules CI side. More on that very soon.++ - More repository metadata in the `herculesCI` attribute; see [evaluation docs](https://docs.hercules-ci.com/hercules-ci-agent/evaluation/#param-herculesCI-primaryRepo).++### Fixed++ - Work around excessive stack use by libstdc++ regex [issue](https://gcc.gnu.org/bugzilla/show_bug.cgi?id=86164)+   The new limit of 256 MiB stack allows larger string inputs to be used.+   This bug was triggered by purs-nix and possibly other Nix expression libraries that parse substantial files.++ - Lift the agent-side restriction on the number of derivations in a job.+ ## [0.9.7] - 2022-07-21  ### Added

@@ -122,8 +122,6 @@       forSystems = f: args: attrs: mapAttrs f (filterSystems args.ciSystems attrs);     in     rec {-      # TODO validate-       # buildable       packages = forSystems (sys: pkgs: pkgs);       checks = forSystems (sys: checks: checks);@@ -132,6 +130,19 @@       apps = forSystems (sys: mapAttrs (k: checkApp));       nixosConfigurations = args: attrs: mapAttrs (k: sys: { config.system.build.toplevel = sys.config.system.build.toplevel; }) (filterSystemConfigs args.ciSystems attrs);       darwinConfigurations = args: attrs: mapAttrs (k: sys: { config.system.build.toplevel = sys.config.system.build.toplevel; }) (filterSystemConfigs args.ciSystems attrs);+      formatter = forSystems (sys: formatter: formatter);+      templates = args: attrs: mapAttrs+        (name: template:+          if builtins.typeOf (template.description or null) != "string"+          then throw "Template `templates.${name}` does not have a `description` string attribute."+          else if builtins.typeOf template.path != "path"+          then throw "Template `templates.${name}` does not have a `path` attribute, containing a path value."+          else if !(builtins.pathExists template.path)+          then throw "Template path `templates.${name}.path` points to a directory that does not exist."+          else template+        )+        attrs;+       effects = args: effects:         if builtins.isAttrs effects         then effects@@ -151,5 +162,6 @@ {   inherit     addDefaults+    flakeToOutputs     ; }

@@ -7,6 +7,7 @@ import Hercules.Agent.Worker.Build.Prefetched (buildDerivation) import qualified Hercules.Agent.Worker.Build.Prefetched as Build import qualified Hercules.Agent.WorkerProtocol.Command.Effect as Command.Effect+import Hercules.Agent.WorkerProtocol.ViaJSON (fromViaJSON) import Hercules.CNix (Store) import qualified Hercules.CNix as CNix import Hercules.CNix.Store (Derivation)@@ -25,6 +26,7 @@       { runEffectDerivation = derivation,         runEffectToken = Just $ Command.Effect.token command,         runEffectSecretsConfigPath = Just $ Command.Effect.secretsPath command,+        runEffectServerSecrets = Command.Effect.serverSecrets command <&> fromViaJSON,         runEffectApiBaseURL = Command.Effect.apiBaseURL command,         runEffectDir = dir,         runEffectProjectId = Just $ Command.Effect.projectId command,

@@ -2,9 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}- {-# HLINT ignore "Use const" #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}  module Hercules.Agent.Worker.Evaluate where @@ -20,13 +20,18 @@ import Data.IORef import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Text as T import Hercules.API.Agent.Evaluate.EvaluateEvent.OnPushHandlerEvent (OnPushHandlerEvent (OnPushHandlerEvent)) import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.OnPushHandlerEvent+import Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent (OnScheduleHandlerEvent (OnScheduleHandlerEvent), TimeConstraints (TimeConstraints))+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask import qualified Hercules.API.Agent.Evaluate.EvaluateTask.OnPush as OnPush+import qualified Hercules.API.Agent.Evaluate.EvaluateTask.OnSchedule as OnSchedule import qualified Hercules.API.Agent.Evaluate.ImmutableGitInput as API.ImmutableGitInput import qualified Hercules.API.Agent.Evaluate.ImmutableInput as API.ImmutableInput-import Hercules.Agent.NixFile (HerculesCISchema, getHerculesCI, homeExprRawValue, loadNixFile, parseExtraInputs)+import Hercules.API.DayOfWeek (DayOfWeek (..))+import Hercules.Agent.NixFile (HerculesCISchema, InputsSchema, OutputsSchema, getHerculesCI, homeExprRawValue, loadNixFile, parseExtraInputs) import qualified Hercules.Agent.NixFile as NixFile import Hercules.Agent.NixFile.HerculesCIArgs (CISystems (CISystems), HerculesCIMeta (HerculesCIMeta), fromGitSource) import qualified Hercules.Agent.NixFile.HerculesCIArgs@@ -39,19 +44,17 @@   ( Eval,   ) import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval-import Hercules.Agent.WorkerProtocol.Event-  ( Event,-    ViaJSON (ViaJSON),-  )+import Hercules.Agent.WorkerProtocol.Event (Event) import qualified Hercules.Agent.WorkerProtocol.Event as Event import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as Attribute import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as AttributeError import qualified Hercules.Agent.WorkerProtocol.Event.AttributeIFD as Event.AttributeIFD+import qualified Hercules.Agent.WorkerProtocol.ViaJSON as ViaJSON import Hercules.CNix as CNix import Hercules.CNix.Expr (Match (IsAttrs, IsString), NixAttrs, RawValue, addAllowedPath, addInternalAllowedPaths, autoCallFunction, evalArgs, getAttrBool, getAttrList, getAttrs, getDrvFile, getFlakeFromArchiveUrl, getFlakeFromGit, getRecurseForDerivations, getStringIgnoreContext, isDerivation, isFunctor, match, rawValueType, rtValue, toRawValue, toValue, withEvalStateConduit) import Hercules.CNix.Expr.Context (EvalState) import qualified Hercules.CNix.Expr.Raw-import Hercules.CNix.Expr.Schema (MonadEval, PSObject, dictionaryToMap, fromPSObject, requireDict, (#.), (#?), (#?!), ($?))+import Hercules.CNix.Expr.Schema (MonadEval, PSObject, dictionaryToMap, fromPSObject, provenance, requireDict, traverseArray, (#.), (#?), (#?!), (#??), ($?), (|!), type (->?), type (.)) import qualified Hercules.CNix.Expr.Schema as Schema import Hercules.CNix.Expr.Typed (Value) import Hercules.CNix.Std.Vector (StdVector)@@ -285,13 +288,16 @@             -- legacy             walk evalEnv args (homeExprRawValue homeExpr)           Just herculesCI -> do-            case Event.fromViaJSON (Eval.selector eval) of+            case ViaJSON.fromViaJSON (Eval.selector eval) of               EvaluateTask.ConfigOrLegacy -> do                 yield Event.JobConfig                 sendConfig evalState isFlake herculesCI               EvaluateTask.OnPush onPush ->                 transPipe (`runReaderT` evalState) do                   walkOnPush evalEnv onPush herculesCI+              EvaluateTask.OnSchedule onSchedule ->+                transPipe (`runReaderT` evalState) do+                  walkOnSchedule evalEnv onSchedule herculesCI     yield Event.EvaluationDone  getHomeExpr :: (MonadThrow m, MonadIO m) => Ptr EvalState -> Eval -> m NixFile.HomeExpr@@ -302,7 +308,7 @@         srcInput <- case Eval.srcInput eval of           Just x -> pure x           Nothing -> panic "srcInput is required for flake job"-        raw <- mkImmutableGitInputFlakeThunk evalState (Event.fromViaJSON srcInput)+        raw <- mkImmutableGitInputFlakeThunk evalState (ViaJSON.fromViaJSON srcInput)         let pso :: PSObject (Schema.Attrs '[])             pso = Schema.PSObject {value = raw, provenance = Schema.Other "flake.nix"}         toValue evalState pso@@ -310,14 +316,32 @@  walkOnPush :: (MonadEval m, MonadUnliftIO m, KatipContext m, MonadThrow m) => EvalEnv -> OnPush.OnPush -> PSObject HerculesCISchema -> ConduitT i Event m () walkOnPush evalEnv onPushParams herculesCI = do+  handler <- herculesCI #?! #onPush >>= requireDict (OnPush.name onPushParams)+  walkHandler evalEnv (OnPush.inputs onPushParams) handler++walkOnSchedule :: (MonadEval m, MonadUnliftIO m, KatipContext m, MonadThrow m) => EvalEnv -> OnSchedule.OnSchedule -> PSObject HerculesCISchema -> ConduitT i Event m ()+walkOnSchedule evalEnv onScheduleParams herculesCI = do+  handler <- herculesCI #?! #onSchedule >>= requireDict (OnSchedule.name onScheduleParams)+  walkHandler evalEnv (OnSchedule.extraInputs onScheduleParams) handler++walkHandler ::+  ( MonadEval m,+    MonadUnliftIO m,+    KatipContext m,+    handlerAttrs . "outputs" ~ (InputsSchema ->? OutputsSchema)+  ) =>+  EvalEnv ->+  Map Text API.ImmutableInput.ImmutableInput ->+  PSObject (Schema.Attrs' handlerAttrs w) ->+  ConduitT i Event m ()+walkHandler evalEnv inputs handler = do   let evalState = evalEnvState evalEnv-  onPushHandler <- herculesCI #?! #onPush >>= requireDict (OnPush.name onPushParams)-  inputs <- liftIO $ do-    inputs <- for (OnPush.inputs onPushParams) \input -> do+  inputs' <- liftIO $ do+    inputs' <- for inputs \input -> do       inputToValue evalState input-    toRawValue evalState inputs-  outputsFun <- onPushHandler #. #outputs-  outputs <- outputsFun $? (Schema.PSObject {value = inputs, provenance = Schema.Data})+    toRawValue evalState inputs'+  outputsFun <- handler #. #outputs+  outputs <- outputsFun $? (Schema.PSObject {value = inputs', provenance = Schema.Data})   simpleWalk evalEnv (Schema.value outputs)  inputToValue :: Ptr EvalState -> API.ImmutableInput.ImmutableInput -> IO RawValue@@ -340,12 +364,105 @@     for_ (M.mapWithKey (,) attrs) \(name, onPush) -> do       ei <- onPush #? #extraInputs >>= traverse parseExtraInputs       enable <- onPush #? #enable >>= traverse fromPSObject <&> fromMaybe True-      when enable . lift . yield . Event.OnPushHandler . ViaJSON $+      when enable . lift . yield . Event.OnPushHandler . ViaJSON.ViaJSON $         OnPushHandlerEvent           { handlerName = decodeUtf8 name,             handlerExtraInputs = M.mapKeys decodeUtf8 (fromMaybe mempty ei),             isFlake = isFlake           }+  herculesCI #? #onSchedule >>= traverse_ \onSchedules -> do+    attrs <- dictionaryToMap onSchedules+    for_ (M.mapWithKey (,) attrs) \(name, onSchedule) -> do+      ei <- onSchedule #? #extraInputs >>= traverse parseExtraInputs+      enable <- onSchedule #? #enable >>= traverse fromPSObject <&> fromMaybe True+      when_ <- onSchedule #?? #when >>= maybe (pure defaultConstraints) parseWhen+      when enable . lift . yield . Event.OnScheduleHandler . ViaJSON.ViaJSON $+        OnScheduleHandlerEvent+          { handlerName = decodeUtf8 name,+            handlerExtraInputs = M.mapKeys decodeUtf8 (fromMaybe mempty ei),+            isFlake = isFlake,+            when = when_+          }++defaultConstraints :: TimeConstraints+defaultConstraints = noConstraints++noConstraints :: TimeConstraints+noConstraints = TimeConstraints Nothing Nothing Nothing Nothing++parseWhen :: MonadEval m => PSObject NixFile.TimeConstraintsSchema -> m Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent.TimeConstraints+parseWhen w = do+  minute_ <-+    w #?? #minute >>= traverse \obj -> do+      v <- fromPSObject obj+      if v >= 0 && v < 60+        then pure v+        else throwIO $ Schema.InvalidValue (provenance obj) $ "minute value " <> show v <> " is out of range [0..59]."++  let validateHour obj = do+        v <- fromPSObject obj+        if v >= 0 && v < 24+          then pure v+          else throwIO $ Schema.InvalidValue (provenance obj) $ "hour value " <> show v <> " is out of range [0..23]."++  hour_ <-+    w #?? #hour+      >>= traverse+        ( (\oneInt -> validateHour oneInt <&> \x -> [x])+            |! ( \hours -> do+                   v <- traverseArray validateHour hours+                   when (null v) do+                     throwIO $ Schema.InvalidValue (provenance hours) $ "hour must not be an empty list."+                   pure v+               )+        )+  dayOfWeek <-+    w #?? #dayOfWeek+      >>= traverse+        ( \dayStringsObject -> do+            days <- traverseArray parseDayOfWeek dayStringsObject+            when (null days) do+              throwIO $ Schema.InvalidValue (provenance dayStringsObject) $ "dayOfWeek must not be an empty list."+            pure days+        )+  dayOfMonth <-+    w #?? #dayOfMonth+      >>= traverse \daysOfMonth -> do+        v <-+          daysOfMonth & traverseArray \obj -> do+            v <- fromPSObject obj+            if v >= 0 && v <= 31+              then pure v+              else throwIO $ Schema.InvalidValue (provenance obj) $ "month value " <> show v <> " is out of range [0..31]."+        when (null v) do+          throwIO $ Schema.InvalidValue (provenance daysOfMonth) $ "dayOfMonth must not be an empty list."+        pure v++  pure $+    TimeConstraints+      { minute = (minute_ :: Maybe Int64) <&> fromIntegral,+        hour = (hour_ :: Maybe [Int64]) <&> fmap fromIntegral,+        dayOfWeek = dayOfWeek,+        dayOfMonth = (dayOfMonth :: Maybe [Int64]) <&> fmap fromIntegral+      }++parseDayOfWeek :: (Schema.FromPSObject a Text, MonadEval m) => PSObject a -> m DayOfWeek+parseDayOfWeek dayString = do+  s <- fromPSObject @_ @Text dayString+  case T.toLower s of+    "mon" -> pure Mon+    "tue" -> pure Tue+    "wed" -> pure Wed+    "thu" -> pure Thu+    "fri" -> pure Fri+    "sat" -> pure Sat+    "sun" -> pure Sun+    other ->+      throwIO+        ( Schema.InvalidValue+            (provenance dayString)+            ("Expected an abbreviated day of week: \"Mon\", \"Tue\", \"Wed\", \"Thu\", \"Fri\", \"Sat\" or \"Sun\". Actual: " <> show other)+        )  data TreeWork = TreeWork   { treeWorkAttrPath :: [ByteString],

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           hercules-ci-agent-version:        0.9.7+version:        0.9.8 synopsis:       Runs Continuous Integration tasks on your machines category:       Nix, CI, Testing, DevOps homepage:       https://docs.hercules-ci.com@@ -86,6 +86,7 @@       Hercules.Agent.Socket       Hercules.Agent.STM       Hercules.Agent.WorkerProcess+      Hercules.Agent.WorkerProtocol.ViaJSON       Hercules.Agent.WorkerProtocol.Command       Hercules.Agent.WorkerProtocol.Command.Build       Hercules.Agent.WorkerProtocol.Command.BuildResult@@ -219,8 +220,8 @@     , filepath     , hercules-ci-agent     , hercules-ci-api-    , hercules-ci-api-core == 0.1.4.0-    , hercules-ci-api-agent == 0.4.5.0+    , hercules-ci-api-core == 0.1.5.0+    , hercules-ci-api-agent == 0.4.6.0     , hostname     , http-client     , http-client-tls

@@ -20,6 +20,7 @@ import qualified Hercules.Agent.WorkerProtocol.Command.Effect as Command.Effect import qualified Hercules.Agent.WorkerProtocol.Event as Event import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import Hercules.Agent.WorkerProtocol.ViaJSON (ViaJSON (ViaJSON)) import qualified Hercules.Secrets as Secrets import qualified Network.URI import Protolude@@ -72,6 +73,7 @@                   },               materializeDerivation = materialize,               secretsPath = toS $ Config.secretsJsonPath config,+              serverSecrets = Sensitive $ ViaJSON (EffectTask.serverSecrets effectTask),               token = Sensitive (EffectTask.token effectTask),               apiBaseURL = Config.herculesApiBaseURL config,               projectId = EffectTask.projectId effectTask,

@@ -11,6 +11,7 @@ import qualified Control.Concurrent.Async.Lifted as Async.Lifted import Control.Concurrent.Chan.Lifted import Control.Exception.Lifted (finally)+import qualified Control.Exception.Safe as Safe import Control.Lens (at, (^?)) import Control.Monad.IO.Unlift (askUnliftIO, unliftIO) import qualified Data.Aeson as A@@ -34,6 +35,7 @@   ) import qualified Hercules.API.Agent.Evaluate.DerivationStatus as DerivationStatus import qualified Hercules.API.Agent.Evaluate.EvaluateEvent as EvaluateEvent+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent as AttributeEffectEvent import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeErrorEvent as AttributeErrorEvent import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEvent as AttributeEvent import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeIFDEvent as AttributeIFDEvent@@ -50,7 +52,6 @@ import Hercules.API.Servant (noContent) import Hercules.API.Task (Task) import qualified Hercules.Agent.Cache as Agent.Cache-import qualified Hercules.Agent.Cachix.Env as Cachix.Env import qualified Hercules.Agent.Client import qualified Hercules.Agent.Config as Config import Hercules.Agent.Env@@ -65,7 +66,6 @@   ( retrieveDerivationInfo,   ) import Hercules.Agent.NixFile (findNixFile)-import Hercules.Agent.NixFile.GitSource (fromRefRevPath) import qualified Hercules.Agent.NixFile.GitSource as GitSource import Hercules.Agent.NixPath   ( renderSubPath,@@ -78,13 +78,15 @@ import qualified Hercules.Agent.WorkerProtocol.Command as Command import qualified Hercules.Agent.WorkerProtocol.Command.BuildResult as BuildResult import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval-import Hercules.Agent.WorkerProtocol.Event (ViaJSON (ViaJSON)) 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.Event.AttributeIFD as AttributeIFD import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import Hercules.Agent.WorkerProtocol.ViaJSON (ViaJSON (ViaJSON), fromViaJSON) import Hercules.CNix.Store (Store, StorePath, parseStorePath)+import qualified Hercules.CNix.Store as CNix+import Hercules.Effect (parseDrvSecretsMap) import Hercules.Error (defaultRetry, quickRetry) import qualified Network.HTTP.Client.Conduit as HTTP.Conduit import qualified Network.HTTP.Simple as HTTP.Simple@@ -119,16 +121,15 @@   Just {} -> do     pure Nothing -produceEvaluationTaskEvents ::-  Store ->-  EvaluateTask.EvaluateTask ->+makeEventEmitter ::   (Syncing EvaluateEvent.EvaluateEvent -> App ()) ->-  App ()-produceEvaluationTaskEvents store task writeToBatch | EvaluateTask.isFlakeJob task = withWorkDir "eval" $ \tmpdir -> do-  logLocM DebugS "Retrieving evaluation task (flake)"+  App (EvaluateEvent.EvaluateEvent -> App ())+makeEventEmitter writeToBatch = do   let emitSingle = writeToBatch . Syncable-      sync = syncer writeToBatch++  eventCounter <- liftIO $ newIORef 0   msgCounter <- liftIO $ newIORef 0+   let fixIndex ::         MonadIO m =>         EvaluateEvent.EvaluateEvent ->@@ -137,13 +138,23 @@         i <- liftIO $ atomicModifyIORef msgCounter (\i0 -> (i0 + 1, i0))         pure $ EvaluateEvent.Message m {Message.index = i}       fixIndex other = pure other-  eventCounter <- liftIO $ newIORef 0-  topDerivationPaths <- liftIO $ newIORef mempty-  let emit :: EvaluateEvent.EvaluateEvent -> App ()++      isLimited :: EvaluateEvent.EvaluateEvent -> Bool+      isLimited = \case+        EvaluateEvent.Attribute {} -> True+        EvaluateEvent.AttributeEffect {} -> True+        EvaluateEvent.AttributeError {} -> True+        EvaluateEvent.Message {} ->+          -- a simplistic solution against unexpected runaway Messages.+          -- we don't expect >1 message, especially since we have a separate eval log now,+          -- so realistically it doesn't impact the attribute limit at all.+          True+        _ -> False+       emit update = do-        n <- liftIO $ atomicModifyIORef eventCounter $ \n -> dup (n + 1)-        if n > eventLimit-          then do+        when (isLimited update) do+          n <- liftIO $ atomicModifyIORef eventCounter $ \n -> dup (n + 1)+          when (n > eventLimit) do             truncMsg <-               fixIndex $                 EvaluateEvent.Message@@ -157,7 +168,19 @@                     }             emitSingle truncMsg             panic "Evaluation limit reached."-          else emitSingle =<< fixIndex update+        emitSingle =<< fixIndex update+  pure emit++produceEvaluationTaskEvents ::+  Store ->+  EvaluateTask.EvaluateTask ->+  (Syncing EvaluateEvent.EvaluateEvent -> App ()) ->+  App ()+produceEvaluationTaskEvents store task writeToBatch | EvaluateTask.isFlakeJob task = withWorkDir "eval" $ \tmpdir -> do+  logLocM DebugS "Retrieving evaluation task (flake)"+  let sync = syncer writeToBatch+  topDerivationPaths <- liftIO $ newIORef mempty+  emit <- makeEventEmitter writeToBatch   let allowedPaths = []    TraversalQueue.with $ \(derivationQueue :: Queue StorePath) ->@@ -177,6 +200,7 @@         evaluation = do           let evalProc =                 do runEvalProcess+                  store                   tmpdir -- unused                   ""                   mempty@@ -202,6 +226,9 @@             EvaluateEvent.Attribute ae -> do               storePath <- liftIO $ parseStorePath store (encodeUtf8 $ AttributeEvent.derivationPath ae)               addTopDerivation storePath+            EvaluateEvent.AttributeEffect ae -> do+              storePath <- liftIO $ parseStorePath store (encodeUtf8 $ AttributeEffectEvent.derivationPath ae)+              addTopDerivation storePath             _ -> pass           emit msg         emitDrvs =@@ -214,8 +241,7 @@      in doIt produceEvaluationTaskEvents store task writeToBatch = withWorkDir "eval" $ \tmpdir -> do   logLocM DebugS "Retrieving evaluation task"-  let emitSingle = writeToBatch . Syncable-      sync = syncer writeToBatch+  let sync = syncer writeToBatch   inputLocations <-     EvaluateTask.otherInputs task       & M.traverseWithKey \k src -> do@@ -283,36 +309,11 @@                     Eval.ExprArg $                       -- TODO pass directly to avoid having to escape (or just escape properly)                       "builtins.fromJSON ''" <> BL.toStrict (A.encode attrs) <> "'' // { outPath = " <> argPath <> "; }"-  msgCounter <- liftIO $ newIORef 0-  let fixIndex ::-        MonadIO m =>-        EvaluateEvent.EvaluateEvent ->-        m EvaluateEvent.EvaluateEvent-      fixIndex (EvaluateEvent.Message m) = do-        i <- liftIO $ atomicModifyIORef msgCounter (\i0 -> (i0 + 1, i0))-        pure $ EvaluateEvent.Message m {Message.index = i}-      fixIndex other = pure other-  eventCounter <- liftIO $ newIORef 0+   topDerivationPaths <- liftIO $ newIORef mempty-  let emit :: EvaluateEvent.EvaluateEvent -> App ()-      emit update = do-        n <- liftIO $ atomicModifyIORef eventCounter $ \n -> dup (n + 1)-        if n > eventLimit-          then do-            truncMsg <--              fixIndex $-                EvaluateEvent.Message-                  Message.Message-                    { index = -1,-                      typ = Message.Error,-                      message =-                        "Evaluation limit reached. Does your nix expression produce infinite attributes? Please make sure that your project is finite. If it really does require more than "-                          <> show eventLimit-                          <> " attributes or messages, please contact info@hercules-ci.com."-                    }-            emitSingle truncMsg-            panic "Evaluation limit reached."-          else emitSingle =<< fixIndex update++  emit <- makeEventEmitter writeToBatch+   let allowedPaths = toList inputLocations <&> toS <&> encodeUtf8   adHocSystem <-     readFileMaybe (projectDir </> "ci-default-system.txt")@@ -343,6 +344,7 @@             Nix.withExtraOptions [("system", T.strip s) | Just s <- [adHocSystem]] do               let evalProc =                     do runEvalProcess+                      store                       projectDir                       file                       autoArguments@@ -368,6 +370,9 @@               EvaluateEvent.Attribute ae -> do                 storePath <- liftIO $ parseStorePath store (encodeUtf8 $ AttributeEvent.derivationPath ae)                 addTopDerivation storePath+              EvaluateEvent.AttributeEffect ae -> do+                storePath <- liftIO $ parseStorePath store (encodeUtf8 $ AttributeEffectEvent.derivationPath ae)+                addTopDerivation storePath               _ -> pass             emit msg           emitDrvs =@@ -389,7 +394,12 @@         || isDigit c         || c `elem` ("+-._?=" :: [Char]) +checkNonEmptyText :: Text -> Maybe Text+checkNonEmptyText "" = Nothing+checkNonEmptyText t = Just t+ runEvalProcess ::+  CNix.Store ->   FilePath ->   FilePath ->   Map Text Eval.Arg ->@@ -403,7 +413,7 @@   EvaluateTask.EvaluateTask ->   [ByteString] ->   App ()-runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush task allowedPaths = do+runEvalProcess store projectDir file autoArguments nixPath emit uploadDerivationInfos flush task allowedPaths = do   extraOpts <- Nix.askExtraOptions   bulkBaseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)   apiBaseUrl <- asks (toS . showBaseUrl . Env.herculesBaseUrl)@@ -411,7 +421,22 @@   srcInput <- getSrcInput task   gitSource <-     case srcInput of-      Just git -> pure $ fromRefRevPath (ImmutableGitInput.ref git) (ImmutableGitInput.rev git) (toS projectDir)+      Just git ->+        pure $+          GitSource.GitSource+            { outPath = toS projectDir,+              ref = ImmutableGitInput.ref git,+              rev = ImmutableGitInput.rev git,+              shortRev = GitSource.shortRevFromRev (ImmutableGitInput.rev git),+              branch = GitSource.branchFromRef (ImmutableGitInput.ref git),+              tag = GitSource.tagFromRef (ImmutableGitInput.ref git),+              remoteHttpUrl = ImmutableGitInput.httpURL git & checkNonEmptyText,+              remoteSshUrl = ImmutableGitInput.sshURL git & checkNonEmptyText,+              webUrl = ImmutableGitInput.webURL git,+              forgeType = ImmutableGitInput.forgeType git,+              owner = ImmutableGitInput.owner git,+              name = ImmutableGitInput.name git+            }       Nothing -> do         (ref, rev) <- case M.lookup "src" (EvaluateTask.inputMetadata task) of           Nothing -> do@@ -419,7 +444,21 @@           Just meta -> pure $ fromMaybe (panic "no ref/rev in primary source metadata") do             (,) <$> (meta ^? at "ref" . traverse . _String)               <*> (meta ^? at "rev" . traverse . _String)-        pure $ fromRefRevPath ref rev (toS projectDir)+        pure $+          GitSource.GitSource+            { outPath = toS projectDir,+              ref = ref,+              rev = rev,+              shortRev = GitSource.shortRevFromRev rev,+              branch = GitSource.branchFromRef ref,+              tag = GitSource.tagFromRef ref,+              remoteHttpUrl = Nothing,+              remoteSshUrl = Nothing,+              webUrl = Nothing,+              forgeType = Nothing,+              owner = Nothing,+              name = Nothing+            }   let eval =         Eval.Eval           { Eval.cwd = projectDir,@@ -484,6 +523,40 @@         listen           workerEventsP           ( \case+              Event.Attribute a | WorkerAttribute.typ a == WorkerAttribute.Effect -> do+                let drvPath = WorkerAttribute.drv a+                secretsMay <- liftIO $ Safe.try do+                  drvStorePath <- CNix.parseStorePath store drvPath+                  derivation <- CNix.getDerivation store drvStorePath+                  drvEnv <- CNix.getDerivationEnv derivation+                  pure $ parseDrvSecretsMap drvEnv++                let emitError msg =+                      emit $+                        EvaluateEvent.AttributeError $+                          AttributeErrorEvent.AttributeErrorEvent+                            { AttributeErrorEvent.expressionPath = decode <$> WorkerAttribute.path a,+                              AttributeErrorEvent.errorMessage = msg,+                              AttributeErrorEvent.errorType = Nothing,+                              AttributeErrorEvent.errorDerivation = Just $ decodeUtf8With lenientDecode (WorkerAttribute.drv a),+                              AttributeErrorEvent.trace = Nothing+                            }+                case secretsMay of+                  Right (Right secrets) -> do+                    emit $+                      EvaluateEvent.AttributeEffect $+                        AttributeEffectEvent.AttributeEffectEvent+                          { expressionPath = decode <$> WorkerAttribute.path a,+                            derivationPath = decode $ WorkerAttribute.drv a,+                            secretsToUse = secrets+                          }+                  Right (Left userError) -> do+                    emitError userError+                  Left technicalError -> do+                    katipAddContext (sl "message" (displayException (technicalError :: SomeException))) do+                      logLocM ErrorS "An unexpected exception occurred while reading an effect."+                    emitError "An unexpected exception occurred while reading the effect. The error message has been logged locally on the agent."+                continue               Event.Attribute a -> do                 emit $                   EvaluateEvent.Attribute $@@ -533,7 +606,6 @@                       }                 continue               Event.Build drv outputName notAttempt waitForStatus -> do-                store <- asks (Cachix.Env.nixStore . Env.cachixEnv)                 storePath <- liftIO (parseStorePath store drv)                 let drvText = decode drv                 withNamedContext "derivation" (decode drv) $ do@@ -574,6 +646,9 @@               Event.OnPushHandler (ViaJSON e) -> do                 emit $ EvaluateEvent.OnPushHandlerEvent e                 continue+              Event.OnScheduleHandler (ViaJSON e) -> do+                emit $ EvaluateEvent.OnScheduleHandlerEvent e+                continue               Event.JobConfig -> do                 emit $ EvaluateEvent.JobConfig JobConfig.JobConfig {sourceCaches = Nothing, binaryCaches = Nothing}                 continue@@ -628,7 +703,7 @@         stderrLineHandler           ( M.fromList               [ ("taskId", A.toJSON taskId),-                ("evalRev", A.toJSON (eval & Eval.gitSource & Event.fromViaJSON & GitSource.rev))+                ("evalRev", A.toJSON (eval & Eval.gitSource & fromViaJSON & GitSource.rev))               ]           )           "Effect worker"

@@ -2,17 +2,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeFamilies #-}  module Hercules.Agent.NixFile   ( -- * Schemas     HomeSchema,     HerculesCISchema,     OnPushSchema,+    OnScheduleSchema,     ExtraInputsSchema,     InputDeclSchema,     InputsSchema,     InputSchema,     OutputsSchema,+    TimeConstraintsSchema,      -- * Loading     findNixFile,@@ -23,12 +26,13 @@     loadDefaultHerculesCI,      -- * @onPush@-    getOnPushOutputValueByPath,+    getVirtualValueByPath,     parseExtraInputs,   ) where  import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import qualified Data.Map as M import Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration (InputDeclaration (SiblingInput), SiblingInput (MkSiblingInput)) import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration import Hercules.Agent.NixFile.CiNixArgs (CiNixArgs (CiNixArgs))@@ -46,6 +50,7 @@     autoCallFunction,     evalFile,     getAttr,+    getFlakeFromFlakeRef,     getLocalFlake,     match',     toRawValue,@@ -53,13 +58,14 @@     valueFromExpressionString,   ) import Hercules.CNix.Expr.Raw (RawValue)-import Hercules.CNix.Expr.Schema (Attrs, Dictionary, MonadEval, PSObject (PSObject), Provenance (Other), StringWithoutContext, basicAttrsWithProvenance, dictionaryToMap, fromPSObject, toPSObject, (#.), (#?), ($?), (.$), (>>$.), type (->.), type (->?), type (::.), type (::?))+import Hercules.CNix.Expr.Schema (Attrs, Dictionary, MonadEval, PSObject (PSObject), Provenance (Other), StringWithoutContext, basicAttrsWithProvenance, dictionaryToMap, fromPSObject, toPSObject, (#.), (#?), ($?), (.$), (>>$.), type (->.), type (->?), type (.), type (::.), type (::?), type (::??), type (?), type (|.)) import qualified Hercules.CNix.Expr.Schema as Schema import Hercules.Error (escalateAs) import Paths_hercules_ci_agent (getDataFileName) import Protolude hiding (evalState) import qualified System.Directory as Dir-import System.FilePath (takeFileName, (</>))+import System.FilePath (takeDirectory, takeFileName, (</>))+import UnliftIO.Directory (doesPathExist)  type Ambiguity = [FilePath] @@ -101,7 +107,19 @@   nixFile <- ExceptT $ findNixFile projectPath   if takeFileName nixFile == "flake.nix"     then do-      val <- liftIO $ getLocalFlake evalState (toS projectPath) >>= assertType evalState+      -- NB This branch of logic is not used by hercules-ci-agent, which fetches+      --    directly from flakeref and does not go through a local path.+      --    An actual consumer of this branch is the hci CLI.++      -- TODO: Can Nix decide isGit (and more) for us?+      isGit <- doesPathExist (takeDirectory nixFile </> ".git")+      val <-+        liftIO+          ( if isGit+              then getFlakeFromFlakeRef evalState ("git+file://" <> encodeUtf8 (toS projectPath))+              else getLocalFlake evalState (toS projectPath)+          )+          >>= assertType evalState       pure (Flake val)     else do       rootValueOrFunction <- liftIO $ evalFile evalState nixFile@@ -115,15 +133,21 @@  type HomeSchema = Attrs '["herculesCI" ::? Attrs '[] ->? HerculesCISchema] -type HerculesCISchema = Attrs '["onPush" ::? Dictionary OnPushSchema]+type HerculesCISchema =+  Attrs+    '[ "onPush" ::? Dictionary OnPushSchema,+       "onSchedule" ::? Dictionary OnScheduleSchema+     ]  type OnPushSchema =   Attrs     '[ "extraInputs" ::? ExtraInputsSchema,-       "outputs" ::. InputsSchema ->? OutputsSchema,+       "outputs" ::. OutputsFunction,        "enable" ::? Bool      ] +type OutputsFunction = InputsSchema ->? OutputsSchema+ type ExtraInputsSchema = Dictionary InputDeclSchema  type InputDeclSchema =@@ -132,6 +156,30 @@        "ref" ::? StringWithoutContext      ] +type OnScheduleSchema =+  Attrs+    '[ "extraInputs" ::? ExtraInputsSchema,+       "outputs" ::. OutputsFunction,+       "enable" ::? Bool,+       "when" ::?? TimeConstraintsSchema+     ]++type TimeConstraintsSchema =+  Attrs+    '[ "hour" ::?? HoursSchema,+       "minute" ::?? MinuteSchema,+       "dayOfWeek" ::?? DaysOfWeekSchema,+       "dayOfMonth" ::?? DaysOfMonthSchema+     ]++type HoursSchema = Int64 |. [Int64]++type MinuteSchema = Int64++type DaysOfWeekSchema = [StringWithoutContext]++type DaysOfMonthSchema = [Int64]+ type InputsSchema = Dictionary InputSchema  type InputSchema = Dictionary RawValue@@ -183,14 +231,19 @@   ref <- d #? #ref >>= traverse fromPSObject   pure $ SiblingInput $ MkSiblingInput {project = project, ref = ref} --- | Given a path, return the onPush output or legacy ci.nix value+-- | A function for retrieving values from `herculesCI` and legacy ci.nix.+-- It treats the expression as tree of attribute sets, making the required+-- function applications and context gather implicit. --+-- For example, given a path, this will return the onPush output or legacy+-- ci.nix value. Oversimplifying:+-- -- @@@ -- e.g.  ["a" "b"]  => ((import file).herculesCI args).onPush.a.outputs.b --       or falling back to --       ["a" "b"]  => (import file legacyArgs).a.b -- @@@-getOnPushOutputValueByPath ::+getVirtualValueByPath ::   Ptr EvalState ->   FilePath ->   HerculesCIArgs ->@@ -198,28 +251,61 @@   (Map ByteString InputDeclaration -> IO (Value NixAttrs)) ->   [ByteString] ->   IO (Maybe RawValue)-getOnPushOutputValueByPath evalState filePath args resolveInputs attrPath = do+getVirtualValueByPath evalState filePath args resolveInputs attrPath = do   homeExpr <- escalateAs FatalError =<< loadNixFile evalState filePath (HerculesCIArgs.primaryRepo args)-  onPush <- flip runReaderT evalState $ runMaybeT do-    herculesCI <- MaybeT $ getHerculesCI homeExpr args-    MaybeT $ herculesCI #? #onPush+  flip runReaderT evalState do+    herculesCI <- getHerculesCI homeExpr args+    onPushMaybe <- join <$> for herculesCI \hci -> hci #? #onPush+    onScheduleMaybe <- join <$> for herculesCI \hci -> hci #? #onSchedule+    let require = MaybeT . pure+        m2s k (Just a) = M.singleton k a+        m2s _ Nothing = mempty -  -- No backtracking. It's either legacy or not...-  case onPush of-    Just jobs -> flip runReaderT evalState $ do+    runMaybeT do       case attrPath of-        [] -> pure $ Just $ Schema.value jobs -- Technically mapAttrs .outputs, meh-        (jobName : attrPath') -> do-          Schema.lookupDictBS jobName jobs >>= \case-            Just selectedJob -> do-              outputs <- resolveAndInvokeOutputs selectedJob (liftIO . resolveInputs)-              outputAttrs <- Schema.check outputs-              liftIO $ attrByPath evalState (rtValue outputAttrs) attrPath'-            Nothing -> pure Nothing-    Nothing -> do-      attrByPath evalState (homeExprRawValue homeExpr) attrPath+        [] | isJust onPushMaybe || isJust onScheduleMaybe -> do+          onPush' <- traverse (liftIO . toRawValue evalState) onPushMaybe+          onSchedule' <- traverse (liftIO . toRawValue evalState) onScheduleMaybe+          liftIO $ toRawValue evalState (m2s ("onPush" :: ByteString) onPush' <> m2s "onSchedule" onSchedule')+        "onPush" : [] -> do+          Schema.value <$> require onPushMaybe+        "onPush" : jobName : attrPath' -> do+          onPush <- require onPushMaybe+          job <- MaybeT $ Schema.lookupDictBS jobName onPush+          outputs <- resolveAndInvokeOutputs job (liftIO . resolveInputs)+          outputAttrs <- Schema.check outputs+          MaybeT $ liftIO $ attrByPath evalState (rtValue outputAttrs) attrPath'+        "onSchedule" : [] -> do+          Schema.value <$> require onScheduleMaybe+        "onSchedule" : jobName : attrPath' -> do+          onSchedule <- require onScheduleMaybe+          job <- MaybeT $ Schema.lookupDictBS jobName onSchedule+          outputs <- resolveAndInvokeOutputs job (liftIO . resolveInputs)+          outputAttrs <- Schema.check outputs+          MaybeT $ liftIO $ attrByPath evalState (rtValue outputAttrs) attrPath'+        _ ->+          case onPushMaybe of+            Just jobs -> do+              case attrPath of+                [] -> pure $ Schema.value jobs -- Technically mapAttrs .outputs, meh+                (jobName : attrPath') -> do+                  Schema.lookupDictBS jobName jobs >>= \case+                    Just selectedJob -> do+                      outputs <- resolveAndInvokeOutputs selectedJob (liftIO . resolveInputs)+                      outputAttrs <- Schema.check outputs+                      MaybeT $ liftIO $ attrByPath evalState (rtValue outputAttrs) attrPath'+                    Nothing -> empty+            Nothing -> do+              MaybeT $ liftIO $ attrByPath evalState (homeExprRawValue homeExpr) attrPath -resolveAndInvokeOutputs :: MonadEval m => PSObject OnPushSchema -> (Map ByteString InputDeclaration -> m (Value NixAttrs)) -> m (PSObject OutputsSchema)+resolveAndInvokeOutputs ::+  ( MonadEval m,+    a . "outputs" ~ OutputsFunction,+    a ? "extraInputs" ~ ExtraInputsSchema+  ) =>+  PSObject (Attrs a) ->+  (Map ByteString InputDeclaration -> m (Value NixAttrs)) ->+  m (PSObject OutputsSchema) resolveAndInvokeOutputs job resolveInputs = do   inputs <- job #? #extraInputs >>= traverse parseExtraInputs   resolved <- resolveInputs (fromMaybe mempty inputs)

@@ -14,18 +14,22 @@     rev :: Text,     shortRev :: Text,     branch :: Maybe Text,-    tag :: Maybe Text+    tag :: Maybe Text,+    remoteHttpUrl :: Maybe Text,+    remoteSshUrl :: Maybe Text,+    webUrl :: Maybe Text,+    forgeType :: Maybe Text,+    owner :: Maybe Text,+    name :: Maybe Text   }   deriving (Generic, ToJSON, FromJSON, Show, Eq)   deriving (ToRawValue) via (ViaJSON GitSource) -fromRefRevPath :: Text -> Text -> Text -> GitSource-fromRefRevPath aRef aRev path =-  GitSource-    { outPath = path,-      ref = aRef,-      rev = aRev,-      shortRev = T.take 7 aRev,-      branch = T.stripPrefix "refs/heads/" aRef,-      tag = T.stripPrefix "refs/tags/" aRef-    }+shortRevFromRev :: Text -> Text+shortRevFromRev = T.take 7++branchFromRef :: Text -> Maybe Text+branchFromRef = T.stripPrefix "refs/heads/"++tagFromRef :: Text -> Maybe Text+tagFromRef = T.stripPrefix "refs/tags/"

@@ -10,7 +10,7 @@ -- | newtype wrapper to avoid leaking sensitive data through Show newtype Sensitive a = Sensitive {reveal :: a}   deriving (Generic)-  deriving newtype (Binary, Eq, Ord)+  deriving newtype (Binary, Eq, Ord, Monoid, Semigroup)   deriving (Functor, Applicative, Monad) via Identity  -- | @const "<sensitive>"@

@@ -3,11 +3,13 @@  module Hercules.Agent.WorkerProtocol.Command.Effect where +import qualified Data.Aeson as A import Data.Binary import Hercules.API.Id (Id) import Hercules.Agent.Sensitive import Hercules.Agent.WorkerProtocol.LogSettings import Hercules.Agent.WorkerProtocol.Orphans ()+import Hercules.Agent.WorkerProtocol.ViaJSON (ViaJSON) import Hercules.Secrets (SecretContext) import Protolude @@ -18,6 +20,7 @@     inputDerivationOutputPaths :: [ByteString],     materializeDerivation :: Bool,     secretsPath :: FilePath,+    serverSecrets :: Sensitive (ViaJSON (Map Text (Map Text A.Value))),     token :: Sensitive Text,     projectId :: Id "project",     projectPath :: Text,

@@ -6,9 +6,9 @@ import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask import Hercules.API.Agent.Evaluate.ImmutableGitInput (ImmutableGitInput) import Hercules.Agent.NixFile.GitSource (GitSource)-import Hercules.Agent.WorkerProtocol.Event (ViaJSON) import Hercules.Agent.WorkerProtocol.LogSettings import Hercules.Agent.WorkerProtocol.Orphans ()+import Hercules.Agent.WorkerProtocol.ViaJSON (ViaJSON) import Protolude  data Eval = Eval

@@ -3,17 +3,16 @@  module Hercules.Agent.WorkerProtocol.Event where -import Control.Monad (fail)-import qualified Data.Aeson as A-import Data.Binary+import Data.Binary (Binary) import Data.UUID (UUID) import Hercules.API.Agent.Evaluate.EvaluateEvent.OnPushHandlerEvent (OnPushHandlerEvent)-import Hercules.Agent.WorkerProtocol.Event.Attribute-import Hercules.Agent.WorkerProtocol.Event.AttributeError+import Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent (OnScheduleHandlerEvent)+import Hercules.Agent.WorkerProtocol.Event.Attribute (Attribute)+import Hercules.Agent.WorkerProtocol.Event.AttributeError (AttributeError) import Hercules.Agent.WorkerProtocol.Event.AttributeIFD (AttributeIFD)-import Hercules.Agent.WorkerProtocol.Event.BuildResult-import Protolude hiding (get, put)-import Prelude ()+import Hercules.Agent.WorkerProtocol.Event.BuildResult (BuildResult)+import Hercules.Agent.WorkerProtocol.ViaJSON (ViaJSON)+import Protolude  data Event   = Attribute Attribute@@ -26,17 +25,6 @@   | EffectResult Int   | JobConfig   | OnPushHandler (ViaJSON OnPushHandlerEvent)+  | OnScheduleHandler (ViaJSON OnScheduleHandlerEvent)   | Exception Text   deriving (Generic, Binary, Show, Eq)--newtype ViaJSON a = ViaJSON {fromViaJSON :: a}-  deriving (Eq, Ord, Show, Read)---- | Orphan-instance (A.ToJSON a, A.FromJSON a) => Binary (ViaJSON a) where-  put (ViaJSON a) = put (A.encode a)-  get = do-    bs <- get-    case A.eitherDecode bs of-      Left s -> fail s-      Right r -> pure (ViaJSON r)

@@ -0,0 +1,16 @@+module Hercules.Agent.WorkerProtocol.ViaJSON where++import qualified Data.Aeson as A+import Data.Binary (Binary (..))+import Prelude++newtype ViaJSON a = ViaJSON {fromViaJSON :: a}+  deriving (Eq, Ord, Show, Read)++instance (A.ToJSON a, A.FromJSON a) => Binary (ViaJSON a) where+  put (ViaJSON a) = put (A.encode a)+  get = do+    bs <- get+    case A.eitherDecode bs of+      Left s -> fail s+      Right r -> pure (ViaJSON r)

@@ -6,9 +6,12 @@  import Control.Monad.Catch (MonadThrow) import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as AK import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M+import Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent (GitToken (..), SecretRef (GitToken, SimpleSecret), SimpleSecret (MkSimpleSecret))+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent import Hercules.API.Id (Id, idText) import Hercules.Agent.Sensitive (Sensitive (Sensitive, reveal), revealContainer) import qualified Hercules.Agent.WorkerProcess as WorkerProcess@@ -28,17 +31,48 @@ import UnliftIO.Process (withCreateProcess) import qualified UnliftIO.Process as Process -parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text Text)+parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text SecretRef) parseDrvSecretsMap drvEnv =-  case drvEnv & M.lookup "secretsMap" of+  case (,) "secretsToUse" <$> M.lookup "secretsToUse" drvEnv+    <|> (,) "secretsMap" <$> M.lookup "secretsMap" drvEnv of     Nothing -> pure mempty-    Just secretsMapText -> case A.eitherDecode (BL.fromStrict secretsMapText) of-      Left _ -> Left "Could not parse secretsMap variable in derivation. It must be a JSON dictionary of strings referencing agent secret names."-      Right r -> Right r+    Just (attrName, secretsMapText) -> case A.eitherDecode (BL.fromStrict secretsMapText) of+      Left _ -> Left $ "Could not parse " <> attrName <> " variable in derivation. It must be a JSON dictionary."+      Right r -> parseSecretRefs attrName r +parseSecretRefs :: Text -> A.Object -> Either Text (Map Text SecretRef)+parseSecretRefs attrName obj =+  AK.toMapText obj & M.traverseWithKey \k v -> parseSecretRef (attrName <> "." <> k) v++parseSecretRef :: Text -> A.Value -> Either Text SecretRef+parseSecretRef _ (A.String s) = pure (SimpleSecret $ MkSimpleSecret s)+parseSecretRef attrName (A.Object o) =+  case AK.lookup "type" o of+    Just (A.String s) ->+      case s of+        "GitToken" -> pure (GitToken $ MkGitToken {})+        _ -> Left $ "Could not parse secret reference " <> attrName <> ", because the type is unknown; must be \"GitToken\"."+    Just _ -> Left $ "Could not parse secret reference " <> attrName <> ", because the type attribute is not a string."+    Nothing -> Left $ "Could not parse secret reference " <> attrName <> ", because it does not have a type attribute."+parseSecretRef attrName _ = Left $ "Could not parse secret reference " <> attrName <> ", because it is neither a string nor an attribute set."+ -- | Write secrets to file based on secretsMap value-writeSecrets :: (MonadIO m, KatipContext m) => Bool -> Maybe SecretContext -> Maybe FilePath -> Map Text Text -> Map Text (Sensitive Formats.Secret.Secret) -> FilePath -> m ()-writeSecrets friendly ctxMaybe sourceFileMaybe secretsMap extraSecrets destinationDirectory = write . fmap reveal . addExtra =<< gather+writeSecrets ::+  (MonadIO m, KatipContext m) =>+  -- | Whether we're in a friendly context, such as the CLI.+  Bool ->+  Maybe SecretContext ->+  -- | Optional source file+  Maybe FilePath ->+  -- | Declared secrets from the effect derivation+  Map Text SecretRef ->+  -- | Local secrets+  Map Text (Sensitive Formats.Secret.Secret) ->+  -- | Server secrets+  Map Text (Sensitive (Map Text A.Value)) ->+  FilePath ->+  m ()+writeSecrets friendly ctxMaybe sourceFileMaybe secretsMap extraSecrets serverSecrets destinationDirectory = write . fmap reveal . addExtra =<< gather   where     addExtra = flip M.union extraSecrets     write = liftIO . BS.writeFile (destinationDirectory </> "secrets.json") . BL.toStrict . A.encode@@ -56,46 +90,57 @@                 Right r -> pure (Sensitive r)            createDirectoryIfMissing True destinationDirectory-          secretsMap & M.traverseWithKey \destinationName (secretName :: Text) -> do-            let gotoFail =-                  liftIO . throwIO . FatalError $-                    "Secret " <> secretName <> " does not exist or access was denied, so we can't get a secret for " <> destinationName <> ". Please make sure that the secret name matches a secret on your agents and make sure that its condition applies."-            case revealContainer (allSecrets <&> M.lookup secretName) of-              Nothing -> gotoFail-              Just ssecret -> do-                let condMaybe = reveal (Formats.Secret.condition <$> ssecret)-                    r = do-                      secret <- ssecret-                      pure $-                        Formats.Secret.Secret-                          { data_ = Formats.Secret.data_ secret,-                            -- Hide the condition-                            condition = Nothing-                          }-                case (friendly, condMaybe) of-                  (True, Nothing) -> do-                    putErrText $ "The secret " <> show secretName <> " does not contain the `condition` field, which is required on hercules-ci-agent >= 0.9."-                    pure r-                  (True, Just cond) | Just ctx <- ctxMaybe ->-                    case evalConditionTrace ctx cond of-                      (_, True) -> pure r-                      (trace_, _) -> do-                        putErrText $ "Could not grant access to secret " <> show secretName <> "."-                        for_ trace_ \ln -> putErrText $ "  " <> ln-                        liftIO . throwIO . FatalError $ "Could not grant access to secret " <> show secretName <> ". See trace in preceding log."-                  (True, Just _) | otherwise -> do-                    -- This is only ok in friendly mode (hci)-                    putErrText "WARNING: not performing secrets access control. The secret.condition field won't be checked."-                    pure r-                  (False, Nothing) -> gotoFail-                  (False, Just cond) ->-                    if evalCondition (fromMaybe (panic "SecretContext is required") ctxMaybe) cond then pure r else gotoFail +          secretsMap & M.traverseWithKey \destinationName secretRef ->+            case secretRef of+              GitToken {} -> do+                case M.lookup destinationName serverSecrets of+                  Just x -> pure (x <&> \data_ -> Formats.Secret.Secret {data_ = data_, condition = Just (Formats.Secret.And [])})+                  Nothing ->+                    liftIO . throwIO . FatalError $+                      "A value for secret " <> destinationName <> " was not provided. This may be a bug."+              SimpleSecret (MkSimpleSecret {name = secretName}) -> do+                let gotoFail name =+                      liftIO . throwIO . FatalError $+                        "Secret " <> name <> " does not exist or access was denied, so we can't get a secret for " <> destinationName <> ". Please make sure that the secret name matches a secret on your agents and make sure that its condition applies."++                case revealContainer (allSecrets <&> M.lookup secretName) of+                  Nothing -> gotoFail secretName+                  Just ssecret -> do+                    let condMaybe = reveal (Formats.Secret.condition <$> ssecret)+                        r = do+                          secret <- ssecret+                          pure $+                            Formats.Secret.Secret+                              { data_ = Formats.Secret.data_ secret,+                                -- Hide the condition+                                condition = Nothing+                              }+                    case (friendly, condMaybe) of+                      (True, Nothing) -> do+                        putErrText $ "The secret " <> show secretName <> " does not contain the `condition` field, which is required on hercules-ci-agent >= 0.9."+                        pure r+                      (True, Just cond) | Just ctx <- ctxMaybe ->+                        case evalConditionTrace ctx cond of+                          (_, True) -> pure r+                          (trace_, _) -> do+                            putErrText $ "Could not grant access to secret " <> show secretName <> "."+                            for_ trace_ \ln -> putErrText $ "  " <> ln+                            liftIO . throwIO . FatalError $ "Could not grant access to secret " <> show secretName <> ". See trace in preceding log."+                      (True, Just _) | otherwise -> do+                        -- This is only ok in friendly mode (hci)+                        putErrText "WARNING: not performing secrets access control. The secret.condition field won't be checked."+                        pure r+                      (False, Nothing) -> gotoFail secretName+                      (False, Just cond) ->+                        if evalCondition (fromMaybe (panic "SecretContext is required") ctxMaybe) cond then pure r else gotoFail secretName+ data RunEffectParams = RunEffectParams   { runEffectDerivation :: Derivation,     runEffectToken :: Maybe (Sensitive Text),     runEffectSecretsConfigPath :: Maybe FilePath,     runEffectSecretContext :: Maybe SecretContext,+    runEffectServerSecrets :: Sensitive (Map Text (Map Text A.Value)),     runEffectApiBaseURL :: Text,     runEffectDir :: FilePath,     runEffectProjectId :: Maybe (Id "project"),@@ -110,7 +155,7 @@ (=:) = M.singleton  runEffect :: (MonadThrow m, KatipContext m) => RunEffectParams -> m ExitCode-runEffect p@RunEffectParams {runEffectDerivation = derivation, runEffectSecretsConfigPath = secretsPath, runEffectApiBaseURL = apiBaseURL, runEffectDir = dir} = do+runEffect p@RunEffectParams {runEffectDerivation = derivation, runEffectSecretsConfigPath = secretsPath, runEffectApiBaseURL = apiBaseURL, runEffectDir = dir, runEffectServerSecrets = serverSecrets} = do   drvBuilder <- liftIO $ getDerivationBuilder derivation   drvArgs <- liftIO $ getDerivationArguments derivation   drvEnv <- liftIO $ getDerivationEnv derivation@@ -133,7 +178,7 @@                         condition = Nothing                       }             )-  writeSecrets (runEffectFriendly p) (runEffectSecretContext p) secretsPath drvSecretsMap extraSecrets (toS secretsDir)+  writeSecrets (runEffectFriendly p) (runEffectSecretContext p) secretsPath drvSecretsMap extraSecrets (revealContainer serverSecrets) (toS secretsDir)   liftIO $ do     -- Nix sandbox sets tmp to buildTopDir     -- Nix sandbox reference: https://github.com/NixOS/nix/blob/24e07c428f21f28df2a41a7a9851d5867f34753a/src/libstore/build.cc#L2545