hercules-ci-agent 0.8.7 → 0.9.0

raw patch · 54 files changed

+1804/−867 lines, 54 filesdep +taggeddep ~aesondep ~hercules-ci-api-agentdep ~hercules-ci-api-core

Dependencies added: tagged

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

Files

• CHANGELOG.md +40/−0
• cbits/hercules-logger.cxx +0/−2
• cbits/hercules-logger.hh +0/−7
• cbits/nix-2.3/hercules-store.cxx +0/−276
• cbits/nix-2.3/hercules-store.hh +0/−150
• cbits/nix-2.4/hercules-store.cxx +1/−0
• cbits/nix-2.4/hercules-store.hh +0/−1
• data/default-herculesCI-for-flake.nix +155/−0
• hercules-ci-agent-worker/Hercules/Agent/Worker.hs +286/−91
• hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs +5/−6
• hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs +7/−15
• hercules-ci-agent-worker/Hercules/Agent/Worker/Effect.hs +7/−3
• hercules-ci-agent-worker/Hercules/Agent/Worker/HerculesStore.hs +1/−3
• hercules-ci-agent-worker/Hercules/Agent/Worker/Logging.hs +23/−0
• hercules-ci-agent-worker/Hercules/Agent/Worker/NixDaemon.hs +123/−0
• hercules-ci-agent.cabal +44/−27
• hercules-ci-agent/Hercules/Agent.hs +4/−3
• hercules-ci-agent/Hercules/Agent/Bag.hs +2/−2
• hercules-ci-agent/Hercules/Agent/Build.hs +8/−1
• hercules-ci-agent/Hercules/Agent/CabalInfo.hs +1/−1
• hercules-ci-agent/Hercules/Agent/Cache.hs +10/−14
• hercules-ci-agent/Hercules/Agent/Compat.hs +7/−2
• hercules-ci-agent/Hercules/Agent/Config.hs +8/−4
• hercules-ci-agent/Hercules/Agent/Effect.hs +17/−2
• hercules-ci-agent/Hercules/Agent/Env.hs +2/−0
• hercules-ci-agent/Hercules/Agent/Evaluate.hs +101/−20
• hercules-ci-agent/Hercules/Agent/Init.hs +3/−1
• hercules-ci-agent/Hercules/Agent/Netrc.hs +35/−0
• hercules-ci-agent/Hercules/Agent/Netrc/Env.hs +7/−0
• hercules-ci-agent/Hercules/Agent/NixPath.hs +0/−27
• hercules-ci-agent/Hercules/Agent/WorkerProcess.hs +0/−122
• src/Hercules/Agent/Binary.hs +23/−0
• src/Hercules/Agent/NixFile.hs +208/−22
• src/Hercules/Agent/NixFile/CiNixArgs.hs +15/−0
• src/Hercules/Agent/NixFile/GitSource.hs +31/−0
• src/Hercules/Agent/NixFile/HerculesCIArgs.hs +46/−0
• src/Hercules/Agent/NixPath.hs +27/−0
• src/Hercules/Agent/Producer.hs +2/−2
• src/Hercules/Agent/Sensitive.hs +0/−1
• src/Hercules/Agent/Socket.hs +16/−15
• src/Hercules/Agent/WorkerProcess.hs +124/−0
• src/Hercules/Agent/WorkerProtocol/Command/Effect.hs +3/−1
• src/Hercules/Agent/WorkerProtocol/Command/Eval.hs +11/−1
• src/Hercules/Agent/WorkerProtocol/Command/StartDaemon.hs +11/−0
• src/Hercules/Agent/WorkerProtocol/Event.hs +19/−1
• src/Hercules/Agent/WorkerProtocol/Event/DaemonStarted.hs +10/−0
• src/Hercules/Agent/WorkerProtocol/LogSettings.hs +0/−2
• src/Hercules/Agent/WorkerProtocol/Orphans.hs +15/−3
• src/Hercules/Effect.hs +111/−37
• src/Hercules/Secrets.hs +100/−0
• src/Hercules/UserException.hs +16/−0
• test/Hercules/Agent/WorkerProcessSpec.hs +2/−2
• test/Hercules/SecretsSpec.hs +115/−0
• test/Spec.hs +2/−0

@@ -5,6 +5,45 @@ 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.9.0] - 2022-03-15++This release comes with an [Upgrade Guide! ✨](https://docs.hercules-ci.com/hercules-ci/guides/upgrade-to-agent-0.9/)++### Added++ - Flakes support!++   Instead of needing a `ci.nix`, the agent will pick up `flake.nix` and look+   for the [`herculesCI`](https://docs.hercules-ci.com/hercules-ci-agent/evaluation/#_herculesci_value) attribute in the flake.++   Only the `outputs.effects` sub-attributes may define effects, making attacks on secrets harder to conceal.++ - Multiple jobs per commit++ - Jobs that run with the latest successful dependency build++ - Conditions on secrets, disallowing access to secrets except when the conditions are met. This enforces the four eyes principle when branch protection is set up to match the secrets' conditions.+   A missing `condition` field does not give a great error message for security reasons, so follow the [upgrade guide](https://docs.hercules-ci.com/hercules-ci/guides/upgrade-to-agent-0.9/).++ - Hardening against rogue contributors. Trivial attacks trying to read system paths or secrets are no longer possible. Similar to typical CIs, secrets _can_ be stolen under specific circumstances: either a misconfiguration of branch protection or by approval of a second maintainer. Note that issue was already largely addressed by only processing contributions from GitHub users with write access to the repository, which also still applies.++ - Built-in support for fetching private repositories and tarballs.++### Changed++ - File lookup order has changed, to support flakes. `ci.nix` or `nix/ci.nix` still take top priority, followed by `flake.nix`, followed by `default.nix`.++ - Installed private repositories can now be read by a collaborator. If you need to enforce confidentiality across repositories, contact us and use a personal access token with appropriate permissions in the meanwhile.++### Fixed++ - When the root of a `ci.nix` is a list, an error message is returned.++### Removed++ - Nix 2.3 support+ ## [0.8.7] - 2022-03-09  ### Added@@ -495,6 +534,7 @@  - Initial release +[0.9.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.8.7...hercules-ci-agent-0.9.0 [0.8.7]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.8.6...hercules-ci-agent-0.8.7 [0.8.6]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.8.5...hercules-ci-agent-0.8.6 [0.8.5]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.8.4...hercules-ci-agent-0.8.5

@@ -21,14 +21,12 @@   })); } -#ifdef NIX_2_4 // TODO structured void HerculesLogger::logEI(const nix::ErrorInfo & ei) {   std::stringstream oss;   showErrorInfo(oss, ei, false);   log(ei.level, oss.str()); }-#endif  void HerculesLogger::startActivity(nix::ActivityId act, nix::Verbosity lvl, nix::ActivityType type,     const std::string & s, const Fields & fields, nix::ActivityId parent) {

@@ -1,11 +1,7 @@ #pragma once  #include <nix/config.h>--#ifdef NIX_2_4 #include <nix/error.hh>-#endif- #include <nix/shared.hh> #include <nix/sync.hh> #include <nix/logging.hh>@@ -50,10 +46,7 @@       const std::string & s, const Fields & fields, nix::ActivityId parent) override;   void stopActivity(nix::ActivityId act) override;   void result(nix::ActivityId act, nix::ResultType type, const Fields & fields) override;--#ifdef NIX_2_4   void logEI(const nix::ErrorInfo &ei) override;-#endif    std::unique_ptr<LogEntry> pop();   void popMany(int max, std::queue<std::unique_ptr<LogEntry>> &out);

@@ -1,276 +0,0 @@-#include <cstdio>-#include <cstring>-#include <math.h>-#include <nix/config.h>-#include <nix/shared.hh>-#include <nix/store-api.hh>-#include <nix/common-eval-args.hh>-#include <nix/get-drvs.hh>-#include <nix/derivations.hh>-#include <nix/globals.hh>--#include "hercules-store.hh"--using namespace nix;--WrappingStore::WrappingStore(const Params& params, ref<Store> storeToWrap)-    : Store(params), wrappedStore(storeToWrap) {}--WrappingStore::~WrappingStore() {}--std::string WrappingStore::getUri() {-  return "wrapped:" + wrappedStore->getUri();-};--bool WrappingStore::isValidPathUncached(const Path& path) {-  return wrappedStore->isValidPath(path);  // not ideal-}--PathSet WrappingStore::queryValidPaths(const PathSet& paths,-                                       SubstituteFlag maybeSubstitute) {-  return wrappedStore->queryValidPaths(paths, maybeSubstitute);-}-PathSet WrappingStore::queryAllValidPaths() {-  return wrappedStore->queryAllValidPaths();-}--// protected:-void WrappingStore::queryPathInfoUncached(-    const Path& path,-    Callback<std::shared_ptr<ValidPathInfo>> callback) noexcept {-  unsupported("queryPathInfoUncached");-  /*-      Callback<ref<ValidPathInfo>>-     callback2([&callback](std::future<ref<ValidPathInfo>> vpi){-        std::shared_ptr<ValidPathInfo> !@#$%^&*-        callback(vpi);-      });-      return wrappedStore->queryPathInfo(path, callback2); // not ideal-  */-}--// public:--void WrappingStore::queryReferrers(const Path& path, PathSet& referrers) {-  wrappedStore->queryReferrers(path, referrers);-}--PathSet WrappingStore::queryValidDerivers(const Path& path) {-  return wrappedStore->queryValidDerivers(path);-}--PathSet WrappingStore::queryDerivationOutputs(const Path& path) {-  return wrappedStore->queryDerivationOutputs(path);-}--StringSet WrappingStore::queryDerivationOutputNames(const Path& path) {-  return wrappedStore->queryDerivationOutputNames(path);-}--Path WrappingStore::queryPathFromHashPart(const string& hashPart) {-  return wrappedStore->queryPathFromHashPart(hashPart);-}--PathSet WrappingStore::querySubstitutablePaths(const PathSet& paths) {-  return wrappedStore->querySubstitutablePaths(paths);-}--void WrappingStore::querySubstitutablePathInfos(const PathSet& paths,-                                                SubstitutablePathInfos& infos) {-  wrappedStore->querySubstitutablePathInfos(paths, infos);-}--bool WrappingStore::wantMassQuery() {-  return wrappedStore->wantMassQuery();-}--void WrappingStore::addToStore(const ValidPathInfo& info,-                               Source& narSource,-                               RepairFlag repair,-                               CheckSigsFlag checkSigs,-                               std::shared_ptr<FSAccessor> accessor) {-  wrappedStore->addToStore(info, narSource, repair, checkSigs, accessor);-}--void WrappingStore::addToStore(const ValidPathInfo& info,-                               const ref<std::string>& nar,-                               RepairFlag repair,-                               CheckSigsFlag checkSigs,-                               std::shared_ptr<FSAccessor> accessor) {-  wrappedStore->addToStore(info, nar, repair, checkSigs, accessor);-}--Path WrappingStore::addToStore(const string& name,-                               const Path& srcPath,-                               bool recursive,-                               HashType hashAlgo,-                               PathFilter& filter,-                               RepairFlag repair) {-  return wrappedStore->addToStore(name, srcPath, recursive, hashAlgo, filter,-                                  repair);-}--Path WrappingStore::addTextToStore(const string& name,-                                   const string& s,-                                   const PathSet& references,-                                   RepairFlag repair) {-  return wrappedStore->addTextToStore(name, s, references, repair);-}--void WrappingStore::narFromPath(const Path& path, Sink& sink) {-  wrappedStore->narFromPath(path, sink);-}--void WrappingStore::buildPaths(const PathSet& paths, BuildMode buildMode) {-  wrappedStore->buildPaths(paths, buildMode);-}--BuildResult WrappingStore::buildDerivation(const Path& drvPath,-                                           const BasicDerivation& drv,-                                           BuildMode buildMode) {-  return wrappedStore->buildDerivation(drvPath, drv, buildMode);-}--void WrappingStore::ensurePath(const Path& path) {-  wrappedStore->ensurePath(path);-}--void WrappingStore::addTempRoot(const Path& path) {-  wrappedStore->addTempRoot(path);-}--void WrappingStore::addIndirectRoot(const Path& path) {-  wrappedStore->addIndirectRoot(path);-}--void WrappingStore::syncWithGC() {-  wrappedStore->syncWithGC();-}--void WrappingStore::collectGarbage(const GCOptions& options,-                                   GCResults& results) {-  wrappedStore->collectGarbage(options, results);-}--void WrappingStore::optimiseStore() {-  wrappedStore->optimiseStore();-};--bool WrappingStore::verifyStore(bool checkContents, RepairFlag repair) {-  return wrappedStore->verifyStore(checkContents, repair);-};--ref<FSAccessor> WrappingStore::getFSAccessor() {-  return wrappedStore->getFSAccessor();-}--void WrappingStore::addSignatures(const Path& storePath,-                                  const StringSet& sigs) {-  wrappedStore->addSignatures(storePath, sigs);-};--void WrappingStore::computeFSClosure(const PathSet& paths,-                                     PathSet& out,-                                     bool flipDirection,-                                     bool includeOutputs,-                                     bool includeDerivers) {-  wrappedStore->computeFSClosure(paths, out, flipDirection, includeOutputs,-                                 includeDerivers);-}--void WrappingStore::queryMissing(const PathSet& targets,-                                 PathSet& willBuild,-                                 PathSet& willSubstitute,-                                 PathSet& unknown,-                                 unsigned long long& downloadSize,-                                 unsigned long long& narSize) {-  wrappedStore->queryMissing(targets, willBuild, willSubstitute, unknown,-                             downloadSize, narSize);-}--std::shared_ptr<std::string> WrappingStore::getBuildLog(const Path& path) {-  return wrappedStore->getBuildLog(path);-}--void WrappingStore::connect() {-  wrappedStore->connect();-};--int WrappingStore::getPriority() {-  return wrappedStore->getPriority();-}--Path WrappingStore::toRealPath(const Path& storePath) {-  return wrappedStore->toRealPath(storePath);-};--/////--HerculesStore::HerculesStore(const Params& params, ref<Store> storeToWrap)-    : WrappingStore(params, storeToWrap) {}--void HerculesStore::ensurePath(const Path& path) {-  /* We avoid asking substituters for paths, since-     those would yield negative pathInfo caches on remote store.--     Instead, we only assert if path exists in the store.--     Once IFD build is performed, we ask for substitution-     via ensurePath.-  */-  if (!wrappedStore->isValidPath(path)) {-    std::exception_ptr exceptionToThrow(nullptr);-    auto pathWO = nix::parsePathWithOutputs(*this, path);-    auto pathsPtr = new std::vector<StorePathWithOutputs>{pathWO};-    // TODO place outside the loop-    builderCallback(pathsPtr, &exceptionToThrow);-    if (exceptionToThrow != nullptr) {-      std::rethrow_exception(exceptionToThrow);-    }-    wrappedStore->ensurePath(path);-  }-  ensuredPaths.insert(path);-};--// Avoid substituting in evaluator, see `ensurePath` for more details-void HerculesStore::queryMissing(const PathSet& targets,-                                 PathSet& willBuild,-                                 PathSet& willSubstitute,-                                 PathSet& unknown,-                                 unsigned long long& downloadSize,-                                 unsigned long long& narSize) {-};--void HerculesStore::buildPaths(const PathSet& paths, BuildMode buildMode) {-  for (Path path : paths) {-    std::exception_ptr exceptionToThrow(nullptr);-    auto pathWO = nix::parsePathWithOutputs(*this, path);-    auto pathsPtr = new std::vector<StorePathWithOutputs>{pathWO};-    // TODO place outside the loop-    builderCallback(pathsPtr, &exceptionToThrow);-    if (exceptionToThrow != nullptr) {-      std::rethrow_exception(exceptionToThrow);-    }-  }-}--BuildResult HerculesStore::buildDerivation(const Path& drvPath,-                                           const BasicDerivation& drv,-                                           BuildMode buildMode) {-  unsupported("buildDerivation");--  std::cerr << "building derivation " << drvPath << std::endl;-  auto r = wrappedStore->buildDerivation(drvPath, drv, buildMode);-  std::cerr << "built derivation " << drvPath << std::endl;-  return r;-}--void HerculesStore::printDiagnostics() {-  for (std::string path : ensuredPaths) {-    std::cerr << path << std::endl;-  }-}--void HerculesStore::setBuilderCallback(void (* newBuilderCallback)(std::vector<nix::StorePathWithOutputs>*, std::exception_ptr *exceptionToThrow)) {-  builderCallback = newBuilderCallback;-}

