diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cbits/aliases.h b/cbits/aliases.h new file mode 100644 --- /dev/null +++ b/cbits/aliases.h @@ -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 refStore; + +typedef nix::ref refHerculesStore; + +typedef nix::Logger::Fields LoggerFields; + +typedef HerculesLogger::LogEntry HerculesLoggerEntry; +typedef std::queue> LogEntryQueue; + +typedef nix::Strings::iterator StringsIterator; +typedef nix::DerivationOutputs::iterator DerivationOutputsIterator; +typedef nix::DerivationInputs::iterator DerivationInputsIterator; +typedef nix::StringPairs::iterator StringPairsIterator; + +using namespace std; diff --git a/cbits/hercules-logger.cc b/cbits/hercules-logger.cc new file mode 100644 --- /dev/null +++ b/cbits/hercules-logger.cc @@ -0,0 +1,90 @@ +#include "hercules-logger.hh" + +HerculesLogger::HerculesLogger() +{ + +} + +void HerculesLogger::push(std::unique_ptr 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(t - t_zero).count(); + return millis; +} + +void HerculesLogger::log(nix::Verbosity lvl, const nix::FormatOrString & fs) { + push(std::make_unique(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 { + .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 { + .entryType = 3, + .ms = getMs(), + .activityId = act + })); +} + +void HerculesLogger::result(nix::ActivityId act, nix::ResultType type, const Fields & fields) { + push(std::make_unique(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::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> &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; diff --git a/cbits/hercules-logger.hh b/cbits/hercules-logger.hh new file mode 100644 --- /dev/null +++ b/cbits/hercules-logger.hh @@ -0,0 +1,55 @@ +#pragma once + +#include +#include +#include +#include +#include +#include +#include + +class HerculesLogger : public nix::Logger { + +public: + struct LogEntry; + +private: + + std::chrono::time_point t_zero = std::chrono::steady_clock::now(); + + struct State { + std::queue> queue; + }; + nix::Sync state_; + std::condition_variable wakeup; + + void push(std::unique_ptr 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 pop(); + void popMany(int max, std::queue> &out); + + void close(); +}; + +extern HerculesLogger *herculesLogger; diff --git a/cbits/hercules-store.cc b/cbits/hercules-store.cc new file mode 100644 --- /dev/null +++ b/cbits/hercules-store.cc @@ -0,0 +1,271 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "hercules-store.hh" + +using namespace nix; + +WrappingStore::WrappingStore(const Params& params, ref 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> callback) noexcept { + unsupported("queryPathInfoUncached"); + /* + Callback> + callback2([&callback](std::future> vpi){ + std::shared_ptr !@#$%^&* + 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 accessor) { + wrappedStore->addToStore(info, narSource, repair, checkSigs, accessor); +} + +void WrappingStore::addToStore(const ValidPathInfo& info, + const ref& nar, + RepairFlag repair, + CheckSigsFlag checkSigs, + std::shared_ptr 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 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 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 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; +} diff --git a/cbits/hercules-store.hh b/cbits/hercules-store.hh new file mode 100644 --- /dev/null +++ b/cbits/hercules-store.hh @@ -0,0 +1,150 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "HsFFI.h" + +using namespace nix; + +class WrappingStore : public Store { + public: + ref wrappedStore; + + WrappingStore(const Params & params, ref 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> 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 accessor = 0) override; + + virtual void addToStore(const ValidPathInfo & info, const ref & nar, + RepairFlag repair = NoRepair, CheckSigsFlag checkSigs = CheckSigs, + std::shared_ptr 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 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 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 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(); +}; diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker.hs @@ -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 diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs @@ -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 diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs @@ -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 "" + +C.include "" + +C.include "" + +C.include "" + +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 diff --git a/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs @@ -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 "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +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> stores = getDefaultSubstituters(); + stores.push_front(*$(refStore* store)); + + nix::Derivation *derivation = nullptr; + + for (nix::ref & 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 + } diff --git a/hercules-ci-agent-worker/Main.hs b/hercules-ci-agent-worker/Main.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent-worker/Main.hs @@ -0,0 +1,6 @@ +module Main + ( main, + ) +where + +import Hercules.Agent.Worker (main) diff --git a/hercules-ci-agent.cabal b/hercules-ci-agent.cabal new file mode 100644 --- /dev/null +++ b/hercules-ci-agent.cabal @@ -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 diff --git a/hercules-ci-agent/Data/Functor/Partitioner.hs b/hercules-ci-agent/Data/Functor/Partitioner.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Data/Functor/Partitioner.hs @@ -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 diff --git a/hercules-ci-agent/Data/Map/Extras/Hercules.hs b/hercules-ci-agent/Data/Map/Extras/Hercules.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Data/Map/Extras/Hercules.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent.hs b/hercules-ci-agent/Hercules/Agent.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent.hs @@ -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" diff --git a/hercules-ci-agent/Hercules/Agent/AgentSocket.hs b/hercules-ci-agent/Hercules/Agent/AgentSocket.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/AgentSocket.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Bag.hs b/hercules-ci-agent/Hercules/Agent/Bag.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Bag.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Build.hs b/hercules-ci-agent/Hercules/Agent/Build.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Build.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/CabalInfo.hs b/hercules-ci-agent/Hercules/Agent/CabalInfo.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/CabalInfo.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/Cache.hs b/hercules-ci-agent/Hercules/Agent/Cache.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Cache.hs @@ -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)) diff --git a/hercules-ci-agent/Hercules/Agent/Cachix.hs b/hercules-ci-agent/Hercules/Agent/Cachix.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Cachix.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/Cachix/Env.hs b/hercules-ci-agent/Hercules/Agent/Cachix/Env.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Cachix/Env.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Cachix/Info.hs b/hercules-ci-agent/Hercules/Agent/Cachix/Info.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Cachix/Info.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/Cachix/Init.hs b/hercules-ci-agent/Hercules/Agent/Cachix/Init.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Cachix/Init.hs @@ -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 + } diff --git a/hercules-ci-agent/Hercules/Agent/Client.hs b/hercules-ci-agent/Hercules/Agent/Client.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Client.hs @@ -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 ())))) diff --git a/hercules-ci-agent/Hercules/Agent/Compat.hs b/hercules-ci-agent/Hercules/Agent/Compat.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Compat.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Config.hs b/hercules-ci-agent/Hercules/Agent/Config.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Config.hs @@ -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 + } diff --git a/hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs b/hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/Env.hs b/hercules-ci-agent/Hercules/Agent/Env.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Env.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs b/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs @@ -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 = "" +cleanUrl t = t diff --git a/hercules-ci-agent/Hercules/Agent/Evaluate.hs b/hercules-ci-agent/Hercules/Agent/Evaluate.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Evaluate.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs b/hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Init.hs b/hercules-ci-agent/Hercules/Agent/Init.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Init.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Log.hs b/hercules-ci-agent/Hercules/Agent/Log.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Log.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/Nix.hs b/hercules-ci-agent/Hercules/Agent/Nix.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Nix.hs @@ -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)) diff --git a/hercules-ci-agent/Hercules/Agent/Nix/Env.hs b/hercules-ci-agent/Hercules/Agent/Nix/Env.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Nix/Env.hs @@ -0,0 +1,8 @@ +module Hercules.Agent.Nix.Env where + +import Protolude + +data Env + = Env + { extraOptions :: [(Text, Text)] + } diff --git a/hercules-ci-agent/Hercules/Agent/Nix/Init.hs b/hercules-ci-agent/Hercules/Agent/Nix/Init.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Nix/Init.hs @@ -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 = [] + } diff --git a/hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs b/hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs @@ -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 + } diff --git a/hercules-ci-agent/Hercules/Agent/NixPath.hs b/hercules-ci-agent/Hercules/Agent/NixPath.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/NixPath.hs @@ -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) diff --git a/hercules-ci-agent/Hercules/Agent/Options.hs b/hercules-ci-agent/Hercules/Agent/Options.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Options.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/SecureDirectory.hs b/hercules-ci-agent/Hercules/Agent/SecureDirectory.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/SecureDirectory.hs @@ -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 diff --git a/hercules-ci-agent/Hercules/Agent/ServiceInfo.hs b/hercules-ci-agent/Hercules/Agent/ServiceInfo.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/ServiceInfo.hs @@ -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_ + } diff --git a/hercules-ci-agent/Hercules/Agent/Token.hs b/hercules-ci-agent/Hercules/Agent/Token.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/Token.hs @@ -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?" diff --git a/hercules-ci-agent/Hercules/Agent/WorkerProcess.hs b/hercules-ci-agent/Hercules/Agent/WorkerProcess.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Hercules/Agent/WorkerProcess.hs @@ -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 diff --git a/hercules-ci-agent/Main.hs b/hercules-ci-agent/Main.hs new file mode 100644 --- /dev/null +++ b/hercules-ci-agent/Main.hs @@ -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 diff --git a/src-cnix/CNix.hs b/src-cnix/CNix.hs new file mode 100644 --- /dev/null +++ b/src-cnix/CNix.hs @@ -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 "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "aliases.h" + +C.include "" + +C.include "" + +C.include "" + +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($(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()); + }|] diff --git a/src-cnix/CNix/Internal/Context.hs b/src-cnix/CNix/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/src-cnix/CNix/Internal/Context.hs @@ -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) diff --git a/src-cnix/CNix/Internal/Raw.hs b/src-cnix/CNix/Internal/Raw.hs new file mode 100644 --- /dev/null +++ b/src-cnix/CNix/Internal/Raw.hs @@ -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 "" + +C.include "" + +C.include "" + +C.include "aliases.h" + +C.include "" + +C.include "" + +C.include "" + +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); + }|] diff --git a/src-cnix/CNix/Internal/Store.hs b/src-cnix/CNix/Internal/Store.hs new file mode 100644 --- /dev/null +++ b/src-cnix/CNix/Internal/Store.hs @@ -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 "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +C.include "" + +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 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 *) )); + }|] diff --git a/src-cnix/CNix/Internal/Typed.hs b/src-cnix/CNix/Internal/Typed.hs new file mode 100644 --- /dev/null +++ b/src-cnix/CNix/Internal/Typed.hs @@ -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" diff --git a/src-internal-ffi/Hercules/Agent/StoreFFI.hs b/src-internal-ffi/Hercules/Agent/StoreFFI.hs new file mode 100644 --- /dev/null +++ b/src-internal-ffi/Hercules/Agent/StoreFFI.hs @@ -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 diff --git a/src/Data/Conduit/Extras.hs b/src/Data/Conduit/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Extras.hs @@ -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)) diff --git a/src/Data/Fixed/Extras.hs b/src/Data/Fixed/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fixed/Extras.hs @@ -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 diff --git a/src/Data/Time/Extras.hs b/src/Data/Time/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Extras.hs @@ -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 diff --git a/src/Hercules/Agent/Producer.hs b/src/Hercules/Agent/Producer.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/Producer.hs @@ -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) diff --git a/src/Hercules/Agent/STM.hs b/src/Hercules/Agent/STM.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/STM.hs @@ -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 diff --git a/src/Hercules/Agent/Socket.hs b/src/Hercules/Agent/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/Socket.hs @@ -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 diff --git a/src/Hercules/Agent/WorkerProtocol/Command.hs b/src/Hercules/Agent/WorkerProtocol/Command.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Command.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Command/Build.hs b/src/Hercules/Agent/WorkerProtocol/Command/Build.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Command/Build.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Command/BuildResult.hs b/src/Hercules/Agent/WorkerProtocol/Command/BuildResult.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Command/BuildResult.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs b/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Command/Eval.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Event.hs b/src/Hercules/Agent/WorkerProtocol/Event.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Event.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Event/Attribute.hs b/src/Hercules/Agent/WorkerProtocol/Event/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Event/Attribute.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Event/AttributeError.hs b/src/Hercules/Agent/WorkerProtocol/Event/AttributeError.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Event/AttributeError.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/Event/BuildResult.hs b/src/Hercules/Agent/WorkerProtocol/Event/BuildResult.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/Event/BuildResult.hs @@ -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) diff --git a/src/Hercules/Agent/WorkerProtocol/LogSettings.hs b/src/Hercules/Agent/WorkerProtocol/LogSettings.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Agent/WorkerProtocol/LogSettings.hs @@ -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 ""@ +instance Show (Sensitive a) where + show _ = "" diff --git a/test/Hercules/Agent/Nix/RetrieveDerivationInfoSpec.hs b/test/Hercules/Agent/Nix/RetrieveDerivationInfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hercules/Agent/Nix/RetrieveDerivationInfoSpec.hs @@ -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})] diff --git a/test/Hercules/Agent/NixPathSpec.hs b/test/Hercules/Agent/NixPathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hercules/Agent/NixPathSpec.hs @@ -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" diff --git a/test/Hercules/Agent/WorkerProcessSpec.hs b/test/Hercules/Agent/WorkerProcessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hercules/Agent/WorkerProcessSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/TestMain.hs b/test/TestMain.hs new file mode 100644 --- /dev/null +++ b/test/TestMain.hs @@ -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} diff --git a/testdata/vm-test-run-agent-test.drv b/testdata/vm-test-run-agent-test.drv new file mode 100644 --- /dev/null +++ b/testdata/vm-test-run-agent-test.drv @@ -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")])