packages feed

hercules-ci-agent (empty) → 0.7.1

raw patch · 73 files changed

+6648/−0 lines, 73 filesdep +aesondep +asyncdep +attoparsecsetup-changed

Dependencies added: aeson, async, attoparsec, base, base64-bytestring, binary, binary-conduit, bytestring, cachix, cachix-api, conduit, conduit-extra, containers, directory, dlist, exceptions, filepath, hercules-ci-agent, hercules-ci-api-agent, hercules-ci-api-core, hostname, hspec, http-client, http-client-tls, http-conduit, inline-c, inline-c-cpp, katip, lens, lens-aeson, lifted-async, lifted-base, monad-control, mtl, network, network-uri, optparse-applicative, process, protolude, safe-exceptions, servant, servant-auth-client, servant-client, servant-client-core, stm, temporary, text, time, tomland, transformers, transformers-base, unbounded-delays, unix, unliftio, unliftio-core, unordered-containers, uuid, vector, websockets, wuss

Files

+ CHANGELOG.md view
@@ -0,0 +1,288 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/)+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [Unreleased]++## [0.7.1] - 2020-06-17++### Added++ - Push to any nix store, including S3, using the `NixCache` kind in `binary-caches.json`++### Changed++ - Switch to Nixpkgs 20.03++ - Environment variables are now passed on to evaluation and build by default. This allows configuration to be passed to Nix without intervention from hercules-ci-agent.++ - `trusted-user` is not a requirement and is configured automatically when using the NixOS module or nix-darwin module.++### Fixed++ - Agent will now reset its connection with hercules-ci.com when pings are not acknowledged in time.++ - Prevent running out of file descriptors by increasing the soft limit if possible.++## [0.7.0] - 2020-05-05++### Known issues++ - Agent process user must be in `trusted-users`. This is the case with the NixOS and nix-darwin module. Doing so is recommended for ease of use and performance but should not be a requirement.++### Added++ - Jobs can be cancelled++ - Build logs are streamed in realtime++ - The build log now has timestamps and color++ - Distributed builds performance has improved by fetching fewer derivations++### Fixed++ - Extra nix options were not passed to the build process++## [0.6.6] - 2020-03-16++### Fixed++ - NixOS, nix-darwin modules: check the `nix-daemon` source and add option to patch an in-memory cache expiry issue+   causing errors in build clusters (of more than 1 machine). The module asks for confirmation.++ - **Manual action:** if you are not using the provided module and you run the agent on+   more than one machine, and you use `nix-daemon`, to fix above issue, you need to:+    - either upgrade your system's Nix to a recent `master` or version 2.4.0 when released,+    - or apply this patch to your system's Nix installation: https://github.com/NixOS/nix/pull/3405++ - Cachix: 0.3.5 -> [0.3.7](https://github.com/cachix/cachix/blob/master/cachix/CHANGELOG.md#037---2020-03-12) to prevent uploading bad NARs in rare cases.++## [0.6.5] - 2020-03-07++### Fixed++ - Work around a systemd behavior where it didn't restart the unit++### Added++ - `--test-configuration` flag to validate the configuration without actually running the agent.++## [0.6.4] - 2020-03-06++### Fixed++ - Fix a bug blocking evaluation when a store path is removed from cache or cache configuration is changed.++### Added++ - Cached builds to speed up `aarch64-linux` agent deployments.++### [0.6.3] - 2020-02-19++### Fixed++ - Fix a concurrency problem causing not all evaluation events to be written to server when evaluation fails.++ - Fix evaluation errors triggered by build outputs go missing from cache, by requesting a forced rebuild.++ - Fix blocked shutdown on NixOS, fix agent status in dashboard, by stopping agent before network shutdown #195.++ - Fix upload of large outputs by using the correct http client manager for Cachix, removing a timeout.++### Changed++ - Agent will now try to verify that the nix-daemon has narinfo-cache-negative-ttl = 0. This is required for correct operation.++### [0.6.2] - 2020-01-30++### Fixed++ - Update cachix to support the API change for the new CDN. This update is+   required for uploading sources and compressed outputs over 100MB in size.+   Please update.++### [0.6.1] - 2019-11-06++### Fixed++ - Fix token leak to system log when reporting an HTTP exception. This was introduced by a library upgrade.+   This was discovered after tagging 0.6.0 but before the release was+   announced and before moving of the `stable` branch.+   Only users of the `hercules-ci-agent` `master` branch and the unannounced+   tag were exposed to this leak.+   We recommend to follow the `stable` branch.++ - Temporarily revert a Nix GC configuration change that might cause problems+   until agent gc root behavior is improved.++### [0.6.0] - 2019-11-04++### Changed++ - Switch to Nix 2.3 and NixOS 19.09. *You should update your deployment to reflect the NixOS upgrade*, unless you're using terraform or nix-darwin, where it's automatic.+ - Increased parallellism during push to cachix+ - Switch to NixOS 19.09+ - Enable min-free/max-free Nix GC++### Fixed++ - Transient errors during source code fetching are now retried+ - Fixed a bug related to narinfo caching in the context of IFD+ - Fixed an exception when the root of ci.nix is a list, although lists are unsupported++## [0.5.0] - 2019-10-01++### Added++- Now deployable with [terraform-hercules-ci](https://github.com/hercules-ci/terraform-hercules-ci)++### Changed++- The `binary-caches.json` file can now be deployed like any other confidential file. Its contents are not required at module evaluation time any more.++- The `services.hercules-ci-agent.binaryCachesFile` option has been removed.++  **NixOps users**: rename to `deployment.keys."binary-caches.json".file`++  **Others**: remove your `binaryCachesFile` value. Make sure `binary-caches.json` is deployed.++- The `binary-caches.json` file is now required. The empty object `{}` is a+  valid file, but we highly recommend to configure a cache.+++### Fixed++ - The agent will now actually auto-restart when the secrets files change.+++## [0.4.0] - 2019-08-30++### Added++- Support for import-from-derivation. See https://blog.hercules-ci.com/2019/08/30/native-support-for-import-for-derivation/ for details.++### Changed+++- Report build failures and technical errors (misconfigurations, etc) separately++- Remove HerculesScribe++- Worker now uses structured logging (including worker pid, etc)++### Fixed++- Disable parallel GHC GC to improve runtime performance++- Bump Cachix to fix a few bugs (errors with too many derivations, performance fixes, etc.)++ - Modern BoehmGC initial settings for Nix memory limits ++## [0.3.2] - 2019-08-11++### Fixed++- Deploying the agent from different system (darwin to linux) resulted into+  using the wrong executable+++## [0.3.1] - 2019-08-07++### Changed++- Emit a log when evaluator starts to push to cachix++- Increase attribute limit to 50k++- Pin nixpkgs commit and speed up compilation via https://hercules-ci.cachix.org+++### Fixed++- Possible exception during evaluation was not propagated,+  resulting into lack of retries++- #8: Refresh agent session on cluster join token change++- Fix segfault on involved IFD project (remove a finalizer)++- Cachix: fix a crash with a lot of attributes (when determining closure graph)++## [0.3.0] - 2019-07-05++### Changed++- Configuration of the agent is now done via `--config agent.toml`+  so all command line arguments were removed.++  See https://docs.hercules-ci.com/#agent-configuration-file++- NixOS-based deployments now require `enable`.++      services.hercules-ci-agent.enable = true;++- All files are placed/expected in new locations that by default derive+  from the `baseDirectory` option in the `agent.toml` file.++  You may remove `~/.hercules-ci-agent` and `~/.local/share/hercules-ci-agent` after upgrading.++### Fixed++- Added retries to status reporting to fix potential+  inconsistencies on the service++### Added++- Added Cachix support, for multi-agent and multi-platform support++- Report derivation outputs with their size and hashes++- Added Darwin support via nix-darwin++- Support `requiredFeatures` attribute on derivations++- Hello and hearthbeat protocol, which will allow the+  service to be aware of how the agent is configured and+  when it's online.++## [0.2] - 2019-05-14++- use [gitignore] instead of [nix-gitignore]+- fix build on Darwin+- limit internal concurrency to max eight OS threads for beefier machines+- show version on `--help`+- build against NixOS 19.03 as default+- propagate agent information to agent view: Nix version, substituters,+  platform and Nix features++## [0.1.1] - 2019-04-16++### Added++- Support ci.nix or nix/ci.nix along with default.nix++## [0.1.0.0] - 2019-03-28++- Initial release++[0.6.6]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.4...hercules-ci-agent-0.6.6+[0.6.5]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.3...hercules-ci-agent-0.6.5+[0.6.4]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.3...hercules-ci-agent-0.6.4+[0.6.3]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.2...hercules-ci-agent-0.6.3+[0.6.2]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.1...hercules-ci-agent-0.6.2+[0.6.1]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.6.0...hercules-ci-agent-0.6.1+[0.6.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.5.0...hercules-ci-agent-0.6.0+[0.5.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.4.0...hercules-ci-agent-0.5.0+[0.4.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.3.2...hercules-ci-agent-0.4.0+[0.3.2]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.3.1...hercules-ci-agent-0.3.2+[0.3.1]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.3.0...hercules-ci-agent-0.3.1+[0.3.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.2...hercules-ci-agent-0.3.0+[0.2]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.1.1...hercules-ci-agent-0.2+[0.1.1]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.1.0.0...hercules-ci-agent-0.1.1+[Unreleased]: https://github.com/hercules-ci/hercules-ci-agent/compare/stable...master+[nix-gitignore]: https://github.com/siers/nix-gitignore+[gitignore]: https://github.com/hercules-ci/gitignore
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ cbits/aliases.h view
@@ -0,0 +1,24 @@+#pragma once++#include "hercules-store.hh"+#include "hercules-logger.hh"+#include "derivations.hh"++// inline-c-cpp doesn't seem to handle namespace operator or template+// syntax so we help it a bit for now. This definition can be inlined+// when it is supported by inline-c-cpp.+typedef nix::ref<nix::Store> refStore;++typedef nix::ref<HerculesStore> refHerculesStore;++typedef nix::Logger::Fields LoggerFields;++typedef HerculesLogger::LogEntry HerculesLoggerEntry;+typedef std::queue<std::unique_ptr<HerculesLogger::LogEntry>> LogEntryQueue;++typedef nix::Strings::iterator StringsIterator;+typedef nix::DerivationOutputs::iterator DerivationOutputsIterator;+typedef nix::DerivationInputs::iterator DerivationInputsIterator;+typedef nix::StringPairs::iterator StringPairsIterator;++using namespace std;
+ cbits/hercules-logger.cc view
@@ -0,0 +1,90 @@+#include "hercules-logger.hh"++HerculesLogger::HerculesLogger()+{++}++void HerculesLogger::push(std::unique_ptr<LogEntry> entry) {+  auto state(state_.lock());+  state->queue.push(std::move(entry));+  wakeup.notify_one();+}++uint64_t HerculesLogger::getMs() {+  auto t = std::chrono::steady_clock::now();+  auto millis = std::chrono::duration_cast<std::chrono::milliseconds>(t - t_zero).count();+  return millis;+}++void HerculesLogger::log(nix::Verbosity lvl, const nix::FormatOrString & fs) {+  push(std::make_unique<LogEntry>(LogEntry {+    .entryType = 1,+    .level = lvl,+    .ms = getMs(),+    .text = fs.s+  }));+}++void HerculesLogger::startActivity(nix::ActivityId act, nix::Verbosity lvl, nix::ActivityType type,+    const std::string & s, const Fields & fields, nix::ActivityId parent) {+  push(std::make_unique<LogEntry>(LogEntry {+    .entryType = 2,+    .level = lvl,+    .ms = getMs(),+    .text = s,+    .activityId = act,+    .type = type,+    .parent = parent,+    .fields = fields+  }));+}++void HerculesLogger::stopActivity(nix::ActivityId act) {+  push(std::make_unique<LogEntry>(LogEntry {+    .entryType = 3,+    .ms = getMs(),+    .activityId = act+  }));+}++void HerculesLogger::result(nix::ActivityId act, nix::ResultType type, const Fields & fields) {+  push(std::make_unique<LogEntry>(LogEntry {+    .entryType = 4,+    .ms = getMs(),+    .activityId = act,+    .type = type,+    .fields = fields+  }));+}++void HerculesLogger::close() {+  auto state(state_.lock());+  state->queue.push(nullptr);+  wakeup.notify_one();+}++std::unique_ptr<HerculesLogger::LogEntry> HerculesLogger::pop () {+  auto state(state_.lock());++  while (state->queue.empty())+    state.wait(wakeup);++  auto r = std::move(state->queue.front());+  state->queue.pop();+  return r;+}++void HerculesLogger::popMany (int max, std::queue<std::unique_ptr<LogEntry>> &out) {+  auto state(state_.lock());++  while (state->queue.empty())+    state.wait(wakeup);++  for (int i = 0; i < max && !state->queue.empty(); i++) {+    out.push(std::move(state->queue.front()));+    state->queue.pop();+  }+}++HerculesLogger *herculesLogger = nullptr;
+ cbits/hercules-logger.hh view
@@ -0,0 +1,55 @@+#pragma once++#include <nix/config.h>+#include <nix/shared.hh>+#include <nix/sync.hh>+#include <nix/logging.hh>+#include <queue>+#include <string>+#include <chrono>++class HerculesLogger : public nix::Logger {++public:+  struct LogEntry;++private:++  std::chrono::time_point<std::chrono::steady_clock> t_zero = std::chrono::steady_clock::now();++  struct State {+    std::queue<std::unique_ptr<LogEntry>> queue;+  };+  nix::Sync<State> state_;+  std::condition_variable wakeup;++  void push(std::unique_ptr<LogEntry> entry);+  uint64_t getMs();++ public:+  HerculesLogger();++  struct LogEntry {+    int entryType;+    int level;+    uint64_t ms;+    std::string text;+    uint64_t activityId;+    uint64_t type;+    uint64_t parent;+    Fields fields;+  };++  void log(nix::Verbosity lvl, const nix::FormatOrString & fs) override;+  void startActivity(nix::ActivityId act, nix::Verbosity lvl, nix::ActivityType type,+      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;++  std::unique_ptr<LogEntry> pop();+  void popMany(int max, std::queue<std::unique_ptr<LogEntry>> &out);++  void close();+};++extern HerculesLogger *herculesLogger;
+ cbits/hercules-store.cc view
@@ -0,0 +1,271 @@+#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/affinity.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);+    builderCallback(strdup(path.c_str()), &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);+    builderCallback(strdup(path.c_str()), &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)(const char *, std::exception_ptr *exceptionToThrow)) {+  builderCallback = newBuilderCallback;+}
+ cbits/hercules-store.hh view
@@ -0,0 +1,150 @@+#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/affinity.hh>+#include <nix/globals.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)(const char *, 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)(const char *, std::exception_ptr *exceptionToThrow));++  void inhibitBuilds();+  void uninhibitBuilds();+};
+ hercules-ci-agent-worker/Hercules/Agent/Worker.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NumericUnderscores #-}++module Hercules.Agent.Worker+  ( main,+  )+where++import CNix+import qualified CNix.Internal.Raw+import Conduit+import Control.Concurrent.STM+import qualified Data.ByteString as BS+import qualified Data.Conduit+import Data.Conduit.Extras (sinkChan, sinkChanTerminate, sourceChan)+import Data.Conduit.Serialization.Binary+  ( conduitDecode,+    conduitEncode,+  )+import Data.IORef+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Typeable (typeOf)+import Data.UUID (UUID)+import Data.Vector (Vector)+import qualified Data.Vector as V+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.LogMessage (LogMessage)+import qualified Hercules.API.Logs.LogMessage as LogMessage+import qualified Hercules.Agent.Socket as Socket+import Hercules.Agent.Worker.Build+import qualified Hercules.Agent.Worker.Build.Logger as Logger+import qualified Hercules.Agent.WorkerProtocol.Command as Command+import Hercules.Agent.WorkerProtocol.Command+  ( Command,+  )+import Hercules.Agent.WorkerProtocol.Command.Build (Build)+import qualified Hercules.Agent.WorkerProtocol.Command.Build as Build+import qualified Hercules.Agent.WorkerProtocol.Command.BuildResult as BuildResult+import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval+import Hercules.Agent.WorkerProtocol.Command.Eval+  ( Eval,+  )+import qualified Hercules.Agent.WorkerProtocol.Event as Event+import Hercules.Agent.WorkerProtocol.Event+  ( Event (Exception),+  )+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 Katip+import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Network.URI+import Protolude hiding (bracket, evalState)+import qualified System.Environment as Environment+import System.IO (BufferMode (LineBuffering), hSetBuffering)+import System.Timeout (timeout)+import UnliftIO.Exception (bracket)+import Prelude ()+import qualified Prelude++data HerculesState+  = HerculesState+      { drvsCompleted :: TVar (Map Text (UUID, BuildResult.BuildStatus)),+        drvsInProgress :: IORef (Set Text),+        herculesStore :: Ptr (Ref HerculesStore),+        wrappedStore :: Ptr (Ref NixStore),+        shortcutChannel :: Chan (Maybe Event)+      }++data BuildException+  = BuildException+      { buildExceptionDerivationPath :: Text,+        buildExceptionDetail :: Maybe Text+      }+  deriving (Show, Typeable)++instance Exception BuildException++main :: IO ()+main = do+  hSetBuffering stderr LineBuffering+  CNix.init+  Logger.initLogger+  [options] <- Environment.getArgs+  -- narinfo-cache-negative-ttl: Always try requesting narinfos because it may have been built in the meanwhile+  let allOptions = Prelude.read options ++ [("narinfo-cache-negative-ttl", "0")]+  for_ allOptions $ \(k, v) -> do+    setGlobalOption k v+    setOption k v+  drvsCompleted_ <- newTVarIO mempty+  drvsInProgress_ <- newIORef mempty+  withStore $ \wrappedStore_ -> withHerculesStore wrappedStore_ $ \herculesStore_ -> do+    setBuilderCallback herculesStore_ mempty+    ch <- liftIO newChan+    let st = HerculesState+          { drvsCompleted = drvsCompleted_,+            drvsInProgress = drvsInProgress_,+            herculesStore = herculesStore_,+            wrappedStore = wrappedStore_,+            shortcutChannel = ch+          }+    let runner =+          ( ( do+                command <- runConduitRes -- Res shouldn't be necessary+                  ( sourceHandle stdin+                      .| conduitDecode+                      .| printCommands+                      .| await+                  )+                  >>= \case+                    Just c -> pure c+                    Nothing -> panic "Not a valid starting command"+                runCommand st ch command+            )+              `catch` ( \e -> do+                          writeChan ch (Just $ Exception (renderException (e :: SomeException)))+                          exitFailure+                      )+          )+            `finally` ( do+                          writeChan ch Nothing+                          putErrText "runner done"+                      )+        writer =+          runConduitRes+            ( sourceChan ch+                .| conduitEncode+                .| concatMapC (\x -> [Chunk x, Flush])+                .| sinkHandleFlush stdout+            )+    void $ do+      withAsync runner $ \runnerAsync -> do+        writer -- runner can stop writer only by passing Nothing in channel (finally)+        putErrText "Writer done"+        wait runnerAsync -- include the potential exception++printCommands :: ConduitT Command Command (ResourceT IO) ()+printCommands =+  mapMC+    ( \x -> do+        liftIO $ hPutStrLn stderr ("Received command: " <> show x :: Text)+        pure x+    )++renderException :: SomeException -> Text+renderException e | Just (C.CppStdException msg) <- fromException e = toSL msg+renderException e+  | Just (C.CppOtherException maybeType) <- fromException e =+    "Unexpected C++ exception" <> foldMap (\t -> " of type " <> toSL t) maybeType+renderException e | Just (FatalError msg) <- fromException e = msg+renderException e = toS $ displayException e++connectCommand :: Chan (Maybe Event) -> ConduitM Command Event (ResourceT IO) () -> IO ()+connectCommand ch conduit =+  runConduitRes+    ( sourceHandle stdin+        .| conduitDecode+        .| printCommands+        .| conduit+        .| sinkChan ch+    )++runCommand :: HerculesState -> Chan (Maybe Event) -> Command -> IO ()+-- runCommand' :: HerculesState -> Command -> ConduitM Command Event (ResourceT IO) ()+runCommand herculesState ch command = do+  -- TODO don't do this+  mainThread <- liftIO $ myThreadId+  case command of+    Command.Eval eval -> connectCommand ch $ do+      void $ liftIO+        $ flip+          forkFinally+          ( \eeu -> case eeu of+              Left e -> throwIO $ FatalError $ "Failed to fork: " <> show e+              Right _ -> pure ()+          )+        $ runConduitRes+          ( Data.Conduit.handleC+              ( \e -> do+                  hPutStrLn stderr $ "Caught exception: " <> renderException e+                  yield $ Event.Error (renderException e)+                  liftIO $ throwTo mainThread e+              )+              ( do+                  runEval herculesState eval+                  liftIO $ throwTo mainThread ExitSuccess+              )+              .| sinkChanTerminate (shortcutChannel herculesState)+          )+      awaitForever $ \case+        Command.BuildResult (BuildResult.BuildResult path attempt result) -> do+          hPutStrLn stderr $ ("BuildResult: " <> show path <> " " <> show result :: Text)+          liftIO $ atomically $ modifyTVar (drvsCompleted herculesState) (M.insert path (attempt, result))+        _ -> pass+    Command.Build build ->+      Logger.withLoggerConduit (logger build) $ do+        connectCommand ch $ runBuild (wrappedStore herculesState) build+    _ ->+      panic "Not a valid starting command"++logger :: Build -> ConduitM () (Vector LogEntry) IO () -> IO ()+logger buildCommand entriesSource = do+  socketConfig <- makeSocketConfig buildCommand+  -- TODO integrate katip more+  withKatip $ Socket.withReliableSocket socketConfig $ \socket -> katipAddNamespace "Build" do+    let conduit =+          entriesSource+            .| Logger.unbatch+            .| Logger.filterProgress+            .| renumber 0+            .| batchAndEnd+            .| socketSink socket+        batch = Logger.batch .| mapC (LogMessage.LogEntries . V.fromList)+        batchAndEnd =+          ( (foldMapTap (Last . ims) `fuseUpstream` batch) >>= \case+              Last (Just (i, ms)) -> yield $ LogMessage.End {i = i + 1, ms = ms}+              Last Nothing -> yield $ LogMessage.End 0 0+          )+          where+            ims (Chunk logEntry) = Just (LogEntry.i logEntry, LogEntry.ms logEntry)+            ims _ = Nothing+        renumber i = await >>= traverse_ \case+          Flush -> yield Flush >> renumber i+          Chunk e -> do+            yield $ Chunk e {LogEntry.i = i}+            renumber (i + 1)+    liftIO $ runConduit $ conduit+    logLocM DebugS "Syncing"+    liftIO (timeout 600_000_000 $ Socket.syncIO $ socket) >>= \case+      Just _ -> pass+      Nothing -> panic "Could not push logs within 10 minutes after completion"+    logLocM DebugS "Logger done"++socketSink :: MonadIO m => Socket.Socket r w -> ConduitT w o m ()+socketSink socket = awaitForever $ liftIO . atomically . Socket.write socket++-- | Perform a foldMap while yielding the original values ("tap").+--+-- '<>' is invoked with the new b on the right.+foldMapTap :: (Monoid b, Monad m) => (a -> b) -> ConduitT a a m b+foldMapTap f = go mempty+  where+    go b = await >>= \case+      Nothing -> pure b+      Just a -> do+        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+  handleScribe <- liftIO $ mkHandleScribeWithFormatter format (ColorLog False) stderr (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 :: Monad m => Build -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m)+makeSocketConfig Build.Build {logSettings = l} = do+  baseURL <- case Network.URI.parseURI $ toS $ LogSettings.baseURL l of+    Just x -> pure x+    Nothing -> panic "LogSettings: invalid base url"+  pure Socket.SocketConfig+    { makeHello = pure (LogMessage.LogEntries mempty),+      checkVersion = Socket.checkVersion',+      baseURL = baseURL,+      path = LogSettings.path l,+      token = toSL $ LogSettings.reveal $ LogSettings.token l+    }++-- TODO: test+autoArgArgs :: Map Text Eval.Arg -> [ByteString]+autoArgArgs kvs = do+  (k, v) <- M.toList kvs+  case v of+    Eval.LiteralArg s -> ["--argstr", toS k, s]+    Eval.ExprArg s -> ["--arg", toS k, s]++withDrvInProgress :: HerculesState -> Text -> IO a -> IO a+withDrvInProgress HerculesState {drvsInProgress = ref} drvPath =+  bracket acquire release . const+  where+    acquire =+      join $ atomicModifyIORef ref $ \inprg ->+        if drvPath `S.member` inprg+          then (inprg, throwIO $ FatalError "Refusing to build derivation that should have been built remotely. Presumably, substitution has failed.")+          else (S.insert drvPath inprg, pass)+    release _ =+      atomicModifyIORef ref $ \inprg ->+        (S.delete drvPath inprg, ())++anyAlternative :: (Foldable l, Alternative f) => l a -> f a+anyAlternative = getAlt . foldMap (Alt . pure)++yieldAttributeError :: Monad m => [ByteString] -> SomeException -> ConduitT i Event m ()+yieldAttributeError path e+  | (Just e') <- fromException e =+    yield $ Event.AttributeError $ AttributeError.AttributeError+      { AttributeError.path = path,+        AttributeError.message =+          "Could not build derivation " <> buildExceptionDerivationPath e'+            <> ", which is required during evaluation."+            <> foldMap (" " <>) (buildExceptionDetail e'),+        AttributeError.errorDerivation = Just (buildExceptionDerivationPath e'),+        AttributeError.errorType = Just "BuildException"+      }+yieldAttributeError path e =+  yield $ Event.AttributeError $ AttributeError.AttributeError+    { AttributeError.path = path,+      AttributeError.message = renderException e,+      AttributeError.errorDerivation = Nothing,+      AttributeError.errorType = Just (show (typeOf e))+    }++maybeThrowBuildException :: MonadIO m => BuildResult.BuildStatus -> Text -> m ()+maybeThrowBuildException result plainDrvText =+  case result of+    BuildResult.Failure -> throwIO $ BuildException plainDrvText Nothing+    BuildResult.DependencyFailure -> throwIO $ BuildException plainDrvText (Just "A dependency could not be built.")+    BuildResult.Success -> pass++runEval :: HerculesState -> Eval -> ConduitM i Event (ResourceT IO) ()+runEval st@HerculesState {herculesStore = hStore, shortcutChannel = shortcutChan, drvsCompleted = drvsCompl} eval = do+  for_ (Eval.extraNixOptions eval) $ liftIO . uncurry setGlobalOption+  for_ (Eval.extraNixOptions eval) $ liftIO . uncurry setOption+  do+    let store = nixStore hStore+    s <- storeUri store+    liftIO $ setBuilderCallback hStore $ \path -> do+      hPutStrLn stderr ("Building " <> show path :: Text)+      let (plainDrv, bangOut) = BS.span (/= fromIntegral (ord '!')) path+          outputName = BS.dropWhile (== fromIntegral (ord '!')) bangOut+          plainDrvText = toS plainDrv+      withDrvInProgress st plainDrvText $ do+        writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) Nothing+        derivation <- getDerivation store plainDrv+        outputPath <- getDerivationOutputPath derivation outputName+        hPutStrLn stderr ("Naive ensurePath " <> outputPath)+        ensurePath (wrappedStore st) outputPath `catch` \e0 -> do+          hPutStrLn stderr ("Naive wrapped.ensurePath failed: " <> show (e0 :: SomeException) :: Text)+          (attempt0, result) <-+            liftIO $ atomically $ do+              c <- readTVar drvsCompl+              anyAlternative $ M.lookup plainDrvText c+          maybeThrowBuildException result plainDrvText+          clearSubstituterCaches+          clearPathInfoCache store+          ensurePath (wrappedStore st) outputPath `catch` \e1 -> do+            hPutStrLn stderr ("Fresh ensurePath failed: " <> show (e1 :: SomeException) :: Text)+            writeChan shortcutChan $ Just $ Event.Build plainDrvText (toSL outputName) (Just attempt0)+            -- TODO sync+            result' <-+              liftIO $ atomically $ do+                c <- readTVar drvsCompl+                (attempt1, r) <- anyAlternative $ M.lookup plainDrvText c+                guard (attempt1 /= attempt0)+                pure r+            maybeThrowBuildException result' plainDrvText+            clearSubstituterCaches+            clearPathInfoCache store+            ensurePath (wrappedStore st) outputPath `catch` \e2 -> do+              throwIO $+                BuildException+                  plainDrvText+                  ( Just $+                      "It could not be retrieved on the evaluating agent, despite a successful rebuild. Exception: "+                        <> show (e2 :: SomeException)+                  )+      hPutStrLn stderr ("Built " <> show path :: Text)+    hPutStrLn stderr ("Store uri: " <> s)+    withEvalState store $ \evalState -> do+      hPutStrLn stderr ("EvalState loaded." :: Text)+      args <-+        liftIO $+          evalArgs evalState (autoArgArgs (Eval.autoArguments eval))+      Data.Conduit.handleC (yieldAttributeError []) $+        do+          imprt <- liftIO $ evalFile evalState (toS $ Eval.file eval)+          applied <- liftIO (autoCallFunction evalState imprt args)+          walk evalState args applied+      yield Event.EvaluationDone++walk ::+  Ptr EvalState ->+  Bindings ->+  RawValue ->+  ConduitT i Event (ResourceT IO) ()+walk evalState = walk' True [] 10+  where+    handleErrors path = Data.Conduit.handleC (yieldAttributeError path)+    walk' ::+      -- | If True, always walk this attribute set. Only True for the root.+      Bool ->+      -- | Attribute path+      [ByteString] ->+      -- | Depth of tree remaining+      Integer ->+      -- | Auto arguments to pass to (attrset-)functions+      Bindings ->+      -- | Current node of the walk+      RawValue ->+      -- | Program that performs the walk and emits 'Event's+      ConduitT i1 Event (ResourceT IO) ()+    walk' forceWalkAttrset path depthRemaining autoArgs v =+      -- liftIO $ hPutStrLn stderr $ "Walking " <> (show path :: Text)+      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 do+                    drvPath <- getDrvFile evalState v+                    yield $+                      Event.Attribute Attribute.Attribute+                        { Attribute.path = path,+                          Attribute.drv = drvPath+                        }+                  else do+                    walkAttrset <-+                      if forceWalkAttrset+                        then pure True+                        else-- Hydra doesn't seem to obey this, because it walks the+                        -- x64_64-linux etc attributes per package. Maybe those+                        -- are special cases?+                        -- For now, we will assume that people don't build a whole Nixpkgs+                          liftIO $ getRecurseForDerivations evalState attrValue+                    isfunctor <- liftIO $ isFunctor evalState v+                    if isfunctor && walkAttrset+                      then do+                        x <- liftIO (autoCallFunction evalState v autoArgs)+                        walk' True path (depthRemaining - 1) autoArgs x+                      else do+                        attrs <- liftIO $ getAttrs attrValue+                        void+                          $ flip M.traverseWithKey attrs+                          $ \name value ->+                            when (depthRemaining > 0 && walkAttrset) $+                              walk' -- TODO: else warn+                                False+                                (path ++ [name])+                                (depthRemaining - 1)+                                autoArgs+                                value+              _any -> liftIO $ do+                vt <- rawValueType v+                unless+                  ( lastMay path+                      == Just "recurseForDerivations"+                      && vt+                      == CNix.Internal.Raw.Bool+                  )+                  $ hPutStrLn stderr+                  $ "Ignoring "+                    <> show path+                    <> " : "+                    <> (show vt :: Text)+                pass
+ hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs view
@@ -0,0 +1,52 @@+module Hercules.Agent.Worker.Build where++import CNix+import CNix.Internal.Context (Derivation)+import Cachix.Client.Store (Store, queryPathInfo, validPathInfoNarHash, validPathInfoNarSize)+import Conduit+import Foreign (ForeignPtr)+import Hercules.Agent.Worker.Build.Prefetched (buildDerivation)+import qualified Hercules.Agent.Worker.Build.Prefetched as Build+import qualified Hercules.Agent.WorkerProtocol.Command.Build as Command.Build+import Hercules.Agent.WorkerProtocol.Event (Event)+import qualified Hercules.Agent.WorkerProtocol.Event as Event+import qualified Hercules.Agent.WorkerProtocol.Event.BuildResult as Event.BuildResult+import Protolude+import Unsafe.Coerce++runBuild :: Ptr (Ref NixStore) -> Command.Build.Build -> ConduitT i Event (ResourceT IO) ()+runBuild store build = do+  let extraPaths = Command.Build.inputDerivationOutputPaths build+      drvPath = toS $ Command.Build.drvPath build+  for_ extraPaths $ \input ->+    liftIO $ CNix.ensurePath store input+  derivationMaybe <- liftIO $ Build.getDerivation store drvPath+  derivation <- case derivationMaybe of+    Just drv -> pure drv+    Nothing -> panic $ "Could not retrieve derivation " <> show drvPath <> " from local store or binary caches."+  nixBuildResult <- liftIO $ buildDerivation store drvPath derivation (extraPaths <$ guard (not (Command.Build.materializeDerivation build)))+  liftIO $ putErrText $ show nixBuildResult+  buildResult <- liftIO $ enrichResult store derivation nixBuildResult+  yield $ Event.BuildResult buildResult++-- TODO: case distinction on BuildStatus enumeration+enrichResult :: Ptr (Ref NixStore) -> ForeignPtr Derivation -> Build.BuildResult -> IO Event.BuildResult.BuildResult+enrichResult _ _ result@Build.BuildResult {isSuccess = False} = pure $+  Event.BuildResult.BuildFailure {errorMessage = Build.errorMessage result}+enrichResult store derivation _ = do+  drvOuts <- getDerivationOutputs derivation+  outputInfos <- for drvOuts $ \drvOut -> do+    vpi <- queryPathInfo (coerceStore store) (derivationOutputPath drvOut)+    hash_ <- validPathInfoNarHash vpi+    let size = validPathInfoNarSize vpi+    pure Event.BuildResult.OutputInfo+      { name = derivationOutputName drvOut,+        path = derivationOutputPath drvOut,+        hash = hash_,+        size = size+      }+  pure $ Event.BuildResult.BuildSuccess outputInfos++-- TODO factor out cnix library and avoid unsafeCoerce https://github.com/hercules-ci/hercules-ci-agent/issues/223+coerceStore :: Ptr (Ref NixStore) -> Store+coerceStore = unsafeCoerce
+ hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Hercules.Agent.Worker.Build.Logger where++import CNix.Internal.Context+import Conduit (filterC)+import Data.ByteString.Unsafe (unsafePackMallocCString)+import Data.Conduit (ConduitT, Flush (..), await, awaitForever, yield)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Foreign (alloca, nullPtr, peek)+import Hercules.API.Logs.LogEntry (LogEntry)+import qualified Hercules.API.Logs.LogEntry as LogEntry+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude+import System.Timeout (timeout)++C.context context++C.include "<cstring>"++C.include "<nix/config.h>"++C.include "<nix/shared.hh>"++C.include "<nix/globals.hh>"++C.include "aliases.h"++C.include "hercules-logger.hh"++C.using "namespace nix"++initLogger :: IO ()+initLogger =+  [C.throwBlock| void {+    herculesLogger = new HerculesLogger();+    nix::logger = herculesLogger;+  }|]++popMany :: IO (Vector LogEntry)+popMany =+  let limit = 100+   in bracket+        [C.exp| LogEntryQueue *{ new LogEntryQueue() }|]+        (\buf -> [C.block| void { delete $(LogEntryQueue *buf); }|])+        ( \buf -> do+            [C.block| void {+        herculesLogger->popMany($(int limit), *$(LogEntryQueue *buf));+        }|]+            let getBufHeadAndReinsertClose =+                  [C.block| HerculesLoggerEntry * {+              LogEntryQueue &buf = *$(LogEntryQueue *buf);+              if (buf.empty()) {+                return nullptr;+              } else {+                auto r = buf.front().get();+                if (r == nullptr) {+                  herculesLogger->close();+                }+                return r;+              }+            }|]+                dropBufHead =+                  [C.block| void { +            $(LogEntryQueue *buf)->pop();+          }|]+                popBufHead = do+                  hdN <- getBufHeadAndReinsertClose+                  forNonNull hdN $ \hd -> do+                    r <- convertEntry hd+                    dropBufHead -- frees hd+                    pure r+            V.unfoldrM+              ( \_ -> do+                  (,()) <<$>> popBufHead+              )+              ()+        )++{-+popOne :: IO (Maybe LogEntry)+popOne = alloca \deleterPtr ->+  bracket [C.throwBlock| HerculesLoggerEntry * {+      auto linePtr = herculesLogger->pop();+      if (linePtr == nullptr) {+        return nullptr;+      } else {+        auto d = linePtr.get_deleter();+        // we need d in the closure for this to work, which is currently+        // hard to do+        *$(void (** deleterPtr)(HerculesLoggerEntry *)) =+          [d](HerculesLoggerEntry *v) { d(v); };+        return linePtr.release();+      }+    }|]+  (\entryNullable -> forNonNull_ entryNullable (\entry -> [C.block| void {+    (*$(void (** deleterPtr)(HerculesLoggerEntry *)))($(HerculesLoggerEntry *entry));+  }|]))+  (\entryNullable ->+    fmap join $ forNonNull entryNullable $ \entry ->+      convertEntry entry+  )+-}++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++-- popping multiple lines into an array would be nice+convertEntry :: Ptr HerculesLoggerEntry -> IO (LogEntry)+convertEntry logEntryPtr = alloca \millisPtr -> alloca \textStrPtr -> alloca \levelPtr -> alloca \activityIdPtr -> alloca \typePtr -> alloca \parentPtr -> alloca \fieldsPtrPtr ->+  do+    r <-+      [C.throwBlock| int {+        const HerculesLogger::LogEntry &ln = *$(HerculesLoggerEntry *logEntryPtr);+        *$(uint64_t *millisPtr) = ln.ms;+        switch (ln.entryType) {+          case 1:+            *$(const char **textStrPtr) = strdup(ln.text.c_str());+            *$(int *levelPtr) = ln.level;+            return ln.entryType;+          case 2:+            *$(const char **textStrPtr) = strdup(ln.text.c_str());+            *$(int *levelPtr) = ln.level;+            *$(uint64_t *activityIdPtr) = ln.activityId;+            *$(uint64_t *typePtr) = ln.type;+            *$(uint64_t *parentPtr) = ln.parent;+            *$(LoggerFields **fieldsPtrPtr) = new nix::Logger::Fields(ln.fields);+            return ln.entryType;+          case 3:+            *$(uint64_t *activityIdPtr) = ln.activityId;+            return ln.entryType;+          case 4:+            *$(uint64_t *activityIdPtr) = ln.activityId;+            *$(uint64_t *typePtr) = ln.type;+            *$(LoggerFields **fieldsPtrPtr) = new nix::Logger::Fields(ln.fields);+            return ln.entryType;+          default:+            return 0;+        }+      }|]+    ms_ <- peek millisPtr+    let i_ = 0+    case r of+      1 -> do+        textStr <- peek textStrPtr+        text_ <- unsafePackMallocCString textStr+        level_ <- peek levelPtr+        pure $ LogEntry.Msg+          { i = i_,+            ms = ms_,+            level = fromIntegral level_,+            msg = toSL text_+          }+      2 -> do+        text_ <- unsafePackMallocCString =<< peek textStrPtr+        act_ <- peek activityIdPtr+        level_ <- peek levelPtr+        parent_ <- peek parentPtr+        typ_ <- peek typePtr+        fields_ <- convertAndDeleteFields =<< peek fieldsPtrPtr+        pure $ LogEntry.Start+          { i = i_,+            ms = ms_,+            act = LogEntry.ActivityId act_,+            level = fromIntegral level_,+            typ = LogEntry.ActivityType typ_,+            text = toSL text_,+            parent = LogEntry.ActivityId parent_,+            fields = fields_+          }+      3 -> do+        act_ <- peek activityIdPtr+        pure $ LogEntry.Stop+          { i = i_,+            ms = ms_,+            act = LogEntry.ActivityId act_+          }+      4 -> do+        act_ <- peek activityIdPtr+        typ_ <- peek typePtr+        fields_ <- convertAndDeleteFields =<< peek fieldsPtrPtr+        pure $ LogEntry.Result+          { i = i_,+            ms = ms_,+            act = LogEntry.ActivityId act_,+            rtype = LogEntry.ResultType typ_,+            fields = fields_+          }+      _ -> panic "convertEntry invalid internal type"++convertAndDeleteFields :: Ptr Fields -> IO (Vector LogEntry.Field)+convertAndDeleteFields fieldsPtr = flip+  finally+  ( [C.block| void { delete $(LoggerFields *fieldsPtr); }|]+  )+  do+    size <- [C.exp| size_t { $(LoggerFields *fieldsPtr)->size() }|]+    V.generateM (fromIntegral size) $ \i' ->+      mask_ $+        let i = fromIntegral i'+         in alloca \uintPtr -> alloca \stringPtr ->+              [C.block| int {+        const nix::Logger::Field &field = (*$(LoggerFields *fieldsPtr)).at($(int i));+        switch (field.type) {+          case nix::Logger::Field::tInt:+            *$(uint64_t *uintPtr) = field.i;+            return 0;+          case nix::Logger::Field::tString:+            *$(const char **stringPtr) = strdup(field.s.c_str());+            return 1;+          default:+            return -1;+        }+      }|]+                >>= \case+                  0 -> LogEntry.Int <$> peek uintPtr+                  1 -> LogEntry.String . toSL <$> unsafeMallocBS (peek stringPtr)+                  _ -> panic "convertAndDeleteFields invalid internal type"++close :: IO ()+close =+  [C.throwBlock| void {+    herculesLogger->close();+  }|]++--+-- Conduits for logger+--++withLoggerConduit :: MonadIO m => (ConduitT () (Vector LogEntry) m () -> IO ()) -> IO a -> IO a+withLoggerConduit logger io = withAsync (logger popper) $ \popperAsync ->+  ((io `finally` close) <* wait popperAsync) `onException` timeout 2_000_000 (wait popperAsync)+  where+    popper = liftIO popMany >>= \case+      lns | null lns -> pass+      lns -> do+        yield lns+        popper++-- | Remove spammy progress results. Use 'nubProgress' instead?+filterProgress :: ConduitT (Flush LogEntry) (Flush LogEntry) IO ()+filterProgress = filterC \case+  Chunk (LogEntry.Result {rtype = LogEntry.ResultTypeProgress}) -> False+  _ -> True++nubProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m ()+nubProgress = nubSubset (toChunk >=> toProgressKey)+  where+    toProgressKey k@(LogEntry.Result {rtype = LogEntry.ResultTypeProgress}) = Just k {LogEntry.i = 0}+    toProgressKey _ = Nothing+    toChunk (Chunk a) = Just a+    toChunk Flush = Nothing++unbatch :: (Monad m, Foldable l) => ConduitT (l a) (Flush a) m ()+unbatch = awaitForever $ \l -> do+  for_ l $ \a -> yield $ Chunk a+  yield Flush++batch :: Monad m => ConduitT (Flush a) [a] m ()+batch = go []+  where+    go acc = await >>= \case+      Nothing -> do+        unless (null acc) (yield $ reverse acc)+      Just Flush -> do+        unless (null acc) (yield $ reverse acc)+        go []+      Just (Chunk c) -> do+        go (c : acc)++nubSubset :: (Eq k, Monad m) => (a -> Maybe k) -> ConduitT a a m ()+nubSubset toKey = await >>= \case+  Nothing -> pass+  Just firstA -> yield firstA+    >> case toKey firstA of+      Nothing -> nubSubset toKey+      Just firstK -> nubSubset1 toKey firstK++nubSubset1 :: (Eq k, Monad m) => (a -> Maybe k) -> k -> ConduitT a a m ()+nubSubset1 toKey prevKey = await >>= \case+  Nothing -> pass+  Just a -> case toKey a of+    Nothing -> do+      yield a+      nubSubset1 toKey prevKey+    Just ak -> do+      unless (ak == prevKey) do+        yield a+      nubSubset1 toKey ak
+ hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- 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.+-- BuildStatus and BuildResult *can* be moved there, but I do not know of an+-- easy to maintain approach to do decouple it with inline-c-cpp. Perhaps it's+-- better to use an FFI generator instead?++module Hercules.Agent.Worker.Build.Prefetched where++import CNix+import CNix.Internal.Context+import qualified Data.ByteString.Char8 as C8+import Foreign (FinalizerPtr, ForeignPtr, alloca, newForeignPtr, nullPtr, peek)+import Foreign.C (peekCString)+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude++C.context context++C.include "<cstring>"++C.include "<nix/config.h>"++C.include "<nix/shared.hh>"++C.include "<nix/store-api.hh>"++C.include "<nix/get-drvs.hh>"++C.include "<nix/derivations.hh>"++C.include "<nix/affinity.hh>"++C.include "<nix/globals.hh>"++C.include "<nix/fs-accessor.hh>"++C.include "aliases.h"++C.using "namespace nix"++data BuildStatus+  = Built+  | Substituted+  | AlreadyValid+  | PermanentFailure+  | InputRejected+  | OutputRejected+  | TransientFailure -- possibly transient+  | CachedFailure -- no longer used+  | TimedOut+  | MiscFailure+  | DependencyFailed+  | LogLimitExceeded+  | NotDeterministic+  | Successful -- Catch-all for unknown successful status+  | UnknownFailure -- Catch-all for unknown unsuccessful status+  deriving (Show)++-- Must match the FFI boilerplate+toBuildStatus :: C.CInt -> BuildStatus+toBuildStatus 0 = Built+toBuildStatus 1 = Substituted+toBuildStatus 2 = AlreadyValid+toBuildStatus 3 = PermanentFailure+toBuildStatus 4 = InputRejected+toBuildStatus 5 = OutputRejected+toBuildStatus 6 = TransientFailure+toBuildStatus 7 = CachedFailure+toBuildStatus 8 = TimedOut+toBuildStatus 9 = MiscFailure+toBuildStatus 10 = DependencyFailed+toBuildStatus 11 = LogLimitExceeded+toBuildStatus 12 = NotDeterministic+toBuildStatus (-1) = Successful+toBuildStatus _ = UnknownFailure++data BuildResult+  = BuildResult+      { isSuccess :: Bool,+        status :: BuildStatus,+        startTime :: C.CTime,+        stopTime :: C.CTime,+        errorMessage :: Text+      }+  deriving (Show)++nullableForeignPtr :: FinalizerPtr a -> Ptr a -> IO (Maybe (ForeignPtr a))+nullableForeignPtr _ rawPtr | rawPtr == nullPtr = pure Nothing+nullableForeignPtr finalize rawPtr = Just <$> newForeignPtr finalize rawPtr++getDerivation :: Ptr (Ref NixStore) -> ByteString -> IO (Maybe (ForeignPtr Derivation))+getDerivation store derivationPath =+  nullableForeignPtr finalizeDerivation+    =<< [C.throwBlock| Derivation *{+      Store &store = **$(refStore* store);+      std::string derivationPath($bs-ptr:derivationPath, $bs-len:derivationPath);+      std::list<nix::ref<nix::Store>> stores = getDefaultSubstituters();+      stores.push_front(*$(refStore* store));++      nix::Derivation *derivation = nullptr;++      for (nix::ref<nix::Store> & currentStore : stores) {+        try {+          auto accessor = currentStore->getFSAccessor();+          auto drvText = accessor->readFile(derivationPath);++          Path tmpDir = createTempDir();+          AutoDelete delTmpDir(tmpDir, true);+          Path drvTmpPath = tmpDir + "/drv";+          writeFile(drvTmpPath, drvText, 0600);+          derivation = new nix::Derivation(nix::readDerivation(drvTmpPath));+          break;+        } catch (nix::Interrupted &e) {+          throw e;+        } catch (nix::Error &e) {+          printTalkative("ignoring exception during drv lookup in %s: %s", currentStore->getUri(), e.what());+        } catch (std::exception &e) {+          printTalkative("ignoring exception during drv lookup in %s: %s", currentStore->getUri(), e.what());+        } catch (...) {+          // FIXME: remove this and make the "specific" catches above work on darwin+          printTalkative("ignoring unknown exception during drv lookup in %s: %s", currentStore->getUri());+        }+      }+      return derivation;+    }|]++-- | @buildDerivation derivationPath derivationText@+buildDerivation :: Ptr (Ref NixStore) -> ByteString -> ForeignPtr Derivation -> Maybe [ByteString] -> IO BuildResult+buildDerivation store derivationPath derivation extraInputs =+  let extraInputsMerged = C8.intercalate "\n" (fromMaybe [] extraInputs)+      materializeDerivation = if isNothing extraInputs then 1 else 0+   in alloca $ \successPtr ->+        alloca $ \statusPtr ->+          alloca $ \startTimePtr ->+            alloca $ \stopTimePtr ->+              alloca $ \errorMessagePtr -> do+                [C.throwBlock| void {+      Store &store = **$(refStore* store);+      bool &success = *$(bool *successPtr);+      int &status = *$(int *statusPtr);+      const char *&errorMessage = *$(const char **errorMessagePtr);+      time_t &startTime = *$(time_t *startTimePtr);+      time_t &stopTime = *$(time_t *stopTimePtr);+      std::string derivationPath($bs-ptr:derivationPath, $bs-len:derivationPath);++      if ($(bool materializeDerivation)) {+        store.ensurePath(derivationPath);+        nix::PathSet paths{derivationPath};+        try {+          store.buildPaths(paths);+          status = -1;+          success = true;+          errorMessage = strdup("");+          startTime = 0;+          stopTime = 0;+        }+        catch (nix::Error &e) {+          status = -2;+          success = false;+          errorMessage = strdup(e.msg().c_str());+          startTime = 0;+          stopTime = 0;+        }+      }+      else {+        nix::BasicDerivation *derivation = new BasicDerivation(*$fptr-ptr:(Derivation *derivation));+        std::string extraInputsMerged($bs-ptr:extraInputsMerged, $bs-len:extraInputsMerged);+        std::string extraInput;+        std::istringstream stream(extraInputsMerged);++        while (std::getline(stream, extraInput)) {+          derivation->inputSrcs.insert(extraInput);+        }++        nix::BuildResult result = store.buildDerivation(derivationPath, *derivation);++        switch (result.status) {+          case nix::BuildResult::Built:+            status = 0;+            break;+          case nix::BuildResult::Substituted:+            status = 1;+            break;+          case nix::BuildResult::AlreadyValid:+            status = 2;+            break;+          case nix::BuildResult::PermanentFailure:+            status = 3;+            break;+          case nix::BuildResult::InputRejected:+            status = 4;+            break;+          case nix::BuildResult::OutputRejected:+            status = 5;+            break;+          case nix::BuildResult::TransientFailure: // possibly transient+            status = 6;+            break;+          case nix::BuildResult::CachedFailure: // no longer used+            status = 7;+            break;+          case nix::BuildResult::TimedOut:+            status = 8;+            break;+          case nix::BuildResult::MiscFailure:+            status = 9;+            break;+          case nix::BuildResult::DependencyFailed:+            status = 10;+            break;+          case nix::BuildResult::LogLimitExceeded:+            status = 11;+            break;+          case nix::BuildResult::NotDeterministic:+            status = 12;+            break;+          default:+            status = result.success() ? -1 : -2;+            break;+        }+        success = result.success();+        errorMessage = strdup(result.errorMsg.c_str());+        startTime = result.startTime;+        stopTime = result.stopTime;+      }+    }+    |]+                successValue <- peek successPtr+                statusValue <- peek statusPtr+                startTimeValue <- peek startTimePtr+                stopTimeValue <- peek stopTimePtr+                errorMessageValue0 <- peek errorMessagePtr+                errorMessageValue <- peekCString errorMessageValue0+                pure $ BuildResult+                  { isSuccess = successValue /= 0,+                    status = toBuildStatus statusValue,+                    startTime = startTimeValue,+                    stopTime = stopTimeValue,+                    errorMessage = toS errorMessageValue+                  }
+ hercules-ci-agent-worker/Main.hs view
@@ -0,0 +1,6 @@+module Main+  ( main,+  )+where++import Hercules.Agent.Worker (main)
+ hercules-ci-agent.cabal view
@@ -0,0 +1,364 @@+cabal-version: 2.4++name:           hercules-ci-agent+version:        0.7.1+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+license:        Apache-2.0+build-type:     Simple+extra-source-files:+    CHANGELOG.md+    cbits/aliases.h+    cbits/hercules-store.hh+    cbits/hercules-logger.hh+    testdata/vm-test-run-agent-test.drv++source-repository head+  type: git+  location: https://github.com/hercules-ci/hercules-ci-agent++library+  exposed-modules:+      Data.Fixed.Extras+      Data.Time.Extras+      Hercules.Agent.Producer+      Hercules.Agent.Socket+      Hercules.Agent.STM+      Hercules.Agent.WorkerProtocol.Command+      Hercules.Agent.WorkerProtocol.Command.Build+      Hercules.Agent.WorkerProtocol.Command.BuildResult+      Hercules.Agent.WorkerProtocol.Command.Eval+      Hercules.Agent.WorkerProtocol.Event+      Hercules.Agent.WorkerProtocol.Event.Attribute+      Hercules.Agent.WorkerProtocol.Event.AttributeError+      Hercules.Agent.WorkerProtocol.Event.BuildResult+      Hercules.Agent.WorkerProtocol.LogSettings+      Data.Conduit.Extras++  other-modules:+      Paths_hercules_ci_agent+  autogen-modules:+      Paths_hercules_ci_agent+  hs-source-dirs:+      src+  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+    , async+    , base >=4.7 && <5+    , binary+    , binary-conduit+    , bytestring+    , conduit+    , containers+    , dlist+    , exceptions+    , hercules-ci-api-agent+    , katip+    , lifted-async+    , lifted-base+    , monad-control+    , mtl+    , network-uri+    , optparse-applicative+    , protolude+    , process+    , safe-exceptions+    , stm+    , text+    , time+    , transformers-base+    , unbounded-delays+    , unliftio-core+    , unliftio+    , uuid+    , websockets+    , wuss+  default-language: Haskell2010++-- ugly hack to avoid https://gitlab.haskell.org/ghc/ghc/issues/16477+library internal-ffi+  exposed-modules:+      Hercules.Agent.StoreFFI+  hs-source-dirs: src-internal-ffi+  build-depends:       base, protolude+  default-language:    Haskell2010++library cnix+  exposed-modules:+      CNix+      CNix.Internal.Context+      CNix.Internal.Raw+      CNix.Internal.Store+      CNix.Internal.Typed+  hs-source-dirs: src-cnix+  include-dirs:+      cbits+  cxx-sources:+     cbits/hercules-store.cc+     cbits/hercules-logger.cc+  build-depends:+      base+    , inline-c+    , inline-c-cpp+    , internal-ffi+    , bytestring+    , cachix+    , conduit+    , containers+    , protolude+    , unliftio-core+  pkgconfig-depends:+      nix-store >= 2.0+    , nix-expr >= 2.0+    , nix-main >= 2.0+    , bdw-gc+  extra-libraries:+      stdc+++      boost_context+  default-language: Haskell2010+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options:+    -Werror=incomplete-patterns -Werror=missing-fields+    -Wall+    -fwarn-tabs+    -fwarn-unused-imports+    -fwarn-missing-signatures+    -fwarn-name-shadowing+    -fwarn-incomplete-patterns+    -- match what Nix is using+    -optc-std=c++17+  cxx-options: -Wall -std=c++17+  if os(darwin)+    -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829+    ld-options:  -Wl,-keep_dwarf_unwind+    ghc-options: -pgmc=clang++++executable hercules-ci-agent+  main-is: Main.hs+  other-modules:+      Data.Functor.Partitioner+      Data.Map.Extras.Hercules+      Hercules.Agent+      Hercules.Agent.AgentSocket+      Hercules.Agent.Bag+      Hercules.Agent.Build+      Hercules.Agent.CabalInfo+      Hercules.Agent.Cache+      Hercules.Agent.Cachix+      Hercules.Agent.Cachix.Env+      Hercules.Agent.Cachix.Info+      Hercules.Agent.Cachix.Init+      Hercules.Agent.Client+      Hercules.Agent.Config+      Hercules.Agent.Config.BinaryCaches+      Hercules.Agent.Compat+      Hercules.Agent.Env+      Hercules.Agent.EnvironmentInfo+      Hercules.Agent.Evaluate+      Hercules.Agent.Evaluate.TraversalQueue+      Hercules.Agent.Init+      Hercules.Agent.Log+      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+  hs-source-dirs:+      hercules-ci-agent+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Werror=incomplete-patterns -Werror=missing-fields -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts "-with-rtsopts=-maxN8 -qg"+  build-depends:+      aeson+    , async+    , attoparsec+    , base >=4.7 && <5+    , base64-bytestring+    , binary+    , binary-conduit+    , bytestring+    , cachix+    , cachix-api+    , cnix+    , conduit+    , conduit-extra+    , containers+    , directory+    , dlist+    , exceptions+    , filepath+    , hercules-ci-agent+    , hercules-ci-api-core == 0.1.1.0+    , hercules-ci-api-agent == 0.2.1.0+    , hostname+    , http-client+    , http-client-tls+    , http-conduit+    , katip+    , lens+    , lens-aeson+    , lifted-async+    , lifted-base+    , monad-control+    , mtl+    , network-uri+    , network+    , optparse-applicative+    , process+    , protolude+    , safe-exceptions+    , servant >=0.14.1+    , servant-auth-client+    , servant-client+    , servant-client-core+    , stm+    , temporary+    , text+    , time+    , tomland >= 1.0.1.0+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , unliftio+    , unordered-containers+    , uuid+    , websockets+    , wuss+  default-language: Haskell2010++executable hercules-ci-agent-worker+  main-is: Main.hs+  other-modules:+      Hercules.Agent.Worker+      Hercules.Agent.Worker.Build+      Hercules.Agent.Worker.Build.Prefetched+      Hercules.Agent.Worker.Build.Logger+      Paths_hercules_ci_agent+  autogen-modules:+      Paths_hercules_ci_agent+  hs-source-dirs:+      hercules-ci-agent-worker+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options:+    -Werror=incomplete-patterns -Werror=missing-fields+    -Wall+    -fwarn-tabs+    -fwarn-unused-imports+    -fwarn-missing-signatures+    -fwarn-name-shadowing+    -fwarn-incomplete-patterns+    -threaded+    -rtsopts+    -with-rtsopts=-maxN8+    -- match what Nix is using+    -optc-std=c++17+  cxx-options: -Wall -std=c++17+  if os(darwin)+    -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829+    ld-options:  -Wl,-keep_dwarf_unwind+    ghc-options: -pgmc=clang+++  include-dirs:+      cbits+  extra-libraries:+      stdc+++      boost_context+  build-depends:+      aeson+    , async+    , base >=4.7 && <5+    , binary+    , binary-conduit+    , bytestring+    , cachix+    , cnix+    , conduit+    , containers+    , exceptions+    , hercules-ci-agent+    , hercules-ci-api-agent+    , internal-ffi+    , inline-c+    , inline-c-cpp+    , katip+    , lifted-async+    , lifted-base+    , monad-control+    , network-uri+    , optparse-applicative+    , protolude+    , safe-exceptions+    , stm+    , text+    , transformers-base+    , unliftio+    , uuid+    , vector+  pkgconfig-depends:+      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:+      Hercules.Agent.Log+      Hercules.Agent.NixPath+      Hercules.Agent.NixPathSpec+      Hercules.Agent.Nix.RetrieveDerivationInfo+      Hercules.Agent.Nix.RetrieveDerivationInfoSpec+      Hercules.Agent.WorkerProcess+      Hercules.Agent.WorkerProcessSpec+      Paths_hercules_ci_agent+      Spec+  hs-source-dirs:+      test+      hercules-ci-agent+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Werror=incomplete-patterns -Werror=missing-fields -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , async+    , attoparsec+    , base >=4.7 && <5+    , binary+    , binary-conduit+    , bytestring+    , cnix+    , conduit+    , containers+    , exceptions+    , filepath+    , hercules-ci-api-agent+    , hercules-ci-agent+    , hercules-ci-api-core+    , hspec+    , katip+    , lifted-async+    , lifted-base+    , monad-control+    , optparse-applicative+    , process+    , protolude+    , safe-exceptions+    , text+    , transformers-base+    , unliftio-core+  default-language: Haskell2010
+ hercules-ci-agent/Data/Functor/Partitioner.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Functor.Partitioner+  ( Partitioner (..),+    partitionList,+    part,+    part',++    -- * Working safely with 'Data.Map.Map's+    type WithKey,+    partitionMap,+    partWithKey,+    traversePartWithKey,+  )+where++import Data.Coerce+import qualified Data.Map as M+import Protolude++-- TODO: Profunctor+data Partitioner a b+  = forall m.+    (Monoid m) =>+    Partitioner+      { ingest :: a -> Maybe m,+        digest :: m -> b+      }++partitionList :: Partitioner a b -> [a] -> b+partitionList (Partitioner ing dig) = dig . fold . mapMaybe ing++part :: (a -> Maybe b) -> Partitioner a [b]+part f = Partitioner {ingest = fmap (: []) . f, digest = identity}++-- | Like 'part' but allows returning multiple entries in the result+part' :: (a -> Maybe [b]) -> Partitioner a [b]+part' f = Partitioner {ingest = f, digest = identity}++instance Functor (Partitioner a) where+  fmap f (Partitioner ing dig) = (Partitioner ing (f . dig))++instance Applicative (Partitioner a) where++  pure a =+    Partitioner {ingest = const (Nothing :: Maybe ()), digest = pure a}++  (Partitioner ingp digp) <*> (Partitioner ingq digq) = Partitioner+    { ingest = \a -> case ingp a of+        Just mp -> Just (mp, mempty)+        Nothing -> (mempty,) <$> ingq a,+      digest = \(mp, mq) -> digp mp (digq mq)+    }++-- instance Profunctor Partitioner+-- ...++-- | Encapsulates a 'Data.Map.Map''s key, in order to maintain the invariant all+-- keys and values are preserved when returning @Just@ from 'partWithKey'.+--+-- The problem with Maps is that if you change the keys in a non-injective way,+-- you may accidentally overwrite values. If you do need to change the keys,+-- this module can not guarantee the correctness of your code. You can munge a+-- Map in arbitrary ways, by using 'partitionList' after 'Data.Map.toList', but+-- make sure that your key mapping is injective, or use a newtype wrapper for+-- Map that uses the inner type @a@'s 'Semigroup' instance.+newtype WithKey k v = WithKey (k, v)++partWithKey ::+  Ord k =>+  (k -> v -> Maybe a) ->+  Partitioner (WithKey k v) (Map k a)+partWithKey f = Partitioner+  { ingest = \(WithKey (k, v)) -> M.singleton k <$> f k v,+    digest = identity+  }++traversePartWithKey ::+  (Ord k, Applicative f) =>+  (k -> v -> Maybe (f a)) ->+  Partitioner (WithKey k v) (f (Map k a))+traversePartWithKey f = Partitioner+  { ingest = \(WithKey (k, v)) -> do+      -- Maybe+      x <- f k v+      pure $ Ap $ (M.singleton k <$> x),+    digest = getAp+  }++-- | Use with 'partWithKey' to match on the key.+--+-- It uses 'WithKey' to maintain the invariant that all keys and values are+-- preserved when returning @Just@ from 'partWithKey'.+partitionMap :: Ord k => Partitioner (WithKey k a) b -> M.Map k a -> b+partitionMap p = partitionList p . coerce . M.toAscList
+ hercules-ci-agent/Data/Map/Extras/Hercules.hs view
@@ -0,0 +1,18 @@+module Data.Map.Extras.Hercules where++import Control.Arrow ((&&&))+import qualified Data.List as L+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as M+import Protolude hiding (groupBy)++groupOn :: Ord k => (a -> k) -> [a] -> M.Map k [a]+groupOn f = fmap toList . groupOnNEL f++groupOnNEL :: Ord k => (a -> k) -> [a] -> M.Map k (NEL.NonEmpty a)+groupOnNEL f =+  M.fromList+    . map (fst . NEL.head &&& map snd)+    . NEL.groupBy ((==) `on` fst)+    . L.sortBy (compare `on` fst)+    . map (f &&& identity)
+ hercules-ci-agent/Hercules/Agent.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.Agent+  ( main,+  )+where++import Control.Concurrent.Async.Lifted+  ( race,+    withAsync,+  )+import Control.Concurrent.Lifted (forkFinally, killThread)+import Control.Concurrent.STM (TVar, readTVar)+import Control.Concurrent.STM.TChan+import Control.Exception (displayException)+import Control.Exception.Lifted (bracket)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import qualified Data.Aeson as A+import qualified Data.Map as M+import Data.Time (getCurrentTime)+import qualified Data.UUID.V4 as UUID+import qualified Hercules.API.Agent.Build.BuildTask as BuildTask+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import qualified Hercules.API.Agent.LifeCycle as LifeCycle+import qualified Hercules.API.Agent.LifeCycle.StartInfo as StartInfo+import Hercules.API.Agent.LifeCycle.StartInfo (tasksInProgress)+import qualified Hercules.API.Agent.Socket.AgentPayload as AgentPayload+import qualified Hercules.API.Agent.Socket.ServicePayload as ServicePayload+import Hercules.API.Agent.Tasks+  ( tasksSetStatus,+  )+import Hercules.API.Id (Id (Id))+import Hercules.API.Servant (noContent)+import Hercules.API.Task (Task)+import qualified Hercules.API.Task as Task+import qualified Hercules.API.TaskStatus as TaskStatus+import Hercules.Agent.AgentSocket (withAgentSocket)+import qualified Hercules.Agent.Build as Build+import Hercules.Agent.CabalInfo (herculesAgentVersion)+import qualified Hercules.Agent.Cache as Cache+import Hercules.Agent.Client+  ( lifeCycleClient,+    tasksClient,+  )+import qualified Hercules.Agent.Config as Config+import qualified Hercules.Agent.Env as Env+import Hercules.Agent.Env+  ( App,+    runHerculesClient,+  )+import Hercules.Agent.EnvironmentInfo (extractAgentInfo)+import qualified Hercules.Agent.Evaluate as Evaluate+import qualified Hercules.Agent.Init as Init+import Hercules.Agent.Log+import qualified Hercules.Agent.Options as Options+import Hercules.Agent.STM+import Hercules.Agent.Socket as Socket+import Hercules.Agent.Socket (serviceChan)+import Hercules.Agent.Token (withAgentToken)+import Hercules.Error+  ( cap,+    exponential,+    retry,+  )+import Protolude hiding+  ( atomically,+    bracket,+    catch,+    forkFinally,+    handle,+    killThread,+    race,+    retry,+    withAsync,+    withMVar,+  )+import System.Posix.Resource+import UnliftIO.Exception (catch)+import qualified Prelude++main :: IO ()+main = Init.setupLogging $ \logEnv -> do+  Init.initCNix+  opts <- Options.parse+  let cfgPath = Options.configFile opts+  cfg <- Config.finalizeConfig cfgPath =<< Config.readConfig cfgPath+  env <- Init.newEnv cfg logEnv+  case Options.mode opts of+    Options.Run -> run env cfg+    Options.Test -> testConfiguration env cfg++testConfiguration :: Env.Env -> Config.FinalConfig -> IO ()+testConfiguration _env _cfg = do+  -- Room for checks that are not in Init.newEnv+  pass++configChecks :: App ()+configChecks = do+  trusted <- asks (Config.nixUserIsTrusted . Env.config)+  when (not trusted) do+    logLocM WarningS "Your config does not indicate you have set up your user as a trusted user on the system. Running the agent as a trusted user ensures that your cache configuration is compatible with the system and improves performance if you have more than one agent. The NixOS and nix-darwin modules should configure this automatically. If this agent was set up with a manually written config file, see https://docs.hercules-ci.com/hercules-ci/reference/agent-config/"++run :: Env.Env -> Config.FinalConfig -> IO ()+run env _cfg = do+  Env.runApp env+    $ katipAddContext (sl "agent-version" (A.String herculesAgentVersion))+    $ (configureLimits >>)+    $ (configChecks >>)+    $ withAgentToken+    $ withLifeCycle \hello -> withTaskState \tasks ->+      withAgentSocket hello tasks \socket ->+        withApplicationLevelPinger socket $ do+          logLocM InfoS "Agent online."+          forever $ do+            (liftIO $ atomically $ readTChan $ serviceChan socket) >>= \case+              ServicePayload.ServiceInfo _ -> pass+              ServicePayload.StartEvaluation evalTask ->+                launchTask tasks socket (Task.upcastId $ EvaluateTask.id evalTask) do+                  Cache.withCaches do+                    Evaluate.performEvaluation evalTask+                    pure $ TaskStatus.Successful ()+              ServicePayload.StartBuild buildTask ->+                launchTask tasks socket (Task.upcastId $ BuildTask.id buildTask) do+                  Cache.withCaches $+                    Build.performBuild buildTask+              ServicePayload.Cancel cancellation -> cancelTask tasks socket cancellation++withTaskState :: (TVar (Map (Id (Task Task.Any)) ThreadId) -> App a) -> App a+withTaskState f = do+  tasks <- newTVarIO mempty+  withAsync (taskStateMonitor tasks) \_ ->+    f tasks++taskStateMonitor :: TVar (Map (Id (Task Task.Any)) ThreadId) -> App ()+taskStateMonitor tasks = watchChange mempty+  where+    watchChange :: Map (Id (Task Task.Any)) ThreadId -> App ()+    watchChange current = do+      new <- atomically do+        now <- readTVar tasks+        guard $ now /= current+        pure now+      katipAddContext (sl "state" (A.toJSON $ fmap Prelude.show new)) do+        logLocM DebugS "Task state updated"+      watchChange new++launchTask :: TVar (Map (Id (Task Task.Any)) ThreadId) -> Env.AgentSocket -> Id (Task Task.Any) -> App TaskStatus.TaskStatus -> App ()+launchTask tasks socket taskId doWork = withNamedContext "task" taskId do+  let insertSelf = do+        me <- liftIO myThreadId+        join $ modifyTVarIO tasks \tasks0 ->+          case M.lookup taskId tasks0 of+            Just preexist ->+              ( tasks0,+                withNamedContext "preexistingThread" (show preexist :: Text) do+                  logLocM ErrorS "Refusing to overwrite thread for task"+              )+            Nothing -> (M.insert taskId me tasks0, pass)+      done st = do+        report' st+        modifyTVarIO tasks \tasks0 ->+          (M.delete taskId tasks0, ())+      report' (Right s@(TaskStatus.Terminated _)) = do+        logLocM InfoS "Completed failed task"+        report s+      report' (Right s@(TaskStatus.Successful _)) = do+        logLocM InfoS "Completed task successfully"+        report s+      report' (Right s@(TaskStatus.Exceptional e)) = withNamedContext "message" e do+        logLocM ErrorS "Exceptional status in task"+        report s+      report' (Left e) = withNamedContext "message" (displayException e) $+        withNamedContext "exception" (show e :: Text) do+          logLocM ErrorS "Exception in task"+          report $ TaskStatus.Exceptional $ toSL $ displayException e+      -- TODO use socket+      report status =+        retry (cap 60 exponential)+          $ noContent+          $ runHerculesClient+          $ tasksSetStatus tasksClient taskId status+  void @_ @ThreadId $+    flip forkFinally done do+      insertSelf+      logLocM InfoS "Starting task"+      liftIO $ atomically $ Socket.write socket $ AgentPayload.Started $ AgentPayload.MkStarted {taskId = taskId}+      doWork++cancelTask :: TVar (Map (Id (Task Task.Any)) ThreadId) -> Env.AgentSocket -> ServicePayload.Cancel -> App ()+cancelTask tasks socket cancellation = do+  let taskId = ServicePayload.taskId cancellation+  withNamedContext "taskId" taskId do+    tasksNow <- readTVarIO tasks+    case M.lookup taskId tasksNow of+      Just x -> do+        logLocM DebugS "Killing thread for cancelled task"+        killThread x+        atomically $ Socket.write socket $ AgentPayload.Cancelled $ AgentPayload.MkCancelled {taskId = taskId}+      Nothing ->+        logLocM DebugS "cancelTask: No such task"++withLifeCycle :: (StartInfo.Hello -> App a) -> App a+withLifeCycle app = do+  agentInfo <- extractAgentInfo+  now <- liftIO getCurrentTime+  freshId <- Id <$> liftIO UUID.nextRandom+  let startInfo = StartInfo.StartInfo {id = freshId, startTime = now}+      hello = StartInfo.Hello+        { agentInfo = agentInfo,+          startInfo = startInfo,+          tasksInProgress = []+        }+      req r =+        retry (cap 60 exponential)+          $ noContent+          $ runHerculesClient+          $ r+      sayGoodbye = req $ LifeCycle.goodbye lifeCycleClient startInfo+  bracket pass (\() -> sayGoodbye) (\() -> app hello)++withApplicationLevelPinger :: Env.AgentSocket -> App a -> App a+withApplicationLevelPinger socket = fmap (either identity identity) . race pinger+  where+    pinger = forever $ do+      liftIO $ atomically $ Socket.write socket AgentPayload.Ping+      liftIO $ threadDelay (oneSecond * 30)+    oneSecond = 1000 * 1000++configureLimits :: (MonadUnliftIO m, KatipContext m) => m ()+configureLimits = do+  tryIncreaseResourceLimitTo ResourceOpenFiles "open files" (ResourceLimit 65536)++tryIncreaseResourceLimitTo :: (MonadUnliftIO m, KatipContext m) => Resource -> Text -> ResourceLimit -> m ()+tryIncreaseResourceLimitTo resource resourceName target = katipAddContext (sl "resource" resourceName) do+  lims <- liftIO $ getResourceLimit resource+  let lims' = ResourceLimits+        { softLimit = target & atLeast (softLimit lims) & atMost (hardLimit lims),+          hardLimit = hardLimit lims+        }+      atLeast ResourceLimitInfinity _ = ResourceLimitInfinity+      atLeast _ ResourceLimitInfinity = ResourceLimitInfinity+      atLeast ResourceLimitUnknown r = r+      atLeast l ResourceLimitUnknown = l+      atLeast (ResourceLimit a) (ResourceLimit b) | a > b = ResourceLimit a+      atLeast _ r = r+      atMost (ResourceLimit a) (ResourceLimit b) | a > b = ResourceLimit b+      atMost (ResourceLimit a) _ = ResourceLimit a+      atMost ResourceLimitInfinity r = r+      atMost l ResourceLimitInfinity = l+      atMost ResourceLimitUnknown r = r+      -- atMost l ResourceLimitUnknown = l -- already covered+      showLimit (ResourceLimitInfinity) = "infinity"+      showLimit (ResourceLimitUnknown) = A.Null+      showLimit (ResourceLimit n) = A.Number $ fromIntegral n+  liftIO (setResourceLimit resource lims') `catch` \e ->+    katipAddContext+      ( sl "message" (displayException (e :: SomeException))+          <> sl "soft" (showLimit (softLimit lims'))+          <> sl "hard" (showLimit (hardLimit lims'))+      )+      do+        logLocM WarningS "Could not increase resource limit"+  limsFinal <- liftIO (getResourceLimit resource)+  katipAddContext+    ( sl "soft" (showLimit (softLimit limsFinal))+        <> sl "hard" (showLimit (hardLimit limsFinal))+    )+    do+      logLocM DebugS "Resource limit"
+ hercules-ci-agent/Hercules/Agent/AgentSocket.hs view
@@ -0,0 +1,49 @@+module Hercules.Agent.AgentSocket (withAgentSocket) where++import qualified Data.Map as M+import Hercules.API.Agent.LifeCycle.StartInfo (Hello, tasksInProgress)+import qualified Hercules.API.Agent.Socket.AgentPayload as AgentPayload+import Hercules.API.Agent.Socket.AgentPayload (AgentPayload)+import qualified Hercules.API.Agent.Socket.ServicePayload as ServicePayload+import Hercules.API.Agent.Socket.ServicePayload (ServicePayload)+import Hercules.API.Id (Id)+import Hercules.API.Task (Task)+import qualified Hercules.API.Task as Task+import Hercules.Agent.Env+  ( App,+  )+import qualified Hercules.Agent.Env as Agent.Env+import Hercules.Agent.STM (TVar, readTVarIO)+import qualified Hercules.Agent.ServiceInfo as ServiceInfo+import Hercules.Agent.Socket as Socket+import Protolude hiding+  ( bracket,+    forkFinally,+    handle,+    killThread,+    race,+    retry,+    withMVar,+  )+import qualified Servant.Auth.Client++withAgentSocket :: Hello -> TVar (Map (Id (Task Task.Any)) b) -> (Socket ServicePayload AgentPayload -> App a) -> App a+withAgentSocket hello tasks f = do+  let setSocket socket env = env {Agent.Env.socket = socket}+      appThread socket = local (setSocket socket) $ f socket+      checkAgentVersion (ServicePayload.ServiceInfo si) = checkVersion' si+      checkAgentVersion _ = throwIO $ FatalError "Unexpected message. This is either a bug or you might need to update your agent."+  base <- asks (ServiceInfo.agentSocketBaseURL . Agent.Env.serviceInfo)+  agentToken <- asks (Servant.Auth.Client.getToken . Agent.Env.currentToken)+  withReliableSocket+    ( Socket.SocketConfig+        { makeHello = do+            currentTasks <- readTVarIO tasks+            pure $ AgentPayload.Hello hello {tasksInProgress = M.keys currentTasks},+          checkVersion = checkAgentVersion,+          baseURL = base,+          path = "/api/v1/agent-socket",+          token = agentToken+        }+    )+    appThread
+ hercules-ci-agent/Hercules/Agent/Bag.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hercules.Agent.Bag+  ( ParseBag (..),+    parseBag,+    part,+    whenKind,+  )+where++import Data.Aeson+import Data.Aeson.Types+import Data.Functor.Compose+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)++-- | 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)+part f = ParseBag $ Compose $ traversePartWithKey f++parseBag :: ParseBag Value a -> Value -> Parser a+parseBag f v = do+  m <- parseJSON v+  partitionMap (getCompose $ getReadBag f) m++-- | Ignore if the value is not an object or if it doesn't have a "kind" field+-- set to the provided kind.+whenKind :: Text -> (Value -> Maybe a) -> Value -> Maybe a+whenKind expectedKind f v@(Object o) =+  ( do+      x <- HashMap.lookup "kind" o+      guard (x == String expectedKind)+  )+    *> f v+whenKind _ _ _ = Nothing
+ hercules-ci-agent/Hercules/Agent/Build.hs view
@@ -0,0 +1,133 @@+module Hercules.Agent.Build where++import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import Data.IORef.Lifted+import qualified Data.Map as M+import qualified Hercules.API.Agent.Build as API.Build+import qualified Hercules.API.Agent.Build.BuildEvent as BuildEvent+import qualified Hercules.API.Agent.Build.BuildEvent.OutputInfo as OutputInfo+import Hercules.API.Agent.Build.BuildEvent.OutputInfo+  ( OutputInfo,+  )+import qualified Hercules.API.Agent.Build.BuildEvent.Pushed as Pushed+import qualified Hercules.API.Agent.Build.BuildTask as BuildTask+import Hercules.API.Agent.Build.BuildTask+  ( BuildTask,+  )+import Hercules.API.Servant (noContent)+import Hercules.API.TaskStatus (TaskStatus)+import qualified Hercules.API.TaskStatus as TaskStatus+import qualified Hercules.Agent.Cache as Agent.Cache+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.Log+import qualified Hercules.Agent.Nix as Nix+import qualified Hercules.Agent.ServiceInfo as ServiceInfo+import Hercules.Agent.WorkerProcess+import qualified Hercules.Agent.WorkerProcess as WorkerProcess+import qualified Hercules.Agent.WorkerProtocol.Command as Command+import qualified Hercules.Agent.WorkerProtocol.Command.Build as Command.Build+import qualified Hercules.Agent.WorkerProtocol.Event as Event+import qualified Hercules.Agent.WorkerProtocol.Event.BuildResult as BuildResult+import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import Hercules.Error (defaultRetry)+import qualified Katip.Core+import qualified Network.URI+import Protolude+import System.Process++performBuild :: BuildTask.BuildTask -> App TaskStatus+performBuild buildTask = do+  workerExe <- getWorkerExe+  commandChan <- liftIO newChan+  statusRef <- newIORef Nothing+  extraNixOptions <- Nix.askExtraOptions+  workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = mempty})+  let opts = [show $ extraNixOptions]+      procSpec =+        (System.Process.proc workerExe opts)+          { env = Just workerEnv,+            close_fds = True,+            cwd = Just "/"+          }+      writeEvent :: Event.Event -> App ()+      writeEvent event = case event of+        Event.BuildResult r -> writeIORef statusRef $ Just r+        Event.Exception e -> do+          logLocM DebugS $ show e+          panic e+        _ -> pass+  baseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)+  materialize <- asks (not . Config.nixUserIsTrusted . Env.config)+  liftIO $ writeChan commandChan $ Just $ Command.Build $ Command.Build.Build+    { drvPath = BuildTask.derivationPath buildTask,+      inputDerivationOutputPaths = toS <$> BuildTask.inputDerivationOutputPaths buildTask,+      logSettings = LogSettings.LogSettings+        { token = LogSettings.Sensitive $ BuildTask.logToken buildTask,+          path = "/api/v1/logs/build/socket",+          baseURL = toS $ Network.URI.uriToString identity baseURL ""+        },+      materializeDerivation = materialize+    }+  exitCode <- runWorker procSpec stderrLineHandler commandChan writeEvent+  logLocM DebugS $ "Worker exit: " <> show exitCode+  case exitCode of+    ExitSuccess -> pass+    _ -> panic $ "Worker failed: " <> show exitCode+  status <- readIORef statusRef+  case status of+    Just (BuildResult.BuildSuccess {outputs = outs'}) -> do+      let outs = convertOutputs (BuildTask.derivationPath buildTask) outs'+      reportOutputInfos buildTask outs+      push buildTask outs+      reportSuccess buildTask+      pure $ TaskStatus.Successful ()+    Just (BuildResult.BuildFailure {}) -> pure $ TaskStatus.Terminated ()+    Nothing -> pure $ TaskStatus.Exceptional "Build did not complete"++convertOutputs :: Text -> [BuildResult.OutputInfo] -> Map Text OutputInfo+convertOutputs deriver = foldMap $ \oi ->+  M.singleton (toS $ BuildResult.name oi) $+    OutputInfo.OutputInfo+      { OutputInfo.deriver = deriver,+        name = toSL $ BuildResult.name oi,+        path = toSL $ BuildResult.path oi,+        size = fromIntegral $ BuildResult.size oi,+        hash = toSL $ BuildResult.hash oi+      }++stderrLineHandler :: Int -> ByteString -> App ()+stderrLineHandler _ ln+  | "@katip " `BS.isPrefixOf` ln,+    Just item <- A.decode (toS $ BS.drop 7 ln) =+    -- "This is the lowest level function [...] useful when implementing centralised logging services."+    Katip.Core.logKatipItem (Katip.Core.SimpleLogPayload . M.toList . fmap (Katip.Core.AnyLogPayload :: A.Value -> Katip.Core.AnyLogPayload) <$> item)+stderrLineHandler pid ln =+  withNamedContext "worker" (pid :: Int)+    $ logLocM InfoS+    $ "Builder: " <> logStr (toSL ln :: Text)++push :: BuildTask -> Map Text OutputInfo -> App ()+push buildTask outs = do+  let paths = OutputInfo.path <$> toList outs+  caches <- activePushCaches+  forM_ caches $ \cache -> do+    Agent.Cache.push cache paths 4+    emitEvents buildTask [BuildEvent.Pushed $ Pushed.Pushed {cache = cache}]++reportSuccess :: BuildTask -> App ()+reportSuccess buildTask = emitEvents buildTask [BuildEvent.Done True]++reportOutputInfos :: BuildTask -> Map Text OutputInfo -> App ()+reportOutputInfos buildTask outs =+  emitEvents buildTask $ map BuildEvent.OutputInfo (toList outs)++emitEvents :: BuildTask -> [BuildEvent.BuildEvent] -> App ()+emitEvents buildTask =+  noContent . defaultRetry . runHerculesClient+    . API.Build.updateBuild+      Hercules.Agent.Client.buildClient+      (BuildTask.id buildTask)
+ hercules-ci-agent/Hercules/Agent/CabalInfo.hs view
@@ -0,0 +1,8 @@+module Hercules.Agent.CabalInfo where++import Data.Version (showVersion)+import Paths_hercules_ci_agent (version)+import Protolude++herculesAgentVersion :: Text+herculesAgentVersion = toS (showVersion version)
+ hercules-ci-agent/Hercules/Agent/Cache.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.Agent.Cache where++import qualified CNix+import qualified Cachix.Client.Store as Store+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.Nix as Nix+import qualified Hercules.Agent.SecureDirectory as SecureDirectory+import qualified Hercules.Formats.NixCache as NixCache+import Katip+import Protolude+import System.IO (hClose)+import qualified Unsafe.Coerce++withCaches :: App a -> App a+withCaches m = do+  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", toSL netrcPath),+        ("substituters", T.intercalate " " (substs <> csubsts)),+        ("trusted-public-keys", T.intercalate " " (pubkeys <> cpubkeys))+      ]+      m++push ::+  -- | Cache name+  Text ->+  -- | Paths, which do not have to form a closure+  [Text] ->+  -- | Number of concurrent upload threads+  Int ->+  App ()+push cacheName paths concurrency = katipAddContext (sl "cacheName" cacheName) do+  caches <- asks Env.binaryCaches+  let maybeNix =+        Config.nixCaches caches & M.lookup cacheName & fmap \cache ->+          nixPush cache paths concurrency+      maybeCachix =+        Config.cachixCaches caches & M.lookup cacheName & fmap \_cache ->+          Cachix.push cacheName paths concurrency+      failNothing =+        throwIO $ FatalError $ "Agent does not have a binary cache named " <> show cacheName <> " in its configuration."+  fromMaybe failNothing (maybeNix <|> maybeCachix)++nixPush :: NixCache.NixCache -> [Text] -> Int -> App ()+nixPush cacheConf pathsText _concurrency = do+  let paths = map encodeUtf8 pathsText+  keys <- liftIO $ for (NixCache.signingKeys cacheConf) (CNix.parseSecretKey . encodeUtf8)+  CNix.withStore $ \store -> do+    (Sum total, Sum signed) <-+      mconcat <$> for keys \key -> liftIO $ do+        pathSet <- paths & map toS & newPathSetWith+        signClosure store key pathSet+    katipAddContext (sl "num-signatures" signed <> sl "num-paths" total) $+      logLocM DebugS "Signed"+    liftIO $ CNix.clearPathInfoCache store+    CNix.withStoreFromURI (NixCache.storeURI cacheConf) $ \cache -> do+      liftIO (CNix.copyClosure store cache paths)++newPathSetWith :: [ByteString] -> IO Store.PathSet+newPathSetWith paths = do+  pathSet <- Store.newEmptyPathSet+  for_ paths \path ->+    Store.addToPathSet path pathSet+  pure pathSet++castStore :: Ptr (CNix.Ref CNix.NixStore) -> Store.Store+castStore = Unsafe.Coerce.unsafeCoerce++signClosure :: Ptr (CNix.Ref CNix.NixStore) -> ForeignPtr CNix.SecretKey -> Store.PathSet -> IO (Sum Int, Sum Int)+signClosure store key' pathSet = withForeignPtr key' \key -> do+  closure <- Store.computeFSClosure (castStore store) Store.defaultClosureParams pathSet+  closure+    & Store.traversePathSet+      ( \path -> do+          CNix.signPath store key path+      )+    <&> foldMap (\case True -> (1, 1); False -> (1, 0))
+ hercules-ci-agent/Hercules/Agent/Cachix.hs view
@@ -0,0 +1,73 @@+module Hercules.Agent.Cachix+  ( module Hercules.Agent.Cachix,+    activePushCaches,+  )+where++import qualified Cachix.Client.Push as Cachix.Push+import Control.Monad.IO.Unlift+import qualified Data.Map as M+import qualified Hercules.Agent.Cachix.Env as Agent.Cachix+import Hercules.Agent.Cachix.Info (activePushCaches)+import Hercules.Agent.Env as Agent.Env hiding (activePushCaches)+import qualified Hercules.Agent.EnvironmentInfo as EnvInfo+import Hercules.Agent.Log+import Hercules.Error+import qualified Hercules.Formats.CachixCache as CachixCache+import Protolude++push :: Text -> [Text] -> Int -> App ()+push cache paths workers = withNamedContext "cache" cache $ do+  Agent.Cachix.Env+    { pushCaches = pushCaches,+      nixStore = nixStore,+      clientEnv = clientEnv+    } <-+    asks $ Agent.Cachix.getEnv+  pushCache <-+    escalate+      $ maybeToEither (FatalError $ "Cache not found " <> cache)+      $ M.lookup cache pushCaches+  ul <- askUnliftIO+  void $+    Cachix.Push.pushClosure+      ( \f l ->+          liftIO $ Cachix.Push.mapConcurrentlyBounded workers (fmap (unliftIO ul) f) l+      )+      clientEnv+      nixStore+      pushCache+      ( \storePath ->+          let ctx = withNamedContext "path" storePath+           in Cachix.Push.PushStrategy+                { onAlreadyPresent = pass,+                  onAttempt = \retryStatus size ->+                    ctx+                      $ withNamedContext "size" size+                      $ withNamedContext "retry" (show retryStatus :: Text)+                      $ logLocM DebugS "pushing",+                  on401 = throwIO $ FatalError $ "Cachix push is unauthorized",+                  onError = \err -> throwIO $ FatalError $ "Error pushing to cachix: " <> show err,+                  onDone = ctx $ logLocM DebugS "push done",+                  withXzipCompressor = Cachix.Push.defaultWithXzipCompressor+                }+      )+      paths++getNetrcLines :: App [Text]+getNetrcLines = asks (Agent.Cachix.netrcLines . Agent.Env.cachixEnv)++getSubstituters :: App [Text]+getSubstituters = do+  cks <- asks (Agent.Cachix.cacheKeys . Agent.Env.cachixEnv)+  nixInfo <- liftIO EnvInfo.getNixInfo+  pure+    ( EnvInfo.nixSubstituters nixInfo+        ++ map (\c -> "https://" <> c <> ".cachix.org") (M.keys cks)+    )++getTrustedPublicKeys :: App [Text]+getTrustedPublicKeys = do+  cks <- asks (Agent.Cachix.cacheKeys . Agent.Env.cachixEnv)+  nixInfo <- liftIO EnvInfo.getNixInfo+  pure (EnvInfo.nixTrustedPublicKeys nixInfo ++ concatMap CachixCache.publicKeys cks)
+ hercules-ci-agent/Hercules/Agent/Cachix/Env.hs view
@@ -0,0 +1,22 @@+module Hercules.Agent.Cachix.Env where++import qualified Cachix.Client.Push as Cachix+import Cachix.Client.Store (Store)+import Hercules.Formats.CachixCache (CachixCache)+import Protolude+import Servant.Client (ClientEnv)++data Env+  = Env+      { pushCaches :: Map Text Cachix.PushCache,+        cacheKeys :: Map Text CachixCache,+        netrcLines :: [Text],+        nixStore :: Store,+        clientEnv :: ClientEnv+      }++class HasEnv env where+  getEnv :: env -> Env++instance HasEnv Env where+  getEnv = identity
+ hercules-ci-agent/Hercules/Agent/Cachix/Info.hs view
@@ -0,0 +1,8 @@+module Hercules.Agent.Cachix.Info where++import qualified Data.Map as M+import Hercules.Agent.Cachix.Env+import Protolude++activePushCaches :: (MonadReader r m, HasEnv r) => m [Text]+activePushCaches = asks (M.keys . pushCaches . getEnv)
+ hercules-ci-agent/Hercules/Agent/Cachix/Init.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}++module Hercules.Agent.Cachix.Init where++import Cachix.Client.Env (cachixVersion)+import qualified Cachix.Client.Push as Cachix.Push+import qualified Cachix.Client.Secrets as Cachix.Secrets+import qualified Cachix.Client.Store as Cachix.Store+import Cachix.Client.URI (defaultCachixBaseUrl)+import qualified Data.Map as M+import Hercules.Agent.Cachix.Env as Env+import qualified Hercules.Agent.Config as Config+import Hercules.Error+import qualified Hercules.Formats.CachixCache as CachixCache+import qualified Katip as K+import Network.HTTP.Client (ManagerSettings (managerModifyRequest, managerResponseTimeout), responseTimeoutNone)+import Network.HTTP.Client.TLS (newTlsManagerWith, tlsManagerSettings)+import Network.HTTP.Simple (setRequestHeader)+import Protolude+import qualified Servant.Auth.Client+import Servant.Client (mkClientEnv)++-- TODO use from lib after cachix >0.3.5 + https://github.com/cachix/cachix/pull/274+customManagerSettings :: ManagerSettings+customManagerSettings =+  tlsManagerSettings+    { managerResponseTimeout = responseTimeoutNone,+      -- managerModifyRequest :: Request -> IO Request+      managerModifyRequest = return . setRequestHeader "User-Agent" [toS cachixVersion]+    }++newEnv :: Config.FinalConfig -> Map Text CachixCache.CachixCache -> K.KatipContextT IO Env.Env+newEnv _config cks = do+  -- FIXME: sl doesn't work??+  K.katipAddContext (K.sl "caches" (M.keys cks)) $+    K.logLocM K.DebugS ("Cachix init " <> K.logStr (show (M.keys cks) :: Text))+  pcs <- liftIO $ toPushCaches cks+  store <- liftIO Cachix.Store.openStore+  httpManager <- newTlsManagerWith customManagerSettings+  pure Env.Env+    { pushCaches = pcs,+      netrcLines = toNetrcLines cks,+      cacheKeys = cks,+      nixStore = store,+      clientEnv = mkClientEnv httpManager defaultCachixBaseUrl+    }++toNetrcLines :: Map Text CachixCache.CachixCache -> [Text]+toNetrcLines = concatMap toNetrcLine . M.toList+  where+    toNetrcLine (name, keys) = do+      pt <- toList $ CachixCache.authToken keys+      pure $ "machine " <> name <> ".cachix.org" <> " password " <> pt++toPushCaches :: Map Text CachixCache.CachixCache -> IO (Map Text Cachix.Push.PushCache)+toPushCaches = sequenceA . M.mapMaybeWithKey toPushCaches'+  where+    toPushCaches' name keys =+      let t = fromMaybe "" (CachixCache.authToken keys)+       in do+            sk <- head $ CachixCache.signingKeys keys+            Just $ escalateAs FatalError $ do+              k' <- Cachix.Secrets.parseSigningKeyLenient sk+              pure $ Cachix.Push.PushCache+                { pushCacheName = name,+                  pushCacheSigningKey = k',+                  pushCacheToken = Servant.Auth.Client.Token $ toSL t+                }
+ hercules-ci-agent/Hercules/Agent/Client.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O0 #-}++-- TODO https://github.com/haskell-servant/servant/issues/986+module Hercules.Agent.Client+  ( client,+    tasksClient,+    evalClient,+    lifeCycleClient,+    buildClient,+    logsClient,+  )+where++import Hercules.API.Agent (AddAPIVersion, AgentAPI, ClientAuth, build, eval, lifeCycle, servantApi, tasks)+import Hercules.API.Agent.Build (BuildAPI)+import Hercules.API.Agent.Evaluate (EvalAPI)+import Hercules.API.Agent.LifeCycle (LifeCycleAPI)+import Hercules.API.Agent.Tasks (TasksAPI)+import Hercules.API.Logs (LogsAPI)+import Hercules.API.Servant (useApi)+import Protolude+import Servant.API.Generic+import Servant.Auth.Client ()+import qualified Servant.Client+import Servant.Client (ClientM)+import Servant.Client.Generic (AsClientT)++client :: AgentAPI ClientAuth (AsClientT ClientM)+client = fromServant $ Servant.Client.client (servantApi @ClientAuth)++tasksClient :: TasksAPI ClientAuth (AsClientT ClientM)+tasksClient = useApi tasks $ Hercules.Agent.Client.client++evalClient :: EvalAPI ClientAuth (AsClientT ClientM)+evalClient = useApi eval $ Hercules.Agent.Client.client++buildClient :: BuildAPI ClientAuth (AsClientT ClientM)+buildClient = useApi build $ Hercules.Agent.Client.client++lifeCycleClient :: LifeCycleAPI ClientAuth (AsClientT ClientM)+lifeCycleClient = useApi lifeCycle $ Hercules.Agent.Client.client++logsClient :: LogsAPI () (AsClientT ClientM)+logsClient =+  fromServant $ Servant.Client.client $+    (Proxy @(AddAPIVersion (ToServantApi (LogsAPI ()))))
+ hercules-ci-agent/Hercules/Agent/Compat.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}+module Hercules.Agent.Compat where++import qualified Katip as K++#if MIN_VERSION_katip(0,8,0)+katipLevel :: K.Severity -> K.PermitFunc+katipLevel =+  K.permitItem+#else+katipLevel x = x+#endif
+ hercules-ci-agent/Hercules/Agent/Config.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Hercules.Agent.Config+  ( Config (..),+    FinalConfig,+    ConfigPath (..),+    Purpose (..),+    readConfig,+    finalizeConfig,+  )+where++import Protolude hiding (to)+import qualified System.Environment+import System.FilePath ((</>))+import Toml++data ConfigPath = TomlPath FilePath++nounPhrase :: ConfigPath -> Text+nounPhrase (TomlPath p) = "your agent.toml file from " <> show p++data Purpose = Input | Final++-- | Whether the 'Final' value is optional.+data Sort = Required | Optional++type family Item purpose sort a where+  Item 'Input _sort a = Maybe a+  Item 'Final 'Required a = a+  Item 'Final 'Optional a = Maybe a++type FinalConfig = Config 'Final++data Config purpose+  = Config+      { herculesApiBaseURL :: Item purpose 'Required Text,+        nixUserIsTrusted :: Item purpose 'Required Bool,+        concurrentTasks :: Item purpose 'Required Integer,+        baseDirectory :: Item purpose 'Required FilePath,+        -- | Read-only+        staticSecretsDirectory :: Item purpose 'Required FilePath,+        workDirectory :: Item purpose 'Required FilePath,+        clusterJoinTokenPath :: Item purpose 'Required FilePath,+        binaryCachesPath :: Item purpose 'Required FilePath+      }+  deriving (Generic)++deriving instance Show (Config 'Final)++tomlCodec :: TomlCodec (Config 'Input)+tomlCodec =+  Config+    <$> dioptional (Toml.text "apiBaseUrl")+    .= herculesApiBaseURL+    <*> dioptional (Toml.bool "nixUserIsTrusted")+    .= nixUserIsTrusted+    <*> dioptional (Toml.integer "concurrentTasks")+    .= concurrentTasks+    <*> dioptional (Toml.string keyBaseDirectory)+    .= baseDirectory+    <*> dioptional (Toml.string "staticSecretsDirectory")+    .= staticSecretsDirectory+    <*> dioptional (Toml.string "workDirectory")+    .= workDirectory+    <*> dioptional (Toml.string keyClusterJoinTokenPath)+    .= clusterJoinTokenPath+    <*> dioptional (Toml.string "binaryCachesPath")+    .= binaryCachesPath++keyClusterJoinTokenPath :: Key+keyClusterJoinTokenPath = "clusterJoinTokenPath"++keyBaseDirectory :: Key+keyBaseDirectory = "baseDirectory"++determineDefaultApiBaseUrl :: IO Text+determineDefaultApiBaseUrl = do+  maybeEnv <- System.Environment.lookupEnv "HERCULES_API_BASE_URL"+  pure $ maybe defaultApiBaseUrl toS maybeEnv++defaultApiBaseUrl :: Text+defaultApiBaseUrl = "https://hercules-ci.com"++defaultConcurrentTasks :: Integer+defaultConcurrentTasks = 4++readConfig :: ConfigPath -> IO (Config 'Input)+readConfig loc = case loc of+  TomlPath fp -> Toml.decodeFile tomlCodec (toSL fp)++finalizeConfig :: ConfigPath -> Config 'Input -> IO (Config 'Final)+finalizeConfig loc input = do+  baseDir <-+    case baseDirectory input of+      Just x -> pure x+      Nothing -> throwIO $ FatalError $ "You need to specify " <> show keyBaseDirectory <> " in " <> nounPhrase loc+  let staticSecretsDir =+        fromMaybe (baseDir </> "secrets") (staticSecretsDirectory input)+      clusterJoinTokenP =+        fromMaybe+          (staticSecretsDir </> "cluster-join-token.key")+          (clusterJoinTokenPath input)+      binaryCachesP =+        fromMaybe+          (staticSecretsDir </> "binary-caches.json")+          (binaryCachesPath input)+      workDir = fromMaybe (baseDir </> "work") (workDirectory input)+  dabu <- determineDefaultApiBaseUrl+  let rawConcurrentTasks = fromMaybe defaultConcurrentTasks $ concurrentTasks input+  validConcurrentTasks <-+    case rawConcurrentTasks of+      x | not (x >= 1) -> throwIO $ FatalError "concurrentTasks must be at least 1"+      x -> pure x+  let apiBaseUrl = fromMaybe dabu $ herculesApiBaseURL input+  pure Config+    { herculesApiBaseURL = apiBaseUrl,+      nixUserIsTrusted = fromMaybe False $ nixUserIsTrusted input,+      binaryCachesPath = binaryCachesP,+      clusterJoinTokenPath = clusterJoinTokenP,+      concurrentTasks = validConcurrentTasks,+      baseDirectory = baseDir,+      staticSecretsDirectory = staticSecretsDir,+      workDirectory = workDir+    }
+ hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.Config.BinaryCaches+  ( BinaryCaches (..),+    parseFile,+  )+where++import Control.Exception.Lifted (catchJust)+import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Hercules.Agent.Bag+import Hercules.Agent.Config+import Hercules.Agent.Log+import Hercules.Error+import Hercules.Formats.CachixCache+import Hercules.Formats.NixCache+import Protolude hiding (catchJust)+import System.IO.Error (isDoesNotExistError)++data BinaryCaches+  = BinaryCaches+      { cachixCaches :: Map Text CachixCache,+        nixCaches :: Map Text NixCache,+        unknownKinds :: Map Text UnknownKind+      }++data UnknownKind = UnknownKind {kind :: Text}+  deriving (Generic, FromJSON)++instance FromJSON BinaryCaches where+  -- note that parseBag already preserves object names.+  parseJSON =+    parseBag+      ( BinaryCaches+          <$> part (\_name -> whenKind "CachixCache" $ \v -> Just $ (parseJSON v))+          <*> part (\_name -> whenKind "NixCache" $ \v -> Just $ (parseJSON v))+          <*> part (\_name v -> Just $ parseJSON v)+      )++parseFile :: Config 'Final -> KatipContextT IO BinaryCaches+parseFile cfg = do+  let fname = binaryCachesPath cfg+  bytes <-+    catchJust+      (mfilter isDoesNotExistError . Just)+      (liftIO (BL.readFile (toS fname)))+      ( \_e ->+          liftIO $ throwIO $ FatalError $+            "The binary-caches.json file does not exist.\+            \\nAccording to the configuration, it should be in\+            \\n  "+              <> toS fname+              <> "\+                 \\n\+                 \\nFor more information about binary-caches.json, see\n\+                 \\nhttps://docs.hercules-ci.com/hercules-ci/reference/binary-caches-json/"+      )+  bcs <- escalateAs (FatalError . toS) $ eitherDecode bytes+  validate (toS fname) bcs+  pure bcs++validate :: FilePath -> BinaryCaches -> KatipContextT IO ()+validate fname bcs = do+  when (null (cachixCaches bcs) && null (nixCaches bcs)) $+    logLocM+      WarningS+      "You did not configure any caches. This is ok for evaluation purposes,\+      \ but a cache is required for multi-agent operation and\+      \ to work well across garbage collection.\+      \ For more information about binary-caches.json, see\+      \ https://docs.hercules-ci.com/hercules-ci/reference/binary-caches-json/"+  forM_ (M.toList (unknownKinds bcs)) $ \(k, v) ->+    logLocM WarningS $+      "In file "+        <> show fname+        <> " in entry "+        <> show k+        <> ": unknown kind "+        <> show (kind v)
+ hercules-ci-agent/Hercules/Agent/Env.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Hercules.Agent.Env where++import Control.Monad.Base (MonadBase)+import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Map as M+import Hercules.API.Agent.Socket.AgentPayload (AgentPayload)+import Hercules.API.Agent.Socket.ServicePayload (ServicePayload)+import qualified Hercules.Agent.Cachix.Env as Cachix+  ( Env,+    HasEnv (..),+  )+import Hercules.Agent.Config (FinalConfig)+import qualified Hercules.Agent.Config.BinaryCaches as Config.BinaryCaches+import qualified Hercules.Agent.Nix.Env as Nix+  ( Env,+  )+import qualified Hercules.Agent.ServiceInfo as ServiceInfo+import Hercules.Agent.Socket (Socket)+import Hercules.Error+import qualified Katip as K+import qualified Network.HTTP.Client+import Protolude+import qualified Servant.Auth.Client+import qualified Servant.Client++data Env+  = Env+      { manager :: Network.HTTP.Client.Manager,+        config :: FinalConfig,+        herculesBaseUrl :: Servant.Client.BaseUrl,+        herculesClientEnv :: Servant.Client.ClientEnv,+        serviceInfo :: ServiceInfo.Env,+        -- TODO: The implicit limitation here is that we can+        --       only have one token at a time. I wouldn't be surprised if this becomes+        --       problematic at some point. Perhaps we should switch to a polymorphic+        --       reader monad like RIO when we hit that limitation.+        currentToken :: Servant.Auth.Client.Token,+        binaryCaches :: Config.BinaryCaches.BinaryCaches,+        cachixEnv :: Cachix.Env,+        nixEnv :: Nix.Env,+        socket :: AgentSocket,+        -- katip+        kNamespace :: K.Namespace,+        kContext :: K.LogContexts,+        kLogEnv :: K.LogEnv+      }++activePushCaches :: App [Text]+activePushCaches = do+  bc <- asks (binaryCaches)+  pure $+    M.keys+      ( void (Config.BinaryCaches.cachixCaches bc)+          <> void (Config.BinaryCaches.nixCaches bc)+      )++type AgentSocket = Socket ServicePayload AgentPayload++instance Cachix.HasEnv Env where+  getEnv = cachixEnv++newtype App a = App {fromApp :: ReaderT Env IO a}+  deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO, MonadCatch, MonadMask, MonadThrow, MonadUnliftIO, MonadBase IO, MonadBaseControl IO)++runApp :: Env -> App a -> IO a+runApp env (App m) = runReaderT m env++runHerculesClient ::+  (Servant.Auth.Client.Token -> Servant.Client.ClientM a) ->+  App a+runHerculesClient f = do+  tok <- asks currentToken+  runHerculesClient' (f tok)++runHerculesClient' :: Servant.Client.ClientM a -> App a+runHerculesClient' m = do+  clientEnv <- asks herculesClientEnv+  escalate =<< liftIO (Servant.Client.runClientM m clientEnv)++instance K.Katip App where++  getLogEnv = asks kLogEnv++  localLogEnv f (App m) = App (local (\s -> s {kLogEnv = f (kLogEnv s)}) m)++instance K.KatipContext App where++  getKatipContext = asks kContext++  localKatipContext f (App m) = App (local (\s -> s {kContext = f (kContext s)}) m)++  getKatipNamespace = asks kNamespace++  localKatipNamespace f (App m) = App (local (\s -> s {kNamespace = f (kNamespace s)}) m)
+ hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs view
@@ -0,0 +1,111 @@+module Hercules.Agent.EnvironmentInfo where++import Control.Lens+  ( (^..),+    (^?),+    to,+  )+import qualified Data.Aeson as Aeson+import Data.Aeson.Lens+  ( _Array,+    _Number,+    _String,+    key,+  )+import Data.Char (isSpace)+import qualified Data.Text as T+import qualified Hercules.API.Agent.LifeCycle.AgentInfo as AgentInfo+import Hercules.Agent.CabalInfo as CabalInfo+import Hercules.Agent.Cachix.Info as Cachix.Info+import qualified Hercules.Agent.Config as Config+import Hercules.Agent.Env as Env+import Hercules.Agent.Log+import Network.HostName (getHostName)+import Protolude hiding (to)+import qualified System.Process as Process++extractAgentInfo :: App AgentInfo.AgentInfo+extractAgentInfo = do+  hostname <- liftIO getHostName+  nix <- liftIO getNixInfo+  cachixPushCaches <- Cachix.Info.activePushCaches+  pushCaches <- Env.activePushCaches+  concurrentTasks <- asks (Config.concurrentTasks . Env.config)+  let s = AgentInfo.AgentInfo+        { hostname = toS hostname,+          agentVersion = CabalInfo.herculesAgentVersion, -- TODO: Add git revision+          nixVersion = nixExeVersion nix,+          platforms = nixPlatforms nix,+          cachixPushCaches = cachixPushCaches,+          pushCaches = pushCaches,+          systemFeatures = nixSystemFeatures nix,+          substituters = nixSubstituters nix, -- TODO: Add cachix substituters+          concurrentTasks = fromIntegral concurrentTasks+        }+  logLocM DebugS $ "Determined environment info: " <> show s+  pure s++data NixInfo+  = NixInfo+      { nixExeVersion :: Text,+        nixPlatforms :: [Text],+        nixSystemFeatures :: [Text],+        nixSubstituters :: [Text],+        nixTrustedPublicKeys :: [Text],+        nixNarinfoCacheNegativeTTL :: Maybe Integer+      }++getNixInfo :: IO NixInfo+getNixInfo = do+  let stdinEmpty = ""+  version <- Process.readProcess "nix" ["--version"] stdinEmpty+  rawJson <- Process.readProcess "nix" ["show-config", "--json"] stdinEmpty+  cfg <-+    case Aeson.eitherDecode (toS rawJson) of+      Left e -> panic $ "Could not parse nix show-config --json: " <> show e+      Right r -> pure r+  pure NixInfo+    { nixExeVersion = T.dropAround isSpace (toSL version),+      nixPlatforms =+        ((cfg :: Aeson.Value) ^.. key "system" . key "value" . _String)+          <> ( cfg+                 ^.. key "extra-platforms"+                 . key "value"+                 . _Array+                 . traverse+                 . _String+             ),+      nixSystemFeatures =+        cfg+          ^.. key "system-features"+          . key "value"+          . _Array+          . traverse+          . _String,+      nixSubstituters =+        cfg+          ^.. key "substituters"+          . key "value"+          . _Array+          . traverse+          . _String+          . to cleanUrl,+      nixTrustedPublicKeys =+        cfg+          ^.. key "trusted-public-keys"+          . key "value"+          . _Array+          . traverse+          . _String+          . to cleanUrl,+      nixNarinfoCacheNegativeTTL =+        cfg+          ^? key "narinfo-cache-negative-ttl"+          . key "value"+          . _Number+          . to floor+    }++cleanUrl :: Text -> Text+cleanUrl t | "@" `T.isInfixOf` t = "<URI censored; might contain secret>"+cleanUrl t = t
+ hercules-ci-agent/Hercules/Agent/Evaluate.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Agent.Evaluate+  ( performEvaluation,+  )+where++import CNix (withStore)+import Conduit+import qualified Control.Concurrent.Async.Lifted as Async.Lifted+import Control.Concurrent.Chan.Lifted+import Control.Monad.IO.Unlift+import Data.Conduit.Process (sourceProcessWithStreams)+import Data.IORef+  ( atomicModifyIORef,+    newIORef,+    readIORef,+  )+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.UUID (UUID)+import Hercules.API.Agent.Evaluate+  ( getDerivationStatus2,+    tasksUpdateEvaluation,+  )+import qualified Hercules.API.Agent.Evaluate.DerivationStatus as DerivationStatus+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent as EvaluateEvent+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeErrorEvent as AttributeErrorEvent+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEvent as AttributeEvent+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.Message as Message+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.PushedAll as PushedAll+import qualified Hercules.API.Agent.Evaluate.EvaluateTask as EvaluateTask+import Hercules.API.Servant (noContent)+import qualified Hercules.Agent.Cache as Agent.Cache+import qualified Hercules.Agent.Client+import qualified Hercules.Agent.Config as Config+import Hercules.Agent.Env+import qualified Hercules.Agent.Evaluate.TraversalQueue as TraversalQueue+import Hercules.Agent.Log+import qualified Hercules.Agent.Nix as Nix+import Hercules.Agent.Nix.RetrieveDerivationInfo+  ( retrieveDerivationInfo,+  )+import Hercules.Agent.NixPath+  ( renderSubPath,+  )+import Hercules.Agent.Producer+import Hercules.Agent.WorkerProcess ()+import qualified Hercules.Agent.WorkerProcess as WorkerProcess+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 qualified Hercules.Agent.WorkerProtocol.Event as Event+import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as WorkerAttribute+import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as WorkerAttributeError+import Hercules.Error (defaultRetry, quickRetry)+import qualified Network.HTTP.Client.Conduit as HTTP.Conduit+import qualified Network.HTTP.Simple as HTTP.Simple+import Protolude hiding (finally, newChan, writeChan)+import qualified Servant.Client+import qualified System.Directory as Dir+import System.FilePath+import System.IO.Temp (withTempDirectory)+import System.Process++eventLimit :: Int+eventLimit = 50000++pushEvalWorkers :: Int+pushEvalWorkers = 16++performEvaluation :: EvaluateTask.EvaluateTask -> App ()+performEvaluation task' =+  withProducer (produceEvaluationTaskEvents task') $ \producer ->+    withBoundedDelayBatchProducer (1000 * 1000) 1000 producer $ \batchProducer ->+      fix $ \continue ->+        joinSTM $ listen batchProducer (\b -> withSync b (postBatch task' . catMaybes) *> continue) pure++produceEvaluationTaskEvents ::+  EvaluateTask.EvaluateTask ->+  (Syncing EvaluateEvent.EvaluateEvent -> App ()) ->+  App ()+produceEvaluationTaskEvents task writeToBatch = withWorkDir $ \tmpdir -> do+  logLocM DebugS "Retrieving evaluation task"+  let emitSingle = writeToBatch . Syncable+      sync = syncer writeToBatch+  projectDir <-+    fetchSource+      (tmpdir </> "primary")+      (EvaluateTask.primaryInput task)+  withNamedContext "projectDir" projectDir $+    logLocM DebugS "Determined projectDir"+  inputLocations <-+    flip M.traverseWithKey (EvaluateTask.otherInputs task) $+      \k src -> fetchSource (tmpdir </> ("arg-" <> toS k)) src+  nixPath <-+    EvaluateTask.nixPath task+      & ( traverse+            . traverse+            . traverse+            $ \identifier -> case M.lookup identifier inputLocations of+              Just x -> pure x+              Nothing ->+                throwIO+                  $ FatalError+                  $ "Nix path references undefined input "+                    <> identifier+        )+  autoArguments' <-+    EvaluateTask.autoArguments task+      & (traverse . traverse)+        ( \identifier -> case M.lookup identifier inputLocations of+            Just x | "/" `isPrefixOf` x -> pure x+            Just x ->+              throwIO+                $ FatalError+                $ "input "+                  <> identifier+                  <> " was not resolved to an absolute path: "+                  <> toS x+            Nothing ->+              throwIO+                $ FatalError+                $ "auto argument references undefined input "+                  <> identifier+        )+  let autoArguments = autoArguments'+        <&> \sp -> Eval.ExprArg $ toS $ renderSubPath $ toS <$> sp+  msgCounter <- liftIO $ newIORef 0+  let fixIndex ::+        MonadIO m =>+        EvaluateEvent.EvaluateEvent ->+        m EvaluateEvent.EvaluateEvent+      fixIndex (EvaluateEvent.Message m) = do+        i <- liftIO $ atomicModifyIORef msgCounter (\i0 -> (i0 + 1, i0))+        pure $ EvaluateEvent.Message m {Message.index = i}+      fixIndex other = pure other+  eventCounter <- liftIO $ newIORef 0+  topDerivationPaths <- liftIO $ newIORef mempty+  let emit :: EvaluateEvent.EvaluateEvent -> App ()+      emit update = do+        n <- liftIO $ atomicModifyIORef eventCounter $ \n -> dup (n + 1)+        if n > eventLimit+          then do+            truncMsg <-+              fixIndex $+                EvaluateEvent.Message Message.Message+                  { index = -1,+                    typ = Message.Error,+                    message =+                      "Evaluation limit reached. Does your nix expression produce infinite attributes? Please make sure that your project is finite. If it really does require more than "+                        <> show eventLimit+                        <> " attributes or messages, please contact info@hercules-ci.com."+                  }+            emitSingle truncMsg+            panic "Evaluation limit reached."+          else emitSingle =<< fixIndex update+  adHocSystem <-+    readFileMaybe (projectDir </> "ci-default-system.txt")+  liftIO (findNixFile projectDir) >>= \case+    Left e ->+      emit $+        EvaluateEvent.Message Message.Message+          { Message.index = -1, -- will be set by emit+            Message.typ = Message.Error,+            Message.message = e+          }+    Right file -> TraversalQueue.with $ \derivationQueue ->+      let doIt = do+            Async.Lifted.concurrently_ evaluation emitDrvs+            -- derivationInfo upload has finished+            -- allAttrPaths :: IORef has been populated+            pushDrvs+          uploadDrvInfos drvPath = do+            TraversalQueue.enqueue derivationQueue drvPath+            TraversalQueue.waitUntilDone derivationQueue+          addTopDerivation drvPath = do+            TraversalQueue.enqueue derivationQueue drvPath+            liftIO $ atomicModifyIORef topDerivationPaths ((,()) . S.insert drvPath)+          evaluation = do+            Nix.withExtraOptions [("system", T.strip s) | Just s <- [adHocSystem]] $+              runEvalProcess+                projectDir+                file+                autoArguments+                nixPath+                captureAttrDrvAndEmit+                uploadDrvInfos+                sync+            -- process has finished+            TraversalQueue.waitUntilDone derivationQueue+            TraversalQueue.close derivationQueue+          pushDrvs = do+            caches <- activePushCaches+            paths <- liftIO $ readIORef topDerivationPaths+            forM_ caches $ \cache -> do+              withNamedContext "cache" cache $ logLocM DebugS "Pushing derivations"+              Agent.Cache.push cache (toList paths) pushEvalWorkers+              emit $ EvaluateEvent.PushedAll $ PushedAll.PushedAll {cache = cache}+          captureAttrDrvAndEmit msg = do+            case msg of+              EvaluateEvent.Attribute ae ->+                addTopDerivation (AttributeEvent.derivationPath ae)+              _ -> pass+            emit msg+          emitDrvs =+            withStore $ \store -> TraversalQueue.work derivationQueue $ \recurse drvPath -> do+              drvInfo <- retrieveDerivationInfo store drvPath+              forM_+                (M.keys $ DerivationInfo.inputDerivations drvInfo)+                recurse -- asynchronously+              emit $ EvaluateEvent.DerivationInfo drvInfo+       in doIt++runEvalProcess ::+  FilePath ->+  FilePath ->+  Map Text Eval.Arg ->+  [ EvaluateTask.NixPathElement+      (EvaluateTask.SubPathOf FilePath)+  ] ->+  (EvaluateEvent.EvaluateEvent -> App ()) ->+  -- | Upload a derivation, return when done+  (Text -> App ()) ->+  App () ->+  App ()+runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush = do+  extraOpts <- Nix.askExtraOptions+  let eval = Eval.Eval+        { Eval.cwd = projectDir,+          Eval.file = toS file,+          Eval.autoArguments = autoArguments,+          Eval.extraNixOptions = extraOpts+        }+  buildRequiredIndex <- liftIO $ newIORef (0 :: Int)+  commandChan <- newChan+  writeChan commandChan $ Just $ Command.Eval eval+  withProducer (produceWorkerEvents eval nixPath commandChan) $+    \workerEventsP -> fix $ \continue ->+      joinSTM $+        listen+          workerEventsP+          ( \case+              Event.Attribute a -> do+                emit $ EvaluateEvent.Attribute $ AttributeEvent.AttributeEvent+                  { AttributeEvent.expressionPath = toSL <$> WorkerAttribute.path a,+                    AttributeEvent.derivationPath = toSL $ WorkerAttribute.drv a+                  }+                continue+              Event.AttributeError e -> do+                emit $ EvaluateEvent.AttributeError $ AttributeErrorEvent.AttributeErrorEvent+                  { AttributeErrorEvent.expressionPath = toSL <$> WorkerAttributeError.path e,+                    AttributeErrorEvent.errorMessage = toSL $ WorkerAttributeError.message e,+                    AttributeErrorEvent.errorType = toSL <$> WorkerAttributeError.errorType e,+                    AttributeErrorEvent.errorDerivation = toSL <$> WorkerAttributeError.errorDerivation e+                  }+                continue+              Event.EvaluationDone ->+                writeChan commandChan Nothing+              Event.Error e -> do+                emit $+                  EvaluateEvent.Message Message.Message+                    { Message.index = -1, -- will be set by emit+                      Message.typ = Message.Error,+                      Message.message = e+                    }+                continue+              Event.Build drv outputName notAttempt -> do+                status <-+                  withNamedContext "derivation" drv $ do+                    currentIndex <- liftIO $ atomicModifyIORef buildRequiredIndex (\i -> (i + 1, i))+                    emit $+                      EvaluateEvent.BuildRequired BuildRequired.BuildRequired+                        { BuildRequired.derivationPath = drv,+                          BuildRequired.index = currentIndex,+                          BuildRequired.outputName = outputName+                        }+                    let pushDerivations = do+                          caches <- activePushCaches+                          forM_ caches $ \cache -> do+                            withNamedContext "cache" cache $ logLocM DebugS "Pushing derivations for import from derivation"+                            Agent.Cache.push cache [drv] pushEvalWorkers+                    Async.Lifted.concurrently_+                      (uploadDerivationInfos drv)+                      pushDerivations+                    emit $ EvaluateEvent.BuildRequest BuildRequest.BuildRequest+                      { derivationPath = drv,+                        forceRebuild = isJust notAttempt+                      }+                    flush+                    status <- drvPoller notAttempt drv+                    logLocM DebugS $ "Got derivation status " <> show status+                    return status+                writeChan commandChan $ Just $ Command.BuildResult $ uncurry (BuildResult.BuildResult drv) status+                continue+              -- Unused during eval+              Event.BuildResult {} -> pass+              Event.Exception e -> panic e+          )+          ( \case+              ExitSuccess -> logLocM DebugS "Clean worker exit"+              ExitFailure e -> do+                withNamedContext "exitStatus" e $ logLocM ErrorS "Worker failed"+                panic $ "Worker failed with exit status: " <> show e+          )++produceWorkerEvents ::+  Eval.Eval ->+  [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)] ->+  Chan (Maybe Command.Command) ->+  (Event.Event -> App ()) ->+  App ExitCode+produceWorkerEvents eval nixPath 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})+  wps <-+    pure+      (System.Process.proc workerExe opts)+        { env = Just workerEnv,+          close_fds = True, -- Disable on Windows?+          cwd = Just (Eval.cwd eval)+        }+  WorkerProcess.runWorker wps stderrLineHandler commandChan writeEvent++drvPoller :: Maybe UUID -> Text -> App (UUID, BuildResult.BuildStatus)+drvPoller notAttempt drvPath = do+  resp <-+    defaultRetry $ runHerculesClient $+      getDerivationStatus2+        Hercules.Agent.Client.evalClient+        drvPath+  let oneSecond = 1000 * 1000+      again = do+        liftIO $ threadDelay oneSecond+        drvPoller notAttempt drvPath+  case resp of+    Nothing -> again+    Just (attempt, _) | Just attempt == notAttempt -> again+    Just (_attempt, DerivationStatus.Waiting) -> again+    Just (_attempt, DerivationStatus.Building) -> again+    Just (attempt, DerivationStatus.BuildFailure) -> pure (attempt, BuildResult.Failure)+    Just (attempt, DerivationStatus.DependencyFailure) -> pure (attempt, BuildResult.DependencyFailure)+    Just (attempt, DerivationStatus.BuildSuccess) -> pure (attempt, BuildResult.Success)++newtype SubprocessFailure = SubprocessFailure {message :: Text}+  deriving (Typeable, Exception, Show)++fetchSource :: FilePath -> Text -> App FilePath+fetchSource targetDir url = do+  clientEnv <- asks herculesClientEnv+  liftIO $ Dir.createDirectoryIfMissing True targetDir+  request <- HTTP.Simple.parseRequest $ toS url+  -- TODO: report stderr to service+  -- TODO: discard stdout+  -- Fewer retries in order to speed up the tests.+  quickRetry $ do+    (x, _, _) <-+      liftIO+        $ (`runReaderT` Servant.Client.manager clientEnv)+        $ HTTP.Conduit.withResponse request+        $ \response -> do+          let tarball = HTTP.Conduit.responseBody response+              procSpec =+                (System.Process.proc "tar" ["-xz"]) {cwd = Just targetDir}+          sourceProcessWithStreams+            procSpec+            tarball+            Conduit.stderrC+            Conduit.stderrC+    case x of+      ExitSuccess -> pass+      ExitFailure {} -> throwIO $ SubprocessFailure "Extracting tarball"+    liftIO $ findTarballDir targetDir++dup :: a -> (a, a)+dup a = (a, a)++-- | Tarballs typically have a single directory at the root to cd into.+findTarballDir :: FilePath -> IO FilePath+findTarballDir fp = do+  nodes <- Dir.listDirectory fp+  case nodes of+    [x] -> Dir.doesDirectoryExist (fp </> x) >>= \case+      True -> pure $ fp </> x+      False -> pure fp+    _ -> pure fp++type Ambiguity = [FilePath]++searchPath :: [Ambiguity]+searchPath = [["nix/ci.nix", "ci.nix"], ["default.nix"]]++findNixFile :: FilePath -> IO (Either Text FilePath)+findNixFile projectDir = do+  searchResult <-+    for searchPath $ traverse $ \relPath ->+      let path = projectDir </> relPath+       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)+    ambiguous : _ ->+      pure+        $ Left+        $ "Don't know what to do, expecting only one of "+          <> englishConjunction "or" (map fst ambiguous)+    [] ->+      pure+        $ Left+        $ "Please provide a Nix expression to build. Could not find any of "+          <> englishConjunction "or" (concat 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++stderrLineHandler :: Int -> ByteString -> App ()+stderrLineHandler pid ln =+  withNamedContext "worker" (pid :: Int)+    $ logLocM InfoS+    $ "Evaluator: "+      <> logStr (toSL ln :: Text)++postBatch :: EvaluateTask.EvaluateTask -> [EvaluateEvent.EvaluateEvent] -> App ()+postBatch task events =+  noContent $ defaultRetry $+    runHerculesClient+      ( tasksUpdateEvaluation+          Hercules.Agent.Client.evalClient+          (EvaluateTask.id task)+          events+      )++-- TODO: configurable temp directory+withWorkDir :: (FilePath -> App b) -> App b+withWorkDir f = do+  UnliftIO {unliftIO = unlift} <- askUnliftIO+  workDir <- asks (Config.workDirectory . config)+  liftIO $ withTempDirectory workDir "eval" $ unlift . f++readFileMaybe :: MonadIO m => FilePath -> m (Maybe Text)+readFileMaybe fp = liftIO do+  exists <- Dir.doesFileExist fp+  guard exists & traverse \_ -> readFile fp
+ hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs view
@@ -0,0 +1,94 @@+-- | Couldn't think of a better name.+--+--  * it dispatches via 'Chan'+--  * keeps track of how many items are being processed (size)+--  * and does things only once.+module Hercules.Agent.Evaluate.TraversalQueue+  ( with,+    work,+    waitUntilDone,+    enqueue,+    close,+    Queue (),+  )+where++import Control.Concurrent.Chan.Lifted+import Control.Concurrent.STM+import Control.Exception.Lifted (bracket)+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.IORef.Lifted+import qualified Data.Set as Set+import Protolude hiding+  ( bracket,+    newChan,+    newQSem,+    newQSemN,+    readChan,+    writeChan,+  )++data Queue a+  = Queue+      { chan :: Chan (Maybe a),+        visitedSet :: IORef (Set a),+        -- | Increased on enqueue, decreased when processed+        size :: TVar Int+      }++with :: MonadBaseControl IO m => (Queue a -> m ()) -> m ()+with = Control.Exception.Lifted.bracket new close++new :: MonadBase IO m => m (Queue a)+new = Queue <$> newChan <*> newIORef Set.empty <*> liftBase (newTVarIO 0)++close :: MonadBase IO m => Queue a -> m ()+close env = writeChan (chan env) Nothing++enqueue :: MonadBase IO m => Queue a -> a -> m ()+enqueue env msg = do+  liftBase $ atomically $ modifyTVar (size env) (+ 1)+  -- Not transactional but shouldn't hurt much since we fail the whole thing+  -- in erlang style anyway using the async library.+  writeChan (chan env) (Just msg)++waitUntilDone :: MonadBase IO m => Queue a -> m ()+waitUntilDone env = liftBase $ atomically $ do+  n <- readTVar (size env)+  check (n == 0)++readJust_ ::+  (MonadBase IO m, MonadIO m) =>+  Chan (Maybe a) ->+  (a -> m ()) ->+  m ()+readJust_ ch f = do+  mmsg <- readChan ch+  case mmsg of+    Nothing -> writeChan ch Nothing+    Just msg -> f msg++work ::+  (MonadBase IO m, MonadIO m, Ord a) =>+  Queue a ->+  ((a -> m ()) -> a -> m ()) ->+  m ()+work env f = work' env $ \snapshot ->+  let enqueue' item = unless (item `Set.member` snapshot) $ enqueue env item+   in f enqueue'++work' ::+  (MonadBase IO m, MonadIO m, Ord a) =>+  Queue a ->+  (Set a -> a -> m ()) ->+  m ()+work' env f = readJust_ (chan env) $ \msg -> do+  snapshotWhenInserted <-+    atomicModifyIORef (visitedSet env) $ \st ->+      if Set.member msg st+        then (st, Nothing)+        else let st' = Set.insert msg st in (st', Just st')+  forM_ snapshotWhenInserted $ \snapshot -> f snapshot msg+  liftBase $ atomically $ modifyTVar (size env) (subtract 1)+  work' env f
+ hercules-ci-agent/Hercules/Agent/Init.hs view
@@ -0,0 +1,67 @@+module Hercules.Agent.Init where++import qualified CNix+import qualified Hercules.Agent.Cachix.Init+import qualified Hercules.Agent.Compat as Compat+import qualified Hercules.Agent.Config as Config+import qualified Hercules.Agent.Config.BinaryCaches as BC+import qualified Hercules.Agent.Env as Env+import Hercules.Agent.Env (Env (Env))+import qualified Hercules.Agent.Nix.Init+import qualified Hercules.Agent.SecureDirectory as SecureDirectory+import qualified Hercules.Agent.ServiceInfo as ServiceInfo+import qualified Hercules.Agent.Token as Token+import qualified Katip as K+import qualified Network.HTTP.Client.TLS+import Protolude+import qualified Servant.Auth.Client+import qualified Servant.Client+import qualified System.Directory++newEnv :: Config.FinalConfig -> K.LogEnv -> IO Env+newEnv config logEnv = do+  let withLogging :: K.KatipContextT IO a -> IO a+      withLogging = K.runKatipContextT logEnv () "Init"+  withLogging $ K.logLocM K.DebugS $ "Config: " <> show config+  System.Directory.createDirectoryIfMissing True (Config.workDirectory config)+  SecureDirectory.init config+  bcs <- withLogging $ BC.parseFile config+  manager <- Network.HTTP.Client.TLS.newTlsManager+  baseUrl <- Servant.Client.parseBaseUrl $ toS $ Config.herculesApiBaseURL config+  let clientEnv :: Servant.Client.ClientEnv+      clientEnv = Servant.Client.mkClientEnv manager baseUrl+  token <- Token.readTokenFile $ toS $ Config.clusterJoinTokenPath config+  cachix <- withLogging $ Hercules.Agent.Cachix.Init.newEnv config (BC.cachixCaches bcs)+  nix <- Hercules.Agent.Nix.Init.newEnv+  serviceInfo <- ServiceInfo.newEnv clientEnv+  pure Env+    { manager = manager,+      config = config,+      herculesBaseUrl = baseUrl,+      herculesClientEnv = clientEnv,+      serviceInfo = serviceInfo,+      currentToken = Servant.Auth.Client.Token $ encodeUtf8 token,+      binaryCaches = bcs,+      cachixEnv = cachix,+      socket = panic "Socket not defined yet.", -- Hmm, needs different monad?+      kNamespace = emptyNamespace,+      kContext = mempty,+      kLogEnv = logEnv,+      nixEnv = nix+    }++setupLogging :: (K.LogEnv -> IO ()) -> IO ()+setupLogging f = do+  handleScribe <- K.mkHandleScribe K.ColorIfTerminal stderr (Compat.katipLevel K.DebugS) K.V2+  let mkLogEnv =+        K.registerScribe "stderr" handleScribe K.defaultScribeSettings+          =<< K.initLogEnv emptyNamespace ""+  bracket mkLogEnv K.closeScribes f++emptyNamespace :: K.Namespace+emptyNamespace = K.Namespace []++initCNix :: IO ()+initCNix = do+  CNix.init+  CNix.setTalkative
+ hercules-ci-agent/Hercules/Agent/Log.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Hercules.Agent.Log+  ( module Katip,+    logLocM,+    module Hercules.Agent.Log,+    getLoc,+  )+where++import Data.Aeson+import Katip hiding (logLocM)+import Katip.Core+import Katip.Monadic (logLocM)+import Protolude++instance StringConv [Char] LogStr where+  strConv l = logStr . (strConv l :: [Char] -> Text)++instance StringConv Text LogStr where+  strConv _ = logStr++withNamedContext :: (ToJSON a, KatipContext m) => Text -> a -> m b -> m b+withNamedContext name = katipAddContext . Katip.sl name++withContext :: (KatipContext m, LogItem a) => a -> m b -> m b+withContext = katipAddContext++-- TODO: Support context for all exceptions and use plain @panic@ instead.+panicWithLog :: KatipContext m => Text -> m a+panicWithLog msg = do+  logLocM ErrorS $ toSL msg+  panic msg
+ hercules-ci-agent/Hercules/Agent/Nix.hs view
@@ -0,0 +1,44 @@+module Hercules.Agent.Nix where++import Hercules.Agent.Env as Agent.Env+import Hercules.Agent.Nix.Env as Nix.Env+import Protolude+import System.Process (readProcess)+import qualified System.Process++withExtraOptions :: [(Text, Text)] -> App a -> App a+withExtraOptions extraOpts = local $ \env ->+  env+    { nixEnv =+        (nixEnv env)+          { extraOptions = extraOptions (nixEnv env) <> extraOpts+          }+    }++askExtraOptions :: MonadReader Agent.Env.Env m => m [(Text, Text)]+askExtraOptions = asks (extraOptions . nixEnv)++getExtraOptionArguments :: MonadReader Agent.Env.Env m => m [Text]+getExtraOptionArguments = do+  asks (f . extraOptions . nixEnv)+  where+    f = concatMap $ \(opt, val) -> ["--option", opt, val]++readNixProcess ::+  -- | Command+  Text ->+  -- | Options+  [Text] ->+  -- | Paths+  [Text] ->+  -- | Stdin+  Text ->+  App Text+readNixProcess cmd opts paths stdinText = do+  extraOpts <- getExtraOptionArguments+  toSL <$> liftIO (readProcess (toSL cmd) (map toSL (opts <> extraOpts <> ["--"] <> paths)) (toSL stdinText))++nixProc :: Text -> [Text] -> [Text] -> App System.Process.CreateProcess+nixProc exe opts args = do+  extraOpts <- getExtraOptionArguments+  pure $ System.Process.proc (toSL exe) (map toSL (opts <> extraOpts <> ["--"] <> args))
+ hercules-ci-agent/Hercules/Agent/Nix/Env.hs view
@@ -0,0 +1,8 @@+module Hercules.Agent.Nix.Env where++import Protolude++data Env+  = Env+      { extraOptions :: [(Text, Text)]+      }
+ hercules-ci-agent/Hercules/Agent/Nix/Init.hs view
@@ -0,0 +1,33 @@+module Hercules.Agent.Nix.Init where++import qualified Hercules.Agent.EnvironmentInfo as EnvironmentInfo+import Hercules.Agent.Nix.Env+import Protolude++newEnv :: IO Env+newEnv = do+  nixInfo <- EnvironmentInfo.getNixInfo+  when (EnvironmentInfo.nixNarinfoCacheNegativeTTL nixInfo /= Just 0) $ do+    putErrText+      "\n\+      \We have detected that the setting narinfo-cache-negative-ttl is non-zero.\n\+      \Running hercules-ci-agent on a system with a non-zero negative ttl will cause\n\+      \problems when run in a cluster.\n\+      \Note that this setting only affects the caching of paths that are *missing*\n\+      \from a cache. Paths that *are* in the binary cache are cached as configured in\n\+      \the 'positive' option.\n\+      \\n\+      \On NixOS and nix-darwin, use the recommended installation method via module,\n\+      \make sure that the `narinfo-cache-negative-ttl` isn't set via other means.\n\+      \If you can't use the module, use\+      \    nix.extraOptions = \"narinfo-cache-negative-ttl = 0\"\n\+      \\n\+      \or add to your system nix.conf:\n\+      \    narinfo-cache-negative-ttl = 0\n\+      \n"+    throwIO $ FatalError "Please configure your system's Nix with:  narinfo-cache-negative-ttl = 0  "+  -- Might want to take stuff from Config and put it in+  -- extraOptions here.+  pure Env+    { extraOptions = []+    }
+ hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs view
@@ -0,0 +1,50 @@+module Hercules.Agent.Nix.RetrieveDerivationInfo where++import CNix+import CNix.Internal.Context (Derivation)+import qualified Data.Map as M+import qualified Data.Text as T+import Foreign.ForeignPtr (ForeignPtr)+import Hercules.API.Agent.Evaluate.EvaluateEvent.DerivationInfo+  ( DerivationInfo (DerivationInfo),+  )+import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.DerivationInfo as DerivationInfo+import Protolude++retrieveDerivationInfo ::+  MonadIO m =>+  Ptr (Ref NixStore) ->+  DerivationInfo.DerivationPathText ->+  m DerivationInfo+retrieveDerivationInfo store drvPath = liftIO $ do+  drv <- getDerivation store (toSL drvPath)+  retrieveDerivationInfo' drvPath drv++retrieveDerivationInfo' :: Text -> ForeignPtr Derivation -> IO DerivationInfo+retrieveDerivationInfo' drvPath drv = do+  sourcePaths <- getDerivationSources drv+  inputDrvPaths <- getDerivationInputs drv+  outputs <- getDerivationOutputs drv+  env <- getDerivationEnv drv+  platform <- getDerivationPlatform drv+  let requiredSystemFeatures = maybe [] splitFeatures $ M.lookup "requiredSystemFeatures" env+      splitFeatures = filter (not . T.null) . T.split (== ' ') . toSL+  pure $ DerivationInfo+    { derivationPath = drvPath,+      platform = toSL platform,+      requiredSystemFeatures = requiredSystemFeatures,+      inputDerivations = inputDrvPaths & map (\(i, os) -> (toSL i, map toSL os)) & M.fromList,+      inputSources = map toSL sourcePaths,+      outputs =+        outputs+          & map+            ( \output ->+                ( toSL $ derivationOutputName output,+                  DerivationInfo.OutputInfo+                    { DerivationInfo.path = toSL $ derivationOutputPath output,+                      DerivationInfo.isFixed = derivationOutputHashAlgo output /= ""+                    }+                )+            )+          & M.fromList+    }
+ hercules-ci-agent/Hercules/Agent/NixPath.hs view
@@ -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)
+ hercules-ci-agent/Hercules/Agent/Options.hs view
@@ -0,0 +1,51 @@+module Hercules.Agent.Options+  ( Options (..),+    Mode (..),+    parse,+  )+where++import Hercules.Agent.CabalInfo (herculesAgentVersion)+import Hercules.Agent.Config (ConfigPath (..))+import Options.Applicative+import Protolude hiding (option)++data Options+  = Options+      { configFile :: ConfigPath,+        mode :: Mode+      }++parseOptions :: Parser Options+parseOptions =+  Options <$> parseConfigPath+    <*> parseMode++data Mode = Test | Run++parseMode :: Parser Mode+parseMode =+  flag Run Test $+    long "test-configuration"+      <> help "Don't start the agent but make sure the configuration is valid."++parseConfigPath :: Parser ConfigPath+parseConfigPath =+  TomlPath+    <$> strOption+      ( long "config" <> metavar "FILE"+          <> help+            "File path to the configuration file (TOML)"+      )++parserInfo :: ParserInfo Options+parserInfo =+  info+    (parseOptions <**> helper)+    ( fullDesc <> progDesc "Accepts tasks from Hercules CI and runs them."+        <> header+          ("hercules-ci-agent " <> toSL herculesAgentVersion)+    )++parse :: IO Options+parse = execParser parserInfo
+ hercules-ci-agent/Hercules/Agent/SecureDirectory.hs view
@@ -0,0 +1,29 @@+module Hercules.Agent.SecureDirectory where++import Hercules.Agent.Config (FinalConfig, workDirectory)+import Hercules.Agent.Env+import Protolude+import qualified System.Directory+import System.FilePath ((</>))+import qualified System.IO.Temp+import qualified System.Posix.Files as Posix++init :: FinalConfig -> IO ()+init cfg = do+  d <- getSecureDirectory cfg+  System.Directory.createDirectoryIfMissing True d+  -- ideally this would be atomic+  Posix.setFileMode d Posix.ownerModes -- owner only++getSecureDirectory :: FinalConfig -> IO FilePath+getSecureDirectory cfg = pure $ workDirectory cfg </> "secure"++withSecureTempFile ::+  -- | file name template+  [Char] ->+  (FilePath -> Handle -> App a) ->+  App a+withSecureTempFile tpl m = do+  cfg <- asks config+  d <- liftIO (getSecureDirectory cfg)+  System.IO.Temp.withTempFile d tpl m
+ hercules-ci-agent/Hercules/Agent/ServiceInfo.hs view
@@ -0,0 +1,32 @@+module Hercules.Agent.ServiceInfo where++import qualified Hercules.API.Agent.LifeCycle as API.LifeCycle+import qualified Hercules.API.Agent.LifeCycle.ServiceInfo as ServiceInfo+import qualified Hercules.Agent.Client as Client+import Hercules.Error (escalate)+import Network.URI+import Protolude+import qualified Servant.Client++data Env+  = Env+      { agentSocketBaseURL :: URI,+        bulkSocketBaseURL :: URI+      }++newEnv :: Servant.Client.ClientEnv -> IO Env+newEnv clientEnv = do+  serviceInfo <- escalate =<< Servant.Client.runClientM (API.LifeCycle.getServiceInfo Client.lifeCycleClient) clientEnv+  let parse varName text = case parseURI (toS text) of+        Nothing -> panic $ varName <> " invalid: " <> ServiceInfo.agentSocketBaseURL serviceInfo+        Just uri -> uri <$ do+          case uriScheme uri of+            "http:" -> pass+            "https:" -> pass+            x -> panic $ varName <> " has invalid uri scheme" <> toS x+  agentSocketBaseURL_ <- parse "agentSocketBaseURL" $ ServiceInfo.agentSocketBaseURL serviceInfo+  bulkSocketBaseURL_ <- parse "bulkSocketBaseURL" $ ServiceInfo.bulkSocketBaseURL serviceInfo+  pure Env+    { agentSocketBaseURL = agentSocketBaseURL_,+      bulkSocketBaseURL = bulkSocketBaseURL_+    }
+ hercules-ci-agent/Hercules/Agent/Token.hs view
@@ -0,0 +1,132 @@+module Hercules.Agent.Token where++import Control.Lens ((^?))+import qualified Data.Aeson as Aeson+import Data.Aeson.Lens (_String, key)+import qualified Data.ByteString.Base64.Lazy as B64L+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Hercules.API.Agent.LifeCycle+import qualified Hercules.API.Agent.LifeCycle.CreateAgentSession_V2 as CreateAgentSession+import Hercules.Agent.Client (lifeCycleClient)+import Hercules.Agent.Config (baseDirectory)+import Hercules.Agent.Env as Env+import qualified Hercules.Agent.EnvironmentInfo as EnvironmentInfo+import Hercules.Agent.Log+import Hercules.Error+import Protolude+import Servant.Auth.Client (Token (Token))+import qualified System.Directory+import System.FilePath ((</>))++getDir :: App FilePath+getDir = asks ((</> "secretState") . baseDirectory . config)++writeAgentSessionKey :: Text -> App ()+writeAgentSessionKey tok = do+  dir <- getDir+  liftIO $ System.Directory.createDirectoryIfMissing True dir+  liftIO $ writeFile (dir </> "session.key") (toS tok)++-- | Reads a token file, strips whitespace+readTokenFile :: MonadIO m => FilePath -> m Text+readTokenFile fp = liftIO $ sanitize <$> readFile fp+  where+    sanitize = T.map subst . T.strip+    subst '\n' = ' '+    subst x = x++readAgentSessionKey :: App (Maybe Text)+readAgentSessionKey = do+  dir <- getDir+  logLocM DebugS $ "Data directory: " <> show dir+  let file = dir </> "session.key"+  liftIO (System.Directory.doesFileExist file) >>= \case+    True -> notEmpty <$> readTokenFile file+      where+        notEmpty "" = Nothing+        notEmpty "x" = Nothing+        notEmpty token = Just token+    False -> pure Nothing++ensureAgentSession :: App Text+ensureAgentSession = readAgentSessionKey >>= \case+  Just sessKey -> do+    logLocM DebugS "Found agent session key"+    let handler e = do+          logLocM WarningS $ "Failed to check whether session token matches cluster join token. Using old session. Remove session.key if you need to force a session update. Exception: " <> show e+          pure sessKey+    safeLiftedHandle handler $ do+      cjt <- getClusterJoinTokenId+      logLocM DebugS $ "Found clusterJoinTokenId " <> show cjt+      scjt <- getSessionClusterJoinTokenId sessKey+      logLocM DebugS $ "Found sessionClusterJoinTokenId " <> show scjt+      if cjt == scjt+        then pure sessKey+        else do+          logLocM DebugS "Getting new session key to match cluster join token..."+          updateAgentSession+  Nothing -> do+    writeAgentSessionKey "x" -- Sanity check+    logLocM DebugS "Creating agent session"+    updateAgentSession++updateAgentSession :: App Text+updateAgentSession = do+  agentSessionKey <- createAgentSession+  logLocM DebugS "Agent session key acquired"+  writeAgentSessionKey agentSessionKey+  logLocM DebugS "Agent session key persisted"+  readAgentSessionKey >>= \case+    Just x -> do+      logLocM DebugS "Found the new agent session"+      pure x+    Nothing ->+      panic+        "The file session.key seems to have disappeared. Refusing to continue."++createAgentSession :: App Text+createAgentSession = do+  agentInfo <- EnvironmentInfo.extractAgentInfo+  logLocM DebugS $ "Agent info: " <> show agentInfo+  let createAgentBody =+        CreateAgentSession.CreateAgentSession {agentInfo = agentInfo}+  token <- asks Env.currentToken+  runHerculesClient' $+    Hercules.API.Agent.LifeCycle.agentSessionCreate+      lifeCycleClient+      createAgentBody+      token++-- TODO: Although this looks nice, the implicit limitation here is that we can+--       only have one token at a time. I wouldn't be surprised if this becomes+--       problematic at some point. Perhaps we should switch to a polymorphic+--       reader monad like RIO when we hit that limitation.+withAgentToken :: App a -> App a+withAgentToken m = do+  agentSessionToken <- ensureAgentSession+  local (\env -> env {Env.currentToken = Token $ toS agentSessionToken}) m++data TokenError = TokenError Text+  deriving (Typeable, Show)++instance Exception TokenError++getClusterJoinTokenId :: App Text+getClusterJoinTokenId = do+  t <-+    asks Env.currentToken >>= \case+      Token jwt -> pure jwt+  v <- decodeToken (toSL t)+  sub <- escalate $ maybeToEither (TokenError "No sub field in cluster join token") (v ^? key "sub" . _String)+  escalate $ maybeToEither (TokenError "Unrecognized token type") $ T.stripPrefix "t$" sub++getSessionClusterJoinTokenId :: Text -> App Text+getSessionClusterJoinTokenId t = do+  v <- decodeToken (toSL t)+  escalate $ maybeToEither (TokenError "No parent field in session token") (v ^? key "parent" . _String)++decodeToken :: BL.ByteString -> App Aeson.Value+decodeToken bs = case BL.split (fromIntegral $ ord '.') bs of+  (_ : payload : _) -> escalateAs (TokenError . toS) $ Aeson.eitherDecode (B64L.decodeLenient payload)+  _ -> throwIO $ FatalError "JWT without periods?"
+ hercules-ci-agent/Hercules/Agent/WorkerProcess.hs view
@@ -0,0 +1,123 @@+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 = case pidMaybe of Just x -> fromIntegral x; Nothing -> 0+    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
+ hercules-ci-agent/Main.hs view
@@ -0,0 +1,13 @@+module Main+  ( main,+  )+where++import qualified Hercules.Agent+import Protolude+import System.Posix.Signals++main :: IO ()+main = do+  _ <- installHandler sigTERM (Catch $ raiseSignal sigINT) Nothing+  Hercules.Agent.main
+ src-cnix/CNix.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module CNix+  ( module CNix,+    RawValue,+    rawValueType,+    module CNix.Internal.Store,+    module CNix.Internal.Typed,+    type NixStore,+    type EvalState,+    type Ref,+    type SecretKey,+  )+where++-- TODO: No more Ptr EvalState+-- TODO: No more NixStore when EvalState is already there+-- TODO: Map Nix-specific C++ exceptions to a CNix exception type+import CNix.Internal.Context+import CNix.Internal.Raw+import CNix.Internal.Store+import CNix.Internal.Typed+import Conduit+import qualified Data.Map as M+import qualified Foreign.C.String+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude hiding (evalState, throwIO)++newtype Bindings = Bindings (Ptr Bindings')++C.context context++C.include "<stdio.h>"++C.include "<cstring>"++C.include "<math.h>"++C.include "<nix/config.h>"++C.include "<nix/shared.hh>"++C.include "<nix/eval.hh>"++C.include "<nix/eval-inline.hh>"++C.include "<nix/store-api.hh>"++C.include "<nix/common-eval-args.hh>"++C.include "<nix/get-drvs.hh>"++C.include "<nix/derivations.hh>"++C.include "<nix/affinity.hh>"++C.include "<nix/globals.hh>"++C.include "aliases.h"++C.include "<gc/gc.h>"++C.include "<gc/gc_cpp.h>"++C.include "<gc/gc_allocator.h>"++C.using "namespace nix"++C.verbatim "\nGC_API void GC_CALL GC_throw_bad_alloc() { throw std::bad_alloc(); }\n"++init :: IO ()+init =+  void+    [C.throwBlock| void {+      nix::initNix();+      nix::initGC();+    } |]++setTalkative :: IO ()+setTalkative =+  [C.throwBlock| void {+    nix::verbosity = nix::lvlTalkative;+  } |]++setDebug :: IO ()+setDebug =+  [C.throwBlock| void {+    nix::verbosity = nix::lvlVomit;+  } |]++setGlobalOption :: Text -> Text -> IO ()+setGlobalOption opt value = do+  let optionStr = encodeUtf8 opt+      valueStr = encodeUtf8 value+  [C.throwBlock| void {+    globalConfig.set($bs-cstr:optionStr, $bs-cstr:valueStr);+  }|]++setOption :: Text -> Text -> IO ()+setOption opt value = do+  let optionStr = encodeUtf8 opt+      valueStr = encodeUtf8 value+  [C.throwBlock| void {+    settings.set($bs-cstr:optionStr, $bs-cstr:valueStr);+  }|]++mkBindings :: Ptr Bindings' -> IO Bindings+mkBindings p = pure $ Bindings p++withEvalState ::+  MonadResource m =>+  Ptr (Ref NixStore) ->+  (Ptr EvalState -> ConduitT i o m r) ->+  ConduitT i o m r+withEvalState store =+  bracketP+    ( liftIO $+        [C.throwBlock| EvalState* {+          Strings searchPaths;+          return new EvalState(searchPaths, *$(refStore* store));+        } |]+    )+    (\x -> liftIO $ [C.throwBlock| void { delete $(EvalState* x); } |])++evalFile :: Ptr EvalState -> FilePath -> IO RawValue+evalFile evalState filename = do+  filename' <- Foreign.C.String.newCString filename+  mkRawValue+    =<< [C.throwBlock| Value* {+      Value value;+      $(EvalState *evalState)->evalFile($(const char *filename'), value);+      return new (NoGC) Value(value);+    }|]++-- leaks+newStrings :: IO (Ptr Strings)+newStrings = [C.exp| Strings* { new (NoGC) Strings() }|]++appendString :: Ptr Strings -> ByteString -> IO ()+appendString ss s =+  [C.block| void {+    $(Strings *ss)->push_back($bs-ptr:s);+  }|]++evalArgs :: Ptr EvalState -> [ByteString] -> IO Bindings+evalArgs evalState args = do+  argsStrings <- newStrings+  forM_ args $ appendString argsStrings+  mkBindings+    =<< [C.throwBlock| Bindings * {+      Strings *args = $(Strings *argsStrings);+      struct MixEvalArgs evalArgs;+      Bindings *autoArgs;+      EvalState &state = *$(EvalState *evalState);++      evalArgs.parseCmdline(*args);+      autoArgs = evalArgs.getAutoArgs(state);+      if (autoArgs == NULL) {+        //cerr << "Could not evaluate automatic arguments" << endl;+        abort(); // FIXME+      }+      return autoArgs;++      // catch (EvalError & e) {+      // catch (Error & e) {+      // catch (std::exception & e) {++    }|]++autoCallFunction :: Ptr EvalState -> RawValue -> Bindings -> IO RawValue+autoCallFunction evalState (RawValue fun) (Bindings autoArgs) =+  mkRawValue+    =<< [C.throwBlock| Value* {+          Value result;+          $(EvalState *evalState)->autoCallFunction(+                  *$(Bindings *autoArgs),+                  *$(Value *fun),+                  result);+          return new (NoGC) Value (result);+        }|]++isDerivation :: Ptr EvalState -> RawValue -> IO Bool+isDerivation evalState (RawValue v) =+  (0 /=)+    <$> [C.throwBlock| int {+          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }+          return $(EvalState *evalState)->isDerivation(*$(Value *v));+        }|]++isFunctor :: Ptr EvalState -> RawValue -> IO Bool+isFunctor evalState (RawValue v) =+  (0 /=)+    <$> [C.throwBlock| int {+          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }+          return $(EvalState *evalState)->isFunctor(*$(Value *v));+        }|]++getRecurseForDerivations :: Ptr EvalState -> Value NixAttrs -> IO Bool+getRecurseForDerivations evalState (Value (RawValue v)) =+  (0 /=)+    <$> [C.throwBlock| int {+          Value *v = $(Value *v);+          EvalState *evalState = $(EvalState *evalState);+          Symbol rfd = evalState->symbols.create("recurseForDerivations");+          Bindings::iterator iter = v->attrs->find(rfd);+          if (iter == v->attrs->end()) {+            return 0;+          } else {+            evalState->forceValue(*iter->value);+            if (iter->value->type == ValueType::tBool) {+              return iter->value->boolean ? 1 : 0;+            } else {+              // They can be empty attrsets???+              // Observed in nixpkgs master 67e2de195a4aa0a50ffb1e1ba0b4fb531dca67dc+              return 1;+            }+          }+        } |]++getAttrBindings :: Value NixAttrs -> IO Bindings+getAttrBindings (Value (RawValue v)) = mkBindings =<< [C.exp| Bindings *{ $(Value *v)->attrs } |]++getAttrs :: Value NixAttrs -> IO (Map ByteString RawValue)+getAttrs (Value (RawValue v)) = do+  begin <- [C.exp| Attr *{ $(Value *v)->attrs->begin() }|]+  end <- [C.exp| Attr *{ $(Value *v)->attrs->end() }|]+  let gather :: Map ByteString RawValue -> Ptr Attr' -> IO (Map ByteString RawValue)+      gather acc i | i == end = pure acc+      gather acc i+        | otherwise =+          do+            name <- unsafeMallocBS [C.exp| const char *{ strdup(static_cast<std::string>($(Attr *i)->name).c_str()) } |]+            value <- mkRawValue =<< [C.exp| Value *{ new (NoGC) Value(*$(Attr *i)->value) } |]+            let acc' = M.insert name value acc+            seq acc' pass+            gather acc' =<< [C.exp| Attr *{ &$(Attr *i)[1] }|]+  gather mempty begin++getDrvFile :: MonadIO m => Ptr EvalState -> RawValue -> m ByteString+getDrvFile evalState (RawValue v) =+  unsafeMallocBS+    [C.throwBlock| const char *{+      EvalState &state = *$(EvalState *evalState);+      auto drvInfo = getDerivation(state, *$(Value *v), false);+      if (!drvInfo)+        throw EvalError("Not a valid derivation");++      std::string drvPath = drvInfo->queryDrvPath();++      // write it (?)+      auto drv = state.store->derivationFromPath(drvPath);++      return strdup(drvPath.c_str());+    }|]
+ src-cnix/CNix/Internal/Context.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module CNix.Internal.Context+  ( module CNix.Internal.Context,+    NixStore,+  )+where++import Cachix.Client.Store.Context (NixStore)+import Data.ByteString.Unsafe (unsafePackMallocCString)+import qualified Data.Map as M+import qualified Foreign.C.String+import Hercules.Agent.StoreFFI (ExceptionPtr)+import qualified Language.C.Inline.Context as C+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Types as C+import Protolude++data EvalState++data Strings++data Ref a++data Bindings'++data Value'++data Attr'++data HerculesStore++data Derivation++data Fields++data HerculesLoggerEntry++data LogEntryQueue++data StringsIterator++data DerivationOutputsIterator++data DerivationInputsIterator++data StringPairsIterator++data StringPairs++data SecretKey++context :: C.Context+context =+  C.cppCtx <> C.fptrCtx+    <> C.bsCtx+      { C.ctxTypesTable =+          M.singleton (C.TypeName "refStore") [t|Ref NixStore|]+            <> M.singleton (C.TypeName "EvalState") [t|EvalState|]+            <> M.singleton (C.TypeName "Bindings") [t|Bindings'|]+            <> M.singleton (C.TypeName "Value") [t|Value'|]+            <> M.singleton (C.TypeName "Attr") [t|Attr'|]+            <> M.singleton (C.TypeName "Strings") [t|Strings|]+            <> M.singleton (C.TypeName "StringsIterator") [t|StringsIterator|]+            <> M.singleton (C.TypeName "StringPairs") [t|StringPairs|]+            <> M.singleton (C.TypeName "StringPairsIterator") [t|StringPairsIterator|]+            <> M.singleton (C.TypeName "refHerculesStore") [t|Ref HerculesStore|]+            <> M.singleton (C.TypeName "Derivation") [t|Derivation|]+            <> M.singleton (C.TypeName "LoggerFields") [t|Fields|]+            <> M.singleton (C.TypeName "HerculesLoggerEntry") [t|HerculesLoggerEntry|]+            <> M.singleton (C.TypeName "LogEntryQueue") [t|LogEntryQueue|]+            <> M.singleton (C.TypeName "DerivationOutputsIterator") [t|DerivationOutputsIterator|]+            <> M.singleton (C.TypeName "DerivationInputsIterator") [t|DerivationInputsIterator|]+            <> M.singleton (C.TypeName "exception_ptr") [t|ExceptionPtr|]+            <> M.singleton (C.TypeName "SecretKey") [t|SecretKey|]+      }++unsafeMallocBS :: MonadIO m => IO Foreign.C.String.CString -> m ByteString+unsafeMallocBS m = liftIO (unsafePackMallocCString =<< m)
+ src-cnix/CNix/Internal/Raw.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module CNix.Internal.Raw where++import CNix.Internal.Context+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude hiding (evalState)+import Prelude ()++C.context context++C.include "<nix/config.h>"++C.include "<nix/eval.hh>"++C.include "<nix/eval-inline.hh>"++C.include "aliases.h"++C.include "<gc/gc.h>"++C.include "<gc/gc_cpp.h>"++C.include "<gc/gc_allocator.h>"++C.using "namespace nix"++newtype RawValue = RawValue (Ptr Value')++-- | Takes ownership of the value.+mkRawValue :: Ptr Value' -> IO RawValue+mkRawValue p = pure $ RawValue p++-- | Similar to Nix's Value->type but conflates the List variations+data RawValueType+  = Int+  | Bool+  | String+  | Path+  | Null+  | Attrs+  | List+  | Thunk+  | App+  | Lambda+  | Blackhole+  | PrimOp+  | PrimOpApp+  | External+  | Float+  | Other+  deriving (Generic, Show, Eq, Ord)++-- | You may need to 'forceValue' first.+rawValueType :: RawValue -> IO RawValueType+rawValueType (RawValue v) =+  f+    <$> [C.block| int {+      switch ($(Value* v)->type) {+        case tInt:         return 1;+        case tBool:        return 2;+        case tString:      return 3;+        case tPath:        return 4;+        case tNull:        return 5;+        case tAttrs:       return 6;+        case tList1:       return 7;+        case tList2:       return 8;+        case tListN:       return 9;+        case tThunk:       return 10;+        case tApp:         return 11;+        case tLambda:      return 12;+        case tBlackhole:   return 13;+        case tPrimOp:      return 14;+        case tPrimOpApp:   return 15;+        case tExternal:    return 16;+        case tFloat:       return 17;+        default: return 0;+      }+    }|]+  where+    f 1 = Int+    f 2 = Bool+    f 3 = String+    f 4 = Path+    f 5 = Null+    f 6 = Attrs+    f 7 = List+    f 8 = List+    f 9 = List+    f 10 = Thunk+    f 11 = App+    f 12 = Lambda+    f 13 = Blackhole+    f 14 = PrimOp+    f 15 = PrimOpApp+    f 16 = External+    f 17 = Float+    f _ = Other++forceValue :: Exception a => Ptr EvalState -> RawValue -> IO (Either a ())+forceValue evalState (RawValue v) =+  try+    [C.catchBlock|  {+      Value *v = $(Value *v);+      if (v == NULL) throw std::invalid_argument("forceValue value must be non-null");+      $(EvalState *evalState)->forceValue(*v);+    }|]
+ src-cnix/CNix/Internal/Store.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module CNix.Internal.Store+  ( module CNix.Internal.Store,+    HerculesStore,+  )+where++import CNix.Internal.Context+import Control.Exception+import Control.Monad.IO.Unlift+import qualified Data.ByteString.Unsafe as BS+import Data.Coerce+import qualified Data.Map as M+import Foreign.C.String (withCString)+import Foreign.ForeignPtr+import Foreign.StablePtr+import Hercules.Agent.StoreFFI+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude+import System.IO.Unsafe (unsafePerformIO)+import Prelude ()++C.context context++C.include "<cstring>"++C.include "<nix/config.h>"++C.include "<nix/shared.hh>"++C.include "<nix/store-api.hh>"++C.include "<nix/get-drvs.hh>"++C.include "<nix/derivations.hh>"++C.include "<nix/affinity.hh>"++C.include "<nix/globals.hh>"++C.include "aliases.h"++C.using "namespace nix"++withStore :: MonadUnliftIO m => (Ptr (Ref NixStore) -> m a) -> m a+withStore m = do+  UnliftIO ul <- askUnliftIO+  liftIO $ withStore' $ \a -> ul (m a)++withStore' ::+  (Ptr (Ref NixStore) -> IO r) ->+  IO r+withStore' =+  bracket+    ( liftIO $+        [C.throwBlock| refStore* {+            refStore s = openStore();+            return new refStore(s);+          } |]+    )+    (\x -> liftIO $ [C.exp| void { delete $(refStore* x) } |])++withStoreFromURI ::+  MonadUnliftIO m =>+  Text ->+  (Ptr (Ref NixStore) -> m r) ->+  m r+withStoreFromURI storeURIText f = do+  let storeURI = encodeUtf8 storeURIText+  (UnliftIO unlift) <- askUnliftIO+  liftIO $+    bracket+      [C.throwBlock| refStore* {+        refStore s = openStore($bs-cstr:storeURI);+        return new refStore(s);+      }|]+      (\x -> [C.exp| void { delete $(refStore* x) } |])+      (unlift . f)++storeUri :: MonadIO m => Ptr (Ref NixStore) -> m ByteString+storeUri store =+  unsafeMallocBS+    [C.block| const char* {+       std::string uri = (*$(refStore* store))->getUri();+       return strdup(uri.c_str());+     } |]++ensurePath :: Ptr (Ref NixStore) -> ByteString -> IO ()+ensurePath store path =+  [C.throwBlock| void {+    (*$(refStore* store))->ensurePath(std::string($bs-ptr:path, $bs-len:path));+  } |]++clearPathInfoCache :: Ptr (Ref NixStore) -> IO ()+clearPathInfoCache store =+  [C.throwBlock| void {+    (*$(refStore* store))->clearPathInfoCache();+  } |]++clearSubstituterCaches :: IO ()+clearSubstituterCaches =+  [C.throwBlock| void {+    auto subs = nix::getDefaultSubstituters();+    for (auto sub : subs) {+      sub->clearPathInfoCache();+    }+  } |]++buildPath :: Ptr (Ref NixStore) -> ByteString -> IO ()+buildPath store path =+  [C.throwBlock| void {+    PathSet ps({std::string($bs-ptr:path, $bs-len:path)});+    (*$(refStore* store))->buildPaths(ps);+   } |]++getDerivation :: Ptr (Ref NixStore) -> ByteString -> IO (ForeignPtr Derivation)+getDerivation store path = do+  ptr <-+    [C.throwBlock| Derivation *{+      return new Derivation(+          (*$(refStore* store))->derivationFromPath(std::string($bs-ptr:path, $bs-len:path))+        );+    } |]+  newForeignPtr finalizeDerivation ptr++-- Useful for testingg+getDerivationFromFile :: ByteString -> IO (ForeignPtr Derivation)+getDerivationFromFile path = do+  ptr <-+    [C.throwBlock| Derivation *{+      return new Derivation(+          readDerivation(std::string($bs-ptr:path, $bs-len:path))+        );+    } |]+  newForeignPtr finalizeDerivation ptr++finalizeDerivation :: FinalizerPtr Derivation+{-# NOINLINE finalizeDerivation #-}+finalizeDerivation =+  unsafePerformIO+    [C.exp|+    void (*)(Derivation *) {+      [](Derivation *v) {+        delete v;+      }+    } |]++-- | Throws when missing+getDerivationOutputPath :: ForeignPtr Derivation -> ByteString -> IO ByteString+getDerivationOutputPath fd outputName = withForeignPtr fd $ \d ->+  [C.throwBlock|+    const char *{+      std::string outputName($bs-ptr:outputName, $bs-len:outputName);+      Derivation *d = $(Derivation *d);+      return strdup(d->outputs.at(outputName).path.c_str());+    }+  |]+    >>= BS.unsafePackMallocCString++data DerivationOutput+  = DerivationOutput+      { derivationOutputName :: !ByteString,+        derivationOutputPath :: !ByteString,+        derivationOutputHashAlgo :: !ByteString,+        derivationOutputHash :: !ByteString+      }++getDerivationOutputs :: ForeignPtr Derivation -> IO [DerivationOutput]+getDerivationOutputs derivation =+  bracket+    [C.exp| DerivationOutputsIterator* {+      new DerivationOutputsIterator($fptr-ptr:(Derivation *derivation)->outputs.begin())+    }|]+    deleteDerivationOutputsIterator+    $ \i -> fix $ \continue -> do+      isEnd <- (0 /=) <$> [C.exp| bool { *$(DerivationOutputsIterator *i) == $fptr-ptr:(Derivation *derivation)->outputs.end() }|]+      if isEnd+        then pure []+        else do+          name <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->first.c_str()) }|] >>= BS.unsafePackMallocCString+          path <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.path.c_str()) }|] >>= BS.unsafePackMallocCString+          hash_ <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.hash.c_str()) }|] >>= BS.unsafePackMallocCString+          hashAlgo <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.hashAlgo.c_str()) }|] >>= BS.unsafePackMallocCString+          [C.block| void { (*$(DerivationOutputsIterator *i))++; }|]+          (DerivationOutput name path hashAlgo hash_ :) <$> continue++deleteDerivationOutputsIterator :: Ptr DerivationOutputsIterator -> IO ()+deleteDerivationOutputsIterator a = [C.block| void { delete $(DerivationOutputsIterator *a); }|]++getDerivationPlatform :: ForeignPtr Derivation -> IO ByteString+getDerivationPlatform derivation =+  unsafeMallocBS+    [C.exp| const char* {+       strdup($fptr-ptr:(Derivation *derivation)->platform.c_str())+     } |]++getDerivationSources :: ForeignPtr Derivation -> IO [ByteString]+getDerivationSources derivation =+  bracket+    [C.throwBlock| Strings* {+      Strings *r = new Strings();+      for (auto i : $fptr-ptr:(Derivation *derivation)->inputSrcs) {+        r->push_back(i);+      }+      return r;+    }|]+    deleteStrings+    toByteStrings++getDerivationInputs :: ForeignPtr Derivation -> IO [(ByteString, [ByteString])]+getDerivationInputs derivation =+  bracket+    [C.exp| DerivationInputsIterator* {+      new DerivationInputsIterator($fptr-ptr:(Derivation *derivation)->inputDrvs.begin())+    }|]+    deleteDerivationInputsIterator+    $ \i -> fix $ \continue -> do+      isEnd <- (0 /=) <$> [C.exp| bool { *$(DerivationInputsIterator *i) == $fptr-ptr:(Derivation *derivation)->inputDrvs.end() }|]+      if isEnd+        then pure []+        else do+          name <- [C.exp| const char*{ strdup((*$(DerivationInputsIterator *i))->first.c_str()) }|] >>= BS.unsafePackMallocCString+          outs <-+            bracket+              [C.block| Strings*{ +                Strings *r = new Strings();+                for (auto i : (*$(DerivationInputsIterator *i))->second) {+                  r->push_back(i);+                }+                return r;+              }|]+              deleteStrings+              toByteStrings+          [C.block| void { (*$(DerivationInputsIterator *i))++; }|]+          ((name, outs) :) <$> continue++deleteDerivationInputsIterator :: Ptr DerivationInputsIterator -> IO ()+deleteDerivationInputsIterator a = [C.block| void { delete $(DerivationInputsIterator *a); }|]++getDerivationEnv :: ForeignPtr Derivation -> IO (Map ByteString ByteString)+getDerivationEnv derivation =+  [C.exp| StringPairs* { &($fptr-ptr:(Derivation *derivation)->env) }|]+    >>= toByteStringMap++getDerivationOutputNames :: ForeignPtr Derivation -> IO [ByteString]+getDerivationOutputNames derivation =+  bracket+    [C.throwBlock| Strings* {+      Strings *r = new Strings();+      for (auto i : $fptr-ptr:(Derivation *derivation)->outputs) {+        r->push_back(i.first);+      }+      return r;+    }|]+    deleteStrings+    toByteStrings++deleteStringPairs :: Ptr StringPairs -> IO ()+deleteStringPairs s = [C.block| void { delete $(StringPairs *s); }|]++deleteStrings :: Ptr Strings -> IO ()+deleteStrings s = [C.block| void { delete $(Strings *s); }|]++finalizeStrings :: FinalizerPtr Strings+{-# NOINLINE finalizeStrings #-}+finalizeStrings =+  unsafePerformIO+    [C.exp|+    void (*)(Strings *) {+      [](Strings *v) {+        delete v;+      }+    } |]++getStringsLength :: Ptr Strings -> IO C.CSize+getStringsLength strings = [C.exp| size_t { $(Strings *strings)->size() }|]++toByteStrings :: Ptr Strings -> IO [ByteString]+toByteStrings strings = do+  i <- [C.exp| StringsIterator *{ new StringsIterator($(Strings *strings)->begin()) } |]+  fix $ \go -> do+    isEnd <- (0 /=) <$> [C.exp| bool { *$(StringsIterator *i) == $(Strings *strings)->end() }|]+    if isEnd+      then pure []+      else do+        s <- [C.exp| const char*{ strdup((*$(StringsIterator *i))->c_str()) }|]+        bs <- BS.unsafePackMallocCString s+        [C.block| void { (*$(StringsIterator *i))++; }|]+        (bs :) <$> go++toByteStringMap :: Ptr StringPairs -> IO (Map ByteString ByteString)+toByteStringMap strings = M.fromList <$> do+  i <- [C.exp| StringPairsIterator *{ new StringPairsIterator($(StringPairs *strings)->begin()) } |]+  fix $ \go -> do+    isEnd <- (0 /=) <$> [C.exp| bool { *$(StringPairsIterator *i) == $(StringPairs *strings)->end() }|]+    if isEnd+      then pure []+      else do+        k <- [C.exp| const char*{ strdup((*$(StringPairsIterator *i))->first.c_str()) }|]+        v <- [C.exp| const char*{ strdup((*$(StringPairsIterator *i))->second.c_str()) }|]+        bk <- BS.unsafePackMallocCString k+        bv <- BS.unsafePackMallocCString v+        [C.block| void { (*$(StringPairsIterator *i))++; }|]+        ((bk, bv) :) <$> go++withStrings :: (Ptr Strings -> IO a) -> IO a+withStrings =+  bracket+    [C.exp| Strings *{ new Strings() }|]+    (\sp -> [C.block| void { delete $(Strings *sp); }|])++pushString :: Ptr Strings -> ByteString -> IO ()+pushString strings s =+  [C.block| void { $(Strings *strings)->push_back($bs-cstr:s); }|]++copyClosure :: Ptr (Ref NixStore) -> Ptr (Ref NixStore) -> [ByteString] -> IO ()+copyClosure src dest paths = do+  withStrings $ \pathStrings -> do+    paths & traverse_ (pushString pathStrings)+    [C.throwBlock| void {+      StringSet pathSet;+      for (auto path : *$(Strings *pathStrings)) {+        pathSet.insert(path);+      }+      nix::copyClosure(*$(refStore* src), *$(refStore* dest), pathSet);+    }|]++parseSecretKey :: ByteString -> IO (ForeignPtr SecretKey)+parseSecretKey bs =+  [C.throwBlock| SecretKey* {+    return new SecretKey($bs-cstr:bs);+  }|]+    >>= newForeignPtr finalizeSecretKey++finalizeSecretKey :: FinalizerPtr SecretKey+{-# NOINLINE finalizeSecretKey #-}+finalizeSecretKey =+  unsafePerformIO+    [C.exp|+    void (*)(SecretKey *) {+      [](SecretKey *v) {+        delete v;+      }+    } |]++signPath ::+  Ptr (Ref NixStore) ->+  -- | Secret signing key+  Ptr SecretKey ->+  -- | Store path+  ByteString ->+  -- | False if the signature was already present, True if the signature was added+  IO Bool+signPath store secretKey path = (== 1) <$> do+  [C.throwBlock| int {+    nix::ref<nix::Store> store = *$(refStore *store);+    std::string storePath($bs-cstr:path);+    auto currentInfo = store->queryPathInfo(storePath);++    auto info2(*currentInfo);+    info2.sigs.clear();+    info2.sign(*$(SecretKey *secretKey));+    assert(!info2.sigs.empty());+    auto sig = *info2.sigs.begin();++    if (currentInfo->sigs.count(sig)) {+      return 0;+    } else {+      store->addSignatures(storePath, info2.sigs);+      return 1;+    }+  }|]++----- Hercules -----+withHerculesStore ::+  Ptr (Ref NixStore) ->+  (Ptr (Ref HerculesStore) -> IO a) ->+  IO a+withHerculesStore wrappedStore =+  bracket+    ( liftIO $+        [C.block| refHerculesStore* {+          refStore &s = *$(refStore *wrappedStore);+          refHerculesStore hs(new HerculesStore({}, s));+          return new refHerculesStore(hs);+        } |]+    )+    (\x -> liftIO $ [C.exp| void { delete $(refHerculesStore* x) } |])++nixStore :: Ptr (Ref HerculesStore) -> Ptr (Ref NixStore)+nixStore = coerce++printDiagnostics :: Ptr (Ref HerculesStore) -> IO ()+printDiagnostics s =+  [C.throwBlock| void{+    (*$(refHerculesStore* s))->printDiagnostics();+  }|]++-- TODO catch pure exceptions from displayException+setBuilderCallback :: Ptr (Ref HerculesStore) -> (ByteString -> IO ()) -> IO ()+setBuilderCallback s callback = do+  p <-+    mkBuilderCallback $ \cstr exceptionToThrowPtr ->+      Control.Exception.catch (BS.unsafePackMallocCString cstr >>= callback) $ \e ->+        withCString (displayException (e :: SomeException)) $ \renderedException -> do+          stablePtr <- castStablePtrToPtr <$> newStablePtr e+          [C.block| void {+            (*$(exception_ptr *exceptionToThrowPtr)) = std::make_exception_ptr(HaskellException(std::string($(const char* renderedException)), $(void* stablePtr)));+          }|]+  [C.throwBlock| void {+    (*$(refHerculesStore* s))->setBuilderCallback($(void (*p)(const char *, exception_ptr *) ));+  }|]
+ src-cnix/CNix/Internal/Typed.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE EmptyDataDecls #-}++module CNix.Internal.Typed where++import CNix.Internal.Context+import CNix.Internal.Raw+import Protolude hiding+  ( evalState,+    throwIO,+  )+import Prelude (userError)++-- | Runtime-Typed Value. This implies that it has been forced,+-- because otherwise the type would not be known.+newtype Value a = Value {rtValue :: RawValue}++data NixInt++data NixFloat++data NixString++data NixPath++data NixAttrs++data NixFunction++data NixList++data NixPrimOp++data NixPrimOpApp++data NixExternal++-- TODO: actually encapsulate the constructor+unsafeAssertType :: RawValue -> Value a+unsafeAssertType = Value++-- This is useful because you regain exhaustiveness checking.+-- Otherwise a bunch of downcast functions might do.+data Match+  = IsInt (Value NixInt)+  | IsBool (Value Bool)+  | IsString (Value NixString)+  | IsPath (Value NixPath)+  | IsNull (Value ())+  | IsAttrs (Value NixAttrs)+  | IsList (Value NixList)+  | IsFunction (Value NixFunction)+  | IsExternal (Value NixExternal)+  | IsFloat (Value NixFloat)++-- FIXME: errors don't provide any clue here+match :: Ptr EvalState -> RawValue -> IO (Either SomeException Match)+match es v = forceValue es v >>= \case+  Left e -> pure (Left e)+  Right _ -> rawValueType v <&> \case+    Int -> pure $ IsInt $ unsafeAssertType v+    Bool -> pure $ IsBool $ unsafeAssertType v+    String -> pure $ IsString $ unsafeAssertType v+    Path -> pure $ IsPath $ unsafeAssertType v+    Null -> pure $ IsNull $ unsafeAssertType v+    Attrs -> pure $ IsAttrs $ unsafeAssertType v+    List -> pure $ IsList $ unsafeAssertType v+    Thunk -> Left $ SomeException $ userError "Could not force Nix thunk" -- FIXME: custom exception?+    App -> Left $ SomeException $ userError "Could not force Nix thunk (App)"+    Blackhole ->+      Left $ SomeException $ userError "Could not force Nix thunk (Blackhole)"+    Lambda -> pure $ IsFunction $ unsafeAssertType v+    PrimOp -> pure $ IsFunction $ unsafeAssertType v+    PrimOpApp -> pure $ IsFunction $ unsafeAssertType v+    External -> pure $ IsExternal $ unsafeAssertType v+    Float -> pure $ IsFloat $ unsafeAssertType v+    Other ->+      Left $ SomeException $ userError "Unknown runtime type in Nix value"
+ src-internal-ffi/Hercules/Agent/StoreFFI.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fobject-code #-}+{-# LANGUAGE CPP #-}++module Hercules.Agent.StoreFFI where++import qualified Foreign.C+import Protolude++type BuilderCallback = Foreign.C.CString -> Ptr ExceptionPtr -> IO ()++-- Work around a problem in ghcide with foreign imports.+#ifndef GHCIDE+foreign import ccall "wrapper"+  mkBuilderCallback :: BuilderCallback -> IO (FunPtr BuilderCallback)+#else+mkBuilderCallback :: BuilderCallback -> IO (FunPtr BuilderCallback)+mkBuilderCallback = panic "This is a stub to work around a ghcide issue. Please compile without -DGHCIDE"+#endif++data ExceptionPtr
+ src/Data/Conduit/Extras.hs view
@@ -0,0 +1,43 @@+module Data.Conduit.Extras where++import Control.Concurrent.Chan+import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Trans+import Data.Conduit+import Prelude++-- | Write to a channel terminating with @Nothing@+sinkChanTerminate :: (MonadUnliftIO m, MonadIO m) => Chan (Maybe a) -> ConduitT a o m ()+sinkChanTerminate ch =+  handleC+    ( \e -> liftIO $ do+        writeChan ch Nothing+        throwIO (e :: SomeException)+    )+    $ do+      awaitForever $ \msg -> liftIO $ writeChan ch (Just msg)+      liftIO $ writeChan ch Nothing++-- | Write to a channel terminating with @Nothing@+sinkChan :: (MonadUnliftIO m, MonadIO m) => Chan (Maybe a) -> ConduitT a o m ()+sinkChan ch =+  handleC+    ( \e -> liftIO $ do+        throwIO (e :: SomeException)+    )+    $ do+      awaitForever $ \msg -> liftIO $ writeChan ch (Just msg)++-- | Read a channel until @Nothing@ is encountered+sourceChan :: MonadIO m => Chan (Maybe a) -> ConduitT i a m ()+sourceChan ch = do+  mmsg <- liftIO $ readChan ch+  case mmsg of+    Nothing -> liftIO $ writeChan ch Nothing+    Just msg -> yield msg >> sourceChan ch++conduitToCallbacks :: (MonadUnliftIO m, MonadIO m) => ConduitT () o m a -> (o -> m ()) -> m a+conduitToCallbacks c w = do+  runConduit (c `fuseUpstream` awaitForever (lift . w))
+ src/Data/Fixed/Extras.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Fixed.Extras where++import Data.Fixed+import Prelude++-- | Round to fixed precision using a rounding function.+--+-- >>> toFixed ceiling 0.12345 :: Milli+-- 0.124+toFixed :: forall res a. (Num a, HasResolution res) => (a -> Integer) -> a -> Fixed res+toFixed rounding a =+  let r = resolution out+      out = MkFixed $ rounding (a * fromIntegral r)+   in out
+ src/Data/Time/Extras.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Time.Extras where++import Control.Concurrent.Thread.Delay+import Data.Fixed+import Data.Fixed.Extras+import Data.Time+import Prelude++delayMicro :: Micro -> IO ()+delayMicro (MkFixed mus) = delay mus++delayNominalDiffTime :: NominalDiffTime -> IO ()+delayNominalDiffTime = delayMicro . toFixed ceiling
+ src/Hercules/Agent/Producer.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Agent.Producer where++import Control.Applicative+import Control.Concurrent hiding (throwTo)+import Control.Concurrent.Async hiding (cancel)+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.State+import Data.Foldable+import Data.Traversable+import Katip+import UnliftIO.Exception+import Prelude++-- | A thread producing zero or more payloads and a final value.+-- Handles exception propagation.+data Producer p r+  = Producer+      { producerQueueRead :: STM (Msg p r),+        producerThread :: ThreadId+      }+  deriving (Functor)++data ProducerCancelled = ProducerCancelled+  deriving (Show, Exception, Typeable)++data Msg p r+  = -- | One of possibly many payloads from the producer+    Payload p+  | -- | The producer stopped due to an exception+    Exception SomeException+  | -- | The producer was done and produced a final value+    Close r+  deriving (Functor)++-- | @forkProducer f@ produces a computation that forks a thread for @f@, which+-- receives a function for returning payloads @p@.+--+-- @f@ may produce a final result value @r@ when it is done.+forkProducer :: forall m p r. (MonadIO m, MonadUnliftIO m) => ((p -> m ()) -> m r) -> m (Producer p r)+forkProducer f = do+  q <- liftIO newTQueueIO+  let write :: MonadIO m' => Msg p r -> m' ()+      write = liftIO . atomically . writeTQueue q+  f' <- toIO (f (write . Payload))+  t <- liftIO $ forkFinally f' (write . toResult)+  pure $ Producer {producerQueueRead = readTQueue q, producerThread = t}+  where+    toResult (Left e) = Exception e+    toResult (Right r) = Close r++-- | Throws 'ProducerCancelled' as an async exception to the producer thread.+-- Blocks until exception is raised. See 'throwTo'.+cancel :: MonadIO m => Producer p r -> m ()+cancel p = liftIO $ throwTo (producerThread p) ProducerCancelled++-- | Perform an computation while @withProducer@ takes care of forking and cleaning up.+--+-- @withProducer (\write -> write "a" >> write "b") $ \producer -> consume producer@+withProducer ::+  (MonadIO m, MonadUnliftIO m) =>+  ((p -> m ()) -> m r) ->+  (Producer p r -> m a) ->+  m a+withProducer f = bracket (forkProducer f) cancel++listen ::+  MonadIO m =>+  Producer p r ->+  (p -> m a) ->+  (r -> m a) ->+  STM (m a)+listen p fPayload fResult =+  fmap f (producerQueueRead p)+  where+    f (Payload payload) = fPayload payload+    f (Exception e) = throwIO e+    f (Close r) = fResult r++joinSTM :: MonadIO m => STM (m a) -> m a+joinSTM = join . liftIO . atomically++data Syncing a = Syncable a | Syncer (Maybe SomeException -> STM ())++-- | Sends sync notifications after the whole computation succeeds (or fails)+-- Note: not exception safe in the presence of pure exceptions.+withSync ::+  (MonadIO m, MonadUnliftIO m, Traversable t) =>+  t (Syncing a) ->+  (t (Maybe a) -> m b) ->+  m b+withSync t f = do+  let (t', syncs) =+        runState+          ( for t $ \case+              Syncable a -> pure (Just a)+              Syncer s -> Nothing <$ modify (*> s)+          )+          (\_ -> pure ())+  b <- f t' `withException` (liftIO . atomically . syncs . Just)+  liftIO $ atomically $ syncs Nothing+  pure b++--  where trav =+--  deriving (Functor)+--instance Applicative Syncing where+--  pure = Synced Nothing+--  Synced sf f <*> Synced af a = Synced (sf <> af) (f a)++-- Potential improvements:+--  - Performance: Get rid of the producer thread by doing the batching in STM.+--                 (pinging thread still required)+--  - Performance: Multiple elements as input+--  - Idle footprint: The pinger can be made to wait for the queue to be non-empty before starting the delay.+--     - Add a tryPeek function to Producer+--     - Make sure it is not woken up after the queue has become non-empty+--     - Alternatively, maybe use stm-delay (which uses GHC.Event for efficiency)+--       https://hackage.haskell.org/package/stm-delay-0.1.1.1/docs/Control-Concurrent-STM-Delay.html+withBoundedDelayBatchProducer ::+  (MonadIO m, MonadUnliftIO m, KatipContext m) =>+  -- | Max time before flushing in microseconds+  Int ->+  -- | Max number of items in batch+  Int ->+  Producer p r ->+  (Producer [p] r -> m a) ->+  m a+withBoundedDelayBatchProducer maxDelay maxItems sourceP f = do+  UnliftIO {unliftIO = unlift} <- askUnliftIO+  flushes <- liftIO $ newTQueueIO+  let producer writeBatch =+        let beginReading = readItems (max 1 maxItems) []+            doPerformBatch [] = pure ()+            doPerformBatch buf = writeBatch (reverse buf)+            readItems 0 buf = do+              --logLocM DebugS "batch on full"+              doPerformBatch buf+              beginReading+            readItems bufferRemaining buf =+              joinSTM+                ( onQueueRead <$> producerQueueRead sourceP+                    <|> onFlush+                    <$ readTQueue flushes+                )+              where+                onQueueRead (Payload a) =+                  readItems (bufferRemaining - 1) (a : buf)+                onQueueRead (Close r) = do+                  --logLocM DebugS $ "batch on close: " <> logStr (show (length buf))+                  doPerformBatch buf+                  pure r+                onQueueRead (Exception e) = do+                  --logLocM DebugS $ "batch on exception: " <> logStr (show (length buf))+                  doPerformBatch buf+                  liftIO $ throwIO e+                onFlush = do+                  --logLocM DebugS $ "batch on flush: " <> logStr (show (length buf))+                  doPerformBatch buf+                  beginReading+         in beginReading+  liftIO+    $ withAsync+      ( forever $ do+          threadDelay maxDelay+          atomically $ writeTQueue flushes ()+      )+    $ \_flusher -> unlift $ withProducer producer f++syncer :: MonadIO m => (Syncing a -> m ()) -> m ()+syncer writer = do+  v <- liftIO $ atomically $ newEmptyTMVar+  writer (Syncer $ putTMVar v)+  mexc <- liftIO $ atomically $ readTMVar v+  for_ mexc (liftIO . throwIO)
+ src/Hercules/Agent/STM.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE PartialTypeSignatures #-}++-- | STM functions in MonadIO and custom functions like modifyTVarIO.+--+-- Why not lifted-stm of stm-lifted package?+--  - neither is in stackage+--  - only a few functions needed+module Hercules.Agent.STM+  ( module Hercules.Agent.STM,+    module Control.Concurrent.STM,+  )+where++import Control.Concurrent.STM (STM, TBQueue, TChan, TVar, readTVar, writeTVar)+import qualified Control.Concurrent.STM as STM+import Protolude hiding (atomically)++atomically :: MonadIO m => STM a -> m a+atomically = liftIO . STM.atomically++readTVarIO :: MonadIO m => TVar a -> m a+readTVarIO = liftIO . STM.readTVarIO++newTVarIO :: MonadIO m => a -> m (TVar a)+newTVarIO = liftIO . STM.newTVarIO++-- | Drop-in replacement for atomicModifyIORef+modifyTVarIO :: MonadIO m => TVar a -> (a -> (a, b)) -> m b+modifyTVarIO tvar f = atomically $ do+  a0 <- readTVar tvar+  let (a1, b) = f a0+  writeTVar tvar a1+  pure b++newTChanIO :: MonadIO m => m (TChan a)+newTChanIO = liftIO STM.newTChanIO
+ src/Hercules/Agent/Socket.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Agent.Socket+  ( withReliableSocket,+    checkVersion',+    Socket (..),+    syncIO,+    SocketConfig (..),+  )+where++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.Monad.IO.Unlift+import qualified Data.Aeson as A+import Data.DList (DList, fromList)+import Data.List (dropWhileEnd)+import Data.Semigroup+import Data.Time (NominalDiffTime, addUTCTime, diffUTCTime, getCurrentTime)+import Data.Time.Extras+import Hercules.API.Agent.LifeCycle.ServiceInfo (ServiceInfo)+import qualified Hercules.API.Agent.LifeCycle.ServiceInfo as ServiceInfo+import qualified Hercules.API.Agent.Socket.Frame as Frame+import Hercules.API.Agent.Socket.Frame (Frame)+import Hercules.Agent.STM (atomically, newTChanIO, newTVarIO)+import Katip (KatipContext, Severity (..), katipAddContext, katipAddNamespace, logLocM, sl)+import Network.URI (URI, uriAuthority, uriPath, uriPort, uriQuery, uriRegName, uriScheme)+import Network.WebSockets (Connection, runClientWith)+import qualified Network.WebSockets as WS+import Protolude hiding (atomically, handle, race, race_)+import UnliftIO.Async (race, race_)+import UnliftIO.Exception (handle)+import Wuss (runSecureClientWith)++data Socket r w+  = Socket+      { write :: w -> STM (),+        serviceChan :: TChan r,+        sync :: STM (STM ())+      }++syncIO :: Socket r w -> IO ()+syncIO = join . fmap atomically . atomically . sync++-- | Parameters to start 'withReliableSocket'.+data SocketConfig ap sp m+  = SocketConfig+      { makeHello :: m ap,+        checkVersion :: (sp -> m (Either Text ())),+        baseURL :: URI,+        path :: Text,+        token :: ByteString+      }++requiredServiceVersion :: (Int, Int)+requiredServiceVersion = (1, 0)++ackTimeout :: NominalDiffTime+ackTimeout = 60 -- seconds++withReliableSocket :: (A.FromJSON sp, A.ToJSON ap, MonadIO m, MonadUnliftIO m, KatipContext m) => SocketConfig ap sp m -> (Socket sp ap -> m a) -> m a+withReliableSocket socketConfig f = do+  writeQueue <- atomically $ newTBQueue 100+  agentMessageNextN <- newTVarIO 0+  serviceMessageChan <- newTChanIO+  highestAcked <- newTVarIO (-1)+  let tagPayload p = do+        c <- readTVar agentMessageNextN+        writeTVar agentMessageNextN (c + 1)+        pure $ Frame.Msg {n = c, p = p}+      socketThread = runReliableSocket socketConfig writeQueue serviceMessageChan highestAcked+      socket = Socket+        { write = tagPayload >=> writeTBQueue writeQueue,+          serviceChan = serviceMessageChan,+          sync = do+            counterAtSyncStart <- (\n -> n - 1) <$> readTVar agentMessageNextN+            pure do+              acked <- readTVar highestAcked+              guard $ acked >= counterAtSyncStart+        }+  race socketThread (f socket) <&> either identity identity++checkVersion' :: Applicative m => ServiceInfo -> m (Either Text ())+checkVersion' si =+  if ServiceInfo.version si < requiredServiceVersion+    then pure $ Left $ "Expected service version " <> show requiredServiceVersion+    else pure $ Right ()++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)+  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+        katipExceptionContext e $ logLocM InfoS "Socket closed. Reconnecting."+        liftIO $ threadDelay 10_000_000+      logWarningPause e | Just (WS.ParseException "not enough bytes") <- fromException e = do+        katipExceptionContext e $ logLocM InfoS "Socket closed prematurely. Reconnecting."+        liftIO $ threadDelay 10_000_000+      logWarningPause e = do+        katipExceptionContext e $ logLocM WarningS "Recovering from exception in socket handler. Reconnecting."+        liftIO $ threadDelay 10_000_000+      setExpectedAckForMsgs :: [Frame ap ap] -> m ()+      setExpectedAckForMsgs msgs =+        msgs+          & foldMap (\case Frame.Msg {n = n} -> Option $ Just $ Max n; _ -> mempty)+          & traverse_ (\(Max n) -> setExpectedAck n)+      send :: Connection -> [Frame ap ap] -> m ()+      send conn msgs = do+        liftIO $ WS.sendDataMessages conn (WS.Binary . A.encode <$> msgs)+        setExpectedAckForMsgs msgs+      recv :: Connection -> m (Frame sp sp)+      recv conn = do+        (liftIO $ A.eitherDecode <$> WS.receiveData conn) >>= \case+          Left e -> liftIO $ throwIO (FatalError $ "Error decoding service message: " <> toSL e)+          Right r -> pure r+      handshake conn = katipAddNamespace "Handshake" do+        siMsg <- recv conn+        case siMsg of+          Frame.Oob {o = o'} -> checkVersion socketConfig o' >>= \case+            Left e -> do+              send conn [Frame.Exception e]+              throwIO $ FatalError "It looks like you're running a development version of hercules-ci-agent that is not yet supported on hercules-ci.com. Please use the stable branch or a tag."+            Right _ -> pass+          _ -> throwIO $ FatalError "Unexpected message. This is either a bug or you might need to update your agent."+        hello <- makeHello socketConfig+        send conn [Frame.Oob hello]+        ackMsg <- recv conn+        case ackMsg of+          Frame.Ack {n = n} -> cleanAcknowledged n+          _ -> throwIO $ FatalError "Expected acknowledgement. This is either a bug or you might need to update your agent."+        sendUnacked conn+      sendUnacked :: Connection -> m ()+      sendUnacked conn = do+        unackedNow <- atomically $ readTVar unacked+        send conn $ fmap (Frame.mapOob absurd) $ toList unackedNow+      cleanAcknowledged newAck = atomically do+        unacked0 <- readTVar unacked+        writeTVar unacked $+          unacked0+            & toList+            & filter+              ( \umsg -> case umsg of+                  Frame.Msg {n = n} -> n > newAck+                  Frame.Oob x -> absurd x+                  Frame.Ack {} -> False+                  Frame.Exception {} -> False+              )+            & fromList+        modifyTVar highestAcked (max newAck)+      -- TODO (performance) IntMap?++      readThread conn = katipAddNamespace "Reader" do+        forever $ do+          msg <- recv conn+          case msg of+            Frame.Msg {p = pl, n = n} -> atomically do+              lastN <- readTVar lastServiceN+              -- when recent+              when (n > lastN) do+                writeTChan serviceMessageChan pl+                writeTVar lastServiceN n+              writeTBQueue writeQueue (Frame.Ack {n = n})+            Frame.Ack {n = n} ->+              cleanAcknowledged n+            Frame.Oob o -> atomically do+              writeTChan serviceMessageChan o+            Frame.Exception e -> katipAddContext (sl "message" e) $ logLocM WarningS $ "Service exception"+      writeThread conn = katipAddNamespace "Writer" do+        forever do+          msgs <- atomically do+            -- TODO: make unacked bounded+            allMessages <- flushTBQueue writeQueue+            when (null allMessages) retry+            modifyTVar unacked (<> (allMessages >>= Frame.removeOob & fromList))+            pure allMessages+          send conn msgs+      setExpectedAck :: Integer -> m ()+      setExpectedAck n = do+        now <- liftIO getCurrentTime+        atomically do+          writeTVar expectedAck $ Just $ (n, now)+      noAckCleanupThread = noAckCleanupThread' (-1)+      noAckCleanupThread' confirmedLastTime = do+        (expectedN, sendTime) <- atomically do+          readTVar expectedAck+            >>= \case+              Nothing -> retry+              Just (expectedN, _) | expectedN <= confirmedLastTime -> retry+              Just a -> pure a+        let expectedArrival = ackTimeout `addUTCTime` sendTime+        liftIO do+          now <- getCurrentTime+          let waitTime = expectedArrival `diffUTCTime` now+          delayNominalDiffTime waitTime+        currentHighestAck <- atomically do+          readTVar highestAcked+        if expectedN > currentHighestAck+          then do+            katipAddContext (sl "expectedAck" expectedN <> sl "highestAck" currentHighestAck) do+              logLocM Katip.DebugS "Did not receive ack in time. Will reconnect."+            -- terminate other threads via race_+            pass+          else noAckCleanupThread' expectedN+  forever+    $ handle logWarningPause+    $ withConnection' socketConfig+    $ \conn -> do+      katipAddNamespace "Handshake" do+        handshake conn+      readThread conn `race_` writeThread conn `race_` noAckCleanupThread++withConnection' :: (MonadUnliftIO m) => SocketConfig any0 any1 m -> (Connection -> m a) -> m a+withConnection' socketConfig m = do+  UnliftIO unlift <- askUnliftIO+  let opts = WS.defaultConnectionOptions+      headers = [("Authorization", "Bearer " <> token socketConfig)]+      base = baseURL socketConfig+      url = base {uriPath = uriPath base `slash` toS (path socketConfig)}+      defaultPort+        | uriScheme url == "http:" = 80+        | uriScheme url == "https:" = 443+        | otherwise = panic "Hercules.Agent.Socket: invalid uri scheme"+      port = fromMaybe defaultPort $ do+        auth <- uriAuthority url+        readMaybe $ dropWhile (== ':') $ uriPort auth+      regname = fromMaybe (panic "Hercules.Agent.Socket: url has no regname") $ do+        auth <- uriAuthority url+        pure $ uriRegName auth+      httpPath = uriPath url <> uriQuery url+      runSocket+        | uriScheme url == "http:" = runClientWith regname port httpPath opts headers+        | uriScheme url == "https:" = runSecureClientWith regname (fromIntegral port) httpPath opts headers+        | otherwise = panic "Hercules.Agent.Socket: invalid uri scheme"+  liftIO $ runSocket $ \conn -> unlift (m conn)++slash :: [Char] -> [Char] -> [Char]+a `slash` b = dropWhileEnd (== '/') a <> "/" <> dropWhile (== '/') b
+ src/Hercules/Agent/WorkerProtocol/Command.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command where++import Data.Binary+import qualified Hercules.Agent.WorkerProtocol.Command.Build as Build+import qualified Hercules.Agent.WorkerProtocol.Command.BuildResult as BuildResult+import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval+import Protolude++data Command+  = Eval Eval.Eval+  | BuildResult BuildResult.BuildResult+  | Build Build.Build+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Command/Build.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command.Build where++import Data.Binary+import Hercules.Agent.WorkerProtocol.LogSettings+import Protolude++data Build+  = Build+      { drvPath :: Text,+        inputDerivationOutputPaths :: [ByteString],+        logSettings :: LogSettings,+        materializeDerivation :: Bool+      }+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Command/BuildResult.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command.BuildResult where++import Data.Binary+import Data.UUID (UUID)+import Protolude++data BuildResult = BuildResult Text UUID BuildStatus+  deriving (Generic, Binary, Show, Eq)++-- | Subset of @DerivationStatus@, with a @Binary@ instance.+data BuildStatus+  = Success+  | Failure+  | DependencyFailure+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Command/Eval.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command.Eval where++import Data.Binary+import Protolude++data Eval+  = Eval+      { cwd :: FilePath,+        file :: Text,+        autoArguments :: Map Text Arg,+        -- | NB currently the options will leak from one evaluation to+        --   the next if you're running them in the same worker!+        --   (as of now, we use one worker process per evaluation)+        extraNixOptions :: [(Text, Text)]+      }+  deriving (Generic, Binary, Show, Eq)++data Arg+  = LiteralArg ByteString+  | ExprArg ByteString+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Event.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Event where++import Data.Binary+import Data.UUID (UUID)+import Hercules.Agent.WorkerProtocol.Event.Attribute+import Hercules.Agent.WorkerProtocol.Event.AttributeError+import Hercules.Agent.WorkerProtocol.Event.BuildResult+import Protolude+import Prelude ()++data Event+  = Attribute Attribute+  | AttributeError AttributeError+  | EvaluationDone+  | Error Text+  | Build Text Text (Maybe UUID)+  | BuildResult BuildResult+  | Exception Text+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Event/Attribute.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Event.Attribute where++import Data.Binary+import Protolude+import Prelude ()++data Attribute+  = Attribute+      { path :: [ByteString],+        drv :: ByteString+        -- TODO: metadata+      }+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Event/AttributeError.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Event.AttributeError where++import Data.Binary+import Protolude+import Prelude ()++data AttributeError+  = AttributeError+      { path :: [ByteString],+        message :: Text,+        errorType :: Maybe Text,+        errorDerivation :: Maybe Text+      }+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/Event/BuildResult.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Event.BuildResult where++import Data.Binary+import Protolude++data BuildResult+  = BuildFailure {errorMessage :: Text}+  | BuildSuccess {outputs :: [OutputInfo]}+  deriving (Generic, Binary, Show, Eq)++data OutputInfo+  = OutputInfo+      { -- | e.g. out, dev+        name :: ByteString,+        -- | store path+        path :: ByteString,+        -- | typically sha256:...+        hash :: ByteString,+        -- | nar size in bytes+        size :: Int64+      }+  deriving (Generic, Binary, Show, Eq)
+ src/Hercules/Agent/WorkerProtocol/LogSettings.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.LogSettings where++import Data.Binary+import Protolude+import Text.Show++data LogSettings+  = LogSettings+      { path :: Text,+        baseURL :: Text,+        token :: Sensitive Text+      }+  deriving (Generic, Binary, Show, Eq)++-- | newtype wrapper to avoid leaking sensitive data through Show+newtype Sensitive a = Sensitive {reveal :: a}+  deriving (Generic, Binary, Eq, Ord)++-- | @const "<sensitive>"@+instance Show (Sensitive a) where+  show _ = "<sensitive>"
+ test/Hercules/Agent/Nix/RetrieveDerivationInfoSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Hercules.Agent.Nix.RetrieveDerivationInfoSpec where++import CNix+import qualified Data.Map as M+import Hercules.API.Agent.Evaluate.EvaluateEvent.DerivationInfo+import Hercules.Agent.Nix.RetrieveDerivationInfo+import Protolude+import Test.Hspec++spec :: Spec+spec = do+  describe "retrieveDerivationInfo" $ do+    it "parses vm-test-run-agent-test.drv correctly" $ do+      drv <- getDerivationFromFile "testdata/vm-test-run-agent-test.drv"+      d <- retrieveDerivationInfo' "testdata/vm-test-run-agent-test.drv" drv+      derivationPath d `shouldBe` "testdata/vm-test-run-agent-test.drv"+      platform d `shouldBe` "x86_64-linux"+      requiredSystemFeatures d `shouldBe` ["kvm", "nixos-test"]+      inputDerivations d `shouldBe` M.fromList [("/nix/store/0si75icim8ajxcsp25d9c52m42kqg1xj-stdenv-linux.drv", ["out"]), ("/nix/store/1kircip4wskspsqqzxbmh6ss73iqh9ah-bash-4.4-p23.drv", ["out"]), ("/nix/store/5kpp7mly0qad7l451xhr60k0wbv6vivi-jquery-1.11.3.drv", ["out"]), ("/nix/store/id49f28qvggmzpmlxp511v6yhc070lkf-jquery-ui-1.11.4.drv", ["out"]), ("/nix/store/kyxayhm3r6gpzbg1d57fwb8m7gkmpwcy-nixos-test-driver-agent-test.drv", ["out"]), ("/nix/store/qzvim3ca1s5zxbbvpzzipizfnfpdf5r2-libxslt-1.1.33.drv", ["dev"])]+      inputSources d `shouldBe` ["/nix/store/9krlzvny65gdc8s7kpb6lkx8cd02c25b-default-builder.sh", "/nix/store/fs6a6m9s5n367dslsvsl9lg89h3ns3ya-logfile.css", "/nix/store/jjh6h82n5rhw45badlpbj1yv7y6m48h2-log2html.xsl", "/nix/store/kdangwwh47ngwxk859ibbvkj4vmm9rzr-treebits.js"]+      outputs d `shouldBe` M.fromList [("out", OutputInfo {path = "/nix/store/7vg7ij5933dhg6dh22fvs90bbzmzg8kj-vm-test-run-agent-test", isFixed = False})]
+ test/Hercules/Agent/NixPathSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Hercules.Agent.NixPathSpec where++import Hercules.API.Agent.Evaluate.EvaluateTask+import Hercules.Agent.NixPath+import Protolude+import Test.Hspec++spec :: Spec+spec = do+  describe "renderNixPath" $ do+    it "renders a=/b" $ \() -> do+      renderNixPath [NixPathElement (Just "a") $ SubPathOf "/b" Nothing]+        `shouldBe` "a=/b"+    it "renders a=/b/c (subpath)" $ \() -> do+      renderNixPath [NixPathElement (Just "a") $ SubPathOf "/b" $ Just "c"]+        `shouldBe` "a=/b/c"+    it "renders /b" $ \() -> do+      renderNixPath [NixPathElement Nothing $ SubPathOf "/b" Nothing]+        `shouldBe` "/b"+    it "renders /b/c" $ \() -> do+      renderNixPath [NixPathElement Nothing $ SubPathOf "/b" $ Just "c"]+        `shouldBe` "/b/c"+    it "renders a=/b:d=/e" $ \() -> do+      renderNixPath+        [ NixPathElement (Just "a") $ SubPathOf "/b" Nothing,+          NixPathElement (Just "d") $ SubPathOf "/e" Nothing+        ]+        `shouldBe` "a=/b:d=/e"
+ test/Hercules/Agent/WorkerProcessSpec.hs view
@@ -0,0 +1,31 @@+module Hercules.Agent.WorkerProcessSpec (spec) where++import qualified Data.Map as M+import Hercules.API.Agent.Evaluate.EvaluateTask+import Hercules.Agent.WorkerProcess+import Protolude+import Test.Hspec++spec :: Spec+spec = do+  describe "modifyEnv" $ do+    let baseEnvSettings = WorkerEnvSettings []+        baseEnv = M.fromList [("NIX_PATH", "")]+    it "sets NIX_PATH" $ \() -> do+      modifyEnv (WorkerEnvSettings [NixPathElement (Just "a") $ SubPathOf "/b" Nothing]) mempty+        `shouldBe` M.fromList [("NIX_PATH", "a=/b")]+    it "filters out NIXPKGS_CONFIG" $ do+      modifyEnv baseEnvSettings ("NIXPKGS_CONFIG" =: "abpuhasur")+        `shouldBe` baseEnv+    it "filters out NIXOS_EXTRA_MODULES" $ do+      modifyEnv baseEnvSettings ("NIXOS_EXTRA_MODULES" =: "a9epr8gabru")+        `shouldBe` baseEnv+    it "filters out IN_NIX_SHELL" $ do+      modifyEnv baseEnvSettings ("IN_NIX_SHELL" =: "sa9e5h8")+        `shouldBe` baseEnv+    it "preserves other vars" $ do+      modifyEnv baseEnvSettings ("IN_NIX_SHELL" =: "sa9e5h8" <> "LD_LIBRARY_PATH" =: "bad idea but works")+        `shouldBe` baseEnv <> "LD_LIBRARY_PATH" =: "bad idea but works"++(=:) :: k -> a -> Map k a+(=:) = M.singleton
+ test/Spec.hs view
@@ -0,0 +1,15 @@+module Spec+  ( spec,+  )+where++import qualified Hercules.Agent.Nix.RetrieveDerivationInfoSpec+import qualified Hercules.Agent.NixPathSpec+import qualified Hercules.Agent.WorkerProcessSpec+import Test.Hspec++spec :: Spec+spec = do+  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
+ test/TestMain.hs view
@@ -0,0 +1,13 @@+module Main where++import CNix+import Protolude+import qualified Spec+import Test.Hspec.Runner++main :: IO ()+main = do+  CNix.init+  hspecWith config Spec.spec+  where+    config = defaultConfig {configColorMode = ColorAlways}
+ testdata/vm-test-run-agent-test.drv view
@@ -0,0 +1,1 @@+Derive([("out","/nix/store/7vg7ij5933dhg6dh22fvs90bbzmzg8kj-vm-test-run-agent-test","","")],[("/nix/store/0si75icim8ajxcsp25d9c52m42kqg1xj-stdenv-linux.drv",["out"]),("/nix/store/1kircip4wskspsqqzxbmh6ss73iqh9ah-bash-4.4-p23.drv",["out"]),("/nix/store/5kpp7mly0qad7l451xhr60k0wbv6vivi-jquery-1.11.3.drv",["out"]),("/nix/store/id49f28qvggmzpmlxp511v6yhc070lkf-jquery-ui-1.11.4.drv",["out"]),("/nix/store/kyxayhm3r6gpzbg1d57fwb8m7gkmpwcy-nixos-test-driver-agent-test.drv",["out"]),("/nix/store/qzvim3ca1s5zxbbvpzzipizfnfpdf5r2-libxslt-1.1.33.drv",["dev"])],["/nix/store/9krlzvny65gdc8s7kpb6lkx8cd02c25b-default-builder.sh","/nix/store/fs6a6m9s5n367dslsvsl9lg89h3ns3ya-logfile.css","/nix/store/jjh6h82n5rhw45badlpbj1yv7y6m48h2-log2html.xsl","/nix/store/kdangwwh47ngwxk859ibbvkj4vmm9rzr-treebits.js"],"x86_64-linux","/nix/store/cinw572b38aln37glr0zb8lxwrgaffl4-bash-4.4-p23/bin/bash",["-e","/nix/store/9krlzvny65gdc8s7kpb6lkx8cd02c25b-default-builder.sh"],[("buildCommand","mkdir -p $out/nix-support\n\nLOGFILE=$out/log.xml tests='eval $ENV{testScript}; die $@ if $@;' /nix/store/l5c7492d3djj7drpx4l4j4yhdbjpw24v-nixos-test-driver-agent-test/bin/nixos-test-driver\n\n# Generate a pretty-printed log.\nxsltproc --output $out/log.html /nix/store/jjh6h82n5rhw45badlpbj1yv7y6m48h2-log2html.xsl $out/log.xml\nln -s /nix/store/fs6a6m9s5n367dslsvsl9lg89h3ns3ya-logfile.css $out/logfile.css\nln -s /nix/store/kdangwwh47ngwxk859ibbvkj4vmm9rzr-treebits.js $out/treebits.js\nln -s /nix/store/4qp20mv05l5mzp5m4df521yyvfy1g4wn-jquery-1.11.3/js/jquery.min.js $out/\nln -s /nix/store/bks3z30z0026j362dz3hlk1py5q3j0da-jquery-ui-1.11.4/js/jquery-ui.min.js $out/\n\ntouch $out/nix-support/hydra-build-products\necho \"report testlog $out log.html\" >> $out/nix-support/hydra-build-products\n\nfor i in */xchg/coverage-data; do\n  mkdir -p $out/coverage-data\n  mv $i $out/coverage-data/$(dirname $(dirname $i))\ndone\n"),("buildInputs","/nix/store/7vgp2hlpbvgsrfm678nvfzy1p28jk8n1-libxslt-1.1.33-dev"),("builder","/nix/store/cinw572b38aln37glr0zb8lxwrgaffl4-bash-4.4-p23/bin/bash"),("configureFlags",""),("depsBuildBuild",""),("depsBuildBuildPropagated",""),("depsBuildTarget",""),("depsBuildTargetPropagated",""),("depsHostHost",""),("depsHostHostPropagated",""),("depsTargetTarget",""),("depsTargetTargetPropagated",""),("doCheck",""),("doInstallCheck",""),("name","vm-test-run-agent-test"),("nativeBuildInputs",""),("out","/nix/store/7vg7ij5933dhg6dh22fvs90bbzmzg8kj-vm-test-run-agent-test"),("outputs","out"),("propagatedBuildInputs",""),("propagatedNativeBuildInputs",""),("requiredSystemFeatures","kvm nixos-test"),("stdenv","/nix/store/63karsgdg7fm3q0if4zfd7apbd8ac1ci-stdenv-linux"),("strictDeps",""),("system","x86_64-linux")])