@@ -1,150 +0,0 @@-#include <cstdio>-#include <cstring>-#include <math.h>-#include <nix/config.h>-#include <nix/shared.hh>-#include <nix/store-api.hh>-#include <nix/common-eval-args.hh>-#include <nix/get-drvs.hh>-#include <nix/derivations.hh>-#include <nix/globals.hh>-#include <nix-compat.hh>-#include "HsFFI.h"--using namespace nix;--class WrappingStore : public Store {- public:-  ref<Store> wrappedStore;--  WrappingStore(const Params & params, ref<Store> storeToWrap);---  virtual ~WrappingStore();--  virtual std::string getUri() override;--protected:--  virtual bool isValidPathUncached(const Path & path) override;--public:--  virtual PathSet queryValidPaths(const PathSet & paths,-      SubstituteFlag maybeSubstitute = NoSubstitute) override;-  virtual PathSet queryAllValidPaths() override;--protected:-  virtual void queryPathInfoUncached(const Path & path,-        Callback<std::shared_ptr<ValidPathInfo>> callback) noexcept override;--public:--  virtual void queryReferrers(const Path & path,-      PathSet & referrers) override;--  virtual PathSet queryValidDerivers(const Path & path) override;--  virtual PathSet queryDerivationOutputs(const Path & path) override;--  virtual StringSet queryDerivationOutputNames(const Path & path) override;--  virtual Path queryPathFromHashPart(const string & hashPart) override;--  virtual PathSet querySubstitutablePaths(const PathSet & paths) override;--  virtual void querySubstitutablePathInfos(const PathSet & paths,-        SubstitutablePathInfos & infos) override;--  virtual bool wantMassQuery() override;--  virtual void addToStore(const ValidPathInfo & info, Source & narSource,-        RepairFlag repair = NoRepair, CheckSigsFlag checkSigs = CheckSigs,-        std::shared_ptr<FSAccessor> accessor = 0) override;--  virtual void addToStore(const ValidPathInfo & info, const ref<std::string> & nar,-        RepairFlag repair = NoRepair, CheckSigsFlag checkSigs = CheckSigs,-        std::shared_ptr<FSAccessor> accessor = 0) override;--  virtual Path addToStore(const string & name, const Path & srcPath,-        bool recursive = true, HashType hashAlgo = htSHA256,-        PathFilter & filter = defaultPathFilter, RepairFlag repair = NoRepair) override;--  virtual Path addTextToStore(const string & name, const string & s,-        const PathSet & references, RepairFlag repair = NoRepair) override;--  virtual void narFromPath(const Path & path, Sink & sink) override;--  virtual void buildPaths(const PathSet & paths, BuildMode buildMode = bmNormal) override;--  virtual BuildResult buildDerivation(const Path & drvPath, const BasicDerivation & drv,-        BuildMode buildMode = bmNormal) override;--  virtual void ensurePath(const Path & path) override;--  virtual void addTempRoot(const Path & path) override;--  virtual void addIndirectRoot(const Path & path) override;--  virtual void syncWithGC() override;--  virtual void collectGarbage(const GCOptions & options, GCResults & results) override;--  virtual void optimiseStore() override;--  virtual bool verifyStore(bool checkContents, RepairFlag repair = NoRepair) override;--  virtual ref<FSAccessor> getFSAccessor() override;--  virtual void addSignatures(const Path & storePath, const StringSet & sigs) override;--    -  virtual void computeFSClosure(const PathSet & paths,-      PathSet & out, bool flipDirection = false,-      bool includeOutputs = false, bool includeDerivers = false) override;--  virtual void queryMissing(const PathSet & targets,-        PathSet & willBuild, PathSet & willSubstitute, PathSet & unknown,-        unsigned long long & downloadSize, unsigned long long & narSize) override;--  virtual std::shared_ptr<std::string> getBuildLog(const Path & path) override;--  virtual void connect() override;--  virtual int getPriority() override;--  virtual Path toRealPath(const Path & storePath) override;-};--class HerculesStore : public WrappingStore {-public:-  PathSet ensuredPaths;-  void (* builderCallback)(std::vector<nix::StorePathWithOutputs>*, std::exception_ptr *exceptionToThrow);--  HerculesStore(const Params & params, ref<Store> storeToWrap);--  // Overrides--  virtual void ensurePath(const Path & path) override;--  virtual void buildPaths(const PathSet & paths, BuildMode buildMode = bmNormal) override;--  virtual BuildResult buildDerivation(const Path & drvPath, const BasicDerivation & drv,-        BuildMode buildMode = bmNormal) override;--  virtual void queryMissing(const PathSet& targets,-                            PathSet& willBuild,-                            PathSet& willSubstitute,-                            PathSet& unknown,-                            unsigned long long& downloadSize,-                            unsigned long long& narSize) override;--  // Additions--  void printDiagnostics();--  void setBuilderCallback(void (* newBuilderCallback)(std::vector<nix::StorePathWithOutputs>*, std::exception_ptr *exceptionToThrow));--  void inhibitBuilds();-  void uninhibitBuilds();-};

@@ -14,6 +14,7 @@ #include <nix/build-result.hh> #include <nix/gc-store.hh> #endif+#include <nix/path-with-outputs.hh>  #include "hercules-store.hh" 

@@ -8,7 +8,6 @@ #include <nix/get-drvs.hh> #include <nix/derivations.hh> #include <nix/globals.hh>-#include <nix-compat.hh> #include "HsFFI.h"  using namespace nix;

@@ -0,0 +1,155 @@+/*+  Helper functions for working with flakes.++  Schema: DefaultHerculesCIHelperSchema+*/+let+  inherit (builtins)+    attrNames+    concatMap+    hasAttr+    intersectAttrs+    listToAttrs+    mapAttrs+    ;++  # lib+  nameValuePair = k: v: { name = k; value = v; };+  filterAttrs = pred: set:+    listToAttrs (+      concatMap+        (name: let v = set.${name}; in if pred name v then [ (nameValuePair name v) ] else [ ])+        (attrNames set)+    );+  optionalAttrs = b: if b then a: a else _: { };+  optionalCall = f: a: if builtins.isFunction f then f a else f;+  # end lib++  # flake -> evalArgs -> { flake | herculesCI }+  addDefaults = flake: evalArgs:+    let+      args = evalArgs // {+        ciSystems =+          if flake?herculesCI.ciSystems+          then listToAttrs (map (sys: nameValuePair sys { }) flake.herculesCI.ciSystems)+          else args.herculesCI.ciSystems;+      };+      herculesCI = optionalCall (flake.herculesCI or { }) evalArgs;+    in+    herculesCI // optionalAttrs (!herculesCI?onPush) {+      onPush.default = {+        outputs = flakeToOutputs flake args;+      };+    };++  flakeToOutputs = flake: args: mapAttrs (translateFlakeAttr args) flake.outputs;++  filterSystems = ciSystems:+    if ciSystems == null+    then attrs: attrs+    else intersectAttrs ciSystems;++  isEnabledSystemConfig = ciSystems:+    if ciSystems == null+    then sys: true+    else+      sys:+      hasAttr sys.config.nixpkgs.localSystem.system ciSystems+      || hasAttr sys.config.nixpkgs.system ciSystems;++  filterSystemConfigs = ciSystems: filterAttrs (k: v:+    if isEnabledSystemConfig ciSystems v+    then true+    else builtins.trace "Ignoring flake attribute ${k} (system not in ciSystems)" false);++  translateFlakeAttr = args: k: v:+    if translations?${k}+    then translations.${k} args v+    else if deprecated?${k}+    then builtins.trace "Ignoring flake attribute ${k} (deprecated)" null+    else builtins.trace "Ignoring flake attribute ${k}" null;++  deprecated = {+    defaultApp = null;+    defaultPackage = null;+    defaultTemplate = null;+    defaultBundler = null;+    overlay = null;+    # too soon?+    # devShell = null;+  };++  checkApp = app:+    if app.type != "app"+    then throw "App type attribute must be set to \"app\"."+    else if builtins.typeOf app.program == "string"+    then {+      program = validateProgramFromStringContext app.program;+    }+    else {+      inherit (app) program;+    };++  validateProgramFromStringContext = s:+    let+      ctx = builtins.getContext s;+      drvs = builtins.attrNames ctx;+      drvPath =+        if drvs == [ ]+        then throw "The provided program string does not have a package in its context. Please set the app's program attribute to a package with `meta.mainProgram` or to a string of the form \"\${pkg}/bin/command\", where `pkg` is a package."+        else if builtins.length drvs != 1+        then throw "The provided program string has multiple packages in its context. Please set the app's program attribute to a single package with `meta.mainProgram` or to a string of the form \"\${pkg}/bin/command\", where `pkg` is a single package."+        else builtins.head drvs;+      basename = baseNameOf drvPath;+      hashLength = 33;+      l = builtins.stringLength basename;+    in+    {+      name = builtins.substring hashLength (l - hashLength - 4) basename;+      type = "derivation";+      drvPath = drvPath;+    };++  translateShell = drv:+    if drv.type or null != "derivation"+    then throw "Attribute is not a shell derivation"+    else drv // { buildDependenciesOnly = true; };++  translations =+    let+      ignore = args: x: null;+      same = args: x: x;+      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);+      devShell = forSystems (sys: translateShell);+      devShells = forSystems (sys: mapAttrs (k: translateShell));+      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);+      effects = args: effects:+        if builtins.isAttrs effects+        then effects+        else effects args;++      # not buildable+      herculesCI = ignore;+      overlays = ignore;+      submodules = ignore;+      nixosModules = ignore;+      darwinModules = ignore;+      legacyPackages = ignore;++    };++in+{+  inherit+    addDefaults+    ;+}

@@ -2,6 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Hercules.Agent.Worker   ( main,@@ -9,11 +12,13 @@ where  import Conduit-import Control.Concurrent.STM+import Control.Concurrent.STM hiding (check) import qualified Control.Exception.Lifted as EL import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Control+import Data.ByteString.Unsafe (unsafePackMallocCString)+import Data.Coerce (coerce) import qualified Data.Conduit import Data.Conduit.Extras (sinkChan, sinkChanTerminate, sourceChan) import Data.Conduit.Katip.Orphans ()@@ -27,12 +32,20 @@ import Data.UUID (UUID) import Data.Vector (Vector) import qualified Data.Vector as V+import Hercules.API.Agent.Evaluate.EvaluateEvent.OnPushHandlerEvent (OnPushHandlerEvent (OnPushHandlerEvent))+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.OnPushHandlerEvent+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import qualified Hercules.API.Agent.Evaluate.ImmutableGitInput as API.ImmutableGitInput+import qualified Hercules.API.Agent.Evaluate.ImmutableInput as API.ImmutableInput 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.NixFile (HerculesCISchema, getHerculesCI, homeExprRawValue, loadNixFile, parseExtraInputs)+import Hercules.Agent.NixFile.HerculesCIArgs (CISystems (CISystems), HerculesCIMeta (HerculesCIMeta), fromGitSource)+import qualified Hercules.Agent.NixFile.HerculesCIArgs import Hercules.Agent.Sensitive import qualified Hercules.Agent.Socket as Socket import Hercules.Agent.Worker.Build (runBuild)@@ -40,6 +53,8 @@ import Hercules.Agent.Worker.Effect (runEffect) import Hercules.Agent.Worker.HerculesStore (nixStore, setBuilderCallback, withHerculesStore) import Hercules.Agent.Worker.HerculesStore.Context (HerculesStore)+import Hercules.Agent.Worker.Logging (withKatip)+import Hercules.Agent.Worker.NixDaemon (nixDaemon) import Hercules.Agent.WorkerProtocol.Command   ( Command,   )@@ -53,28 +68,32 @@ import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval import Hercules.Agent.WorkerProtocol.Event   ( Event (Exception),+    ViaJSON (ViaJSON),   ) 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.LogSettings as LogSettings import Hercules.CNix as CNix-import Hercules.CNix.Expr (Match (IsAttrs, IsString), NixAttrs, RawValue, autoCallFunction, evalArgs, evalFile, getAttrBool, getAttrList, getAttrs, getDrvFile, getRecurseForDerivations, getStringIgnoreContext, init, isDerivation, isFunctor, match, rawValueType, withEvalStateConduit)+import Hercules.CNix.Expr (Match (IsAttrs, IsString), NixAttrs, RawValue, addAllowedPath, addInternalAllowedPaths, autoCallFunction, evalArgs, getAttrBool, getAttrList, getAttrs, getDrvFile, getFlakeFromArchiveUrl, getFlakeFromGit, getRecurseForDerivations, getStringIgnoreContext, init, isDerivation, isFunctor, match, rawValueType, rtValue, toRawValue, withEvalStateConduit) import Hercules.CNix.Expr.Context (EvalState) import qualified Hercules.CNix.Expr.Raw+import Hercules.CNix.Expr.Schema (MonadEval, PSObject, dictionaryToMap, fromPSObject, requireDict, (#.), (#?), (#?!), ($?))+import qualified Hercules.CNix.Expr.Schema as Schema import Hercules.CNix.Expr.Typed (Value) import Hercules.CNix.Std.Vector (StdVector) import qualified Hercules.CNix.Std.Vector as Std.Vector import Hercules.CNix.Store.Context (NixStorePathWithOutputs) import Hercules.CNix.Util (installDefaultSigINTHandler) import Hercules.Error+import Hercules.UserException (UserException (UserException)) import Katip-import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exception as C import qualified Network.URI-import Protolude hiding (bracket, catch, evalState, wait, withAsync, yield)+import Protolude hiding (bracket, catch, check, evalState, wait, withAsync, yield) import qualified System.Environment as Environment import System.IO (BufferMode (LineBuffering), hSetBuffering)-import System.Posix.IO (dup, fdToHandle, stdError) import System.Posix.Signals (Handler (Catch), installHandler, raiseSignal, sigINT, sigTERM) import System.Timeout (timeout) import UnliftIO.Async (wait, withAsync)@@ -82,12 +101,19 @@ import Prelude () import qualified Prelude +C.context (C.cppCtx <> C.fptrCtx)++C.include "<nix/error.hh>"+C.include "<iostream>"+C.include "<sstream>"+ data HerculesState = HerculesState   { drvsCompleted :: TVar (Map StorePath (UUID, BuildResult.BuildStatus)),     drvsInProgress :: IORef (Set StorePath),     herculesStore :: Ptr (Ref HerculesStore),     wrappedStore :: Store,-    shortcutChannel :: Chan (Maybe Event)+    shortcutChannel :: Chan (Maybe Event),+    extraNixOptions :: [(Text, Text)]   }  data BuildException = BuildException@@ -105,19 +131,35 @@   _ <- installHandler sigTERM (Catch $ raiseSignal sigINT) Nothing   installDefaultSigINTHandler   Logger.initLogger-  [options] <- Environment.getArgs-  let allOptions =-        Prelude.read options-          ++ [-               -- narinfo-cache-negative-ttl: Always try requesting narinfos because it may have been built in the meanwhile-               ("narinfo-cache-negative-ttl", "0"),-               -- Build concurrency is controlled by hercules-ci-agent, so set it-               -- to 1 to avoid accidentally consuming too many resources at once.-               ("max-jobs", "1")-             ]-  for_ allOptions $ \(k, v) -> do+  args <- Environment.getArgs+  case args of+    ["nix-daemon", options] -> do+      setOptions options+      nixDaemon+    [options] -> taskWorker options+    _ -> throwIO $ FatalError "worker: Unrecognized command line arguments"++-- TODO Make this part of the worker protocol instead+parseOptions :: (Read a, Read b, IsString a, IsString b) => Prelude.String -> [(a, b)]+parseOptions options =+  Prelude.read options+    ++ [+         -- narinfo-cache-negative-ttl: Always try requesting narinfos because it may have been built in the meanwhile+         ("narinfo-cache-negative-ttl", "0"),+         -- Build concurrency is controlled by hercules-ci-agent, so set it+         -- to 1 to avoid accidentally consuming too many resources at once.+         ("max-jobs", "1")+       ]++setOptions :: [Char] -> IO ()+setOptions options = do+  for_ (parseOptions options) $ \(k, v) -> do     setGlobalOption k v     setOption k v++taskWorker :: [Char] -> IO ()+taskWorker options = do+  setOptions options   drvsCompleted_ <- newTVarIO mempty   drvsInProgress_ <- newIORef mempty   withStore $ \wrappedStore_ -> withHerculesStore wrappedStore_ $ \herculesStore_ -> withKatip $ do@@ -129,7 +171,8 @@               drvsInProgress = drvsInProgress_,               herculesStore = herculesStore_,               wrappedStore = wrappedStore_,-              shortcutChannel = ch+              shortcutChannel = ch,+              extraNixOptions = parseOptions options             }     let runner :: KatipContextT IO ()         runner =@@ -147,7 +190,8 @@                 runCommand st ch command             )               `safeLiftedCatch` ( \e -> liftIO $ do-                                    writeChan ch (Just $ Exception (renderException (e :: SomeException)))+                                    e' <- renderException e+                                    writeChan ch (Just $ Exception e')                                     exitFailure                                 )           )@@ -177,14 +221,38 @@         pure x     ) -renderException :: SomeException -> Text-renderException e | Just (C.CppStdException msg) <- fromException e = toS msg+renderException :: SomeException -> IO Text+renderException e | Just (C.CppStdException ex _msg _ty) <- fromException e = renderStdException ex renderException e-  | Just (C.CppOtherException maybeType) <- fromException e =-    "Unexpected C++ exception" <> foldMap (\t -> " of type " <> toS t) maybeType-renderException e | Just (FatalError msg) <- fromException e = msg-renderException e = toS $ displayException e+  | Just (C.CppNonStdException _ex maybeType) <- fromException e =+    pure $ "Unexpected C++ exception" <> foldMap (\t -> " of type " <> decodeUtf8With lenientDecode t) maybeType+renderException e | Just (FatalError msg) <- fromException e = pure msg+renderException e = pure $ toS $ displayException e +renderStdException :: C.CppExceptionPtr -> IO Text+renderStdException e =+  [C.throwBlock| char * {+    std::string r;+    std::exception_ptr *e = $fptr-ptr:(std::exception_ptr *e);+    try {+      std::rethrow_exception(*e);+    } catch (const nix::Error &e) {+      // r = e.what();+      std::stringstream s;+      nix::showErrorInfo(s, e.info(), true);+      r = s.str();+    } catch (const std::exception &e) {+      r = e.what();+    } catch (...) {+      // shouldn't happen because inline-c-cpp only put std::exception in CppStdException+      throw std::runtime_error("renderStdException: Attempt to render unknown exception.");+    }++    return strdup(r.c_str());+  }|]+    >>= unsafePackMallocCString+    <&> decodeUtf8With lenientDecode+ connectCommand ::   (MonadUnliftIO m, KatipContext m, MonadThrow m) =>   Chan (Maybe Event) ->@@ -211,6 +279,7 @@     Command.Eval eval -> Logger.withLoggerConduit (logger (Eval.logSettings eval) protocolVersion) $       Logger.withTappedStderr Logger.tapper $         connectCommand ch $ do+          liftIO $ restrictEval eval           void $             liftIO $               flip@@ -220,7 +289,7 @@                   runConduitRes                     ( Data.Conduit.handleC                         ( \e -> do-                            yield $ Event.Error (renderException e)+                            yield . Event.Error =<< liftIO (renderException e)                             liftIO $ throwTo mainThread e                         )                         ( do@@ -248,12 +317,23 @@         Logger.withLoggerConduit (logger (Effect.logSettings effect) protocolVersion) $           Logger.withTappedStderr Logger.tapper $             connectCommand ch $ do-              runEffect (wrappedStore herculesState) effect >>= \case+              runEffect (extraNixOptions herculesState) (wrappedStore herculesState) effect >>= \case                 ExitSuccess -> yield $ Event.EffectResult 0                 ExitFailure n -> yield $ Event.EffectResult n     _ ->       panic "Not a valid starting command" +restrictEval :: Eval -> IO ()+restrictEval eval = do+  setGlobalOption "restrict-eval" "true"+  setGlobalOption "allowed-uris" $+    if Eval.allowInsecureBuiltinFetchers eval+      then allSchemes+      else safeSchemes+  where+    safeSchemes = "ssh:// https://"+    allSchemes = safeSchemes <> " http:// git://"+ 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@@ -311,21 +391,6 @@           yield a           go (b <> f a) -withKatip :: (MonadUnliftIO m) => KatipContextT m a -> m a-withKatip m = do-  let format :: forall a. LogItem a => ItemFormatter a-      format = (\_ _ _ -> "@katip ") <> jsonFormat-  -- 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.-      -- closeScribes will stop accepting new logs, flush existing ones and clean up resources-  bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \logEnv ->-    runKatipContextT logEnv initialContext extraNs m- makeSocketConfig :: MonadIO m => LogSettings.LogSettings -> Int -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m) makeSocketConfig l storeProtocolVersionValue = do   clientProtocolVersionValue <- liftIO getClientProtocolVersion@@ -374,7 +439,7 @@ anyAlternative :: (Foldable l, Alternative f) => l a -> f a anyAlternative = getAlt . foldMap (Alt . pure) -yieldAttributeError :: Monad m => [ByteString] -> SomeException -> ConduitT i Event m ()+yieldAttributeError :: MonadIO m => [ByteString] -> SomeException -> ConduitT i Event m () yieldAttributeError path e   | (Just e') <- fromException e =     yield $@@ -388,12 +453,13 @@             AttributeError.errorDerivation = Just (buildExceptionDerivationPath e'),             AttributeError.errorType = Just "BuildException"           }-yieldAttributeError path e =+yieldAttributeError path e = do+  e' <- liftIO $ renderException e   yield $     Event.AttributeError $       AttributeError.AttributeError         { AttributeError.path = path,-          AttributeError.message = renderException e,+          AttributeError.message = e',           AttributeError.errorDerivation = Nothing,           AttributeError.errorType = Just (show (typeOf e))         }@@ -407,7 +473,7 @@  runEval ::   forall i m.-  (MonadResource m, KatipContext m, MonadUnliftIO m) =>+  (MonadResource m, KatipContext m, MonadUnliftIO m, MonadThrow m) =>   HerculesState ->   Eval ->   ConduitM i Event m ()@@ -480,6 +546,9 @@                           )             logLocM DebugS "Built"   withEvalStateConduit store $ \evalState -> do+    liftIO do+      addInternalAllowedPaths evalState+      for_ (Eval.allowedPaths eval) (addAllowedPath evalState)     katipAddContext (sl "storeURI" (decode s)) $       logLocM DebugS "EvalState loaded."     args <-@@ -487,16 +556,123 @@         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 store evalState args applied+        homeExpr <- escalateAs UserException =<< liftIO (loadNixFile evalState (toS $ Eval.cwd eval) (coerce $ Eval.gitSource eval))+        let hargs = fromGitSource (coerce $ Eval.gitSource eval) meta+            meta = HerculesCIMeta {apiBaseUrl = Eval.apiBaseUrl eval, ciSystems = CISystems (Eval.ciSystems eval)}+        liftIO (flip runReaderT evalState $ getHerculesCI homeExpr hargs) >>= \case+          Nothing ->+            -- legacy+            walk store evalState args (homeExprRawValue homeExpr)+          Just herculesCI -> do+            case Event.fromViaJSON (Eval.selector eval) of+              EvaluateTask.ConfigOrLegacy -> do+                yield Event.JobConfig+                sendConfig evalState herculesCI+              EvaluateTask.OnPush onPush ->+                transPipe (`runReaderT` evalState) do+                  walkOnPush store evalState onPush herculesCI     yield Event.EvaluationDone +walkOnPush :: (MonadEval m, MonadUnliftIO m, KatipContext m, MonadThrow m) => Store -> Ptr EvalState -> EvaluateTask.OnPush -> PSObject HerculesCISchema -> ConduitT i Event m ()+walkOnPush store evalState onPushParams herculesCI = do+  onPushHandler <- herculesCI #?! #onPush >>= requireDict (EvaluateTask.name onPushParams)+  inputs <- liftIO $ do+    inputs <- for (EvaluateTask.inputs onPushParams) \input -> do+      inputToValue evalState input+    toRawValue evalState inputs+  outputsFun <- onPushHandler #. #outputs+  outputs <- outputsFun $? (Schema.PSObject {value = inputs, provenance = Schema.Data})+  simpleWalk store evalState (Schema.value outputs)++inputToValue :: Ptr EvalState -> API.ImmutableInput.ImmutableInput -> IO RawValue+inputToValue evalState (API.ImmutableInput.ArchiveUrl u) = getFlakeFromArchiveUrl evalState u+inputToValue evalState (API.ImmutableInput.Git g) = mkImmutableGitInputFlakeThunk evalState g++mkImmutableGitInputFlakeThunk :: Ptr EvalState -> API.ImmutableGitInput.ImmutableGitInput -> IO RawValue+mkImmutableGitInputFlakeThunk evalState git = do+  -- TODO: allow picking ssh/http url+  getFlakeFromGit+    evalState+    (API.ImmutableGitInput.httpURL git)+    (API.ImmutableGitInput.ref git)+    (API.ImmutableGitInput.rev git)++sendConfig :: MonadIO m => Ptr EvalState -> PSObject HerculesCISchema -> ConduitT i Event m ()+sendConfig evalState herculesCI = flip runReaderT evalState $ do+  herculesCI #? #onPush >>= traverse_ \onPushes -> do+    attrs <- dictionaryToMap onPushes+    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 $+        OnPushHandlerEvent+          { handlerName = decodeUtf8 name,+            handlerExtraInputs = M.mapKeys decodeUtf8 (fromMaybe mempty ei)+          }++-- | Documented in @docs/modules/ROOT/pages/evaluation.adoc@.+simpleWalk ::+  (MonadUnliftIO m, KatipContext m) =>+  Store ->+  Ptr EvalState ->+  RawValue ->+  ConduitT i Event m ()+simpleWalk store evalState = walk' [] 10+  where+    handleErrors path = Data.Conduit.handleC (yieldAttributeError path)+    walk' ::+      (MonadUnliftIO m, KatipContext m) =>+      -- Attribute path+      [ByteString] ->+      -- Depth of tree remaining+      Integer ->+      -- Current node of the walk+      RawValue ->+      -- Program that performs the walk and emits 'Event's+      ConduitT i1 Event m ()+    walk' path depthRemaining v =+      handleErrors path $+        liftIO (match evalState v)+          >>= \case+            Left e ->+              yieldAttributeError path e+            Right m -> case m of+              IsAttrs attrValue -> do+                isDeriv <- liftIO $ isDerivation evalState v+                if isDeriv+                  then walkDerivation store evalState False path attrValue+                  else do+                    attrs <- liftIO $ getAttrs attrValue+                    void $+                      flip M.traverseWithKey attrs $+                        \name value ->+                          if depthRemaining > 0+                            then+                              walk'+                                (path ++ [name])+                                (depthRemaining - 1)+                                value+                            else yield (Event.Error $ "Max recursion depth reached at path " <> show path)+              _any -> do+                vt <- liftIO $ rawValueType v+                unless+                  ( lastMay path == Just "recurseForDerivations"+                      && vt == Hercules.CNix.Expr.Raw.Bool+                  )+                  do+                    logLocM DebugS $+                      logStr $+                        "Ignoring "+                          <> show path+                          <> " : "+                          <> (show vt :: Text)+ traverseSPWOs :: (StorePathWithOutputs -> IO ()) -> StdVector NixStorePathWithOutputs -> IO () traverseSPWOs f v = do   v' <- Std.Vector.toListFP v   traverse_ f v' +-- | Documented in @docs/modules/ROOT/pages/legacy-evaluation.adoc@. walk ::   (MonadUnliftIO m, KatipContext m) =>   Store ->@@ -532,48 +708,7 @@               IsAttrs attrValue -> do                 isDeriv <- liftIO $ isDerivation evalState v                 if isDeriv-                  then do-                    drvStorePath <- getDrvFile evalState v-                    drvPath <- liftIO $ CNix.storePathToPath store drvStorePath-                    typE <- runExceptT do-                      isEffect <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "isEffect")-                      case isEffect of-                        Just True -> throwE $ Right Attribute.Effect-                        _ -> pass-                      isDependenciesOnly <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "buildDependenciesOnly")-                      case isDependenciesOnly of-                        Just True -> throwE $ Right Attribute.DependenciesOnly-                        _ -> pass-                      phases <- liftEitherAs Left =<< liftIO (getAttrList evalState attrValue "phases")-                      case phases of-                        Just [aSingularPhase] ->-                          liftIO (match evalState aSingularPhase) >>= liftEitherAs Left >>= \case-                            IsString phaseNameValue -> do-                              phaseName <- liftIO (getStringIgnoreContext phaseNameValue)-                              when (phaseName == "nobuildPhase") do-                                throwE $ Right Attribute.DependenciesOnly-                            _ -> pass-                        _ -> pass-                      mayFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "ignoreFailure")-                      case mayFail of-                        Just True -> throwE $ Right Attribute.MayFail-                        _ -> pass-                      mustFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "requireFailure")-                      case mustFail of-                        Just True -> throwE $ Right Attribute.MustFail-                        _ -> pass-                    let yieldAttribute typ =-                          yield $-                            Event.Attribute-                              Attribute.Attribute-                                { Attribute.path = path,-                                  Attribute.drv = drvPath,-                                  Attribute.typ = typ-                                }-                    case typE of-                      Left (Left e) -> yieldAttributeError path e-                      Left (Right t) -> yieldAttribute t-                      Right _ -> yieldAttribute Attribute.Regular+                  then walkDerivation store evalState True path attrValue                   else do                     walkAttrset <-                       if forceWalkAttrset@@ -615,6 +750,66 @@                         <> " : "                         <> (show vt :: Text)                 pass++-- | Documented in @docs/modules/ROOT/pages/evaluation.adoc@.+walkDerivation ::+  MonadIO m =>+  Store ->+  Ptr EvalState ->+  Bool ->+  [ByteString] ->+  Value NixAttrs ->+  ConduitT i Event m ()+walkDerivation store evalState effectsAnywhere path attrValue = do+  drvStorePath <- getDrvFile evalState (rtValue attrValue)+  drvPath <- liftIO $ CNix.storePathToPath store drvStorePath+  typE <- runExceptT do+    isEffect <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "isEffect")+    case isEffect of+      Just True+        | effectsAnywhere+            || inEffects path ->+          throwE $ Right Attribute.Effect+      Just True | otherwise -> throwE $ Left $ toException $ UserException "This derivation is marked as an effect, but effects are only allowed below the effects attribute."+      _ -> pass+    isDependenciesOnly <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "buildDependenciesOnly")+    case isDependenciesOnly of+      Just True -> throwE $ Right Attribute.DependenciesOnly+      _ -> pass+    phases <- liftEitherAs Left =<< liftIO (getAttrList evalState attrValue "phases")+    case phases of+      Just [aSingularPhase] ->+        liftIO (match evalState aSingularPhase) >>= liftEitherAs Left >>= \case+          IsString phaseNameValue -> do+            phaseName <- liftIO (getStringIgnoreContext phaseNameValue)+            when (phaseName == "nobuildPhase") do+              throwE $ Right Attribute.DependenciesOnly+          _ -> pass+      _ -> pass+    mayFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "ignoreFailure")+    case mayFail of+      Just True -> throwE $ Right Attribute.MayFail+      _ -> pass+    mustFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "requireFailure")+    case mustFail of+      Just True -> throwE $ Right Attribute.MustFail+      _ -> pass+  let yieldAttribute typ =+        yield $+          Event.Attribute+            Attribute.Attribute+              { Attribute.path = path,+                Attribute.drv = drvPath,+                Attribute.typ = typ+              }+  case typE of+    Left (Left e) -> yieldAttributeError path e+    Left (Right t) -> yieldAttribute t+    Right _ -> yieldAttribute Attribute.Regular+  where+    inEffects :: [ByteString] -> Bool+    inEffects ("effects" : _) = True+    inEffects _ = False  liftEitherAs :: MonadError e m => (e0 -> e) -> Either e0 a -> m a liftEitherAs f = liftEither . rmap

@@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -module Hercules.Agent.Worker.Build.Logger where+module Hercules.Agent.Worker.Build.Logger (initLogger, withLoggerConduit, tapper, withTappedStderr, batch, unbatch, filterProgress, nubProgress) where  import Conduit (MonadUnliftIO, filterC) import qualified Data.ByteString.Char8 as BSC@@ -18,7 +18,7 @@ import Hercules.CNix.Store.Context (unsafeMallocBS) import Katip import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Language.C.Inline.Cpp.Exception as C import Protolude hiding (bracket, finally, mask_, onException, tryJust, wait, withAsync, yield) import System.IO (BufferMode (LineBuffering), hSetBuffering) import System.IO.Error (isEOFError)@@ -117,9 +117,6 @@   ) -} -forNonNull_ :: Ptr a -> (Ptr a -> IO ()) -> IO ()-forNonNull_ p f = if p == nullPtr then pass else f p- forNonNull :: Ptr a -> (Ptr a -> IO b) -> IO (Maybe b) forNonNull p f = if p == nullPtr then pure Nothing else Just <$> f p @@ -262,7 +259,9 @@           yield lns           popper --- | Remove spammy progress results. Use 'nubProgress' instead?+-- TODO: Use 'nubProgress' instead?++-- | Remove spammy progress results. filterProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m () filterProgress = filterC \case   Chunk LogEntry.Result {rtype = LogEntry.ResultTypeProgress} -> False

@@ -1,6 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}  -- This implements an optimized routine to build from a remote derivation. -- It is not in the "CNix" tree because it seems to be too specific for general use.@@ -16,7 +16,7 @@ import Hercules.CNix.Encapsulation import Hercules.CNix.Store import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Language.C.Inline.Cpp.Exception as C import Protolude  C.context context@@ -41,7 +41,7 @@ C.include "<nix/build-result.hh>" #endif -C.include "<nix-compat.hh>"+C.include "<nix/path-with-outputs.hh>"  C.include "<hercules-ci-cnix/store.hxx>" @@ -109,7 +109,7 @@        for (nix::ref<nix::Store> & currentStore : stores) {         try {-          derivation = new nix::Derivation(currentStore->derivationFromPath(printPath23(*currentStore, derivationPath)));+          derivation = new nix::Derivation(currentStore->derivationFromPath(derivationPath));           break;         } catch (nix::Interrupted &e) {           throw e;@@ -146,16 +146,12 @@       StorePath derivationPath = *$fptr-ptr:(nix::StorePath *derivationPath);        if ($(bool materializeDerivation)) {-        store.ensurePath(printPath23(store, derivationPath));-#ifdef NIX_2_4+        store.ensurePath(derivationPath);         auto derivation = store.derivationFromPath(derivationPath);         StorePathWithOutputs storePathWithOutputs { .path = derivationPath, .outputs = derivation.outputNames() };         std::vector<nix::StorePathWithOutputs> paths{storePathWithOutputs};-#else-        nix::PathSet paths{printPath23(store, derivationPath)};-#endif         try {-          store.buildPaths(toDerivedPaths24(paths));+          store.buildPaths(toDerivedPaths(paths));           status = -1;           success = true;           errorMessage = strdup("");@@ -177,15 +173,11 @@         std::istringstream stream(extraInputsMerged);          while (std::getline(stream, extraInput)) {-#ifdef NIX_2_4           auto path = store.parseStorePath(extraInput);-#else-          auto path = extraInput;-#endif           derivation->inputSrcs.insert(path);         } -        nix::BuildResult result = store.buildDerivation(printPath23(store, derivationPath), *derivation);+        nix::BuildResult result = store.buildDerivation(derivationPath, *derivation);          switch (result.status) {           case nix::BuildResult::Built:

@@ -16,8 +16,8 @@ import Protolude import UnliftIO.Directory (getCurrentDirectory) -runEffect :: (MonadIO m, KatipContext m, MonadThrow m) => Store -> Command.Effect.Effect -> m ExitCode-runEffect store command = do+runEffect :: (MonadIO m, KatipContext m, MonadThrow m) => [(Text, Text)] -> Store -> Command.Effect.Effect -> m ExitCode+runEffect extraNixOptions store command = do   derivation <- prepareDerivation store command   dir <- getCurrentDirectory   Effect.runEffect@@ -28,7 +28,11 @@         runEffectApiBaseURL = Command.Effect.apiBaseURL command,         runEffectDir = dir,         runEffectProjectId = Just $ Command.Effect.projectId command,-        runEffectProjectPath = Just $ Command.Effect.projectPath command+        runEffectProjectPath = Just $ Command.Effect.projectPath command,+        runEffectSecretContext = Just $ Command.Effect.secretContext command,+        runEffectUseNixDaemonProxy = True,+        runEffectExtraNixOptions = extraNixOptions,+        runEffectFriendly = False       }  prepareDerivation :: MonadIO m => Store -> Command.Effect.Effect -> m Derivation

@@ -25,7 +25,7 @@ import Hercules.CNix.Std.Vector (CStdVector, StdVector) import Hercules.CNix.Store.Context (Ref) import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Language.C.Inline.Cpp.Exception as C import Protolude import Prelude () @@ -44,8 +44,6 @@ C.include "<nix/derivations.hh>"  C.include "<nix/globals.hh>"--C.include "<nix-compat.hh>"  C.include "hercules-aliases.h" 

@@ -0,0 +1,23 @@+module Hercules.Agent.Worker.Logging where++import Katip+import Protolude hiding (bracket)+import System.Posix (fdToHandle, stdError)+import System.Posix.IO (dup)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (bracket)++withKatip :: (MonadUnliftIO m) => KatipContextT m a -> m a+withKatip m = do+  let format :: forall a. LogItem a => ItemFormatter a+      format = (\_ _ _ -> "@katip ") <> jsonFormat+  -- 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.+      -- closeScribes will stop accepting new logs, flush existing ones and clean up resources+  bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \logEnv ->+    runKatipContextT logEnv initialContext extraNs m

@@ -0,0 +1,123 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Hercules.Agent.Worker.NixDaemon where++import Control.Concurrent.STM.TVar (modifyTVar, newTVarIO, readTVar)+import qualified Data.Binary+import qualified Data.Binary.Get+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Hercules.Agent.Binary (decodeBinaryFromHandle)+import qualified Hercules.Agent.WorkerProtocol.Command.StartDaemon as StartDaemon+import Hercules.Agent.WorkerProtocol.Event.DaemonStarted (DaemonStarted (DaemonStarted, _dummy))+import qualified Hercules.CNix as CNix+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exception as C+import Network.Socket+import Protolude+import System.Posix.Internals (setNonBlockingFD)+import UnliftIO (BufferMode (NoBuffering), hSetBuffering, timeout)+import UnliftIO.IO (hFlush)++C.context C.cppCtx++C.include "<nix/config.h>"+C.include "<nix/daemon.hh>"+C.include "<iostream>"+C.using "namespace nix"++nixDaemon :: IO ()+-- nixDaemon = withKatip $ Logger.withLoggerConduit (_) $ Logger.withTappedStderr Logger.tapper $ liftIO $ do+nixDaemon = do+  hSetBuffering stdin NoBuffering+  startCmd <-+    getStdinMessage >>= \case+      Left _ -> throwIO $ FatalError "Could not decode command"+      Right Nothing -> do+        putErrText "warning: Exit before receiving start command"+        exitSuccess -- We're done.+      Right (Just r) -> pure r+  let path = StartDaemon.socketPath startCmd++  CNix.init++  clientThreads <- newTVarIO mempty++  sock <- socket AF_UNIX Stream 0+  bind sock (SockAddrUnix path)+  listen sock 100++  putStdoutMessage DaemonStarted {_dummy = True}++  let socketLoop =+        forever do+          (clientSocket, _) <- accept sock+          (pid, _uid, _gid) <- getPeerCredential clientSocket+          uninterruptibleMask \_unmask -> do+            let removeMe = do+                  t <- myThreadId+                  atomically do+                    modifyTVar clientThreads (M.delete t)+            t <-+              forkFinally -- TODO forkOS?+                (handleClient clientSocket)+                \case+                  Left _e -> removeMe -- >> putErrText ("Connection for pid " <> showPid pid <> " ended: " <> toS (displayException _e))+                  Right _ -> removeMe+            atomically do+              modifyTVar clientThreads (M.insert t pid)+  withAsync socketLoop \_socketLoopAsync ->+    void getStdinMessage++  void $ timeout (10 * 60 * 1000 * 1000) do+    hadThreads <- do+      ts <- atomically do+        readTVar clientThreads+      let hasThreads = not (null ts)+      when hasThreads do+        putErrLn ("Waiting for termination of connections from pids " <> unwords (showPid <$> toList ts))+      pure hasThreads+    atomically do+      ts <- readTVar clientThreads+      guard $ null ts+    when hadThreads do+      putErrText "All connections terminated; exiting"++showPid :: Maybe C.CUInt -> Text+showPid = maybe "unknown pid" show++putStdoutMessage :: DaemonStarted -> IO ()+putStdoutMessage msg = do+  BS.hPut stdout $ BL.toStrict $ Data.Binary.encode msg+  hFlush stdout++getStdinMessage ::+  IO+    ( Either+        (ByteString, Data.Binary.Get.ByteOffset, [Char])+        (Maybe StartDaemon.StartDaemon)+    )+getStdinMessage = decodeBinaryFromHandle stdin++handleClient :: Socket -> IO ()+handleClient clientSocket = withFdSocket clientSocket \fd -> flip finally (close clientSocket) do+  setNonBlockingFD fd False+  [C.throwBlock| void {+    ref<Store> store = openStore();+    FdSource from($(int fd));+    FdSink to($(int fd));+    daemon::TrustedFlag trusted = daemon::NotTrusted;+    daemon::RecursiveFlag recursive = daemon::NotRecursive;+    std::function<void(Store &)> authHook = [](Store &){};+    daemon::processConnection(+        store+        , from+        , to+        , trusted+        , recursive+        , authHook+        );+  }|]

@@ -1,26 +1,32 @@ cabal-version: 2.4  name:           hercules-ci-agent-version:        0.8.7+version:        0.9.0 synopsis:       Runs Continuous Integration tasks on your machines category:       Nix, CI, Testing, DevOps homepage:       https://docs.hercules-ci.com bug-reports:    https://github.com/hercules-ci/hercules-ci-agent/issues author:         Hercules CI contributors maintainer:     info@hercules-ci.com-copyright:      2018-2020 Hercules CI+copyright:      2018-2021 Hercules CI license:        Apache-2.0 build-type:     Custom extra-source-files:     CHANGELOG.md     cbits/hercules-aliases.h     cbits/hercules-logger.hh-    cbits/nix-2.3/hercules-store.hh     cbits/nix-2.4/hercules-store.hh     testdata/vm-test-run-agent-test.drv+data-files:+    data/default-herculesCI-for-flake.nix +-- Deprecated flag nix-2_4-  description: Build for Nix >=2.4pre*+  description: Build for Nix >=2.4*+  default: True++flag nix-2_5+  description: Build for Nix >=2.5*   default: False  source-repository head@@ -34,6 +40,12 @@     -Wall   extra-libraries: stdc++ +  if flag(nix-2_5)+    cxx-options:+      -DNIX_2_5+    cpp-options:+      -DNIX_2_5+   if os(darwin)     -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829     ld-options:  -Wl,-keep_dwarf_unwind@@ -51,13 +63,6 @@     if os(darwin)       ghc-options: -pgmc=clang++ -  if flag(nix-2_4)-    cpp-options:-        -DNIX_2_4-    cxx-options:-        -DNIX_2_4-- custom-setup   setup-depends:     base@@ -69,24 +74,34 @@   exposed-modules:       Data.Fixed.Extras       Data.Time.Extras+      Hercules.Agent.Binary       Hercules.Agent.NixFile+      Hercules.Agent.NixFile.GitSource+      Hercules.Agent.NixFile.HerculesCIArgs+      Hercules.Agent.NixFile.CiNixArgs+      Hercules.Agent.NixPath       Hercules.Agent.Producer       Hercules.Agent.Sensitive       Hercules.Agent.Socket       Hercules.Agent.STM+      Hercules.Agent.WorkerProcess       Hercules.Agent.WorkerProtocol.Command       Hercules.Agent.WorkerProtocol.Command.Build       Hercules.Agent.WorkerProtocol.Command.BuildResult       Hercules.Agent.WorkerProtocol.Command.Effect       Hercules.Agent.WorkerProtocol.Command.Eval+      Hercules.Agent.WorkerProtocol.Command.StartDaemon       Hercules.Agent.WorkerProtocol.Event       Hercules.Agent.WorkerProtocol.Event.Attribute       Hercules.Agent.WorkerProtocol.Event.AttributeError       Hercules.Agent.WorkerProtocol.Event.BuildResult+      Hercules.Agent.WorkerProtocol.Event.DaemonStarted       Hercules.Agent.WorkerProtocol.LogSettings       Hercules.Agent.WorkerProtocol.Orphans       Hercules.Effect       Hercules.Effect.Container+      Hercules.Secrets+      Hercules.UserException       Data.Conduit.Extras       Data.Conduit.Katip.Orphans @@ -99,7 +114,7 @@   default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators   ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns   build-depends:-      aeson+      aeson >= 2     , async     , base >=4.7 && <5     , binary@@ -113,6 +128,7 @@     , filepath     , hercules-ci-api-agent     , hercules-ci-api-core+    , hercules-ci-cnix-expr     , hercules-ci-cnix-store     , katip     , lens@@ -127,9 +143,11 @@     , process-extras     , safe-exceptions     , stm+    , tagged     , temporary     , text     , time+    , transformers     , transformers-base     , unbounded-delays     , unix@@ -167,16 +185,16 @@       Hercules.Agent.Files       Hercules.Agent.Init       Hercules.Agent.Log+      Hercules.Agent.Netrc+      Hercules.Agent.Netrc.Env       Hercules.Agent.Nix       Hercules.Agent.Nix.Env       Hercules.Agent.Nix.Init       Hercules.Agent.Nix.RetrieveDerivationInfo-      Hercules.Agent.NixPath       Hercules.Agent.Options       Hercules.Agent.SecureDirectory       Hercules.Agent.ServiceInfo       Hercules.Agent.Token-      Hercules.Agent.WorkerProcess       Paths_hercules_ci_agent   autogen-modules:       Paths_hercules_ci_agent@@ -204,8 +222,8 @@     , exceptions     , filepath     , hercules-ci-agent-    , hercules-ci-api-core == 0.1.3.0-    , hercules-ci-api-agent == 0.4.1.2+    , hercules-ci-api-core == 0.1.4.0+    , hercules-ci-api-agent == 0.4.2.0     , hostname     , http-client     , http-client-tls@@ -259,18 +277,16 @@       Paths_hercules_ci_agent       Hercules.Agent.Worker.HerculesStore       Hercules.Agent.Worker.HerculesStore.Context+      Hercules.Agent.Worker.Logging+      Hercules.Agent.Worker.NixDaemon   autogen-modules:       Paths_hercules_ci_agent   hs-source-dirs:       hercules-ci-agent-worker+   cxx-sources:       cbits/hercules-logger.cxx-  if flag(nix-2_4)-    cxx-sources:       cbits/nix-2.4/hercules-store.cxx-  else-    cxx-sources:-      cbits/nix-2.3/hercules-store.cxx    default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators   ghc-options:@@ -286,12 +302,7 @@     -with-rtsopts=-maxN8   include-dirs:       cbits-  if flag(nix-2_4)-    include-dirs:       cbits/nix-2.4-  else-    include-dirs:-      cbits/nix-2.3   extra-libraries:       boost_context   build-depends:@@ -321,6 +332,7 @@     , lifted-base     , monad-control     , mtl+    , network     , network-uri     , protolude     , process@@ -340,13 +352,13 @@       nix-store >= 2.0     , nix-expr >= 2.0     , nix-main >= 2.0-    , bdw-gc   default-language: Haskell2010  test-suite hercules-test   type: exitcode-stdio-1.0   main-is: TestMain.hs   other-modules:+      Data.Conduit.Extras       Hercules.Agent.Log       Hercules.Agent.NixPath       Hercules.Agent.NixPathSpec@@ -354,9 +366,12 @@       Hercules.Agent.Nix.RetrieveDerivationInfoSpec       Hercules.Agent.WorkerProcess       Hercules.Agent.WorkerProcessSpec+      Hercules.Secrets+      Hercules.SecretsSpec       Paths_hercules_ci_agent       Spec   hs-source-dirs:+      src       test       hercules-ci-agent   default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators@@ -382,9 +397,11 @@     , lifted-async     , lifted-base     , monad-control+    , mtl     , process     , protolude     , safe-exceptions+    , tagged     , temporary     , text     , transformers-base

@@ -53,6 +53,7 @@ import qualified Hercules.Agent.Evaluate as Evaluate import qualified Hercules.Agent.Init as Init import Hercules.Agent.Log+import qualified Hercules.Agent.Netrc as Netrc import qualified Hercules.Agent.Options as Options import Hercules.Agent.STM import Hercules.Agent.Socket as Socket@@ -117,18 +118,18 @@                       ServicePayload.ServiceInfo _ -> pass                       ServicePayload.StartEvaluation evalTask ->                         launchTask tasks socket (Task.upcastId $ EvaluateTask.id evalTask) do-                          Cache.withCaches do+                          Netrc.withNixNetrc $ Cache.withCaches do                             -- TODO move the store directly under env                             store <- asks (Cachix.Env.nixStore . Env.cachixEnv)                             Evaluate.performEvaluation store evalTask                             pure $ TaskStatus.Successful ()                       ServicePayload.StartBuild buildTask ->                         launchTask tasks socket (Task.upcastId $ BuildTask.id buildTask) do-                          Cache.withCaches $+                          Netrc.withNixNetrc $ Cache.withCaches do                             Build.performBuild buildTask                       ServicePayload.StartEffect effectTask ->                         launchTask tasks socket (Task.upcastId $ EffectTask.id effectTask) do-                          Cache.withCaches $+                          Netrc.withNixNetrc $ Cache.withCaches do                             Effect.performEffect effectTask                       ServicePayload.Cancel cancellation -> cancelTask tasks socket cancellation 

@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Hercules.Agent.Bag@@ -15,14 +16,13 @@ import Data.Functor.Partitioner hiding   ( part,   )-import qualified Data.HashMap.Strict as HashMap import Protolude  -- TODO: Use a Validation instead of Either to return all errors at once  -- | Partitioning and validation for heterogeneous JSON maps newtype ParseBag a b = ParseBag {getReadBag :: Compose (Partitioner (WithKey Text a)) Parser b}-  deriving (Functor, Applicative)+  deriving newtype (Functor, Applicative)  -- | Text argument: Map key, a: thing you're parsing. Return 'Nothing' to skip the object and let another part handle it. part :: (Text -> a -> Maybe (Parser b)) -> ParseBag a (Map Text b)

@@ -45,7 +45,14 @@   commandChan <- liftIO newChan   statusRef <- newIORef Nothing   extraNixOptions <- Nix.askExtraOptions-  workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = mempty})+  workerEnv <-+    liftIO $+      WorkerProcess.prepareEnv+        ( WorkerProcess.WorkerEnvSettings+            { nixPath = mempty,+              extraEnv = mempty+            }+        )   let opts = [show extraNixOptions]       procSpec =         (System.Process.proc workerExe opts)

@@ -1,4 +1,4 @@-module Hercules.Agent.CabalInfo where+module Hercules.Agent.CabalInfo (herculesAgentVersion) where  import Data.Version (showVersion) import Paths_hercules_ci_agent (version)

@@ -4,14 +4,13 @@  import qualified Data.Map as M import qualified Data.Text as T-import qualified Data.Text.IO as T import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import qualified Hercules.Agent.Cachix as Cachix import qualified Hercules.Agent.Config.BinaryCaches as Config import Hercules.Agent.Env (App) import qualified Hercules.Agent.Env as Env+import qualified Hercules.Agent.Netrc as Netrc import qualified Hercules.Agent.Nix as Nix-import qualified Hercules.Agent.SecureDirectory as SecureDirectory import qualified Hercules.CNix as CNix import Hercules.CNix.Std.Set (StdSet, toListFP) import qualified Hercules.CNix.Std.Set as Std.Set@@ -20,26 +19,23 @@ import qualified Hercules.Formats.NixCache as NixCache import Katip import Protolude-import System.IO (hClose)  withCaches :: App a -> App a withCaches m = do-  netrcLns <- (<>) <$> Cachix.getNetrcLines <*> Nix.getNetrcLines+  netrcLns <- Cachix.getNetrcLines   csubsts <- Cachix.getSubstituters   cpubkeys <- Cachix.getTrustedPublicKeys   nixCaches <- asks (Config.nixCaches . Env.binaryCaches)   let substs = nixCaches & toList <&> NixCache.storeURI       pubkeys = nixCaches & toList <&> NixCache.publicKeys & join-  SecureDirectory.withSecureTempFile "tmp-netrc.key" $ \netrcPath netrcHandle -> do-    liftIO $ do-      T.hPutStrLn netrcHandle (T.unlines netrcLns)-      hClose netrcHandle-    Nix.withExtraOptions-      [ ("netrc-file", toS netrcPath),-        ("substituters", T.intercalate " " (substs <> csubsts)),-        ("trusted-public-keys", T.intercalate " " (pubkeys <> cpubkeys))-      ]-      m+  netrcFile <- Netrc.getNetrcFile+  Netrc.appendLines netrcLns+  Nix.withExtraOptions+    [ ("netrc-file", toS netrcFile),+      ("substituters", T.intercalate " " (substs <> csubsts)),+      ("trusted-public-keys", T.intercalate " " (pubkeys <> cpubkeys))+    ]+    m  push ::   -- | Cache name

@@ -1,12 +1,17 @@ {-# LANGUAGE CPP #-}-module Hercules.Agent.Compat where +module Hercules.Agent.Compat (katipLevel) where+ import qualified Katip as K+import Protolude -#if MIN_VERSION_katip(0,8,0) katipLevel :: K.Severity -> K.PermitFunc+#if MIN_VERSION_katip(0,8,0) katipLevel a =   K.permitItem a #else katipLevel x = x #endif++{- eta expansion required for type checking -}+{-# ANN katipLevel ("HLint: ignore Eta reduce" :: Text) #-}

@@ -56,7 +56,8 @@     binaryCachesPath :: Item purpose 'Required FilePath,     secretsJsonPath :: Item purpose 'Required FilePath,     logLevel :: Item purpose 'Required Severity,-    labels :: Item purpose 'Required (Map Text A.Value)+    labels :: Item purpose 'Required (Map Text A.Value),+    allowInsecureBuiltinFetchers :: Item purpose 'Required Bool   }   deriving (Generic) @@ -90,19 +91,21 @@     .= logLevel     <*> dioptional (Toml.tableMap _KeyText embedJson "labels")     .= labels+    <*> dioptional (Toml.bool "allowInsecureBuiltinFetchers")+    .= allowInsecureBuiltinFetchers  embedJson :: Key -> TomlCodec A.Value embedJson key =   Codec     { codecRead =         codecRead (match (embedJsonBiMap key) key)-          <!> codecRead (A.Object <$> AK.fromHashMapText <$> Toml.tableHashMap _KeyText embedJson key),+          <!> codecRead (A.Object . AK.fromHashMapText <$> 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 <$> AK.fromHashMapText <$> codecWrite (Toml.tableHashMap _KeyText embedJson key) (AK.toHashMapText o)+        A.Object o -> A.Object . AK.fromHashMapText <$> codecWrite (Toml.tableHashMap _KeyText embedJson key) (AK.toHashMapText o)         A.Null -> eitherToTomlState (Left ("null is not supported in TOML" :: Text))     } @@ -211,5 +214,6 @@         secretsJsonPath = secretsJsonP,         workDirectory = workDir,         logLevel = logLevel input & fromMaybe InfoS,-        labels = fromMaybe mempty $ labels input+        labels = fromMaybe mempty $ labels input,+        allowInsecureBuiltinFetchers = fromMaybe False $ allowInsecureBuiltinFetchers input       }

@@ -18,6 +18,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 qualified Hercules.Secrets as Secrets import qualified Network.URI import Protolude import qualified System.Posix.Signals as PS@@ -28,7 +29,14 @@   workerExe <- getWorkerExe   commandChan <- liftIO newChan   extraNixOptions <- Nix.askExtraOptions-  workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = mempty})+  workerEnv <-+    liftIO $+      WorkerProcess.prepareEnv+        ( WorkerProcess.WorkerEnvSettings+            { nixPath = mempty,+              extraEnv = mempty+            }+        )   effectResult <- liftIO $ newIORef Nothing   let opts = [show extraNixOptions]       procSpec =@@ -65,7 +73,14 @@               token = Sensitive (EffectTask.token effectTask),               apiBaseURL = Config.herculesApiBaseURL config,               projectId = EffectTask.projectId effectTask,-              projectPath = EffectTask.projectPath effectTask+              projectPath = EffectTask.projectPath effectTask,+              secretContext =+                Secrets.SecretContext+                  { ownerName = EffectTask.ownerName effectTask,+                    repoName = EffectTask.repoName effectTask,+                    ref = EffectTask.ref effectTask,+                    isDefaultBranch = EffectTask.isDefaultBranch effectTask+                  }             }   exitCode <- runWorker procSpec (stderrLineHandler "Effect worker") commandChan writeEvent   logLocM DebugS $ "Worker exit: " <> logStr (show exitCode :: Text)

@@ -16,6 +16,7 @@   ) import Hercules.Agent.Config (FinalConfig) import qualified Hercules.Agent.Config.BinaryCaches as Config.BinaryCaches+import qualified Hercules.Agent.Netrc.Env as Netrc import qualified Hercules.Agent.Nix.Env as Nix   ( Env,   )@@ -42,6 +43,7 @@     binaryCaches :: Config.BinaryCaches.BinaryCaches,     cachixEnv :: Cachix.Env,     nixEnv :: Nix.Env,+    netrcEnv :: Netrc.Env,     socket :: AgentSocket,     -- katip     kNamespace :: K.Namespace,

@@ -4,7 +4,6 @@  module Hercules.Agent.Evaluate   ( performEvaluation,-    findNixFile,   ) where @@ -12,7 +11,9 @@ import qualified Control.Concurrent.Async.Lifted as Async.Lifted import Control.Concurrent.Chan.Lifted import Control.Exception.Lifted (finally)+import Control.Lens (at, (^?)) import qualified Data.Aeson as A+import Data.Aeson.Lens (_String) import qualified Data.ByteString.Lazy as BL import Data.Char (isAsciiLower, isAsciiUpper) import Data.Conduit.Process (sourceProcessWithStreams)@@ -36,6 +37,7 @@ import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.BuildRequest as BuildRequest import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.BuildRequired as BuildRequired import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.DerivationInfo as DerivationInfo+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.JobConfig as JobConfig import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.Message as Message import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.PushedAll as PushedAll import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask@@ -43,17 +45,20 @@ 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 import qualified Hercules.Agent.Env as Env import Hercules.Agent.Evaluate.TraversalQueue (Queue) import qualified Hercules.Agent.Evaluate.TraversalQueue as TraversalQueue import Hercules.Agent.Files import Hercules.Agent.Log+import qualified Hercules.Agent.Netrc as Netrc import qualified Hercules.Agent.Nix as Nix import Hercules.Agent.Nix.RetrieveDerivationInfo   ( retrieveDerivationInfo,   ) import Hercules.Agent.NixFile (findNixFile)+import Hercules.Agent.NixFile.GitSource (fromRefRevPath) import Hercules.Agent.NixPath   ( renderSubPath,   )@@ -65,6 +70,7 @@ 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@@ -76,6 +82,7 @@ import qualified Network.URI import Protolude hiding (finally, newChan, writeChan) import qualified Servant.Client+import Servant.Client.Core (showBaseUrl) import qualified System.Directory as Dir import System.FilePath import System.Process@@ -126,6 +133,12 @@   projectDir <- case M.lookup "src" inputLocations of     Nothing -> panic "No primary source provided"     Just x -> pure x+  (ref, rev) <- case M.lookup "src" (EvaluateTask.inputMetadata task) of+    Nothing -> do+      panic $ "No primary source metadata provided" <> show task+    Just meta -> pure $ fromMaybe (panic "no ref/rev in primary source metadata") do+      (,) <$> (meta ^? at "ref" . traverse . _String)+        <*> (meta ^? at "rev" . traverse . _String)   nixPath <-     EvaluateTask.nixPath task       & ( traverse@@ -199,6 +212,7 @@             emitSingle truncMsg             panic "Evaluation limit reached."           else emitSingle =<< fixIndex update+  let allowedPaths = toList inputLocations <&> toS <&> encodeUtf8   adHocSystem <-     readFileMaybe (projectDir </> "ci-default-system.txt")   liftIO (findNixFile projectDir) >>= \case@@ -225,9 +239,9 @@             TraversalQueue.enqueue derivationQueue drvPath             liftIO $ atomicModifyIORef topDerivationPaths ((,()) . S.insert drvPath)           evaluation = do-            let evalProc = do-                  Nix.withExtraOptions [("system", T.strip s) | Just s <- [adHocSystem]] $-                    runEvalProcess+            Nix.withExtraOptions [("system", T.strip s) | Just s <- [adHocSystem]] do+              let evalProc =+                    do runEvalProcess                       projectDir                       file                       autoArguments@@ -235,11 +249,13 @@                       captureAttrDrvAndEmit                       uploadDrvInfos                       sync-                      (EvaluateTask.logToken task)-            evalProc `finally` do-              -- Always upload drv infos, even in case of a crash in the worker-              TraversalQueue.waitUntilDone derivationQueue-                `finally` TraversalQueue.close derivationQueue+                      task+                      (ref, rev)+                      allowedPaths+              evalProc `finally` do+                -- Always upload drv infos, even in case of a crash in the worker+                TraversalQueue.waitUntilDone derivationQueue+                  `finally` TraversalQueue.close derivationQueue           pushDrvs = do             caches <- activePushCaches             paths <- liftIO $ readIORef topDerivationPaths@@ -284,12 +300,17 @@   -- | Upload a derivation, return when done   (StorePath -> App ()) ->   App () ->-  Text ->+  EvaluateTask.EvaluateTask ->+  (Text, Text) ->+  [ByteString] ->   App ()-runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush logToken = do+runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush task (ref, rev) allowedPaths = do   extraOpts <- Nix.askExtraOptions-  baseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)-  let eval =+  bulkBaseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)+  apiBaseUrl <- asks (toS . showBaseUrl . Env.herculesBaseUrl)+  cfg <- asks Env.config+  let gitSource = fromRefRevPath ref rev (toS projectDir)+      eval =         Eval.Eval           { Eval.cwd = projectDir,             Eval.file = toS file,@@ -297,16 +318,54 @@             Eval.extraNixOptions = extraOpts,             Eval.logSettings =               LogSettings.LogSettings-                { token = Sensitive logToken,+                { token = Sensitive $ EvaluateTask.logToken task,                   path = "/api/v1/logs/build/socket",-                  baseURL = toS $ Network.URI.uriToString identity baseURL ""-                }+                  baseURL = toS $ Network.URI.uriToString identity bulkBaseURL ""+                },+            Eval.gitSource = ViaJSON gitSource,+            Eval.apiBaseUrl = apiBaseUrl,+            Eval.ciSystems = EvaluateTask.ciSystems task,+            Eval.selector = ViaJSON $ EvaluateTask.selector task,+            Eval.allowInsecureBuiltinFetchers = Config.allowInsecureBuiltinFetchers cfg,+            Eval.allowedPaths = allowedPaths           }   buildRequiredIndex <- liftIO $ newIORef (0 :: Int)   commandChan <- newChan   writeChan commandChan $ Just $ Command.Eval eval+  for_ (EvaluateTask.extraGitCredentials task) \creds ->+    Netrc.appendLines (credentialToLines =<< creds)+  netrcFile <- Netrc.getNetrcFile   let decode = decodeUtf8With lenientDecode-  withProducer (produceWorkerEvents eval nixPath commandChan) $+      toGitConfigEnv items =+        M.fromList $+          ("GIT_CONFIG_COUNT", show (length items)) :+          concatMap+            ( \(i, (k, v)) ->+                [ ("GIT_CONFIG_KEY_" <> show i, k),+                  ("GIT_CONFIG_VALUE_" <> show i, v)+                ]+            )+            (zip [0 :: Int ..] items)+      envSettings =+        WorkerProcess.WorkerEnvSettings+          { nixPath = nixPath,+            extraEnv =+              toGitConfigEnv+                [ ("credential.helper", "netrc --file " <> netrcFile),+                  -- Deny by default.+                  ("protocol.allow", "never"),+                  -- Safe protocols.+                  -- More protocols can be added as long as they can be shown+                  -- not to leak credentials from netrc or .git-credentials.+                  -- If a protocol is lacking in confidentiality, authenticity,+                  -- etc, it must be off by default with a Config item to+                  -- enable it.+                  ("protocol.https.allow", "always"),+                  ("protocol.ssh.allow", "always"),+                  ("protocol.file.allow", "always")+                ]+          }+  withProducer (produceWorkerEvents eval envSettings commandChan) $     \workerEventsP -> fix $ \continue ->       joinSTM $         listen@@ -381,6 +440,12 @@                     return status                 writeChan commandChan $ Just $ Command.BuildResult $ uncurry (BuildResult.BuildResult drvText) status                 continue+              Event.OnPushHandler (ViaJSON e) -> do+                emit $ EvaluateEvent.OnPushHandlerEvent e+                continue+              Event.JobConfig -> do+                emit $ EvaluateEvent.JobConfig JobConfig.JobConfig {sourceCaches = Nothing, binaryCaches = Nothing}+                continue               Event.Exception e -> panic e               -- Unused during eval               Event.BuildResult {} -> pass@@ -393,18 +458,34 @@                 panic $ "Worker failed with exit status: " <> show e           ) +credentialToLines :: EvaluateTask.Credential -> [Text]+credentialToLines c =+  fromMaybe [] do+    host <- hostFromUrl (EvaluateTask.url c)+    pure+      [ "machine " <> host,+        "login " <> EvaluateTask.username c,+        "password " <> EvaluateTask.password c+      ]++hostFromUrl :: Text -> Maybe Text+hostFromUrl t = do+  uri <- Network.URI.parseURI (toS t)+  a <- Network.URI.uriAuthority uri+  pure $ toS $ Network.URI.uriRegName a+ produceWorkerEvents ::   Eval.Eval ->-  [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)] ->+  WorkerProcess.WorkerEnvSettings ->   Chan (Maybe Command.Command) ->   (Event.Event -> App ()) ->   App ExitCode-produceWorkerEvents eval nixPath commandChan writeEvent = do+produceWorkerEvents eval envSettings commandChan writeEvent = do   workerExe <- WorkerProcess.getWorkerExe   let opts = [show $ Eval.extraNixOptions eval]   -- NiceToHave: replace renderNixPath by something structured like -I   -- to support = and : in paths-  workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = nixPath})+  workerEnv <- liftIO $ WorkerProcess.prepareEnv envSettings   let wps =         (System.Process.proc workerExe opts)           { env = Just workerEnv,

@@ -6,6 +6,7 @@ import qualified Hercules.Agent.Config.BinaryCaches as BC import Hercules.Agent.Env (Env (Env)) import qualified Hercules.Agent.Env as Env+import qualified Hercules.Agent.Netrc.Env as Netrc import qualified Hercules.Agent.Nix.Init import qualified Hercules.Agent.SecureDirectory as SecureDirectory import qualified Hercules.Agent.ServiceInfo as ServiceInfo@@ -49,7 +50,8 @@         kNamespace = emptyNamespace,         kContext = mempty,         kLogEnv = logEnv,-        nixEnv = nix+        nixEnv = nix,+        netrcEnv = Netrc.Env Nothing       }  setupLogging :: Config.FinalConfig -> (K.LogEnv -> IO ()) -> IO ()

@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.Agent.Netrc where++import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Hercules.Agent.Env as Env+import Hercules.Agent.Netrc.Env (Env (Env, netrcFile))+import qualified Hercules.Agent.Nix as Nix+import qualified Hercules.Agent.SecureDirectory as SecureDirectory+import Protolude+import System.IO (hClose)++withNixNetrc :: Env.App a -> Env.App a+withNixNetrc m = do+  baseLns <- Nix.getNetrcLines+  SecureDirectory.withSecureTempFile "tmp-netrc.key" $ \netrcPath netrcHandle -> do+    liftIO $ do+      T.hPutStrLn netrcHandle (T.unlines baseLns)+      hClose netrcHandle+    local (\env -> env {Env.netrcEnv = Env {netrcFile = Just netrcPath}}) m++getNetrcFile :: Env.App FilePath+getNetrcFile = do+  env <- asks Env.netrcEnv+  case netrcFile env of+    Nothing -> throwIO $ FatalError "getNetrcFile is only valid in withNixNetrc"+    Just f -> pure f++appendLines :: [Text] -> Env.App ()+appendLines lns = do+  f <- getNetrcFile+  liftIO do+    withFile f AppendMode \h -> do+      T.hPutStrLn h ("\n" <> T.unlines lns)

@@ -0,0 +1,7 @@+module Hercules.Agent.Netrc.Env where++import Protolude++data Env = Env+  { netrcFile :: Maybe FilePath+  }

@@ -1,27 +0,0 @@-module Hercules.Agent.NixPath-  ( renderNixPath,-    renderNixPathElement,-    renderSubPath,-  )-where--import qualified Data.Text as T-import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask-import Protolude--renderNixPath ::-  [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)] ->-  Text-renderNixPath = T.intercalate ":" . map renderNixPathElement--renderNixPathElement ::-  EvaluateTask.NixPathElement-    (EvaluateTask.SubPathOf FilePath) ->-  Text-renderNixPathElement pe =-  foldMap (<> "=") (EvaluateTask.prefix pe)-    <> renderSubPath (toS <$> EvaluateTask.value pe)--renderSubPath :: EvaluateTask.SubPathOf Text -> Text-renderSubPath sp =-  toS (EvaluateTask.path sp) <> foldMap ("/" <>) (EvaluateTask.subPath sp)

@@ -1,122 +0,0 @@-module Hercules.Agent.WorkerProcess-  ( runWorker,-    getWorkerExe,-    WorkerEnvSettings (..),-    prepareEnv,-    modifyEnv,-  )-where--import Conduit hiding (Producer)-import qualified Control.Exception.Safe as Safe-import Control.Monad.IO.Unlift-import Data.Binary (Binary)-import Data.Conduit.Extras (conduitToCallbacks, sourceChan)-import Data.Conduit.Serialization.Binary-  ( conduitDecode,-    conduitEncode,-  )-import qualified Data.Map as M-import GHC.IO.Exception-import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask-import Hercules.Agent.NixPath (renderNixPath)-import Paths_hercules_ci_agent (getBinDir)-import Protolude-import System.Environment (getEnvironment)-import System.FilePath ((</>))-import System.IO (hClose)-import System.IO.Error-import System.Process-import System.Timeout (timeout)-import Prelude ()--data WorkerException = WorkerException-  { originalException :: SomeException,-    exitStatus :: Maybe ExitCode-  }-  deriving (Show, Typeable)--instance Exception WorkerException where-  displayException we =-    displayException (originalException we)-      <> case exitStatus we of-        Nothing -> ""-        Just s -> " (worker: " <> show s <> ")"--data WorkerEnvSettings = WorkerEnvSettings-  { nixPath :: [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)]-  }---- | Filter out impure env vars by wildcard, set NIX_PATH-modifyEnv :: WorkerEnvSettings -> Map [Char] [Char] -> Map [Char] [Char]-modifyEnv workerEnvSettings =-  M.insert "NIX_PATH" (toS $ renderNixPath $ nixPath workerEnvSettings)-    . M.filterWithKey (\k _v -> not ("NIXPKGS_" `isPrefixOf` k))-    . M.filterWithKey (\k _v -> not ("NIXOS_" `isPrefixOf` k))-    . M.delete "IN_NIX_SHELL"--prepareEnv :: WorkerEnvSettings -> IO [([Char], [Char])]-prepareEnv workerEnvSettings = do-  envMap <- M.fromList <$> getEnvironment-  pure $ M.toList $ modifyEnv workerEnvSettings envMap--getWorkerExe :: MonadIO m => m [Char]-getWorkerExe = do-  liftIO getBinDir <&> (</> "hercules-ci-agent-worker")---- | Control a child process by communicating over stdin and stdout--- using a 'Binary' interface.-runWorker ::-  (Binary command, Binary event, MonadUnliftIO m, MonadThrow m) =>-  -- | Process invocation details. Will ignore std_in, std_out and std_err fields.-  CreateProcess ->-  (Int -> ByteString -> m ()) ->-  Chan (Maybe command) ->-  (event -> m ()) ->-  m ExitCode-runWorker baseProcess stderrLineHandler commandChan eventHandler = do-  UnliftIO {unliftIO = unlift} <- askUnliftIO-  let createProcessSpec =-        baseProcess-          { std_in = CreatePipe,-            std_out = CreatePipe,-            std_err = CreatePipe-          }-  liftIO $-    withCreateProcess createProcessSpec $ \mIn mOut mErr processHandle -> do-      (inHandle, outHandle, errHandle) <--        case (,,) <$> mIn <*> mOut <*> mErr of-          Just x -> pure x-          Nothing ->-            throwIO $-              mkIOError-                illegalOperationErrorType-                "Process did not return all handles"-                Nothing -- no handle-                Nothing -- no path-      pidMaybe <- liftIO $ getPid processHandle-      let pid = maybe 0 fromIntegral pidMaybe-      let stderrPiper =-            liftIO $-              runConduit-                (sourceHandle errHandle .| linesUnboundedAsciiC .| awaitForever (liftIO . unlift . stderrLineHandler pid))-      let eventConduit = sourceHandle outHandle .| conduitDecode-          commandConduit =-            sourceChan commandChan-              .| conduitEncode-              .| concatMapC (\x -> [Chunk x, Flush])-              .| handleC handleEPIPE (sinkHandleFlush inHandle)-          handleEPIPE e | ioeGetErrorType e == ResourceVanished = pure ()-          handleEPIPE e = throwIO e-      let cmdThread = runConduit commandConduit `finally` hClose outHandle-          eventThread = unlift $ conduitToCallbacks eventConduit eventHandler-      -- plain forkIO so it can process all of stderr in case of an exception-      void $ forkIO stderrPiper-      withAsync (waitForProcess processHandle) $ \exitAsync -> do-        withAsync cmdThread $ \_ -> do-          eventThread-            `Safe.catch` \e -> do-              let oneSecond = 1000 * 1000-              maybeStatus <- timeout (5 * oneSecond) (wait exitAsync)-              throwIO $ WorkerException e maybeStatus-          wait exitAsync

@@ -0,0 +1,23 @@+module Hercules.Agent.Binary where++import Data.Binary+import Data.Binary.Get+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder.Extra as BL+import System.IO (Handle)+import Prelude++-- As recommended in the binary docs, taken from https://hackage.haskell.org/package/binary-0.8.9.0/docs/src/Data.Binary.html#decodeFileOrFail++-- | Decode a value from a 'Handle'. Returning 'Left' on failure and 'Right' on success.+-- In case of failure, the unconsumed input and a human-readable error message will be returned.+decodeBinaryFromHandle :: Binary a => Handle -> IO (Either (BS.ByteString, ByteOffset, String) a)+decodeBinaryFromHandle = feed (runGetIncremental get)+  where+    feed (Done _ _ x) _ = pure (Right x)+    feed (Fail unconsumed pos str) _ = pure (Left (unconsumed, pos, str))+    feed (Partial k) h = do+      chunk <- BS.hGetSome h BL.defaultChunkSize+      case BS.length chunk of+        0 -> feed (k Nothing) h+        _ -> feed (k (Just chunk)) h

@@ -1,16 +1,69 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedLabels #-}+ module Hercules.Agent.NixFile-  ( findNixFile,+  ( -- * Schemas+    HomeSchema,+    HerculesCISchema,+    OnPushSchema,+    ExtraInputsSchema,+    InputDeclSchema,+    InputsSchema,+    InputSchema,+    OutputsSchema,++    -- * Loading+    findNixFile,+    loadNixFile,+    HomeExpr (..),+    homeExprRawValue,+    getHerculesCI,+    loadDefaultHerculesCI,++    -- * @onPush@+    getOnPushOutputValueByPath,+    parseExtraInputs,   ) where -import Protolude+import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+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))+import qualified Hercules.Agent.NixFile.CiNixArgs+import Hercules.Agent.NixFile.GitSource (GitSource)+import Hercules.Agent.NixFile.HerculesCIArgs (HerculesCIArgs)+import qualified Hercules.Agent.NixFile.HerculesCIArgs as HerculesCIArgs+import Hercules.CNix.Expr+  ( EvalState,+    Match (IsAttrs),+    NixAttrs,+    Value (Value, rtValue),+    addAllowedPath,+    assertType,+    autoCallFunction,+    evalFile,+    getAttr,+    getLocalFlake,+    match',+    toRawValue,+    unsafeAssertType,+  )+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 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 ((</>))+import System.FilePath (takeFileName, (</>))  type Ambiguity = [FilePath]  searchPath :: [Ambiguity]-searchPath = [["nix/ci.nix", "ci.nix"], ["default.nix"]]+searchPath = [["nix/ci.nix", "ci.nix"], ["flake.nix"], ["default.nix"]]  findNixFile :: FilePath -> IO (Either Text FilePath) findNixFile projectDir = do@@ -21,24 +74,157 @@          in Dir.doesFileExist path >>= \case               True -> pure $ Just (relPath, path)               False -> pure Nothing-  case filter (not . null) $ map catMaybes searchResult of-    [(_relPath, unambiguous)] : _ -> pure (pure unambiguous)+  pure $ case filter (not . null) $ map catMaybes searchResult of+    [(_relPath, unambiguous)] : _ -> pure unambiguous     ambiguous : _ ->-      pure $-        Left $-          "Don't know what to do, expecting only one of "-            <> englishConjunction "or" (map fst ambiguous)+      Left $+        "Don't know what to do, expecting only one of "+          <> Schema.englishOr (map (toS . fst) ambiguous)     [] ->-      pure $-        Left $-          "Please provide a Nix expression to build. Could not find any of "-            <> englishConjunction "or" (concat searchPath)-            <> " in your source"+      Left $+        "Please provide a Nix expression to build. Could not find any of "+          <> Schema.englishOr (concatMap (map toS) searchPath)+          <> " in your source" -englishConjunction :: Show a => Text -> [a] -> Text-englishConjunction _ [] = "none"-englishConjunction _ [a] = show a-englishConjunction connective [a1, a2] =-  show a1 <> " " <> connective <> " " <> show a2-englishConjunction connective (a : as) =-  show a <> ", " <> englishConjunction connective as+-- | Expression containing the bulk of the project+data HomeExpr+  = Flake (Value NixAttrs)+  | CiNix FilePath RawValue++homeExprRawValue :: HomeExpr -> RawValue+homeExprRawValue (Flake (Value r)) = r+homeExprRawValue (CiNix _ r) = r++loadNixFile :: Ptr EvalState -> FilePath -> GitSource -> IO (Either Text HomeExpr)+loadNixFile evalState projectPath src = runExceptT do+  nixFile <- ExceptT $ findNixFile projectPath+  if takeFileName nixFile == "flake.nix"+    then do+      val <- liftIO $ getLocalFlake evalState (toS projectPath) >>= assertType evalState+      pure (Flake val)+    else do+      rootValueOrFunction <- liftIO $ evalFile evalState nixFile+      args <- unsafeAssertType @NixAttrs <$> liftIO (toRawValue evalState CiNixArgs {src = src})+      homeExpr <- liftIO $ autoCallFunction evalState rootValueOrFunction args+      pure (CiNix nixFile homeExpr)++getHomeExprObject :: MonadEval m => HomeExpr -> m (PSObject HomeSchema)+getHomeExprObject (Flake attrs) = pure PSObject {value = rtValue attrs, provenance = Schema.File "flake.nix"}+getHomeExprObject (CiNix f obj) = pure PSObject {value = obj, provenance = Schema.File f}++type HomeSchema = Attrs '["herculesCI" ::? Attrs '[] ->? HerculesCISchema]++type HerculesCISchema = Attrs '["onPush" ::? Dictionary OnPushSchema]++type OnPushSchema =+  Attrs+    '[ "extraInputs" ::? ExtraInputsSchema,+       "outputs" ::. InputsSchema ->? OutputsSchema,+       "enable" ::? Bool+     ]++type ExtraInputsSchema = Dictionary InputDeclSchema++type InputDeclSchema =+  Attrs+    '[ "project" ::. StringWithoutContext,+       "ref" ::? StringWithoutContext+     ]++type InputsSchema = Dictionary InputSchema++type InputSchema = Dictionary RawValue++type OutputsSchema = Dictionary RawValue++type DefaultHerculesCIHelperSchema =+  Attrs+    '[ "addDefaults" ::. Attrs '[] ->. Attrs '[] ->. HerculesCISchema+     ]++getHerculesCI :: MonadEval m => HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema))+getHerculesCI homeExpr args = do+  home <- getHomeExprObject homeExpr+  args' <- Schema.uncheckedCast <$> toPSObject args+  case homeExpr of+    CiNix {} ->+      home #? #herculesCI+        >>= traverse @Maybe \herculesCI ->+          herculesCI $? args'+    Flake flake ->+      Just <$> do+        dh <- loadDefaultHerculesCI+        fn <- dh #. #addDefaults+        let flakeObj = basicAttrsWithProvenance flake $ Schema.Other "your flake"+        hci <- fn .$ flakeObj >>$. pure args'+        pure hci {Schema.provenance = Other "the herculesCI attribute of your flake (after adding defaults)"}++parseExtraInputs :: MonadEval m => PSObject ExtraInputsSchema -> m (Map ByteString InputDeclaration)+parseExtraInputs eis = dictionaryToMap eis >>= traverse parseInputDecl++parseInputDecl :: MonadEval m => PSObject InputDeclSchema -> m InputDeclaration+parseInputDecl d = do+  project <- d #. #project >>= fromPSObject+  ref <- d #? #ref >>= traverse fromPSObject+  pure $ SiblingInput $ MkSiblingInput {project = project, ref = ref}++-- | Given a path, return the onPush output or legacy ci.nix value+--+-- @@@+-- e.g.  ["a" "b"]  => ((import file).herculesCI args).onPush.a.outputs.b+--       or falling back to+--       ["a" "b"]  => (import file legacyArgs).a.b+-- @@@+getOnPushOutputValueByPath ::+  Ptr EvalState ->+  FilePath ->+  HerculesCIArgs ->+  -- | Resolve inputs to an attrset of fetched/fetchable stuff+  (Map ByteString InputDeclaration -> IO (Value NixAttrs)) ->+  [ByteString] ->+  IO (Maybe RawValue)+getOnPushOutputValueByPath 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++  -- No backtracking. It's either legacy or not...+  case onPush of+    Just jobs -> flip runReaderT evalState $ 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++resolveAndInvokeOutputs :: MonadEval m => PSObject OnPushSchema -> (Map ByteString InputDeclaration -> m (Value NixAttrs)) -> m (PSObject OutputsSchema)+resolveAndInvokeOutputs job resolveInputs = do+  inputs <- job #? #extraInputs >>= traverse parseExtraInputs+  resolved <- resolveInputs (fromMaybe mempty inputs)+  f <- job #. #outputs+  f $? (PSObject {provenance = Schema.Data, value = rtValue resolved})++attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)+attrByPath _ v [] = pure (Just v)+attrByPath evalState v (a : as) = do+  match' evalState v >>= \case+    IsAttrs attrs ->+      getAttr evalState attrs a+        >>= traverse (\attrValue -> attrByPath evalState attrValue as)+        & fmap join+    _ -> pure Nothing++loadDefaultHerculesCI :: (MonadEval m) => m (PSObject DefaultHerculesCIHelperSchema)+loadDefaultHerculesCI = do+  fname <- liftIO $ getDataFileName "data/default-herculesCI-for-flake.nix"+  evalState <- ask+  liftIO $ addAllowedPath evalState . encodeUtf8 . toS $ fname+  v <- liftIO $ evalFile evalState fname+  pure (PSObject {value = v, provenance = Other "<default herculesCI helper shim>"})

@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}++module Hercules.Agent.NixFile.CiNixArgs where++import Data.Aeson (ToJSON)+import Hercules.Agent.NixFile.GitSource (GitSource)+import Hercules.CNix.Expr (ToRawValue, ViaJSON (ViaJSON))+import Protolude++data CiNixArgs = CiNixArgs+  { src :: GitSource+  }+  deriving (Generic, ToJSON)+  deriving (ToRawValue) via (ViaJSON CiNixArgs)

@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}++module Hercules.Agent.NixFile.GitSource where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Text as T+import Hercules.CNix.Expr (ToRawValue, ViaJSON (ViaJSON))+import Protolude++data GitSource = GitSource+  { outPath :: Text,+    ref :: Text,+    rev :: Text,+    shortRev :: Text,+    branch :: Maybe Text,+    tag :: 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+    }

@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}++module Hercules.Agent.NixFile.HerculesCIArgs where++import Data.Aeson (ToJSON)+import Hercules.Agent.NixFile.GitSource (GitSource)+import qualified Hercules.Agent.NixFile.GitSource as GitSource+import Hercules.CNix.Expr (ToRawValue, ViaJSON (ViaJSON))+import Protolude++-- | Documented in @docs/modules/ROOT/pages/evaluation.adoc@.+data HerculesCIMeta = HerculesCIMeta+  { apiBaseUrl :: Text,+    ciSystems :: CISystems+  }+  deriving (Generic, ToJSON)++-- | Documented in @docs/modules/ROOT/pages/evaluation.adoc@.+data HerculesCIArgs = HerculesCIArgs+  { rev :: Text,+    shortRev :: Text,+    ref :: Text,+    branch :: Maybe Text,+    tag :: Maybe Text,+    primaryRepo :: GitSource,+    herculesCI :: HerculesCIMeta+  }+  deriving (Generic, ToJSON)+  deriving (ToRawValue) via (ViaJSON HerculesCIArgs)++newtype CISystems = CISystems (Maybe (Map Text ()))+  deriving (Generic, ToJSON)+  deriving (ToRawValue) via (ViaJSON CISystems)++fromGitSource :: GitSource -> HerculesCIMeta -> HerculesCIArgs+fromGitSource primary hci =+  HerculesCIArgs+    { rev = GitSource.rev primary,+      shortRev = GitSource.shortRev primary,+      ref = GitSource.ref primary,+      branch = GitSource.branch primary,+      tag = GitSource.tag primary,+      primaryRepo = primary,+      herculesCI = hci+    }

@@ -0,0 +1,27 @@+module Hercules.Agent.NixPath+  ( renderNixPath,+    renderNixPathElement,+    renderSubPath,+  )+where++import qualified Data.Text as T+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import Protolude++renderNixPath ::+  [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)] ->+  Text+renderNixPath = T.intercalate ":" . map renderNixPathElement++renderNixPathElement ::+  EvaluateTask.NixPathElement+    (EvaluateTask.SubPathOf FilePath) ->+  Text+renderNixPathElement pe =+  foldMap (<> "=") (EvaluateTask.prefix pe)+    <> renderSubPath (toS <$> EvaluateTask.value pe)++renderSubPath :: EvaluateTask.SubPathOf Text -> Text+renderSubPath sp =+  toS (EvaluateTask.path sp) <> foldMap ("/" <>) (EvaluateTask.subPath sp)

@@ -132,7 +132,7 @@   m a withBoundedDelayBatchProducer maxDelay maxItems sourceP f = do   UnliftIO {unliftIO = unlift} <- askUnliftIO-  flushes <- liftIO $ newTQueueIO+  flushes <- liftIO newTQueueIO   let producer writeBatch =         let beginReading = readItems (max 1 maxItems) []             doPerformBatch [] = pure ()@@ -173,7 +173,7 @@  syncer :: MonadIO m => (Syncing a -> m ()) -> m () syncer writer = do-  v <- liftIO $ atomically $ newEmptyTMVar+  v <- liftIO newEmptyTMVarIO   writer (Syncer $ putTMVar v)   mexc <- liftIO $ atomically $ readTMVar v   for_ mexc (liftIO . throwIO)

@@ -1,4 +1,3 @@-{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} 

@@ -1,6 +1,6 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-}  module Hercules.Agent.Socket@@ -14,7 +14,7 @@  import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue, newTBQueue, writeTBQueue) import Control.Concurrent.STM.TChan (TChan, writeTChan)-import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVar, readTVar, writeTVar)+import Control.Concurrent.STM.TVar (TVar, modifyTVar, readTVar, writeTVar) import Control.Monad.IO.Unlift import qualified Data.Aeson as A import Data.DList (DList, fromList)@@ -34,6 +34,7 @@ import Protolude hiding (atomically, handle, race, race_) import UnliftIO.Async (race, race_) import UnliftIO.Exception (handle)+import UnliftIO.STM (readTVarIO) import UnliftIO.Timeout (timeout) import Wuss (runSecureClientWith) @@ -44,12 +45,12 @@   }  syncIO :: Socket r w -> IO ()-syncIO = join . fmap atomically . atomically . sync+syncIO = atomically <=< atomically . sync  -- | Parameters to start 'withReliableSocket'. data SocketConfig ap sp m = SocketConfig   { makeHello :: m ap,-    checkVersion :: (sp -> m (Either Text ())),+    checkVersion :: sp -> m (Either Text ()),     baseURL :: URI,     path :: Text,     token :: ByteString@@ -93,13 +94,13 @@ runReliableSocket :: forall ap sp m. (A.ToJSON ap, A.FromJSON sp, MonadUnliftIO m, KatipContext m) => SocketConfig ap sp m -> TBQueue (Frame ap ap) -> TChan sp -> TVar Integer -> forall a. m a runReliableSocket socketConfig writeQueue serviceMessageChan highestAcked = katipAddNamespace "Socket" do   expectedAck <- liftIO $ newTVarIO Nothing-  (unacked :: TVar (DList (Frame Void ap))) <- atomically $ newTVar mempty-  (lastServiceN :: TVar Integer) <- atomically $ newTVar (-1)+  (unacked :: TVar (DList (Frame Void ap))) <- newTVarIO mempty+  (lastServiceN :: TVar Integer) <- newTVarIO (-1)   let katipExceptionContext e =         katipAddContext (sl "message" (displayException e))           . katipAddContext (sl "exception" (show e :: [Char]))       logWarningPause :: SomeException -> m ()-      logWarningPause e | Just (WS.ConnectionClosed) <- fromException e = do+      logWarningPause e | Just WS.ConnectionClosed <- fromException e = do         katipExceptionContext e $ logLocM InfoS "Socket closed. Reconnecting."         liftIO $ threadDelay 10_000_000       logWarningPause e | Just (WS.ParseException "not enough bytes") <- fromException e = do@@ -111,7 +112,7 @@       setExpectedAckForMsgs :: [Frame ap ap] -> m ()       setExpectedAckForMsgs msgs =         msgs-          & foldMap (\case Frame.Msg {n = n} -> Option $ Just $ Max n; _ -> mempty)+          & foldMap (\case Frame.Msg {n = n} -> Just $ Max n; _ -> mempty)           & traverse_ (\(Max n) -> setExpectedAck n)       send :: Connection -> [Frame ap ap] -> m ()       send conn = sendSorted . sortBy (compare `on` msgN)@@ -129,7 +130,7 @@       recv :: Connection -> m (Frame sp sp)       recv conn = do         withTimeout ackTimeout (FatalError "Hercules.Agent.Socket.recv timed out") $-          (liftIO $ A.eitherDecode <$> WS.receiveData conn) >>= \case+          liftIO (A.eitherDecode <$> WS.receiveData conn) >>= \case             Left e -> liftIO $ throwIO (FatalError $ "Error decoding service message: " <> toS e)             Right r -> pure r       handshake conn = katipAddNamespace "Handshake" do@@ -151,15 +152,15 @@         sendUnacked conn       sendUnacked :: Connection -> m ()       sendUnacked conn = do-        unackedNow <- atomically $ readTVar unacked-        send conn $ fmap (Frame.mapOob absurd) $ toList unackedNow+        unackedNow <- readTVarIO unacked+        send conn $ Frame.mapOob absurd <$> toList unackedNow       cleanAcknowledged newAck = atomically do         unacked0 <- readTVar unacked         writeTVar unacked $           unacked0             & toList             & filter-              ( \umsg -> case umsg of+              ( \case                   Frame.Msg {n = n} -> n > newAck                   Frame.Oob x -> absurd x                   Frame.Ack {} -> False@@ -184,7 +185,7 @@               cleanAcknowledged n             Frame.Oob o -> atomically do               writeTChan serviceMessageChan o-            Frame.Exception e -> katipAddContext (sl "message" e) $ logLocM WarningS $ "Service exception"+            Frame.Exception e -> katipAddContext (sl "message" e) $ logLocM WarningS "Service exception"       writeThread conn = katipAddNamespace "Writer" do         forever do           msgs <- atomically do@@ -198,7 +199,7 @@       setExpectedAck n = do         now <- liftIO getCurrentTime         atomically do-          writeTVar expectedAck $ Just $ (n, now)+          writeTVar expectedAck $ Just (n, now)       noAckCleanupThread = noAckCleanupThread' (-1)       noAckCleanupThread' confirmedLastTime = do         (expectedN, sendTime) <- atomically do@@ -230,7 +231,7 @@           readThread conn `race_` writeThread conn `race_` noAckCleanupThread  msgN :: Frame o a -> Maybe Integer-msgN (Frame.Msg {n = n}) = Just n+msgN Frame.Msg {n = n} = Just n msgN _ = Nothing  withConnection' :: (MonadUnliftIO m) => SocketConfig any0 any1 m -> (Connection -> m a) -> m a

@@ -0,0 +1,124 @@+module Hercules.Agent.WorkerProcess+  ( runWorker,+    getWorkerExe,+    WorkerEnvSettings (..),+    prepareEnv,+    modifyEnv,+  )+where++import Conduit hiding (Producer)+import qualified Control.Exception.Safe as Safe+import Control.Monad.IO.Unlift+import Data.Binary (Binary)+import Data.Conduit.Extras (conduitToCallbacks, sourceChan)+import Data.Conduit.Serialization.Binary+  ( conduitDecode,+    conduitEncode,+  )+import qualified Data.Map as M+import GHC.IO.Exception+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import Hercules.Agent.NixPath (renderNixPath)+import Paths_hercules_ci_agent (getBinDir)+import Protolude+import System.Environment (getEnvironment)+import System.FilePath ((</>))+import System.IO (hClose)+import System.IO.Error+import System.Process+import System.Timeout (timeout)+import Prelude ()++data WorkerException = WorkerException+  { originalException :: SomeException,+    exitStatus :: Maybe ExitCode+  }+  deriving (Show, Typeable)++instance Exception WorkerException where+  displayException we =+    displayException (originalException we)+      <> case exitStatus we of+        Nothing -> ""+        Just s -> " (worker: " <> show s <> ")"++data WorkerEnvSettings = WorkerEnvSettings+  { nixPath :: [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)],+    extraEnv :: Map [Char] [Char]+  }++-- | Filter out impure env vars by wildcard, set NIX_PATH+modifyEnv :: WorkerEnvSettings -> Map [Char] [Char] -> Map [Char] [Char]+modifyEnv workerEnvSettings =+  M.union (extraEnv workerEnvSettings)+    . M.insert "NIX_PATH" (toS $ renderNixPath $ nixPath workerEnvSettings)+    . M.filterWithKey (\k _v -> not ("NIXPKGS_" `isPrefixOf` k))+    . M.filterWithKey (\k _v -> not ("NIXOS_" `isPrefixOf` k))+    . M.delete "IN_NIX_SHELL"++prepareEnv :: WorkerEnvSettings -> IO [([Char], [Char])]+prepareEnv workerEnvSettings = do+  envMap <- M.fromList <$> getEnvironment+  pure $ M.toList $ modifyEnv workerEnvSettings envMap++getWorkerExe :: MonadIO m => m [Char]+getWorkerExe = do+  liftIO getBinDir <&> (</> "hercules-ci-agent-worker")++-- | Control a child process by communicating over stdin and stdout+-- using a 'Binary' interface.+runWorker ::+  (Binary command, Binary event, MonadUnliftIO m, MonadThrow m) =>+  -- | Process invocation details. Will ignore std_in, std_out and std_err fields.+  CreateProcess ->+  (Int -> ByteString -> m ()) ->+  Chan (Maybe command) ->+  (event -> m ()) ->+  m ExitCode+runWorker baseProcess stderrLineHandler commandChan eventHandler = do+  UnliftIO {unliftIO = unlift} <- askUnliftIO+  let createProcessSpec =+        baseProcess+          { std_in = CreatePipe,+            std_out = CreatePipe,+            std_err = CreatePipe+          }+  liftIO $+    withCreateProcess createProcessSpec $ \mIn mOut mErr processHandle -> do+      (inHandle, outHandle, errHandle) <-+        case (,,) <$> mIn <*> mOut <*> mErr of+          Just x -> pure x+          Nothing ->+            throwIO $+              mkIOError+                illegalOperationErrorType+                "Process did not return all handles"+                Nothing -- no handle+                Nothing -- no path+      pidMaybe <- liftIO $ getPid processHandle+      let pid = maybe 0 fromIntegral pidMaybe+      let stderrPiper =+            liftIO $+              runConduit+                (sourceHandle errHandle .| linesUnboundedAsciiC .| awaitForever (liftIO . unlift . stderrLineHandler pid))+      let eventConduit = sourceHandle outHandle .| conduitDecode+          commandConduit =+            sourceChan commandChan+              .| conduitEncode+              .| concatMapC (\x -> [Chunk x, Flush])+              .| handleC handleEPIPE (sinkHandleFlush inHandle)+          handleEPIPE e | ioeGetErrorType e == ResourceVanished = pure ()+          handleEPIPE e = throwIO e+      let cmdThread = runConduit commandConduit `finally` hClose outHandle+          eventThread = unlift $ conduitToCallbacks eventConduit eventHandler+      -- plain forkIO so it can process all of stderr in case of an exception+      void $ forkIO stderrPiper+      withAsync (waitForProcess processHandle) $ \exitAsync -> do+        withAsync cmdThread $ \_ -> do+          eventThread+            `Safe.catch` \e -> do+              let oneSecond = 1000 * 1000+              maybeStatus <- timeout (5 * oneSecond) (wait exitAsync)+              throwIO $ WorkerException e maybeStatus+          wait exitAsync

@@ -8,6 +8,7 @@ import Hercules.Agent.Sensitive import Hercules.Agent.WorkerProtocol.LogSettings import Hercules.Agent.WorkerProtocol.Orphans ()+import Hercules.Secrets (SecretContext) import Protolude  data Effect = Effect@@ -19,6 +20,7 @@     secretsPath :: FilePath,     token :: Sensitive Text,     projectId :: Id "project",-    projectPath :: Text+    projectPath :: Text,+    secretContext :: SecretContext   }   deriving (Generic, Binary, Show, Eq)

@@ -3,7 +3,11 @@ module Hercules.Agent.WorkerProtocol.Command.Eval where  import Data.Binary+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import Hercules.Agent.NixFile.GitSource (GitSource)+import Hercules.Agent.WorkerProtocol.Event (ViaJSON) import Hercules.Agent.WorkerProtocol.LogSettings+import Hercules.Agent.WorkerProtocol.Orphans () import Protolude  data Eval = Eval@@ -14,7 +18,13 @@     --   the next if you're running them in the same worker!     --   (as of now, we use one worker process per evaluation)     extraNixOptions :: [(Text, Text)],-    logSettings :: LogSettings+    gitSource :: ViaJSON GitSource,+    apiBaseUrl :: Text,+    logSettings :: LogSettings,+    selector :: ViaJSON EvaluateTask.Selector,+    ciSystems :: Maybe (Map Text ()),+    allowInsecureBuiltinFetchers :: Bool,+    allowedPaths :: [ByteString]   }   deriving (Generic, Binary, Show, Eq) 

@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command.StartDaemon where++import Data.Binary+import Protolude++data StartDaemon = StartDaemon+  { socketPath :: FilePath+  }+  deriving (Generic, Binary, Show, Eq)

@@ -1,13 +1,17 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Hercules.Agent.WorkerProtocol.Event where +import Control.Monad (fail)+import qualified Data.Aeson as A import Data.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.Agent.WorkerProtocol.Event.BuildResult-import Protolude+import Protolude hiding (get, put) import Prelude ()  data Event@@ -18,5 +22,19 @@   | Build ByteString Text (Maybe UUID)   | BuildResult BuildResult   | EffectResult Int+  | JobConfig+  | OnPushHandler (ViaJSON OnPushHandlerEvent)   | 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,10 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Event.DaemonStarted where++import Data.Binary+import Protolude++data DaemonStarted = DaemonStarted+  {_dummy :: Bool {- make its binary representation non-empty -}}+  deriving (Generic, Binary, Show, Eq)

@@ -1,7 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Hercules.Agent.WorkerProtocol.LogSettings where 

@@ -1,13 +1,25 @@-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Hercules.Agent.WorkerProtocol.Orphans where -import Control.Applicative ((<$>))-import Data.Binary+import Control.Monad.Fail (fail)+import qualified Data.Aeson as A+import Data.Binary (Binary (get, put)) import Hercules.API.Id (Id (..))+import Hercules.CNix.Expr (ViaJSON (ViaJSON))+import Protolude hiding (get, put) +-- | Orphan instance Binary (Id (a :: k)) where   put (Id uuid) = put uuid   get = Id <$> get++-- | 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)

@@ -7,20 +7,30 @@ import Control.Monad.Catch (MonadThrow) import qualified Data.Aeson as A import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M import Hercules.API.Id (Id, idText) import Hercules.Agent.Sensitive (Sensitive (Sensitive, reveal), revealContainer)+import Hercules.Agent.WorkerProcess (runWorker)+import qualified Hercules.Agent.WorkerProcess as WorkerProcess+import Hercules.Agent.WorkerProtocol.Command.StartDaemon (StartDaemon (StartDaemon))+import qualified Hercules.Agent.WorkerProtocol.Command.StartDaemon as StartDaemon+import Hercules.Agent.WorkerProtocol.Event.DaemonStarted (DaemonStarted (DaemonStarted)) import Hercules.CNix (Derivation) import Hercules.CNix.Store (getDerivationArguments, getDerivationBuilder, getDerivationEnv) import Hercules.Effect.Container (BindMount (BindMount)) import qualified Hercules.Effect.Container as Container import Hercules.Error (escalateAs) import qualified Hercules.Formats.Secret as Formats.Secret+import Hercules.Secrets (SecretContext, evalCondition, evalConditionTrace) import Katip (KatipContext, Severity (..), logLocM, logStr) import Protolude import System.FilePath+import UnliftIO (timeout)+import qualified UnliftIO import UnliftIO.Directory (createDirectory, createDirectoryIfMissing)+import qualified UnliftIO.Process as Process  parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text Text) parseDrvSecretsMap drvEnv =@@ -31,8 +41,8 @@       Right r -> Right r  -- | Write secrets to file based on secretsMap value-writeSecrets :: (MonadIO m, KatipContext m) => Maybe FilePath -> Map Text Text -> Map Text (Sensitive Formats.Secret.Secret) -> FilePath -> m ()-writeSecrets sourceFileMaybe secretsMap extraSecrets destinationDirectory = write . fmap reveal . addExtra =<< gather+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   where     addExtra = flip M.union extraSecrets     write = liftIO . BS.writeFile (destinationDirectory </> "secrets.json") . BL.toStrict . A.encode@@ -51,30 +61,53 @@            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 ->-                liftIO $-                  throwIO $-                    FatalError $-                      "Secret " <> secretName <> " does not exist, so we can't find a secret for " <> destinationName <> ". Please make sure that the secret name matches a secret on your agents."-              Just ssecret ->-                pure do-                  secret <- ssecret-                  -- Currently this is `id` but we might want to fork the-                  -- format here or omit some fields.-                  pure $-                    Formats.Secret.Secret-                      { data_ = Formats.Secret.data_ secret-                      }+              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  data RunEffectParams = RunEffectParams   { runEffectDerivation :: Derivation,     runEffectToken :: Maybe (Sensitive Text),     runEffectSecretsConfigPath :: Maybe FilePath,+    runEffectSecretContext :: Maybe SecretContext,     runEffectApiBaseURL :: Text,     runEffectDir :: FilePath,     runEffectProjectId :: Maybe (Id "project"),-    runEffectProjectPath :: Maybe Text+    runEffectProjectPath :: Maybe Text,+    runEffectUseNixDaemonProxy :: Bool,+    runEffectExtraNixOptions :: [(Text, Text)],+    -- | Whether we can relax security in favor of usability; 'True' in @hci effect run@. 'False' in agent.+    runEffectFriendly :: Bool   }  (=:) :: k -> a -> Map k a@@ -100,10 +133,11 @@                   tok <- token                   pure $                     Formats.Secret.Secret-                      { data_ = M.singleton "token" $ A.String tok+                      { data_ = M.singleton "token" $ A.String tok,+                        condition = Nothing                       }             )-  writeSecrets secretsPath drvSecretsMap extraSecrets (toS secretsDir)+  writeSecrets (runEffectFriendly p) (runEffectSecretContext p) secretsPath drvSecretsMap extraSecrets (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@@ -143,21 +177,61 @@             ]         (//) :: Ord k => Map k a -> Map k a -> Map k a         (//) = flip M.union-    Container.run-      runcDir-      Container.Config-        { extraBindMounts =-            [ BindMount {pathInContainer = "/build", pathInHost = buildDir, readOnly = False},-              BindMount {pathInContainer = "/etc", pathInHost = etcDir, readOnly = False},-              BindMount {pathInContainer = "/secrets", pathInHost = secretsDir, readOnly = True},-              -- we cannot bind mount this read-only because of https://github.com/opencontainers/runc/issues/1523-              BindMount {pathInContainer = "/etc/resolv.conf", pathInHost = "/etc/resolv.conf", readOnly = False},-              BindMount {pathInContainer = "/nix/var/nix/daemon-socket/socket", pathInHost = "/nix/var/nix/daemon-socket/socket", readOnly = True}-            ],-          executable = decodeUtf8With lenientDecode drvBuilder,-          arguments = map (decodeUtf8With lenientDecode) drvArgs,-          environment = overridableEnv // drvEnv' // onlyImpureOverridableEnv // impureEnvVars // fixedEnv,-          workingDirectory = "/build",-          hostname = "hercules-ci",-          rootReadOnly = False-        }+    let (withNixDaemonProxyPerhaps, forwardedSocketPath) =+          if runEffectUseNixDaemonProxy p+            then+              let socketPath = dir </> "nix-daemon-socket"+               in (withNixDaemonProxy (runEffectExtraNixOptions p) socketPath, socketPath)+            else (identity, "/nix/var/nix/daemon-socket/socket")++    withNixDaemonProxyPerhaps $+      Container.run+        runcDir+        Container.Config+          { extraBindMounts =+              [ BindMount {pathInContainer = "/build", pathInHost = buildDir, readOnly = False},+                BindMount {pathInContainer = "/etc", pathInHost = etcDir, readOnly = False},+                BindMount {pathInContainer = "/secrets", pathInHost = secretsDir, readOnly = True},+                -- we cannot bind mount this read-only because of https://github.com/opencontainers/runc/issues/1523+                BindMount {pathInContainer = "/etc/resolv.conf", pathInHost = "/etc/resolv.conf", readOnly = False},+                BindMount {pathInContainer = "/nix/var/nix/daemon-socket/socket", pathInHost = toS forwardedSocketPath, readOnly = True}+              ],+            executable = decodeUtf8With lenientDecode drvBuilder,+            arguments = map (decodeUtf8With lenientDecode) drvArgs,+            environment = overridableEnv // drvEnv' // onlyImpureOverridableEnv // impureEnvVars // fixedEnv,+            workingDirectory = "/build",+            hostname = "hercules-ci",+            rootReadOnly = False+          }++withNixDaemonProxy :: [(Text, Text)] -> FilePath -> IO a -> IO a+withNixDaemonProxy extraNixOptions socketPath wrappedAction = do+  workerExe <- WorkerProcess.getWorkerExe+  let opts = ["nix-daemon", show extraNixOptions]+      procSpec =+        (Process.proc workerExe opts)+          { -- Process.env = Just workerEnv,+            Process.close_fds = True+            -- Process.cwd = Just workDir+          }+  daemonCmdChan <- liftIO newChan+  daemonReadyVar <- liftIO newEmptyMVar+  let onDaemonEvent :: MonadIO m => DaemonStarted -> m ()+      onDaemonEvent DaemonStarted {} = liftIO (void $ tryPutMVar daemonReadyVar ())+  liftIO $ writeChan daemonCmdChan (Just $ Just $ StartDaemon {socketPath = socketPath})+  UnliftIO.withAsync (runWorker procSpec (\_ s -> liftIO (C8.hPutStrLn stderr ("hci proxy nix-daemon: " <> s))) daemonCmdChan onDaemonEvent) $ \daemonAsync -> do+    race (readMVar daemonReadyVar) (wait daemonAsync) >>= \case+      Left _ -> pass+      Right e -> throwIO $ FatalError $ "Hercules CI proxy nix-daemon exited before being told to; status " <> show e++    a <- wrappedAction++    timeoutResult <- timeout (60 * 1000 * 1000) $ do+      writeChan daemonCmdChan (Just Nothing)+      writeChan daemonCmdChan Nothing+      void $ wait daemonAsync+    case timeoutResult of+      Nothing -> putErrText "warning: Hercules CI proxy nix-daemon did not shut down in time."+      _ -> pass++    pure a

@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}++module Hercules.Secrets+  ( SecretContext (..),+    evalCondition,+    evalConditionTrace,+  )+where++import qualified Control.Monad.Writer+import Data.Binary (Binary)+import Data.Tagged+import qualified Data.Text as T+import Hercules.Formats.Secret+import Protolude++data SecretContext = SecretContext+  { ownerName :: Text,+    repoName :: Text,+    isDefaultBranch :: Bool,+    ref :: Text+  }+  deriving (Generic, Binary, Show, Eq)++evalCondition' :: (Monad m, MonadMiniWriter [Text] m) => SecretContext -> Condition -> m Bool+evalCondition' ctx = eval+  where+    eval (Or cs) = do+      tell ["or: Entering"]+      let go [] = do+            tell ["or: Leaving (false)"]+            pure False+          go (a : as) = do+            b <- eval a+            if b+              then do+                tell ["or: Leaving (true)"]+                pure True+              else do+                unless (null as) (tell ["or: Backtracking"])+                go as+      go cs+    eval (And cs) = do+      tell ["and: Entering"]+      let go [] = do+            tell ["and: Leaving (true)"]+            pure True+          go (a : as) = do+            b <- eval a+            if b+              then go as+              else do+                tell ["and: Leaving (false)"]+                pure False+      go cs+    eval IsDefaultBranch =+      if isDefaultBranch ctx+        then pure True+        else False <$ tell ["isDefaultBranch: ref " <> show (ref ctx) <> " is not the default branch"]+    eval IsTag =+      if "refs/tags/" `T.isPrefixOf` ref ctx+        then pure True+        else False <$ tell ["isTag: ref " <> show (ref ctx) <> " is not a tag"]+    eval (IsBranch b) = do+      let expect = "refs/heads/" <> b+          actual = ref ctx+      if expect == actual+        then pure True+        else False <$ tell ["isBranch: ref " <> show actual <> " is not the desired " <> show expect]+    eval (IsRepo expect) = do+      let actual = repoName ctx+      if actual == expect+        then pure True+        else False <$ tell ["isRepo: repo " <> show actual <> " is not the desired " <> show expect]+    eval (IsOwner expect) = do+      let actual = ownerName ctx+      if actual == expect+        then pure True+        else False <$ tell ["isOwner: owner " <> show actual <> " is not the desired " <> show expect]++-- This uses tagless final to derive both an efficient and a tracing function.++evalCondition :: SecretContext -> Condition -> Bool+evalCondition ctx c = unTagged (evalCondition' ctx c :: Tagged [Text] Bool)++evalConditionTrace :: SecretContext -> Condition -> ([Text], Bool)+evalConditionTrace = evalCondition'++-- | Like 'Control.Monad.Class.Writer.MonadWriter' but simpler.+class MonadMiniWriter w m | m -> w where+  tell :: w -> m ()++instance Monoid w => MonadMiniWriter w ((,) w) where+  tell = Control.Monad.Writer.tell++instance MonadMiniWriter w (Tagged w) where+  tell _ = pure ()

@@ -0,0 +1,16 @@+module Hercules.UserException where++import Control.Exception (Exception (displayException))+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Prelude (Show (..))++-- | 'Exception' representation of errors that may be caused by user error.+data UserException = UserException Text++instance Exception UserException where+  displayException = show++instance Show UserException where+  show (UserException msg) = "error: " <> T.unpack msg

@@ -9,10 +9,10 @@ spec :: Spec spec = do   describe "modifyEnv" $ do-    let baseEnvSettings = WorkerEnvSettings []+    let baseEnvSettings = WorkerEnvSettings [] mempty         baseEnv = M.fromList [("NIX_PATH", "")]     it "sets NIX_PATH" $ \() -> do-      modifyEnv (WorkerEnvSettings [NixPathElement (Just "a") $ SubPathOf "/b" Nothing]) mempty+      modifyEnv (WorkerEnvSettings [NixPathElement (Just "a") $ SubPathOf "/b" Nothing] mempty) mempty         `shouldBe` M.fromList [("NIX_PATH", "a=/b")]     it "filters out NIXPKGS_CONFIG" $ do       modifyEnv baseEnvSettings ("NIXPKGS_CONFIG" =: "abpuhasur")

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++module Hercules.SecretsSpec where++import Hercules.Formats.Secret (Condition (..))+import Hercules.Secrets (SecretContext (..), evalCondition, evalConditionTrace)+import Protolude+import Test.Hspec (Spec, describe, it, shouldBe)++condition :: Condition+condition =+  Or+    [ And+        [ IsOwner "unicorn",+          IsRepo "killer-app",+          -- normally, you'd specify one of these two:+          IsDefaultBranch,+          IsBranch "main"+        ],+      And+        [ IsOwner "unicorn",+          IsRepo "meta",+          IsTag+        ]+    ]++context1 :: SecretContext+context1 =+  SecretContext+    { ownerName = "unicorn",+      repoName = "killer-app",+      isDefaultBranch = True,+      ref = "refs/heads/main"+    }++context2 :: SecretContext+context2 =+  SecretContext+    { ownerName = "unicorn",+      repoName = "meta",+      isDefaultBranch = False,+      ref = "refs/tags/v4.2"+    }++spec :: Spec+spec = do+  describe "evalCondition" $ do+    it "accepts situation 1" $ do+      evalCondition+        SecretContext+          { ownerName = "unicorn",+            repoName = "killer-app",+            isDefaultBranch = True,+            ref = "refs/heads/main"+          }+        condition+        `shouldBe` True++    it "accepts situation 2" $ do+      evalCondition+        context2+        condition+        `shouldBe` True++    it "rejects non-matching owner, with trace" $ do+      evalConditionTrace+        SecretContext+          { ownerName = "mallory",+            repoName = "killer-app",+            isDefaultBranch = True,+            ref = "refs/heads/main"+          }+        condition+        `shouldBe` ( [ "or: Entering",+                       "and: Entering",+                       "isOwner: owner \"mallory\" is not the desired \"unicorn\"",+                       "and: Leaving (false)",+                       "or: Backtracking",+                       "and: Entering",+                       "isOwner: owner \"mallory\" is not the desired \"unicorn\"",+                       "and: Leaving (false)",+                       "or: Leaving (false)"+                     ],+                     False+                   )++    it "rejects non-matching repo" $ do+      evalCondition+        context1 {repoName = "dotfiles"}+        condition+        `shouldBe` False++    it "rejects non-default branch" $ do+      evalCondition+        context1 {isDefaultBranch = False}+        condition+        `shouldBe` False++    it "rejects branch" $ do+      evalCondition+        context1 {ref = "refs/heads/feat-foo"}+        condition+        `shouldBe` False++    it "rejects non-tag" $ do+      evalCondition+        context2 {ref = "refs/heads/main"}+        condition+        `shouldBe` False++    it "rejects mix and match" $ do+      evalCondition+        context1 {repoName = repoName context2}+        condition+        `shouldBe` False

@@ -6,6 +6,7 @@ import qualified Hercules.Agent.Nix.RetrieveDerivationInfoSpec import qualified Hercules.Agent.NixPathSpec import qualified Hercules.Agent.WorkerProcessSpec+import qualified Hercules.SecretsSpec import Test.Hspec  spec :: Spec@@ -13,3 +14,4 @@   describe "Hercules.Agent.NixPathSpec" Hercules.Agent.NixPathSpec.spec   describe "Hercules.Agent.WorkerProcessSpec" Hercules.Agent.WorkerProcessSpec.spec   describe "Hercules.Agent.Nix.RetrieveDerivationInfo" Hercules.Agent.Nix.RetrieveDerivationInfoSpec.spec+  describe "Hercules.Secret" Hercules.SecretsSpec.spec