packages feed

hercules-ci-agent 0.7.5 → 0.8.0

raw patch · 63 files changed

+2042/−2054 lines, 63 filesdep +hercules-ci-cnix-exprdep +hercules-ci-cnix-storedep +process-extrasdep ~basedep ~cachixdep ~hercules-ci-api-agent

Dependencies added: hercules-ci-cnix-expr, hercules-ci-cnix-store, process-extras

Dependency ranges changed: base, cachix, hercules-ci-api-agent, hercules-ci-api-core, protolude

Files

CHANGELOG.md view
@@ -5,6 +5,77 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.8.0]++### Added++ - Hercules CI Effects, a new feature for running programs that interact with+   the real world, with useful features for continous deployment.++    - Effects only run after the build completes successfully++    - Effects are defined like a derivation, not unlike a Nix shell++    - Independent processes can run concurrently as distinct effects++    - No two commits in the same repo run effects at the same time; no need to+      worry about concurrency in deployment scripts++    - Effects each run in their own sandbox with access to network, Nix store,+      remote state file API and secrets++    - Secrets are configured locally on your agents, so you don't have to trust+      a third party with your cloud credentials++ - Hercules CI Agent is now a flake. The highlights are+    - `nixosModules` overriding the NixOS-distributed module to the in-repo version+      - `agent-profile` for agent machines, or+      - `agent-service` for just the service definition+    - `packages`+      - `hercules-ci-cli` the user command line interface+      - `hercules-ci-agent` for custom installation methods, etc++ - The `hci` command (flake: `defaultApp`)+    - `hci login` to authenticate yourself+    - `hci state` to work with Effects state files+    - `hci effect` to run effects locally++ - Commit metadata as a `ci.nix` argument. Make your `ci.nix` a function:++   ```nix+   { src ? { ref = null; rev = null; }}:+   # rest of your ci.nix+   ```++   `src.ref` will have e.g. `refs/heads/master` and `rev` will have the+   git commit SHA.++ - Shell derivations will only be built for their dependencies. Add a+   `mkShell`-based expression like you would add a derivation.++   This behavior can be requested explicitly for shells and non-shell+   derivations alike by appending ` // { buildDependenciesOnly = true; }` to+   the attribute definition.++ - Attributes can now be marked to require or ignore a build failure in the+   derivation it references directly.+   ([support#34](https://github.com/hercules-ci/support/issues/34))++ - `concurrentTasks` now has a default, `"auto"` for ease of setup and to help+   avoid underutilization.++### Fixed++ - The parent directory name will match the repo name [support#40](https://github.com/hercules-ci/support/issues/40)++ - Previously, lines from Nix's configured netrc file were ignored. Now they are appended to Hercules CI's netrc lines.++### Changed++ - Cachix caches without `signingKeys` will be pushed to, as part of the recently+   introduced write token feature (Cachix-managed signing keys)++ ## [0.7.5] - 2020-11-27  ### Fixed@@ -47,7 +118,7 @@    normal NixOS expectations. Notably, it does not configure automatic garbage    collection and it does not preconfigure NixOps keys deployment. -   The configuration interface will remain unchanged for `0.7` but `0.8` will+   The configuration interface in the hercules-ci-agent repo will remain unchanged for `0.7` but `0.8` will    match the upstream interface.  ## [0.7.3] - 2020-07-18@@ -330,6 +401,8 @@  - Initial release +[0.8.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.5...hercules-ci-agent-0.8.0+[0.7.5]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.4...hercules-ci-agent-0.7.5 [0.7.4]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.3...hercules-ci-agent-0.7.4 [0.7.3]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.2...hercules-ci-agent-0.7.3 [0.7.2]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.7.1...hercules-ci-agent-0.7.2
cbits/hercules-aliases.h view
@@ -3,6 +3,8 @@ #include "hercules-store.hh" #include "hercules-logger.hh" #include "derivations.hh"+#include <hercules-ci-cnix/store.hxx>+#include <hercules-ci-cnix/expr.hxx>  // 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
hercules-ci-agent-worker/Hercules/Agent/Worker.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}  module Hercules.Agent.Worker@@ -7,11 +8,10 @@   ) where -import CNix-import qualified CNix.Internal.Raw import Conduit import Control.Concurrent.STM import qualified Control.Exception.Lifted as EL+import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Control import qualified Data.ByteString as BS@@ -25,7 +25,6 @@ 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@@ -34,26 +33,36 @@ import qualified Hercules.API.Logs.LogEntry as LogEntry import Hercules.API.Logs.LogMessage (LogMessage) import qualified Hercules.API.Logs.LogMessage as LogMessage+import Hercules.Agent.Sensitive import qualified Hercules.Agent.Socket as Socket-import Hercules.Agent.Worker.Build+import Hercules.Agent.Worker.Build (runBuild) import qualified Hercules.Agent.Worker.Build.Logger as Logger-import qualified Hercules.Agent.WorkerProtocol.Command as Command+import Hercules.Agent.Worker.Effect (runEffect)+import Hercules.Agent.Worker.HerculesStore (nixStore, setBuilderCallback, withHerculesStore)+import Hercules.Agent.Worker.HerculesStore.Context (HerculesStore) import Hercules.Agent.WorkerProtocol.Command   ( Command,   )+import qualified Hercules.Agent.WorkerProtocol.Command as Command 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 qualified Hercules.Agent.WorkerProtocol.Command.Effect as Effect import Hercules.Agent.WorkerProtocol.Command.Eval   ( Eval,   )-import qualified Hercules.Agent.WorkerProtocol.Event as Event+import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval import Hercules.Agent.WorkerProtocol.Event   ( Event (Exception),   )+import qualified Hercules.Agent.WorkerProtocol.Event as Event import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as Attribute import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as AttributeError import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import Hercules.CNix as CNix+import Hercules.CNix.Expr (Match (IsAttrs, IsString), NixAttrs, RawValue, autoCallFunction, evalArgs, evalFile, getAttrBool, getAttrList, getAttrs, getDrvFile, getRecurseForDerivations, getStringIgnoreContext, init, isDerivation, isFunctor, match, rawValueType, withEvalStateConduit)+import Hercules.CNix.Expr.Context (EvalState)+import qualified Hercules.CNix.Expr.Raw+import Hercules.CNix.Expr.Typed (Value) import Hercules.Error import Katip import qualified Language.C.Inline.Cpp.Exceptions as C@@ -62,26 +71,25 @@ import qualified System.Environment as Environment import System.IO (BufferMode (LineBuffering), hSetBuffering) import System.Posix.IO (dup, fdToHandle, stdError)+import System.Posix.Signals (Handler (Catch), installHandler, raiseSignal, sigINT, sigTERM) import System.Timeout (timeout) import UnliftIO.Async (wait, withAsync) import UnliftIO.Exception (bracket, catch) 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 HerculesState = HerculesState+  { drvsCompleted :: TVar (Map Text (UUID, BuildResult.BuildStatus)),+    drvsInProgress :: IORef (Set Text),+    herculesStore :: Ptr (Ref HerculesStore),+    wrappedStore :: Store,+    shortcutChannel :: Chan (Maybe Event)+  } -data BuildException-  = BuildException-      { buildExceptionDerivationPath :: Text,-        buildExceptionDetail :: Maybe Text-      }+data BuildException = BuildException+  { buildExceptionDerivationPath :: Text,+    buildExceptionDetail :: Maybe Text+  }   deriving (Show, Typeable)  instance Exception BuildException@@ -89,7 +97,8 @@ main :: IO () main = do   hSetBuffering stderr LineBuffering-  CNix.init+  Hercules.CNix.Expr.init+  _ <- installHandler sigTERM (Catch $ raiseSignal sigINT) Nothing   Logger.initLogger   [options] <- Environment.getArgs   let allOptions =@@ -109,25 +118,27 @@   withStore $ \wrappedStore_ -> withHerculesStore wrappedStore_ $ \herculesStore_ -> withKatip $ do     liftIO $ setBuilderCallback herculesStore_ mempty     ch <- liftIO newChan-    let st = HerculesState-          { drvsCompleted = drvsCompleted_,-            drvsInProgress = drvsInProgress_,-            herculesStore = herculesStore_,-            wrappedStore = wrappedStore_,-            shortcutChannel = ch-          }+    let st =+          HerculesState+            { drvsCompleted = drvsCompleted_,+              drvsInProgress = drvsInProgress_,+              herculesStore = herculesStore_,+              wrappedStore = wrappedStore_,+              shortcutChannel = ch+            }     let runner :: KatipContextT IO ()         runner =           ( ( do-                command <- runConduitRes -- Res shouldn't be necessary-                  ( transPipe liftIO (sourceHandle stdin)-                      .| conduitDecode-                      .| printCommands-                      .| await-                  )-                  >>= \case-                    Just c -> pure c-                    Nothing -> panic "Not a valid starting command"+                command <-+                  runConduitRes -- Res shouldn't be necessary+                    ( transPipe liftIO (sourceHandle stdin)+                        .| conduitDecode+                        .| printCommands+                        .| await+                    )+                    >>= \case+                      Just c -> pure c+                      Nothing -> panic "Not a valid starting command"                 runCommand st ch command             )               `safeLiftedCatch` ( \e -> liftIO $ do@@ -146,7 +157,7 @@                 .| concatMapC (\x -> [Chunk x, Flush])                 .| transPipe liftIO (sinkHandleFlush stdout)             )-    void $ do+    void $       withAsync runner $ \runnerAsync -> do         writer -- runner can stop writer only by passing Nothing in channel (finally)         logLocM DebugS "Writer done"@@ -156,7 +167,7 @@ printCommands =   mapMC     ( \x -> do-        katipAddContext (sl "command" (show x :: Text)) $ do+        katipAddContext (sl "command" (show x :: Text)) $           logLocM DebugS "Received command"         pure x     )@@ -187,40 +198,51 @@ -- runCommand' :: HerculesState -> Command -> ConduitM Command Event (ResourceT IO) () runCommand herculesState ch command = do   -- TODO don't do this-  mainThread <- liftIO $ myThreadId+  mainThread <- liftIO myThreadId   UnliftIO unlift <- askUnliftIO   case command of-    Command.Eval eval -> Logger.withLoggerConduit (logger $ Eval.logSettings eval) $ Logger.withTappedStderr Logger.tapper $ connectCommand ch $ do-      void $ liftIO-        $ flip-          forkFinally-          ( \eeu -> case eeu of-              Left e -> throwIO $ FatalError $ "Failed to fork: " <> show e-              Right _ -> pure ()-          )-        $ unlift-        $ runConduitRes-          ( Data.Conduit.handleC-              ( \e -> do-                  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-          katipAddContext (sl "path" path <> sl "result" (show result :: Text))-            $ logLocM DebugS-            $ "Received remote build result"-          liftIO $ atomically $ modifyTVar (drvsCompleted herculesState) (M.insert path (attempt, result))-        _ -> pass+    Command.Eval eval -> Logger.withLoggerConduit (logger $ Eval.logSettings eval) $+      Logger.withTappedStderr Logger.tapper $+        connectCommand ch $ do+          void $+            liftIO $+              flip+                forkFinally+                (escalateAs \e -> FatalError $ "Failed to fork: " <> show e)+                $ unlift $+                  runConduitRes+                    ( Data.Conduit.handleC+                        ( \e -> do+                            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+              katipAddContext (sl "path" path <> sl "result" (show result :: Text)) $+                logLocM+                  DebugS+                  "Received remote build result"+              liftIO $ atomically $ modifyTVar (drvsCompleted herculesState) (M.insert path (attempt, result))+            _ -> pass     Command.Build build ->-      Logger.withLoggerConduit (logger $ Build.logSettings build) $ Logger.withTappedStderr Logger.tapper $ do-        connectCommand ch $ runBuild (wrappedStore herculesState) build+      katipAddNamespace "Build" $+        Logger.withLoggerConduit (logger $ Build.logSettings build) $+          Logger.withTappedStderr Logger.tapper $+            connectCommand ch $ runBuild (wrappedStore herculesState) build+    Command.Effect effect ->+      katipAddNamespace "Effect" $+        Logger.withLoggerConduit (logger $ Effect.logSettings effect) $+          Logger.withTappedStderr Logger.tapper $+            connectCommand ch $ do+              runEffect (wrappedStore herculesState) effect >>= \case+                ExitSuccess -> yield $ Event.EffectResult 0+                ExitFailure n -> yield $ Event.EffectResult n     _ ->       panic "Not a valid starting command" @@ -236,7 +258,7 @@               atomically $ Socket.write socket ping           )           (const m)-  Socket.withReliableSocket socketConfig $ \socket -> withPings socket $ katipAddNamespace "Build" do+  Socket.withReliableSocket socketConfig $ \socket -> withPings socket do     let conduit =           entriesSource             .| Logger.unbatch@@ -246,21 +268,21 @@             .| 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-          )+          (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)-    runConduit $ conduit+        renumber i =+          await >>= traverse_ \case+            Flush -> yield Flush >> renumber i+            Chunk e -> do+              yield $ Chunk e {LogEntry.i = i}+              renumber (i + 1)+    runConduit conduit     logLocM DebugS "Syncing"-    liftIO (timeout 600_000_000 $ Socket.syncIO $ socket) >>= \case+    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"@@ -274,11 +296,12 @@ 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)+    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@@ -291,7 +314,7 @@   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+      -- closeScribes will stop accepting new logs, flush existing ones and clean up resources   bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \logEnv ->     runKatipContextT logEnv initialContext extraNs m @@ -300,13 +323,14 @@   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 = encodeUtf8 $ LogSettings.reveal $ LogSettings.token l-    }+  pure+    Socket.SocketConfig+      { makeHello = pure (LogMessage.LogEntries mempty),+        checkVersion = Socket.checkVersion',+        baseURL = baseURL,+        path = LogSettings.path l,+        token = encodeUtf8 $ reveal $ LogSettings.token l+      }  -- TODO: test autoArgArgs :: Map Text Eval.Arg -> [ByteString]@@ -321,13 +345,16 @@   bracket acquire release . const   where     acquire =-      liftIO $ 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)+      liftIO $+        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 _ =-      liftIO $ atomicModifyIORef ref $ \inprg ->-        (S.delete drvPath inprg, ())+      liftIO $+        atomicModifyIORef ref $ \inprg ->+          (S.delete drvPath inprg, ())  anyAlternative :: (Foldable l, Alternative f) => l a -> f a anyAlternative = getAlt . foldMap (Alt . pure)@@ -335,22 +362,26 @@ 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"-      }+    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))-    }+  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 =@@ -372,51 +403,56 @@   s <- storeUri store   UnliftIO unlift <- lift askUnliftIO   let decode = decodeUtf8With lenientDecode-  liftIO $ setBuilderCallback hStore $ \path -> unlift $ katipAddContext (sl "fullpath" (decode path)) $ do-    logLocM DebugS "Building"-    let (plainDrv, bangOut) = BS.span (/= fromIntegral (ord '!')) path-        outputName = BS.dropWhile (== fromIntegral (ord '!')) bangOut-        plainDrvText = decode plainDrv-    withDrvInProgress st plainDrvText $ do-      liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (decode outputName) Nothing-      derivation <- liftIO $ getDerivation store plainDrv-      outputPath <- liftIO $ getDerivationOutputPath derivation outputName-      katipAddContext (sl "outputPath" (decode outputPath)) $ do-        logLocM DebugS "Naively calling ensurePath"-      liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e0 -> do-        katipAddContext (sl "message" (show (e0 :: SomeException) :: Text)) $-          logLocM DebugS "Recovering from failed wrapped.ensurePath"-        (attempt0, result) <--          liftIO $ atomically $ do-            c <- readTVar drvsCompl-            anyAlternative $ M.lookup plainDrvText c-        liftIO $ maybeThrowBuildException result plainDrvText-        liftIO $ clearSubstituterCaches-        liftIO $ clearPathInfoCache store-        liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e1 -> do-          katipAddContext (sl "message" (show (e1 :: SomeException) :: Text)) $-            logLocM DebugS "Recovering from fresh ensurePath"-          liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (decode outputName) (Just attempt0)-          -- TODO sync-          result' <--            liftIO $ atomically $ do-              c <- readTVar drvsCompl-              (attempt1, r) <- anyAlternative $ M.lookup plainDrvText c-              guard (attempt1 /= attempt0)-              pure r-          liftIO $ maybeThrowBuildException result' plainDrvText-          liftIO $ clearSubstituterCaches-          liftIO $ clearPathInfoCache store-          liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e2 -> do-            liftIO $ throwIO $-              BuildException-                plainDrvText-                ( Just $-                    "It could not be retrieved on the evaluating agent, despite a successful rebuild. Exception: "-                      <> show (e2 :: SomeException)-                )-    logLocM DebugS ("Built")-  withEvalState store $ \evalState -> do+  liftIO $+    setBuilderCallback hStore $ \path -> unlift $+      katipAddContext (sl "fullpath" (decode path)) $ do+        logLocM DebugS "Building"+        let (plainDrv, bangOut) = BS.span (/= fromIntegral (ord '!')) path+            outputName = BS.dropWhile (== fromIntegral (ord '!')) bangOut+            plainDrvText = decode plainDrv+        withDrvInProgress st plainDrvText $ do+          liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (decode outputName) Nothing+          derivation <- liftIO $ getDerivation store plainDrv+          outputPath <- liftIO $ getDerivationOutputPath derivation outputName+          katipAddContext (sl "outputPath" (decode outputPath)) $+            logLocM DebugS "Naively calling ensurePath"+          liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e0 -> do+            katipAddContext (sl "message" (show (e0 :: SomeException) :: Text)) $+              logLocM DebugS "Recovering from failed wrapped.ensurePath"+            (attempt0, result) <-+              liftIO $+                atomically $ do+                  c <- readTVar drvsCompl+                  anyAlternative $ M.lookup plainDrvText c+            liftIO $ maybeThrowBuildException result plainDrvText+            liftIO clearSubstituterCaches+            liftIO $ clearPathInfoCache store+            liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e1 -> do+              katipAddContext (sl "message" (show (e1 :: SomeException) :: Text)) $+                logLocM DebugS "Recovering from fresh ensurePath"+              liftIO $ writeChan shortcutChan $ Just $ Event.Build plainDrvText (decode outputName) (Just attempt0)+              -- TODO sync+              result' <-+                liftIO $+                  atomically $ do+                    c <- readTVar drvsCompl+                    (attempt1, r) <- anyAlternative $ M.lookup plainDrvText c+                    guard (attempt1 /= attempt0)+                    pure r+              liftIO $ maybeThrowBuildException result' plainDrvText+              liftIO clearSubstituterCaches+              liftIO $ clearPathInfoCache store+              liftIO (ensurePath (wrappedStore st) outputPath) `catch` \e2 ->+                liftIO $+                  throwIO $+                    BuildException+                      plainDrvText+                      ( Just $+                          "It could not be retrieved on the evaluating agent, despite a successful rebuild. Exception: "+                            <> show (e2 :: SomeException)+                      )+        logLocM DebugS "Built"+  withEvalStateConduit store $ \evalState -> do     katipAddContext (sl "storeURI" (decode s)) $       logLocM DebugS "EvalState loaded."     args <-@@ -432,7 +468,7 @@ walk ::   (MonadUnliftIO m, KatipContext m) =>   Ptr EvalState ->-  Bindings ->+  Value NixAttrs ->   RawValue ->   ConduitT i Event m () walk evalState = walk' True [] 10@@ -447,7 +483,7 @@       -- | Depth of tree remaining       Integer ->       -- | Auto arguments to pass to (attrset-)functions-      Bindings ->+      Value NixAttrs ->       -- | Current node of the walk       RawValue ->       -- | Program that performs the walk and emits 'Event's@@ -465,16 +501,50 @@                 if isDeriv                   then do                     drvPath <- getDrvFile evalState v-                    yield $-                      Event.Attribute Attribute.Attribute-                        { Attribute.path = path,-                          Attribute.drv = drvPath-                        }+                    typE <- runExceptT do+                      isEffect <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "isEffect")+                      case isEffect of+                        Just True -> throwE $ Right Attribute.Effect+                        _ -> pass+                      isDependenciesOnly <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "buildDependenciesOnly")+                      case isDependenciesOnly of+                        Just True -> throwE $ Right Attribute.DependenciesOnly+                        _ -> pass+                      phases <- liftEitherAs Left =<< liftIO (getAttrList evalState attrValue "phases")+                      case phases of+                        Just [aSingularPhase] ->+                          liftIO (match evalState aSingularPhase) >>= liftEitherAs Left >>= \case+                            IsString phaseNameValue -> do+                              phaseName <- liftIO (getStringIgnoreContext phaseNameValue)+                              when (phaseName == "nobuildPhase") do+                                throwE $ Right Attribute.DependenciesOnly+                            _ -> pass+                        _ -> pass+                      mayFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "ignoreFailure")+                      case mayFail of+                        Just True -> throwE $ Right Attribute.MayFail+                        _ -> pass+                      mustFail <- liftEitherAs Left =<< liftIO (getAttrBool evalState attrValue "requireFailure")+                      case mustFail of+                        Just True -> throwE $ Right Attribute.MustFail+                        _ -> pass+                    let yieldAttribute typ =+                          yield $+                            Event.Attribute+                              Attribute.Attribute+                                { Attribute.path = path,+                                  Attribute.drv = drvPath,+                                  Attribute.typ = typ+                                }+                    case typE of+                      Left (Left e) -> yieldAttributeError path e+                      Left (Right t) -> yieldAttribute t+                      Right _ -> yieldAttribute Attribute.Regular                   else do                     walkAttrset <-                       if forceWalkAttrset                         then pure True-                        else-- Hydra doesn't seem to obey this, because it walks the+                        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@@ -486,28 +556,34 @@                         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+                        void $+                          flip M.traverseWithKey attrs $+                            \name value ->+                              when (depthRemaining > 0 && walkAttrset) $+                                walk' -- TODO: else warn+                                  False+                                  (path ++ [name])+                                  (depthRemaining - 1)+                                  autoArgs+                                  value               _any -> do                 vt <- liftIO $ rawValueType v                 unless                   ( lastMay path                       == Just "recurseForDerivations"                       && vt-                      == CNix.Internal.Raw.Bool+                      == Hercules.CNix.Expr.Raw.Bool                   )-                  $ logLocM DebugS-                  $ logStr-                  $ "Ignoring "-                    <> show path-                    <> " : "-                    <> (show vt :: Text)+                  $ logLocM DebugS $+                    logStr $+                      "Ignoring "+                        <> show path+                        <> " : "+                        <> (show vt :: Text)                 pass++liftEitherAs :: MonadError e m => (e0 -> e) -> Either e0 a -> m a+liftEitherAs f = liftEither . rmap+  where+    rmap (Left e) = Left (f e)+    rmap (Right a) = Right a
hercules-ci-agent-worker/Hercules/Agent/Worker/Build.hs view
@@ -3,9 +3,6 @@  module Hercules.Agent.Worker.Build where -import CNix-import CNix.Internal.Context (Derivation)-import Cachix.Client.Store (Store, queryPathInfo, validPathInfoNarHash, validPathInfoNarSize) import Conduit import Data.Conduit.Katip.Orphans () import Foreign (ForeignPtr)@@ -15,11 +12,17 @@ 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 Hercules.CNix+  ( DerivationOutput (derivationOutputName, derivationOutputPath),+    getDerivationOutputs,+  )+import qualified Hercules.CNix as CNix+import Hercules.CNix.Store (Store, queryPathInfo, validPathInfoNarHash, validPathInfoNarSize)+import Hercules.CNix.Store.Context (Derivation) import Katip import Protolude hiding (yield)-import Unsafe.Coerce -runBuild :: (MonadIO m, KatipContext m) => Ptr (Ref NixStore) -> Command.Build.Build -> ConduitT i Event m ()+runBuild :: (MonadIO m, KatipContext m) => Store -> Command.Build.Build -> ConduitT i Event m () runBuild store build = do   let extraPaths = Command.Build.inputDerivationOutputPaths build       drvPath = encodeUtf8 $ Command.Build.drvPath build@@ -31,7 +34,7 @@       pure $ Command.Build.materializeDerivation build     Left (e :: SomeException) -> liftIO do       CNix.logInfo $ "while retrieving dependencies: " <> toS (displayException e)-      CNix.logInfo $ "unable to retrieve dependency; will build locally"+      CNix.logInfo "unable to retrieve dependency; attempting fallback to local build"       pure True   derivationMaybe <- liftIO $ Build.getDerivation store drvPath   derivation <- case derivationMaybe of@@ -44,23 +47,21 @@   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 -> 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)+    vpi <- queryPathInfo 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.OutputInfo+        { name = derivationOutputName drvOut,+          path = derivationOutputPath drvOut,+          hash = hash_,+          size = size+        }   pure $ Event.BuildResult.BuildSuccess outputInfos---- TODO factor out cnix library and avoid unsafeCoerce https://github.com/hercules-ci/hercules-ci-agent/issues/223-coerceStore :: Ptr (Ref NixStore) -> Store-coerceStore = unsafeCoerce
hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs view
@@ -5,7 +5,6 @@  module Hercules.Agent.Worker.Build.Logger where -import CNix.Internal.Context import Conduit (MonadUnliftIO, filterC) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Unsafe (unsafePackMallocCString)@@ -15,6 +14,8 @@ import Foreign (alloca, nullPtr, peek) import Hercules.API.Logs.LogEntry (LogEntry) import qualified Hercules.API.Logs.LogEntry as LogEntry+import Hercules.Agent.Worker.Build.Logger.Context (Fields, HerculesLoggerEntry, context)+import Hercules.CNix.Store.Context (unsafeMallocBS) import Katip import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Cpp.Exceptions as C@@ -123,7 +124,7 @@ 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 :: Ptr HerculesLoggerEntry -> IO LogEntry convertEntry logEntryPtr = alloca \millisPtr -> alloca \textStrPtr -> alloca \levelPtr -> alloca \activityIdPtr -> alloca \typePtr -> alloca \parentPtr -> alloca \fieldsPtrPtr ->   do     r <-@@ -162,12 +163,13 @@         textStr <- peek textStrPtr         text_ <- unsafePackMallocCString textStr         level_ <- peek levelPtr-        pure $ LogEntry.Msg-          { i = i_,-            ms = ms_,-            level = fromIntegral level_,-            msg = decode text_-          }+        pure $+          LogEntry.Msg+            { i = i_,+              ms = ms_,+              level = fromIntegral level_,+              msg = decode text_+            }       2 -> do         text_ <- unsafePackMallocCString =<< peek textStrPtr         act_ <- peek activityIdPtr@@ -175,41 +177,43 @@         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 = decode text_,-            parent = LogEntry.ActivityId parent_,-            fields = fields_-          }+        pure $+          LogEntry.Start+            { i = i_,+              ms = ms_,+              act = LogEntry.ActivityId act_,+              level = fromIntegral level_,+              typ = LogEntry.ActivityType typ_,+              text = decode text_,+              parent = LogEntry.ActivityId parent_,+              fields = fields_+            }       3 -> do         act_ <- peek activityIdPtr-        pure $ LogEntry.Stop-          { i = i_,-            ms = ms_,-            act = LogEntry.ActivityId act_-          }+        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_-          }+        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); }|]-  )+  [C.block| void { delete $(LoggerFields *fieldsPtr); }|]   do     size <- [C.exp| size_t { $(LoggerFields *fieldsPtr)->size() }|]     V.generateM (fromIntegral size) $ \i' ->@@ -251,22 +255,23 @@ withLoggerConduit logger io = withAsync (logger popper) $ \popperAsync ->   ((io `finally` liftIO close) <* wait popperAsync) `onException` liftIO (timeout 2_000_000 (wait popperAsync))   where-    popper = liftIO popMany >>= \case-      lns | null lns -> pass-      lns -> do-        yield lns-        popper+    popper =+      liftIO popMany >>= \case+        lns | null lns -> pass+        lns -> do+          yield lns+          popper  -- | Remove spammy progress results. Use 'nubProgress' instead? filterProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m () filterProgress = filterC \case-  Chunk (LogEntry.Result {rtype = LogEntry.ResultTypeProgress}) -> False+  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 k@LogEntry.Result {rtype = LogEntry.ResultTypeProgress} = Just k {LogEntry.i = 0}     toProgressKey _ = Nothing     toChunk (Chunk a) = Just a     toChunk Flush = Nothing@@ -279,37 +284,41 @@ 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)+    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+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+nubSubset1 toKey prevKey =+  await >>= \case+    Nothing -> pass+    Just a -> case toKey a of+      Nothing -> do         yield a-      nubSubset1 toKey ak+        nubSubset1 toKey prevKey+      Just ak -> do+        unless (ak == prevKey) do+          yield a+        nubSubset1 toKey ak  tryReadLine :: MonadUnliftIO m => Handle -> m (Either () ByteString)-tryReadLine s = tryJust (\e -> guard $ isEOFError e) (liftIO (BSC.hGetLine s))+tryReadLine s = tryJust (guard . isEOFError) (liftIO (BSC.hGetLine s))  tapper :: (KatipContext m, MonadUnliftIO m) => TapState -> m () tapper s = do@@ -317,9 +326,6 @@     Left _ -> pass     Right "__%%hercules terminate log%%__" -> pass     Right ln -> do-      katipAddContext (sl "line" (decode ln))-        $ logLocM DebugS-        $ "Intercepted stderr"       liftIO         [C.throwBlock| void {           std::string s = $bs-cstr:ln;@@ -374,7 +380,8 @@         hSetBuffering h LineBuffering         pure h   readableHandle <- mkHandle readable-  pure TapState-    { originalStderrCopy = oldStdError,-      readableStderrEnd = readableHandle-    }+  pure+    TapState+      { originalStderrCopy = oldStdError,+        readableStderrEnd = readableHandle+      }
+ hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger/Context.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Hercules.Agent.Worker.Build.Logger.Context where++import qualified Data.Map as M+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 HerculesLoggerEntry++data Fields++data LogEntryQueue++context :: C.Context+context =+  C.cppCtx <> C.fptrCtx+    <> C.bsCtx+    <> loggerContext++(=:) :: k -> a -> Map k a+(=:) = M.singleton++loggerContext :: C.Context+loggerContext =+  mempty+    { C.ctxTypesTable =+        C.TypeName "HerculesLoggerEntry" =: [t|HerculesLoggerEntry|]+          <> C.TypeName "LogEntryQueue" =: [t|LogEntryQueue|]+          <> C.TypeName "LoggerFields" =: [t|Fields|]+    }
hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Prefetched.hs view
@@ -9,11 +9,10 @@  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 Hercules.CNix.Store import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Cpp.Exceptions as C import Protolude@@ -38,7 +37,7 @@  C.include "<nix/fs-accessor.hh>" -C.include "hercules-aliases.h"+C.include "<hercules-ci-cnix/store.hxx>"  C.using "namespace nix" @@ -78,25 +77,23 @@ toBuildStatus (-1) = Successful toBuildStatus _ = UnknownFailure -data BuildResult-  = BuildResult-      { isSuccess :: Bool,-        status :: BuildStatus,-        startTime :: C.CTime,-        stopTime :: C.CTime,-        errorMessage :: Text-      }+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 =+getDerivation :: Store -> ByteString -> IO (Maybe (ForeignPtr Derivation))+getDerivation (Store store) derivationPath =   nullableForeignPtr finalizeDerivation     =<< [C.throwBlock| Derivation *{-      Store &store = **$(refStore* store);       std::string derivationPath($bs-ptr:derivationPath, $bs-len:derivationPath);       std::list<nix::ref<nix::Store>> stores = getDefaultSubstituters();       stores.push_front(*$(refStore* store));@@ -129,8 +126,8 @@     }|]  -- | @buildDerivation derivationPath derivationText@-buildDerivation :: Ptr (Ref NixStore) -> ByteString -> ForeignPtr Derivation -> Maybe [ByteString] -> IO BuildResult-buildDerivation store derivationPath derivation extraInputs =+buildDerivation :: Store -> ByteString -> ForeignPtr Derivation -> Maybe [ByteString] -> IO BuildResult+buildDerivation (Store store) derivationPath derivation extraInputs =   let extraInputsMerged = C8.intercalate "\n" (fromMaybe [] extraInputs)       materializeDerivation = if isNothing extraInputs then 1 else 0    in alloca $ \successPtr ->@@ -235,10 +232,11 @@                 stopTimeValue <- peek stopTimePtr                 errorMessageValue0 <- peek errorMessagePtr                 errorMessageValue <- peekCString errorMessageValue0-                pure $ BuildResult-                  { isSuccess = successValue /= 0,-                    status = toBuildStatus statusValue,-                    startTime = startTimeValue,-                    stopTime = stopTimeValue,-                    errorMessage = toS errorMessageValue-                  }+                pure $+                  BuildResult+                    { isSuccess = successValue /= 0,+                      status = toBuildStatus statusValue,+                      startTime = startTimeValue,+                      stopTime = stopTimeValue,+                      errorMessage = toS errorMessageValue+                    }
+ hercules-ci-agent-worker/Hercules/Agent/Worker/Effect.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Agent.Worker.Effect where++import Control.Monad.Catch (MonadThrow)+import GHC.ForeignPtr (ForeignPtr)+import Hercules.Agent.Worker.Build.Prefetched (buildDerivation)+import qualified Hercules.Agent.Worker.Build.Prefetched as Build+import qualified Hercules.Agent.WorkerProtocol.Command.Effect as Command.Effect+import Hercules.CNix (Store)+import qualified Hercules.CNix as CNix+import Hercules.CNix.Store.Context (Derivation)+import qualified Hercules.Effect as Effect+import Katip (KatipContext)+import Protolude+import UnliftIO.Directory (getCurrentDirectory)++runEffect :: (MonadIO m, KatipContext m, MonadThrow m) => Store -> Command.Effect.Effect -> m ExitCode+runEffect store command = do+  derivation <- prepareDerivation store command+  dir <- getCurrentDirectory+  Effect.runEffect derivation (Command.Effect.token command) (Command.Effect.secretsPath command) (Command.Effect.apiBaseURL command) dir++prepareDerivation :: MonadIO m => Store -> Command.Effect.Effect -> m (ForeignPtr Derivation)+prepareDerivation store command = do+  let extraPaths = Command.Effect.inputDerivationOutputPaths command+      drvPath = encodeUtf8 $ Command.Effect.drvPath command+      ensureDeps = for_ extraPaths $ \input ->+        liftIO $ CNix.ensurePath store input+  liftIO $ do+    ensureDeps `catch` \e -> do+      CNix.logInfo $ "while retrieving dependencies: " <> toS (displayException (e :: SomeException))+      CNix.logInfo "unable to retrieve dependency; attempting fallback to local build"+      CNix.ensurePath store drvPath+      derivation <- CNix.getDerivation store drvPath+      depDrvPaths <- CNix.getDerivationInputs derivation+      for_ depDrvPaths \(depDrv, _outputs) -> do+        depDerivation <- CNix.getDerivation store depDrv+        _nixBuildResult <- liftIO $ buildDerivation store depDrv depDerivation mempty+        pass+  derivation <-+    liftIO (Build.getDerivation store drvPath) >>= \case+      Just drv -> pure drv+      Nothing -> panic $ "Could not retrieve derivation " <> show drvPath <> " from local store or binary caches."+  sources <- liftIO $ CNix.getDerivationSources derivation+  for_ sources \src -> do+    liftIO $ CNix.ensurePath store src+  pure derivation
+ hercules-ci-agent-worker/Hercules/Agent/Worker/HerculesStore.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Hercules.Agent.Worker.HerculesStore+  ( module Hercules.Agent.Worker.HerculesStore,+    HerculesStore,+  )+where++import Control.Exception+  ( catch,+  )+import qualified Data.ByteString.Unsafe as BS+import Data.Coerce (coerce)+import qualified Foreign.C+import Foreign.C.String (withCString)+import Foreign.StablePtr (castStablePtrToPtr, newStablePtr)+import Hercules.Agent.Worker.HerculesStore.Context+  ( ExceptionPtr,+    HerculesStore,+    context,+  )+import Hercules.CNix (Store)+import Hercules.CNix.Expr (Store (Store))+import Hercules.CNix.Store.Context (Ref)+import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Cpp.Exceptions as C+import Protolude+import Prelude ()++C.context context++C.include "<cstring>"++C.include "<nix/config.h>"++C.include "<nix/shared.hh>"++C.include "<nix/store-api.hh>"++C.include "<nix/get-drvs.hh>"++C.include "<nix/derivations.hh>"++C.include "<nix/affinity.hh>"++C.include "<nix/globals.hh>"++C.include "hercules-aliases.h"++C.using "namespace nix"++withHerculesStore ::+  Store ->+  (Ptr (Ref HerculesStore) -> IO a) ->+  IO a+withHerculesStore (Store 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) -> Store+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 *) ));+  }|]++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 -D__GHCIDE__"+#endif
+ hercules-ci-agent-worker/Hercules/Agent/Worker/HerculesStore/Context.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Hercules.Agent.Worker.HerculesStore.Context where++import qualified Data.Map as M+import Hercules.CNix.Expr.Context (Ref)+import qualified Hercules.CNix.Store.Context as Store+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 HerculesStore++data ExceptionPtr++context :: C.Context+context =+  C.cppCtx <> C.fptrCtx+    <> C.bsCtx+    <> Store.context+    <> herculesStoreContext++(=:) :: k -> a -> Map k a+(=:) = M.singleton++herculesStoreContext :: C.Context+herculesStoreContext =+  mempty+    { C.ctxTypesTable =+        C.TypeName "refHerculesStore" =: [t|Ref HerculesStore|]+          <> C.TypeName "exception_ptr" =: [t|ExceptionPtr|]+    }
hercules-ci-agent.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           hercules-ci-agent-version:        0.7.5+version:        0.8.0 synopsis:       Runs Continuous Integration tasks on your machines category:       Nix, CI, Testing, DevOps homepage:       https://docs.hercules-ci.com@@ -49,18 +49,23 @@   exposed-modules:       Data.Fixed.Extras       Data.Time.Extras+      Hercules.Agent.NixFile       Hercules.Agent.Producer+      Hercules.Agent.Sensitive       Hercules.Agent.Socket       Hercules.Agent.STM       Hercules.Agent.WorkerProtocol.Command       Hercules.Agent.WorkerProtocol.Command.Build       Hercules.Agent.WorkerProtocol.Command.BuildResult+      Hercules.Agent.WorkerProtocol.Command.Effect       Hercules.Agent.WorkerProtocol.Command.Eval       Hercules.Agent.WorkerProtocol.Event       Hercules.Agent.WorkerProtocol.Event.Attribute       Hercules.Agent.WorkerProtocol.Event.AttributeError       Hercules.Agent.WorkerProtocol.Event.BuildResult       Hercules.Agent.WorkerProtocol.LogSettings+      Hercules.Effect+      Hercules.Effect.Container       Data.Conduit.Extras       Data.Conduit.Katip.Orphans @@ -81,24 +86,32 @@     , bytestring     , conduit     , containers+    , directory     , dlist     , exceptions+    , filepath     , hercules-ci-api-agent+    , hercules-ci-api-core+    , hercules-ci-cnix-store     , katip+    , lens+    , lens-aeson     , lifted-async     , lifted-base     , monad-control     , mtl     , network-uri-    , optparse-applicative     , protolude >= 0.3     , process+    , process-extras     , safe-exceptions     , stm+    , temporary     , text     , time     , transformers-base     , unbounded-delays+    , unix     , unliftio-core     , unliftio     , uuid@@ -106,57 +119,6 @@     , 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-  import: cxx-opts-  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.cxx-     cbits/hercules-logger.cxx-  build-depends:-      base-    , inline-c-    , inline-c-cpp-    , internal-ffi-    , bytestring-    , cachix >= 0.5.1-    , conduit-    , containers-    , protolude-    , unliftio-core-  pkgconfig-depends:-      nix-store >= 2.0-    , nix-expr >= 2.0-    , nix-main >= 2.0-    , bdw-gc-  extra-libraries:-      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- executable hercules-ci-agent   main-is: Main.hs   other-modules:@@ -176,10 +138,12 @@       Hercules.Agent.Config       Hercules.Agent.Config.BinaryCaches       Hercules.Agent.Compat+      Hercules.Agent.Effect       Hercules.Agent.Env       Hercules.Agent.EnvironmentInfo       Hercules.Agent.Evaluate       Hercules.Agent.Evaluate.TraversalQueue+      Hercules.Agent.Files       Hercules.Agent.Init       Hercules.Agent.Log       Hercules.Agent.Nix@@ -203,14 +167,14 @@       aeson     , async     , attoparsec-    , base >=4.7 && <5+    , base     , base64-bytestring     , binary     , binary-conduit     , bytestring     , cachix     , cachix-api-    , cnix+    , hercules-ci-cnix-store     , conduit     , conduit-extra     , containers@@ -219,8 +183,8 @@     , exceptions     , filepath     , hercules-ci-agent-    , hercules-ci-api-core == 0.1.1.0-    , hercules-ci-api-agent == 0.2.2.0+    , hercules-ci-api-core == 0.1.2.0+    , hercules-ci-api-agent == 0.3.0.0     , hostname     , http-client     , http-client-tls@@ -236,6 +200,7 @@     , network     , optparse-applicative     , process+    , process-extras     , protolude     , safe-exceptions     , servant >=0.14.1@@ -266,11 +231,18 @@       Hercules.Agent.Worker.Build       Hercules.Agent.Worker.Build.Prefetched       Hercules.Agent.Worker.Build.Logger+      Hercules.Agent.Worker.Build.Logger.Context+      Hercules.Agent.Worker.Effect       Paths_hercules_ci_agent+      Hercules.Agent.Worker.HerculesStore+      Hercules.Agent.Worker.HerculesStore.Context   autogen-modules:       Paths_hercules_ci_agent   hs-source-dirs:       hercules-ci-agent-worker+  cxx-sources:+      cbits/hercules-store.cxx+      cbits/hercules-logger.cxx   default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators   ghc-options:     -Werror=incomplete-patterns -Werror=missing-fields@@ -290,31 +262,39 @@   build-depends:       aeson     , async-    , base >=4.7 && <5+    , base     , binary     , binary-conduit     , bytestring     , cachix-    , cnix     , conduit     , containers+    , directory     , exceptions+    , filepath     , hercules-ci-agent     , hercules-ci-api-agent     , hercules-ci-api-core-    , internal-ffi+    , hercules-ci-cnix-store+    , hercules-ci-cnix-expr     , inline-c     , inline-c-cpp     , katip+    , lens+    , lens-aeson     , lifted-async     , lifted-base     , monad-control+    , mtl     , network-uri-    , optparse-applicative     , protolude+    , process+    , process-extras     , safe-exceptions     , stm     , text+    , temporary+    , transformers     , transformers-base     , unix     , unliftio@@ -350,11 +330,11 @@       aeson     , async     , attoparsec-    , base >=4.7 && <5+    , base     , binary     , binary-conduit     , bytestring-    , cnix+    , hercules-ci-cnix-store     , conduit     , containers     , exceptions@@ -367,7 +347,6 @@     , lifted-async     , lifted-base     , monad-control-    , optparse-applicative     , process     , protolude     , safe-exceptions
hercules-ci-agent/Data/Functor/Partitioner.hs view
@@ -20,13 +20,12 @@ import Protolude  -- TODO: Profunctor-data Partitioner a b-  = forall m.-    (Monoid m) =>-    Partitioner-      { ingest :: a -> Maybe m,-        digest :: m -> b-      }+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@@ -42,16 +41,16 @@   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)-    }+  (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 -- ...@@ -71,22 +70,24 @@   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-  }+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-  }+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. --
hercules-ci-agent/Hercules/Agent.hs view
@@ -10,9 +10,7 @@     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@@ -20,10 +18,11 @@ 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.Effect.EffectTask as EffectTask 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.LifeCycle.StartInfo as StartInfo import qualified Hercules.API.Agent.Socket.AgentPayload as AgentPayload import qualified Hercules.API.Agent.Socket.ServicePayload as ServicePayload import Hercules.API.Agent.Tasks@@ -43,11 +42,12 @@     tasksClient,   ) import qualified Hercules.Agent.Config as Config-import qualified Hercules.Agent.Env as Env+import qualified Hercules.Agent.Effect as Effect import Hercules.Agent.Env   ( App,     runHerculesClient,   )+import qualified Hercules.Agent.Env as Env import Hercules.Agent.EnvironmentInfo (extractAgentInfo) import qualified Hercules.Agent.Evaluate as Evaluate import qualified Hercules.Agent.Init as Init@@ -55,7 +55,6 @@ 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,@@ -103,28 +102,32 @@  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+  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.StartEffect effectTask ->+                        launchTask tasks socket (Task.upcastId $ EffectTask.id effectTask) do+                          Cache.withCaches $+                            Effect.performEffect effectTask+                      ServicePayload.Cancel cancellation -> cancelTask tasks socket cancellation  withTaskState :: (TVar (Map (Id (Task Task.Any)) ThreadId) -> App a) -> App a withTaskState f = do@@ -176,10 +179,10 @@           report $ TaskStatus.Exceptional $ toS $ displayException e       -- TODO use socket       report status =-        retry (cap 60 exponential)-          $ noContent-          $ runHerculesClient-          $ tasksSetStatus tasksClient taskId status+        retry (cap 60 exponential) $+          noContent $+            runHerculesClient $+              tasksSetStatus tasksClient taskId status   void @_ @ThreadId $     flip forkFinally done do       insertSelf@@ -206,16 +209,16 @@   now <- liftIO getCurrentTime   freshId <- Id <$> liftIO UUID.nextRandom   let startInfo = StartInfo.StartInfo {id = freshId, startTime = now}-      hello = StartInfo.Hello-        { agentInfo = agentInfo,-          startInfo = startInfo,-          tasksInProgress = []-        }+      hello =+        StartInfo.Hello+          { agentInfo = agentInfo,+            startInfo = startInfo,+            tasksInProgress = []+          }       req r =-        retry (cap 60 exponential)-          $ noContent-          $ runHerculesClient-          $ r+        retry (cap 60 exponential) $+          noContent $+            runHerculesClient r       sayGoodbye = req $ LifeCycle.goodbye lifeCycleClient startInfo   bracket pass (\() -> sayGoodbye) (\() -> app hello) @@ -234,10 +237,11 @@ 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-        }+  let lims' =+        ResourceLimits+          { softLimit = target & atLeast (softLimit lims) & atMost (hardLimit lims),+            hardLimit = hardLimit lims+          }       atLeast ResourceLimitInfinity _ = ResourceLimitInfinity       atLeast _ ResourceLimitInfinity = ResourceLimitInfinity       atLeast ResourceLimitUnknown r = r@@ -250,8 +254,8 @@       atMost l ResourceLimitInfinity = l       atMost ResourceLimitUnknown r = r       -- atMost l ResourceLimitUnknown = l -- already covered-      showLimit (ResourceLimitInfinity) = "infinity"-      showLimit (ResourceLimitUnknown) = A.Null+      showLimit ResourceLimitInfinity = "infinity"+      showLimit ResourceLimitUnknown = A.Null       showLimit (ResourceLimit n) = A.Number $ fromIntegral n   liftIO (setResourceLimit resource lims') `catch` \e ->     katipAddContext
hercules-ci-agent/Hercules/Agent/AgentSocket.hs view
@@ -2,10 +2,10 @@  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 qualified Hercules.API.Agent.Socket.AgentPayload as AgentPayload import Hercules.API.Agent.Socket.ServicePayload (ServicePayload)+import qualified Hercules.API.Agent.Socket.ServicePayload as ServicePayload import Hercules.API.Id (Id) import Hercules.API.Task (Task) import qualified Hercules.API.Task as Task
hercules-ci-agent/Hercules/Agent/Build.hs view
@@ -4,15 +4,15 @@ 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.OutputInfo as 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 qualified Hercules.API.Agent.Build.BuildTask as BuildTask import Hercules.API.Servant (noContent) import Hercules.API.TaskStatus (TaskStatus) import qualified Hercules.API.TaskStatus as TaskStatus@@ -23,6 +23,7 @@ import qualified Hercules.Agent.Env as Env import Hercules.Agent.Log import qualified Hercules.Agent.Nix as Nix+import Hercules.Agent.Sensitive (Sensitive (Sensitive)) import qualified Hercules.Agent.ServiceInfo as ServiceInfo import Hercules.Agent.WorkerProcess import qualified Hercules.Agent.WorkerProcess as WorkerProcess@@ -43,7 +44,7 @@   statusRef <- newIORef Nothing   extraNixOptions <- Nix.askExtraOptions   workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = mempty})-  let opts = [show $ extraNixOptions]+  let opts = [show extraNixOptions]       procSpec =         (System.Process.proc workerExe opts)           { env = Just workerEnv,@@ -59,16 +60,21 @@         _ -> 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 = encodeUtf8 <$> 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-    }+  liftIO $+    writeChan commandChan $+      Just $+        Command.Build $+          Command.Build.Build+            { drvPath = BuildTask.derivationPath buildTask,+              inputDerivationOutputPaths = encodeUtf8 <$> BuildTask.inputDerivationOutputPaths buildTask,+              logSettings =+                LogSettings.LogSettings+                  { token = Sensitive $ BuildTask.logToken buildTask,+                    path = "/api/v1/logs/build/socket",+                    baseURL = toS $ Network.URI.uriToString identity baseURL ""+                  },+              materializeDerivation = materialize+            }   exitCode <- runWorker procSpec (stderrLineHandler "Builder") commandChan writeEvent   logLocM DebugS $ "Worker exit: " <> logStr (show exitCode :: Text)   case exitCode of@@ -76,13 +82,13 @@     _ -> panic $ "Worker failed: " <> show exitCode   status <- readIORef statusRef   case status of-    Just (BuildResult.BuildSuccess {outputs = outs'}) -> do+    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 ()+    Just BuildResult.BuildFailure {} -> pure $ TaskStatus.Terminated ()     Nothing -> pure $ TaskStatus.Exceptional "Build did not complete"  convertOutputs :: Text -> [BuildResult.OutputInfo] -> Map Text OutputInfo
hercules-ci-agent/Hercules/Agent/Cache.hs view
@@ -2,8 +2,6 @@  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@@ -14,15 +12,16 @@ import qualified Hercules.Agent.Env as Env import qualified Hercules.Agent.Nix as Nix import qualified Hercules.Agent.SecureDirectory as SecureDirectory+import qualified Hercules.CNix as CNix+import qualified Hercules.CNix.Store as Store 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+  netrcLns <- (<>) <$> Cachix.getNetrcLines <*> Nix.getNetrcLines   csubsts <- Cachix.getSubstituters   cpubkeys <- Cachix.getTrustedPublicKeys   nixCaches <- asks (Config.nixCaches . Env.binaryCaches)@@ -81,12 +80,9 @@     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 :: CNix.Store -> 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.computeFSClosure store Store.defaultClosureParams pathSet   closure     & Store.traversePathSet       ( \path -> do
hercules-ci-agent/Hercules/Agent/Cachix.hs view
@@ -23,36 +23,38 @@       nixStore = nixStore,       clientEnv = clientEnv     } <--    asks $ Agent.Cachix.getEnv+    asks Agent.Cachix.getEnv   pushCache <--    escalate-      $ maybeToEither (FatalError $ "Cache not found " <> cache)-      $ M.lookup cache pushCaches+    escalate $+      maybeToEither (FatalError $ "Cache not found " <> cache) $+        M.lookup cache pushCaches   ul <- askUnliftIO+  let pushParams =+        Cachix.Push.PushParams+          { pushParamsName = Agent.Cachix.pushCacheName pushCache,+            pushParamsSecret = Agent.Cachix.pushCacheSecret pushCache,+            pushParamsStore = nixStore,+            pushParamsClientEnv = clientEnv,+            pushParamsStrategy = \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,+                      omitDeriver = False+                    }+          }   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,-                  omitDeriver = False-                }-      )+      (\f l -> liftIO $ Cachix.Push.mapConcurrentlyBounded workers (fmap (unliftIO ul) f) l)+      pushParams       paths  getNetrcLines :: App [Text]
hercules-ci-agent/Hercules/Agent/Cachix/Env.hs view
@@ -1,19 +1,23 @@ module Hercules.Agent.Cachix.Env where  import qualified Cachix.Client.Push as Cachix-import Cachix.Client.Store (Store)+import Hercules.CNix.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-      }+data PushCache = PushCache+  { pushCacheName :: Text,+    pushCacheSecret :: Cachix.PushSecret+  }++data Env = Env+  { pushCaches :: Map Text PushCache,+    cacheKeys :: Map Text CachixCache,+    netrcLines :: [Text],+    nixStore :: Store,+    clientEnv :: ClientEnv+  }  class HasEnv env where   getEnv :: env -> Env
hercules-ci-agent/Hercules/Agent/Cachix/Init.hs view
@@ -5,11 +5,11 @@ 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.CNix.Store (openStore) import Hercules.Error import qualified Hercules.Formats.CachixCache as CachixCache import qualified Katip as K@@ -35,15 +35,16 @@   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+  store <- liftIO openStore   httpManager <- newTlsManagerWith customManagerSettings-  pure Env.Env-    { pushCaches = pcs,-      netrcLines = toNetrcLines cks,-      cacheKeys = cks,-      nixStore = store,-      clientEnv = mkClientEnv httpManager defaultCachixBaseUrl-    }+  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@@ -52,19 +53,30 @@       pt <- toList $ CachixCache.authToken keys       pure $ "machine " <> name <> ".cachix.org" <> " password " <> pt -toPushCaches :: Map Text CachixCache.CachixCache -> IO (Map Text Cachix.Push.PushCache)+toPushCaches :: Map Text CachixCache.CachixCache -> IO (Map Text 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,-                  pushCacheSecret =-                    Cachix.Push.PushSigningKey-                      (Servant.Auth.Client.Token $ encodeUtf8 t)-                      k'-                }+            Just $+              escalateAs FatalError $ do+                k' <- Cachix.Secrets.parseSigningKeyLenient sk+                pure+                  PushCache+                    { pushCacheName = name,+                      pushCacheSecret =+                        Cachix.Push.PushSigningKey+                          (Servant.Auth.Client.Token $ encodeUtf8 t)+                          k'+                    }+            <|> do+              token <- head $ CachixCache.authToken keys+              Just $+                pure+                  PushCache+                    { pushCacheName = name,+                      pushCacheSecret =+                        Cachix.Push.PushToken (Servant.Auth.Client.Token $ encodeUtf8 token)+                    }
hercules-ci-agent/Hercules/Agent/Client.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -O0 #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- TODO https://github.com/haskell-servant/servant/issues/986 module Hercules.Agent.Client@@ -16,32 +20,47 @@ import Hercules.API.Agent.Build (BuildAPI) import Hercules.API.Agent.Evaluate (EvalAPI) import Hercules.API.Agent.LifeCycle (LifeCycleAPI)+import Hercules.API.Agent.State (ContentLength) import Hercules.API.Agent.Tasks (TasksAPI) import Hercules.API.Logs (LogsAPI) import Hercules.API.Servant (useApi) import Protolude+import Servant.API import Servant.API.Generic import Servant.Auth.Client ()-import qualified Servant.Client-import Servant.Client (ClientM) import Servant.Client.Generic (AsClientT)+import Servant.Client.Streaming (ClientM)+import qualified Servant.Client.Streaming +-- | Bad instance to make it the client for State api compile. GHC seems to pick+-- the wrong overlappable instance.+instance+  FromSourceIO+    ByteString+    ( Headers+        '[Hercules.API.Agent.State.ContentLength]+        (SourceIO ByteString)+    )+  where+  fromSourceIO = addHeader (-1) . fromSourceIO+ client :: AgentAPI ClientAuth (AsClientT ClientM)-client = fromServant $ Servant.Client.client (servantApi @ClientAuth)+client = fromServant $ Servant.Client.Streaming.client (servantApi @ClientAuth)  tasksClient :: TasksAPI ClientAuth (AsClientT ClientM)-tasksClient = useApi tasks $ Hercules.Agent.Client.client+tasksClient = useApi tasks Hercules.Agent.Client.client  evalClient :: EvalAPI ClientAuth (AsClientT ClientM)-evalClient = useApi eval $ Hercules.Agent.Client.client+evalClient = useApi eval Hercules.Agent.Client.client  buildClient :: BuildAPI ClientAuth (AsClientT ClientM)-buildClient = useApi build $ Hercules.Agent.Client.client+buildClient = useApi build Hercules.Agent.Client.client  lifeCycleClient :: LifeCycleAPI ClientAuth (AsClientT ClientM)-lifeCycleClient = useApi lifeCycle $ Hercules.Agent.Client.client+lifeCycleClient = useApi lifeCycle Hercules.Agent.Client.client  logsClient :: LogsAPI () (AsClientT ClientM) logsClient =-  fromServant $ Servant.Client.client $-    (Proxy @(AddAPIVersion (ToServantApi (LogsAPI ()))))+  fromServant $+    Servant.Client.Streaming.client+      (Proxy @(AddAPIVersion (ToServantApi (LogsAPI ()))))
hercules-ci-agent/Hercules/Agent/Config.hs view
@@ -14,6 +14,7 @@   ) where +import GHC.Conc (getNumProcessors) import Katip (Severity (..)) import Protolude hiding (to) import qualified System.Environment@@ -28,28 +29,29 @@ data Purpose = Input | Final  -- | Whether the 'Final' value is optional.-data Sort = Required | Optional+data Sort = Required | Optional | From Sort Type  type family Item purpose sort a where+  Item 'Input ('From sort b) a = Item 'Input sort b+  Item 'Final ('From sort b) a = Item 'Final sort a   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,-        logLevel :: Item purpose 'Required Severity-      }+data Config purpose = Config+  { herculesApiBaseURL :: Item purpose 'Required Text,+    nixUserIsTrusted :: Item purpose 'Required Bool,+    concurrentTasks :: Item purpose ('From 'Required (Either () Int)) Int,+    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,+    logLevel :: Item purpose 'Required Severity+  }   deriving (Generic)  deriving instance Show (Config 'Final)@@ -61,7 +63,10 @@     .= herculesApiBaseURL     <*> dioptional (Toml.bool "nixUserIsTrusted")     .= nixUserIsTrusted-    <*> dioptional (Toml.integer "concurrentTasks")+    <*> dioptional+      ( Toml.dimatch matchRight Right (Toml.int "concurrentTasks")+          <|> Toml.dimatch matchLeft Left (Toml.textBy (\() -> "auto") isAuto "concurrentTasks")+      )     .= concurrentTasks     <*> dioptional (Toml.string keyBaseDirectory)     .= baseDirectory@@ -76,6 +81,18 @@     <*> dioptional (Toml.enumBounded "logLevel")     .= logLevel +matchLeft :: Either a b -> Maybe a+matchLeft (Left a) = Just a+matchLeft _ = Nothing++matchRight :: Either a1 a2 -> Maybe a2+matchRight (Right a) = Just a+matchRight _ = Nothing++isAuto :: Text -> Either Text ()+isAuto "auto" = Right ()+isAuto _ = Left "The only permissible string value is \"auto\""+ keyClusterJoinTokenPath :: Key keyClusterJoinTokenPath = "clusterJoinTokenPath" @@ -91,9 +108,6 @@ 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 (toS fp)@@ -116,20 +130,27 @@           (binaryCachesPath input)       workDir = fromMaybe (baseDir </> "work") (workDirectory input)   dabu <- determineDefaultApiBaseUrl-  let rawConcurrentTasks = fromMaybe defaultConcurrentTasks $ concurrentTasks input+  numProc <- getNumProcessors+  let -- make sure the default is at least two, for ifd+      autoConcurrentTasks = max 2 numProc+      configuredConcurrentTasks = case concurrentTasks input of+        Nothing -> autoConcurrentTasks+        Just (Left _auto) -> autoConcurrentTasks+        Just (Right n) -> fromIntegral n   validConcurrentTasks <--    case rawConcurrentTasks of-      x | not (x >= 1) -> throwIO $ FatalError "concurrentTasks must be at least 1"-      x -> pure x+    case configuredConcurrentTasks of+      x | x >= 1 -> pure x+      _ -> throwIO $ FatalError "concurrentTasks must be at least 1"   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,-      logLevel = logLevel input & fromMaybe InfoS-    }+  pure+    Config+      { herculesApiBaseURL = apiBaseUrl,+        nixUserIsTrusted = fromMaybe False $ nixUserIsTrusted input,+        binaryCachesPath = binaryCachesP,+        clusterJoinTokenPath = clusterJoinTokenP,+        concurrentTasks = validConcurrentTasks,+        baseDirectory = baseDir,+        staticSecretsDirectory = staticSecretsDir,+        workDirectory = workDir,+        logLevel = logLevel input & fromMaybe InfoS+      }
hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs view
@@ -20,12 +20,11 @@ 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 BinaryCaches = BinaryCaches+  { cachixCaches :: Map Text CachixCache,+    nixCaches :: Map Text NixCache,+    unknownKinds :: Map Text UnknownKind+  }  data UnknownKind = UnknownKind {kind :: Text}   deriving (Generic, FromJSON)@@ -35,8 +34,8 @@   parseJSON =     parseBag       ( BinaryCaches-          <$> part (\_name -> whenKind "CachixCache" $ \v -> Just $ (parseJSON v))-          <*> part (\_name -> whenKind "NixCache" $ \v -> Just $ (parseJSON v))+          <$> part (\_name -> whenKind "CachixCache" $ \v -> Just $ parseJSON v)+          <*> part (\_name -> whenKind "NixCache" $ \v -> Just $ parseJSON v)           <*> part (\_name v -> Just $ parseJSON v)       ) @@ -48,15 +47,17 @@       (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/"+          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
+ hercules-ci-agent/Hercules/Agent/Effect.hs view
@@ -0,0 +1,91 @@+module Hercules.Agent.Effect where++import Data.IORef+import qualified Hercules.API.Agent.Effect.EffectTask as EffectTask+import Hercules.API.TaskStatus (TaskStatus)+import qualified Hercules.API.TaskStatus as TaskStatus+import qualified Hercules.Agent.Config as Config+import Hercules.Agent.Env hiding (config)+import qualified Hercules.Agent.Env as Env+import Hercules.Agent.Files+import Hercules.Agent.Log+import qualified Hercules.Agent.Nix as Nix+import Hercules.Agent.Sensitive (Sensitive (Sensitive))+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.Effect as Command.Effect+import qualified Hercules.Agent.WorkerProtocol.Event as Event+import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import qualified Network.URI+import Protolude+import System.FilePath ((</>))+import qualified System.Posix.Signals as PS+import System.Process++performEffect :: EffectTask.EffectTask -> App TaskStatus+performEffect effectTask = withWorkDir "effect" $ \workDir -> do+  workerExe <- getWorkerExe+  commandChan <- liftIO newChan+  extraNixOptions <- Nix.askExtraOptions+  workerEnv <- liftIO $ WorkerProcess.prepareEnv (WorkerProcess.WorkerEnvSettings {nixPath = mempty})+  effectResult <- liftIO $ newIORef Nothing+  let opts = [show extraNixOptions]+      procSpec =+        (System.Process.proc workerExe opts)+          { env = Just workerEnv,+            close_fds = True,+            cwd = Just workDir+          }+      writeEvent :: Event.Event -> App ()+      writeEvent event = case event of+        Event.EffectResult e -> do+          liftIO $ writeIORef effectResult (Just e)+        Event.Exception e -> do+          panic e+        _ -> pass+  config <- asks Env.config+  let materialize = not (Config.nixUserIsTrusted config)+  baseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)+  liftIO $+    writeChan commandChan $+      Just $+        Command.Effect $+          Command.Effect.Effect+            { drvPath = EffectTask.derivationPath effectTask,+              inputDerivationOutputPaths = encodeUtf8 <$> EffectTask.inputDerivationOutputPaths effectTask,+              logSettings =+                LogSettings.LogSettings+                  { token = Sensitive $ EffectTask.logToken effectTask,+                    path = "/api/v1/logs/build/socket",+                    baseURL = toS $ Network.URI.uriToString identity baseURL ""+                  },+              materializeDerivation = materialize,+              secretsPath = toS $ Config.staticSecretsDirectory config </> "secrets.json",+              token = Sensitive (EffectTask.token effectTask),+              apiBaseURL = Config.herculesApiBaseURL config+            }+  exitCode <- runWorker procSpec (stderrLineHandler "Effect worker") commandChan writeEvent+  logLocM DebugS $ "Worker exit: " <> logStr (show exitCode :: Text)+  let showSig n | n == PS.sigABRT = " (Aborted)"+      showSig n | n == PS.sigBUS = " (Bus)"+      showSig n | n == PS.sigCHLD = " (Child)"+      showSig n | n == PS.sigFPE = " (Floating point exception)"+      showSig n | n == PS.sigHUP = " (Hangup)"+      showSig n | n == PS.sigILL = " (Illegal instruction)"+      showSig n | n == PS.sigINT = " (Interrupted)"+      showSig n | n == PS.sigKILL = " (Killed)"+      showSig n | n == PS.sigPIPE = " (Broken pipe)"+      showSig n | n == PS.sigQUIT = " (Quit)"+      showSig n | n == PS.sigSEGV = " (Segmentation fault)"+      showSig n | n == PS.sigTERM = " (Terminated)"+      showSig _ = ""+  case exitCode of+    ExitSuccess -> pass+    ExitFailure n -> panic $ "Effect worker failed with exit code " <> show n <> showSig (negate $ fromIntegral n)+  liftIO (readIORef effectResult) >>= \case+    Nothing -> pure $ TaskStatus.Exceptional "Effect worker terminated without reporting status"+    Just 0 -> pure $ TaskStatus.Successful ()+    Just n | n > 0 -> pure $ TaskStatus.Terminated ()+    Just n -> pure $ TaskStatus.Exceptional $ "Effect process exited with status code " <> show n <> showSig (negate $ fromIntegral n)
hercules-ci-agent/Hercules/Agent/Env.hs view
@@ -26,33 +26,32 @@ import qualified Network.HTTP.Client import Protolude import qualified Servant.Auth.Client-import qualified Servant.Client+import qualified Servant.Client.Streaming -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-      }+data Env = Env+  { manager :: Network.HTTP.Client.Manager,+    config :: FinalConfig,+    herculesBaseUrl :: Servant.Client.Streaming.BaseUrl,+    herculesClientEnv :: Servant.Client.Streaming.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)+  bc <- asks binaryCaches   pure $     M.keys       ( void (Config.BinaryCaches.cachixCaches bc)@@ -71,25 +70,24 @@ runApp env (App m) = runReaderT m env  runHerculesClient ::-  (Servant.Auth.Client.Token -> Servant.Client.ClientM a) ->+  NFData a =>+  (Servant.Auth.Client.Token -> Servant.Client.Streaming.ClientM a) ->   App a runHerculesClient f = do   tok <- asks currentToken   runHerculesClient' (f tok) -runHerculesClient' :: Servant.Client.ClientM a -> App a+runHerculesClient' :: NFData a => Servant.Client.Streaming.ClientM a -> App a runHerculesClient' m = do   clientEnv <- asks herculesClientEnv-  escalate =<< liftIO (Servant.Client.runClientM m clientEnv)+  escalate =<< liftIO (Servant.Client.Streaming.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)
hercules-ci-agent/Hercules/Agent/EnvironmentInfo.hs view
@@ -1,19 +1,18 @@ module Hercules.Agent.EnvironmentInfo where  import Control.Lens-  ( (^..),+  ( to,+    (^..),     (^?),-    to,   ) import qualified Data.Aeson as Aeson import Data.Aeson.Lens-  ( _Array,+  ( key,+    _Array,     _Number,     _String,-    key,   ) import qualified Data.ByteString.Lazy as LBS-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@@ -32,29 +31,30 @@   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-        }+  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: " <> logStr (show s :: Text)   pure s -data NixInfo-  = NixInfo-      { nixExeVersion :: Text,-        nixPlatforms :: [Text],-        nixSystemFeatures :: [Text],-        nixSubstituters :: [Text],-        nixTrustedPublicKeys :: [Text],-        nixNarinfoCacheNegativeTTL :: Maybe Integer-      }+data NixInfo = NixInfo+  { nixExeVersion :: Text,+    nixPlatforms :: [Text],+    nixSystemFeatures :: [Text],+    nixSubstituters :: [Text],+    nixTrustedPublicKeys :: [Text],+    nixNarinfoCacheNegativeTTL :: Maybe Integer,+    nixNetrcFile :: Maybe Text+  }  getNixInfo :: IO NixInfo getNixInfo = do@@ -62,50 +62,56 @@   version <- Process.readProcess "nix" ["--version"] stdinEmpty   rawJson <- Process.readProcess "nix" ["show-config", "--json"] stdinEmpty   cfg <--    case Aeson.eitherDecode (LBS.fromStrict $ encodeUtf8 $ toS $ rawJson) of+    case Aeson.eitherDecode (LBS.fromStrict $ encodeUtf8 $ 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 (toS 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-    }+  pure+    NixInfo+      { nixExeVersion = T.dropAround isSpace (toS 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,+        nixNetrcFile =+          cfg+            ^? key "netrc-file"+              . key "value"+              . _String+      }  cleanUrl :: Text -> Text cleanUrl t | "@" `T.isInfixOf` t = "<URI censored; might contain secret>"
hercules-ci-agent/Hercules/Agent/Evaluate.hs view
@@ -4,14 +4,16 @@  module Hercules.Agent.Evaluate   ( performEvaluation,+    findNixFile,   ) 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 qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import Data.Char (isAsciiLower, isAsciiUpper) import Data.Conduit.Process (sourceProcessWithStreams) import Data.IORef   ( atomicModifyIORef,@@ -39,19 +41,21 @@ 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.Env as Env import qualified Hercules.Agent.Evaluate.TraversalQueue as TraversalQueue+import Hercules.Agent.Files import Hercules.Agent.Log import qualified Hercules.Agent.Nix as Nix import Hercules.Agent.Nix.RetrieveDerivationInfo   ( retrieveDerivationInfo,   )+import Hercules.Agent.NixFile (findNixFile) import Hercules.Agent.NixPath   ( renderSubPath,   ) import Hercules.Agent.Producer+import Hercules.Agent.Sensitive (Sensitive (Sensitive)) import qualified Hercules.Agent.ServiceInfo as ServiceInfo import Hercules.Agent.WorkerProcess () import qualified Hercules.Agent.WorkerProcess as WorkerProcess@@ -62,6 +66,7 @@ import qualified Hercules.Agent.WorkerProtocol.Event.Attribute as WorkerAttribute import qualified Hercules.Agent.WorkerProtocol.Event.AttributeError as WorkerAttributeError import qualified Hercules.Agent.WorkerProtocol.LogSettings as LogSettings+import Hercules.CNix (withStore) import Hercules.Error (defaultRetry, quickRetry) import qualified Network.HTTP.Client.Conduit as HTTP.Conduit import qualified Network.HTTP.Simple as HTTP.Simple@@ -70,7 +75,6 @@ import qualified Servant.Client import qualified System.Directory as Dir import System.FilePath-import System.IO.Temp (withTempDirectory) import System.Process  eventLimit :: Int@@ -90,19 +94,34 @@   EvaluateTask.EvaluateTask ->   (Syncing EvaluateEvent.EvaluateEvent -> App ()) ->   App ()-produceEvaluationTaskEvents task writeToBatch = withWorkDir $ \tmpdir -> do+produceEvaluationTaskEvents task writeToBatch = withWorkDir "eval" $ \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+    EvaluateTask.otherInputs task+      & M.traverseWithKey \k src -> do+        let fetchName = tmpdir </> ("fetch-" <> toS k)+            argName = tmpdir </> ("arg-" <> toS k)+            metaName = do+              meta <- EvaluateTask.inputMetadata task & M.lookup k+              nameValue <- meta & M.lookup "name"+              name <- case A.fromJSON nameValue of+                A.Success a -> pure a+                _ -> Nothing+              guard (isValidName name)+              pure name+            destName+              | Just sourceName <- metaName = argName </> sourceName+              | otherwise = argName+        fetched <- fetchSource fetchName src+        liftIO do+          Dir.createDirectoryIfMissing True (takeDirectory destName)+          renamePathTryHarder fetched destName+        pure destName+  projectDir <- case M.lookup "src" inputLocations of+    Nothing -> panic "No primary source provided"+    Just x -> pure x   nixPath <-     EvaluateTask.nixPath task       & ( traverse@@ -111,10 +130,10 @@             $ \identifier -> case M.lookup identifier inputLocations of               Just x -> pure x               Nothing ->-                throwIO-                  $ FatalError-                  $ "Nix path references undefined input "-                    <> identifier+                throwIO $+                  FatalError $+                    "Nix path references undefined input "+                      <> identifier         )   autoArguments' <-     EvaluateTask.autoArguments task@@ -122,20 +141,30 @@         ( \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+              throwIO $+                FatalError $+                  "input "+                    <> identifier+                    <> " was not resolved to an absolute path: "+                    <> toS x             Nothing ->-              throwIO-                $ FatalError-                $ "auto argument references undefined input "-                  <> identifier+              throwIO $+                FatalError $+                  "auto argument references undefined input "+                    <> identifier         )-  let autoArguments = autoArguments'-        <&> \sp -> Eval.ExprArg $ encodeUtf8 $ renderSubPath $ toS <$> sp+  let autoArguments =+        autoArguments'+          & M.mapWithKey \k sp ->+            let argPath = encodeUtf8 $ renderSubPath $ toS <$> sp+             in case do+                  inputId <- EvaluateTask.autoArguments task & M.lookup k+                  EvaluateTask.inputMetadata task & M.lookup (EvaluateTask.path inputId) of+                  Nothing -> Eval.ExprArg argPath+                  Just attrs ->+                    Eval.ExprArg $+                      -- TODO pass directly to avoid having to escape (or just escape properly)+                      "builtins.fromJSON ''" <> BL.toStrict (A.encode attrs) <> "'' // { outPath = " <> argPath <> "; }"   msgCounter <- liftIO $ newIORef 0   let fixIndex ::         MonadIO m =>@@ -154,14 +183,15 @@           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."-                  }+                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@@ -170,11 +200,12 @@   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-          }+        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@@ -223,6 +254,16 @@               emit $ EvaluateEvent.DerivationInfo drvInfo        in doIt +isValidName :: FilePath -> Bool+isValidName "" = False+isValidName cs@(c0 : _) = all isValidNameChar cs && c0 /= '.'+  where+    isValidNameChar c =+      isAsciiUpper c+        || isAsciiLower c+        || isDigit c+        || c `elem` ("+-._?=" :: [Char])+ runEvalProcess ::   FilePath ->   FilePath ->@@ -239,17 +280,19 @@ runEvalProcess projectDir file autoArguments nixPath emit uploadDerivationInfos flush logToken = do   extraOpts <- Nix.askExtraOptions   baseURL <- asks (ServiceInfo.bulkSocketBaseURL . Env.serviceInfo)-  let eval = Eval.Eval-        { Eval.cwd = projectDir,-          Eval.file = toS file,-          Eval.autoArguments = autoArguments,-          Eval.extraNixOptions = extraOpts,-          Eval.logSettings = LogSettings.LogSettings-            { token = LogSettings.Sensitive logToken,-              path = "/api/v1/logs/build/socket",-              baseURL = toS $ Network.URI.uriToString identity baseURL ""-            }-        }+  let eval =+        Eval.Eval+          { Eval.cwd = projectDir,+            Eval.file = toS file,+            Eval.autoArguments = autoArguments,+            Eval.extraNixOptions = extraOpts,+            Eval.logSettings =+              LogSettings.LogSettings+                { token = Sensitive logToken,+                  path = "/api/v1/logs/build/socket",+                  baseURL = toS $ Network.URI.uriToString identity baseURL ""+                }+          }   buildRequiredIndex <- liftIO $ newIORef (0 :: Int)   commandChan <- newChan   writeChan commandChan $ Just $ Command.Eval eval@@ -261,39 +304,51 @@           workerEventsP           ( \case               Event.Attribute a -> do-                emit $ EvaluateEvent.Attribute $ AttributeEvent.AttributeEvent-                  { AttributeEvent.expressionPath = decode <$> WorkerAttribute.path a,-                    AttributeEvent.derivationPath = decode $ WorkerAttribute.drv a-                  }+                emit $+                  EvaluateEvent.Attribute $+                    AttributeEvent.AttributeEvent+                      { AttributeEvent.expressionPath = decode <$> WorkerAttribute.path a,+                        AttributeEvent.derivationPath = decode $ WorkerAttribute.drv a,+                        AttributeEvent.typ = case WorkerAttribute.typ a of+                          WorkerAttribute.Regular -> AttributeEvent.Regular+                          WorkerAttribute.MustFail -> AttributeEvent.MustFail+                          WorkerAttribute.MayFail -> AttributeEvent.MayFail+                          WorkerAttribute.Effect -> AttributeEvent.Effect+                          WorkerAttribute.DependenciesOnly -> AttributeEvent.DependenciesOnly+                      }                 continue               Event.AttributeError e -> do-                emit $ EvaluateEvent.AttributeError $ AttributeErrorEvent.AttributeErrorEvent-                  { AttributeErrorEvent.expressionPath = decode <$> WorkerAttributeError.path e,-                    AttributeErrorEvent.errorMessage = WorkerAttributeError.message e,-                    AttributeErrorEvent.errorType = WorkerAttributeError.errorType e,-                    AttributeErrorEvent.errorDerivation = WorkerAttributeError.errorDerivation e-                  }+                emit $+                  EvaluateEvent.AttributeError $+                    AttributeErrorEvent.AttributeErrorEvent+                      { AttributeErrorEvent.expressionPath = decode <$> WorkerAttributeError.path e,+                        AttributeErrorEvent.errorMessage = WorkerAttributeError.message e,+                        AttributeErrorEvent.errorType = WorkerAttributeError.errorType e,+                        AttributeErrorEvent.errorDerivation = 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-                    }+                  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-                        }+                      EvaluateEvent.BuildRequired+                        BuildRequired.BuildRequired+                          { BuildRequired.derivationPath = drv,+                            BuildRequired.index = currentIndex,+                            BuildRequired.outputName = outputName+                          }                     let pushDerivations = do                           caches <- activePushCaches                           forM_ caches $ \cache -> do@@ -302,19 +357,22 @@                     Async.Lifted.concurrently_                       (uploadDerivationInfos drv)                       pushDerivations-                    emit $ EvaluateEvent.BuildRequest BuildRequest.BuildRequest-                      { derivationPath = drv,-                        forceRebuild = isJust notAttempt-                      }+                    emit $+                      EvaluateEvent.BuildRequest+                        BuildRequest.BuildRequest+                          { derivationPath = drv,+                            forceRebuild = isJust notAttempt+                          }                     flush                     status <- drvPoller notAttempt drv                     logLocM DebugS $ "Got derivation status " <> logStr (show status :: Text)                     return status                 writeChan commandChan $ Just $ Command.BuildResult $ uncurry (BuildResult.BuildResult drv) status                 continue+              Event.Exception e -> panic e               -- Unused during eval               Event.BuildResult {} -> pass-              Event.Exception e -> panic e+              Event.EffectResult {} -> pass           )           ( \case               ExitSuccess -> logLocM DebugS "Clean worker exit"@@ -335,22 +393,22 @@   -- 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)-        }+  let wps =+        (System.Process.proc workerExe opts)+          { env = Just workerEnv,+            close_fds = True, -- Disable on Windows?+            cwd = Just (Eval.cwd eval)+          }   WorkerProcess.runWorker wps (stderrLineHandler "evaluator") commandChan writeEvent  drvPoller :: Maybe UUID -> Text -> App (UUID, BuildResult.BuildStatus) drvPoller notAttempt drvPath = do   resp <--    defaultRetry $ runHerculesClient $-      getDerivationStatus2-        Hercules.Agent.Client.evalClient-        drvPath+    defaultRetry $+      runHerculesClient $+        getDerivationStatus2+          Hercules.Agent.Client.evalClient+          drvPath   let oneSecond = 1000 * 1000       again = do         liftIO $ threadDelay oneSecond@@ -377,18 +435,18 @@   -- 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+      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"@@ -402,64 +460,19 @@ findTarballDir fp = do   nodes <- Dir.listDirectory fp   case nodes of-    [x] -> Dir.doesDirectoryExist (fp </> x) >>= \case-      True -> pure $ fp </> x-      False -> pure fp+    [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- 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+  noContent $+    defaultRetry $+      runHerculesClient+        ( tasksUpdateEvaluation+            Hercules.Agent.Client.evalClient+            (EvaluateTask.id task)+            events+        )
hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs view
@@ -29,13 +29,12 @@     writeChan,   ) -data Queue a-  = Queue-      { chan :: Chan (Maybe a),-        visitedSet :: IORef (Set a),-        -- | Increased on enqueue, decreased when processed-        size :: TVar Int-      }+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@@ -54,9 +53,10 @@   writeChan (chan env) (Just msg)  waitUntilDone :: MonadBase IO m => Queue a -> m ()-waitUntilDone env = liftBase $ atomically $ do-  n <- readTVar (size env)-  check (n == 0)+waitUntilDone env = liftBase $+  atomically $ do+    n <- readTVar (size env)+    check (n == 0)  readJust_ ::   (MonadBase IO m, MonadIO m) =>
+ hercules-ci-agent/Hercules/Agent/Files.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.Agent.Files where++import Control.Monad.IO.Unlift+import qualified Hercules.Agent.Config as Config+import Hercules.Agent.Env+import Protolude+import System.Directory+import System.FilePath+import System.IO.Error+import System.IO.Temp++withWorkDir :: Text -> (FilePath -> App b) -> App b+withWorkDir hint f = do+  UnliftIO {unliftIO = unlift} <- askUnliftIO+  workDir <- asks (Config.workDirectory . config)+  liftIO $ withTempDirectory workDir (toS hint) $ unlift . f++readFileMaybe :: MonadIO m => FilePath -> m (Maybe Text)+readFileMaybe fp = liftIO do+  exists <- doesFileExist fp+  guard exists & traverse \_ -> readFile fp++renamePathTryHarder :: FilePath -> FilePath -> IO ()+renamePathTryHarder source dest = do+  catchJust+    ( \case+        e | isPermissionError e -> Just e+        _ -> Nothing+    )+    doIt+    (const tryHarder)+  where+    doIt = renamePath source dest+    modifyPermissions f p = getPermissions p >>= setPermissions p . f+    tryHarder = do+      modifyPermissions (setOwnerWritable True) (takeDirectory source)+      modifyPermissions (setOwnerWritable True) source+      modifyPermissions (setOwnerWritable True) (takeDirectory dest)+      doIt
hercules-ci-agent/Hercules/Agent/Init.hs view
@@ -1,16 +1,16 @@ 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.Env as 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 Hercules.CNix import qualified Katip as K import qualified Network.HTTP.Client.TLS import Protolude@@ -34,21 +34,22 @@   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-    }+  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 :: Config.FinalConfig -> (K.LogEnv -> IO ()) -> IO () setupLogging cfg f = do@@ -63,5 +64,5 @@  initCNix :: IO () initCNix = do-  CNix.init-  CNix.setTalkative+  Hercules.CNix.init+  Hercules.CNix.setTalkative
hercules-ci-agent/Hercules/Agent/Log.hs view
@@ -38,7 +38,7 @@     -- "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 processRole pid ln =-  withNamedContext "worker" (pid :: Int)-    $ logLocM InfoS-    $ logStr-    $ processRole <> ": " <> decodeUtf8With lenientDecode ln+  withNamedContext "worker" (pid :: Int) $+    logLocM InfoS $+      logStr $+        processRole <> ": " <> decodeUtf8With lenientDecode ln
hercules-ci-agent/Hercules/Agent/Nix.hs view
@@ -1,8 +1,13 @@ module Hercules.Agent.Nix where +import Control.Monad.Trans.Maybe+import qualified Data.ByteString as BS+import qualified Data.Text as T import Hercules.Agent.Env as Agent.Env+import Hercules.Agent.EnvironmentInfo (getNixInfo, nixNetrcFile) import Hercules.Agent.Nix.Env as Nix.Env import Protolude+import System.Directory (doesFileExist) import System.Process (readProcess) import qualified System.Process @@ -42,3 +47,17 @@ nixProc exe opts args = do   extraOpts <- getExtraOptionArguments   pure $ System.Process.proc (toS exe) (map toS (opts <> extraOpts <> ["--"] <> args))++getNetrcLines :: App [Text]+getNetrcLines = liftIO $ do+  info <- getNixInfo+  let fm = toS <$> nixNetrcFile info+  fmap fold <$> runMaybeT $ do+    f <- MaybeT $ pure fm+    exs <- lift $ doesFileExist f+    guard exs+    bs <- liftIO $ BS.readFile f+    pure $+      bs+        & decodeUtf8+        & T.lines
hercules-ci-agent/Hercules/Agent/Nix/Env.hs view
@@ -2,7 +2,6 @@  import Protolude -data Env-  = Env-      { extraOptions :: [(Text, Text)]-      }+data Env = Env+  { extraOptions :: [(Text, Text)]+  }
hercules-ci-agent/Hercules/Agent/Nix/Init.hs view
@@ -28,6 +28,7 @@     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 = []-    }+  pure+    Env+      { extraOptions = []+      }
hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs view
@@ -1,7 +1,5 @@ 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)@@ -9,11 +7,12 @@   ( DerivationInfo (DerivationInfo),   ) import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.DerivationInfo as DerivationInfo+import Hercules.CNix import Protolude  retrieveDerivationInfo ::   MonadIO m =>-  Ptr (Ref NixStore) ->+  Store ->   DerivationInfo.DerivationPathText ->   m DerivationInfo retrieveDerivationInfo store drvPath = liftIO $ do@@ -30,22 +29,23 @@   let requiredSystemFeatures = maybe [] splitFeatures $ M.lookup "requiredSystemFeatures" env       splitFeatures = filter (not . T.null) . T.split (== ' ') . decode       decode = decodeUtf8With lenientDecode-  pure $ DerivationInfo-    { derivationPath = drvPath,-      platform = decodeUtf8With lenientDecode platform,-      requiredSystemFeatures = requiredSystemFeatures,-      inputDerivations = inputDrvPaths & map (\(i, os) -> (decode i, map decode os)) & M.fromList,-      inputSources = map decode sourcePaths,-      outputs =-        outputs-          & map-            ( \output ->-                ( decode $ derivationOutputName output,-                  DerivationInfo.OutputInfo-                    { DerivationInfo.path = decode $ derivationOutputPath output,-                      DerivationInfo.isFixed = derivationOutputHashAlgo output /= ""-                    }-                )-            )-          & M.fromList-    }+  pure $+    DerivationInfo+      { derivationPath = drvPath,+        platform = decode platform,+        requiredSystemFeatures = requiredSystemFeatures,+        inputDerivations = inputDrvPaths & map (bimap decode (map decode)) & M.fromList,+        inputSources = map decode sourcePaths,+        outputs =+          outputs+            & map+              ( \output ->+                  ( decode $ derivationOutputName output,+                    DerivationInfo.OutputInfo+                      { DerivationInfo.path = decode $ derivationOutputPath output,+                        DerivationInfo.isFixed = derivationOutputHashAlgo output /= ""+                      }+                  )+              )+            & M.fromList+      }
hercules-ci-agent/Hercules/Agent/Options.hs view
@@ -10,11 +10,10 @@ import Options.Applicative import Protolude hiding (option) -data Options-  = Options-      { configFile :: ConfigPath,-        mode :: Mode-      }+data Options = Options+  { configFile :: ConfigPath,+    mode :: Mode+  }  parseOptions :: Parser Options parseOptions =
hercules-ci-agent/Hercules/Agent/ServiceInfo.hs view
@@ -6,27 +6,28 @@ import Hercules.Error (escalate) import Network.URI import Protolude-import qualified Servant.Client+import qualified Servant.Client.Streaming -data Env-  = Env-      { agentSocketBaseURL :: URI,-        bulkSocketBaseURL :: URI-      }+data Env = Env+  { agentSocketBaseURL :: URI,+    bulkSocketBaseURL :: URI+  } -newEnv :: Servant.Client.ClientEnv -> IO Env+newEnv :: Servant.Client.Streaming.ClientEnv -> IO Env newEnv clientEnv = do-  serviceInfo <- escalate =<< Servant.Client.runClientM (API.LifeCycle.getServiceInfo Client.lifeCycleClient) clientEnv+  serviceInfo <- escalate =<< Servant.Client.Streaming.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+        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_-    }+  pure+    Env+      { agentSocketBaseURL = agentSocketBaseURL_,+        bulkSocketBaseURL = bulkSocketBaseURL_+      }
hercules-ci-agent/Hercules/Agent/Token.hs view
@@ -2,7 +2,7 @@  import Control.Lens ((^?)) import qualified Data.Aeson as Aeson-import Data.Aeson.Lens (_String, key)+import Data.Aeson.Lens (key, _String) import qualified Data.ByteString.Base64.Lazy as B64L import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T@@ -50,26 +50,27 @@     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: " <> logStr (displayException e)-          pure sessKey-    safeLiftedHandle handler $ do-      cjt <- getClusterJoinTokenId-      logLocM DebugS $ "Found clusterJoinTokenId " <> logStr cjt-      scjt <- getSessionClusterJoinTokenId sessKey-      logLocM DebugS $ "Found sessionClusterJoinTokenId " <> logStr 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+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: " <> logStr (displayException e)+            pure sessKey+      safeLiftedHandle handler $ do+        cjt <- getClusterJoinTokenId+        logLocM DebugS $ "Found clusterJoinTokenId " <> logStr cjt+        scjt <- getSessionClusterJoinTokenId sessKey+        logLocM DebugS $ "Found sessionClusterJoinTokenId " <> logStr 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
hercules-ci-agent/Hercules/Agent/WorkerProcess.hs view
@@ -30,11 +30,10 @@ import System.Timeout (timeout) import Prelude () -data WorkerException-  = WorkerException-      { originalException :: SomeException,-        exitStatus :: Maybe ExitCode-      }+data WorkerException = WorkerException+  { originalException :: SomeException,+    exitStatus :: Maybe ExitCode+  }   deriving (Show, Typeable)  instance Exception WorkerException where@@ -44,10 +43,9 @@         Nothing -> ""         Just s -> " (worker: " <> show s <> ")" -data WorkerEnvSettings-  = WorkerEnvSettings-      { nixPath :: [EvaluateTask.NixPathElement (EvaluateTask.SubPathOf FilePath)]-      }+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]@@ -84,40 +82,41 @@             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+  liftIO $+    withCreateProcess createProcessSpec $ \mIn mOut mErr processHandle -> do+      (inHandle, outHandle, errHandle) <-+        case (,,) <$> mIn <*> mOut <*> mErr of+          Just x -> pure x+          Nothing ->+            throwIO $+              mkIOError+                illegalOperationErrorType+                "Process did not return all handles"+                Nothing -- no handle+                Nothing -- no path+      pidMaybe <- liftIO $ getPid processHandle+      let pid = maybe 0 fromIntegral pidMaybe+      let stderrPiper =+            liftIO $+              runConduit+                (sourceHandle errHandle .| linesUnboundedAsciiC .| awaitForever (liftIO . unlift . stderrLineHandler pid))+      let eventConduit = sourceHandle outHandle .| conduitDecode+          commandConduit =+            sourceChan commandChan+              .| conduitEncode+              .| concatMapC (\x -> [Chunk x, Flush])+              .| handleC handleEPIPE (sinkHandleFlush inHandle)+          handleEPIPE e | ioeGetErrorType e == ResourceVanished = pure ()+          handleEPIPE e = throwIO e+      let cmdThread = runConduit commandConduit `finally` hClose outHandle+          eventThread = unlift $ conduitToCallbacks eventConduit eventHandler+      -- plain forkIO so it can process all of stderr in case of an exception+      void $ forkIO stderrPiper+      withAsync (waitForProcess processHandle) $ \exitAsync -> do+        withAsync cmdThread $ \_ -> do+          eventThread+            `Safe.catch` \e -> do+              let oneSecond = 1000 * 1000+              maybeStatus <- timeout (5 * oneSecond) (wait exitAsync)+              throwIO $ WorkerException e maybeStatus+          wait exitAsync
− src-cnix/CNix.hs 
@@ -1,263 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module CNix-  ( module CNix,-    RawValue,-    rawValueType,-    module CNix.Internal.Store,-    module CNix.Internal.Typed,-    type NixStore,-    type EvalState,-    type Ref,-    type SecretKey,-  )-where---- TODO: No more Ptr EvalState--- TODO: No more NixStore when EvalState is already there--- TODO: Map Nix-specific C++ exceptions to a CNix exception type-import CNix.Internal.Context-import CNix.Internal.Raw-import CNix.Internal.Store-import CNix.Internal.Typed-import Conduit-import qualified Data.Map as M-import qualified Foreign.C.String-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C-import Protolude hiding (evalState, throwIO)--newtype Bindings = Bindings (Ptr Bindings')--C.context context--C.include "<stdio.h>"--C.include "<cstring>"--C.include "<math.h>"--C.include "<nix/config.h>"--C.include "<nix/shared.hh>"--C.include "<nix/eval.hh>"--C.include "<nix/eval-inline.hh>"--C.include "<nix/store-api.hh>"--C.include "<nix/common-eval-args.hh>"--C.include "<nix/get-drvs.hh>"--C.include "<nix/derivations.hh>"--C.include "<nix/affinity.hh>"--C.include "<nix/globals.hh>"--C.include "hercules-aliases.h"--C.include "<gc/gc.h>"--C.include "<gc/gc_cpp.h>"--C.include "<gc/gc_allocator.h>"--C.using "namespace nix"--C.verbatim "\nGC_API void GC_CALL GC_throw_bad_alloc() { throw std::bad_alloc(); }\n"--init :: IO ()-init =-  void-    [C.throwBlock| void {-      nix::initNix();-      nix::initGC();-    } |]--setTalkative :: IO ()-setTalkative =-  [C.throwBlock| void {-    nix::verbosity = nix::lvlTalkative;-  } |]--setDebug :: IO ()-setDebug =-  [C.throwBlock| void {-    nix::verbosity = nix::lvlVomit;-  } |]--setGlobalOption :: Text -> Text -> IO ()-setGlobalOption opt value = do-  let optionStr = encodeUtf8 opt-      valueStr = encodeUtf8 value-  [C.throwBlock| void {-    globalConfig.set($bs-cstr:optionStr, $bs-cstr:valueStr);-  }|]--setOption :: Text -> Text -> IO ()-setOption opt value = do-  let optionStr = encodeUtf8 opt-      valueStr = encodeUtf8 value-  [C.throwBlock| void {-    settings.set($bs-cstr:optionStr, $bs-cstr:valueStr);-  }|]--logInfo :: Text -> IO ()-logInfo t = do-  let bstr = encodeUtf8 t-  [C.throwBlock| void {-    printInfo($bs-cstr:bstr);-  }|]--mkBindings :: Ptr Bindings' -> IO Bindings-mkBindings p = pure $ Bindings p--withEvalState ::-  MonadResource m =>-  Ptr (Ref NixStore) ->-  (Ptr EvalState -> ConduitT i o m r) ->-  ConduitT i o m r-withEvalState store =-  bracketP-    ( liftIO $-        [C.throwBlock| EvalState* {-          Strings searchPaths;-          return new EvalState(searchPaths, *$(refStore* store));-        } |]-    )-    (\x -> liftIO $ [C.throwBlock| void { delete $(EvalState* x); } |])--evalFile :: Ptr EvalState -> FilePath -> IO RawValue-evalFile evalState filename = do-  filename' <- Foreign.C.String.newCString filename-  mkRawValue-    =<< [C.throwBlock| Value* {-      Value value;-      $(EvalState *evalState)->evalFile($(const char *filename'), value);-      return new (NoGC) Value(value);-    }|]---- leaks-newStrings :: IO (Ptr Strings)-newStrings = [C.exp| Strings* { new (NoGC) Strings() }|]--appendString :: Ptr Strings -> ByteString -> IO ()-appendString ss s =-  [C.block| void {-    $(Strings *ss)->push_back($bs-ptr:s);-  }|]--evalArgs :: Ptr EvalState -> [ByteString] -> IO Bindings-evalArgs evalState args = do-  argsStrings <- newStrings-  forM_ args $ appendString argsStrings-  mkBindings-    =<< [C.throwBlock| Bindings * {-      Strings *args = $(Strings *argsStrings);-      struct MixEvalArgs evalArgs;-      Bindings *autoArgs;-      EvalState &state = *$(EvalState *evalState);--      evalArgs.parseCmdline(*args);-      autoArgs = evalArgs.getAutoArgs(state);-      if (autoArgs == NULL) {-        //cerr << "Could not evaluate automatic arguments" << endl;-        abort(); // FIXME-      }-      return autoArgs;--      // catch (EvalError & e) {-      // catch (Error & e) {-      // catch (std::exception & e) {--    }|]--autoCallFunction :: Ptr EvalState -> RawValue -> Bindings -> IO RawValue-autoCallFunction evalState (RawValue fun) (Bindings autoArgs) =-  mkRawValue-    =<< [C.throwBlock| Value* {-          Value result;-          $(EvalState *evalState)->autoCallFunction(-                  *$(Bindings *autoArgs),-                  *$(Value *fun),-                  result);-          return new (NoGC) Value (result);-        }|]--isDerivation :: Ptr EvalState -> RawValue -> IO Bool-isDerivation evalState (RawValue v) =-  (0 /=)-    <$> [C.throwBlock| int {-          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }-          return $(EvalState *evalState)->isDerivation(*$(Value *v));-        }|]--isFunctor :: Ptr EvalState -> RawValue -> IO Bool-isFunctor evalState (RawValue v) =-  (0 /=)-    <$> [C.throwBlock| int {-          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }-          return $(EvalState *evalState)->isFunctor(*$(Value *v));-        }|]--getRecurseForDerivations :: Ptr EvalState -> Value NixAttrs -> IO Bool-getRecurseForDerivations evalState (Value (RawValue v)) =-  (0 /=)-    <$> [C.throwBlock| int {-          Value *v = $(Value *v);-          EvalState *evalState = $(EvalState *evalState);-          Symbol rfd = evalState->symbols.create("recurseForDerivations");-          Bindings::iterator iter = v->attrs->find(rfd);-          if (iter == v->attrs->end()) {-            return 0;-          } else {-            evalState->forceValue(*iter->value);-            if (iter->value->type == ValueType::tBool) {-              return iter->value->boolean ? 1 : 0;-            } else {-              // They can be empty attrsets???-              // Observed in nixpkgs master 67e2de195a4aa0a50ffb1e1ba0b4fb531dca67dc-              return 1;-            }-          }-        } |]--getAttrBindings :: Value NixAttrs -> IO Bindings-getAttrBindings (Value (RawValue v)) = mkBindings =<< [C.exp| Bindings *{ $(Value *v)->attrs } |]--getAttrs :: Value NixAttrs -> IO (Map ByteString RawValue)-getAttrs (Value (RawValue v)) = do-  begin <- [C.exp| Attr *{ $(Value *v)->attrs->begin() }|]-  end <- [C.exp| Attr *{ $(Value *v)->attrs->end() }|]-  let gather :: Map ByteString RawValue -> Ptr Attr' -> IO (Map ByteString RawValue)-      gather acc i | i == end = pure acc-      gather acc i-        | otherwise =-          do-            name <- unsafeMallocBS [C.exp| const char *{ strdup(static_cast<std::string>($(Attr *i)->name).c_str()) } |]-            value <- mkRawValue =<< [C.exp| Value *{ new (NoGC) Value(*$(Attr *i)->value) } |]-            let acc' = M.insert name value acc-            seq acc' pass-            gather acc' =<< [C.exp| Attr *{ &$(Attr *i)[1] }|]-  gather mempty begin--getDrvFile :: MonadIO m => Ptr EvalState -> RawValue -> m ByteString-getDrvFile evalState (RawValue v) =-  unsafeMallocBS-    [C.throwBlock| const char *{-      EvalState &state = *$(EvalState *evalState);-      auto drvInfo = getDerivation(state, *$(Value *v), false);-      if (!drvInfo)-        throw EvalError("Not a valid derivation");--      std::string drvPath = drvInfo->queryDrvPath();--      // write it (?)-      auto drv = state.store->derivationFromPath(drvPath);--      return strdup(drvPath.c_str());-    }|]
− src-cnix/CNix/Internal/Context.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module CNix.Internal.Context-  ( module CNix.Internal.Context,-    NixStore,-  )-where--import Cachix.Client.Store.Context (NixStore)-import Data.ByteString.Unsafe (unsafePackMallocCString)-import qualified Data.Map as M-import qualified Foreign.C.String-import Hercules.Agent.StoreFFI (ExceptionPtr)-import qualified Language.C.Inline.Context as C-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Types as C-import Protolude--data EvalState--data Strings--data Ref a--data Bindings'--data Value'--data Attr'--data HerculesStore--data Derivation--data Fields--data HerculesLoggerEntry--data LogEntryQueue--data StringsIterator--data DerivationOutputsIterator--data DerivationInputsIterator--data StringPairsIterator--data StringPairs--data SecretKey--context :: C.Context-context =-  C.cppCtx <> C.fptrCtx-    <> C.bsCtx-      { C.ctxTypesTable =-          M.singleton (C.TypeName "refStore") [t|Ref NixStore|]-            <> M.singleton (C.TypeName "EvalState") [t|EvalState|]-            <> M.singleton (C.TypeName "Bindings") [t|Bindings'|]-            <> M.singleton (C.TypeName "Value") [t|Value'|]-            <> M.singleton (C.TypeName "Attr") [t|Attr'|]-            <> M.singleton (C.TypeName "Strings") [t|Strings|]-            <> M.singleton (C.TypeName "StringsIterator") [t|StringsIterator|]-            <> M.singleton (C.TypeName "StringPairs") [t|StringPairs|]-            <> M.singleton (C.TypeName "StringPairsIterator") [t|StringPairsIterator|]-            <> M.singleton (C.TypeName "refHerculesStore") [t|Ref HerculesStore|]-            <> M.singleton (C.TypeName "Derivation") [t|Derivation|]-            <> M.singleton (C.TypeName "LoggerFields") [t|Fields|]-            <> M.singleton (C.TypeName "HerculesLoggerEntry") [t|HerculesLoggerEntry|]-            <> M.singleton (C.TypeName "LogEntryQueue") [t|LogEntryQueue|]-            <> M.singleton (C.TypeName "DerivationOutputsIterator") [t|DerivationOutputsIterator|]-            <> M.singleton (C.TypeName "DerivationInputsIterator") [t|DerivationInputsIterator|]-            <> M.singleton (C.TypeName "exception_ptr") [t|ExceptionPtr|]-            <> M.singleton (C.TypeName "SecretKey") [t|SecretKey|]-      }--unsafeMallocBS :: MonadIO m => IO Foreign.C.String.CString -> m ByteString-unsafeMallocBS m = liftIO (unsafePackMallocCString =<< m)
− src-cnix/CNix/Internal/Raw.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module CNix.Internal.Raw where--import CNix.Internal.Context-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C-import Protolude hiding (evalState)-import Prelude ()--C.context context--C.include "<nix/config.h>"--C.include "<nix/eval.hh>"--C.include "<nix/eval-inline.hh>"--C.include "hercules-aliases.h"--C.include "<gc/gc.h>"--C.include "<gc/gc_cpp.h>"--C.include "<gc/gc_allocator.h>"--C.using "namespace nix"--newtype RawValue = RawValue (Ptr Value')---- | Takes ownership of the value.-mkRawValue :: Ptr Value' -> IO RawValue-mkRawValue p = pure $ RawValue p---- | Similar to Nix's Value->type but conflates the List variations-data RawValueType-  = Int-  | Bool-  | String-  | Path-  | Null-  | Attrs-  | List-  | Thunk-  | App-  | Lambda-  | Blackhole-  | PrimOp-  | PrimOpApp-  | External-  | Float-  | Other-  deriving (Generic, Show, Eq, Ord)---- | You may need to 'forceValue' first.-rawValueType :: RawValue -> IO RawValueType-rawValueType (RawValue v) =-  f-    <$> [C.block| int {-      switch ($(Value* v)->type) {-        case tInt:         return 1;-        case tBool:        return 2;-        case tString:      return 3;-        case tPath:        return 4;-        case tNull:        return 5;-        case tAttrs:       return 6;-        case tList1:       return 7;-        case tList2:       return 8;-        case tListN:       return 9;-        case tThunk:       return 10;-        case tApp:         return 11;-        case tLambda:      return 12;-        case tBlackhole:   return 13;-        case tPrimOp:      return 14;-        case tPrimOpApp:   return 15;-        case tExternal:    return 16;-        case tFloat:       return 17;-        default: return 0;-      }-    }|]-  where-    f 1 = Int-    f 2 = Bool-    f 3 = String-    f 4 = Path-    f 5 = Null-    f 6 = Attrs-    f 7 = List-    f 8 = List-    f 9 = List-    f 10 = Thunk-    f 11 = App-    f 12 = Lambda-    f 13 = Blackhole-    f 14 = PrimOp-    f 15 = PrimOpApp-    f 16 = External-    f 17 = Float-    f _ = Other--forceValue :: Exception a => Ptr EvalState -> RawValue -> IO (Either a ())-forceValue evalState (RawValue v) =-  try-    [C.catchBlock|  {-      Value *v = $(Value *v);-      if (v == NULL) throw std::invalid_argument("forceValue value must be non-null");-      $(EvalState *evalState)->forceValue(*v);-    }|]
− src-cnix/CNix/Internal/Store.hs 
@@ -1,415 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module CNix.Internal.Store-  ( module CNix.Internal.Store,-    HerculesStore,-  )-where--import CNix.Internal.Context-import Control.Exception-import Control.Monad.IO.Unlift-import qualified Data.ByteString.Unsafe as BS-import Data.Coerce-import qualified Data.Map as M-import Foreign.C.String (withCString)-import Foreign.ForeignPtr-import Foreign.StablePtr-import Hercules.Agent.StoreFFI-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C-import Protolude-import System.IO.Unsafe (unsafePerformIO)-import Prelude ()--C.context context--C.include "<cstring>"--C.include "<nix/config.h>"--C.include "<nix/shared.hh>"--C.include "<nix/store-api.hh>"--C.include "<nix/get-drvs.hh>"--C.include "<nix/derivations.hh>"--C.include "<nix/affinity.hh>"--C.include "<nix/globals.hh>"--C.include "hercules-aliases.h"--C.using "namespace nix"--withStore :: MonadUnliftIO m => (Ptr (Ref NixStore) -> m a) -> m a-withStore m = do-  UnliftIO ul <- askUnliftIO-  liftIO $ withStore' $ \a -> ul (m a)--withStore' ::-  (Ptr (Ref NixStore) -> IO r) ->-  IO r-withStore' =-  bracket-    ( liftIO $-        [C.throwBlock| refStore* {-            refStore s = openStore();-            return new refStore(s);-          } |]-    )-    (\x -> liftIO $ [C.exp| void { delete $(refStore* x) } |])--withStoreFromURI ::-  MonadUnliftIO m =>-  Text ->-  (Ptr (Ref NixStore) -> m r) ->-  m r-withStoreFromURI storeURIText f = do-  let storeURI = encodeUtf8 storeURIText-  (UnliftIO unlift) <- askUnliftIO-  liftIO $-    bracket-      [C.throwBlock| refStore* {-        refStore s = openStore($bs-cstr:storeURI);-        return new refStore(s);-      }|]-      (\x -> [C.exp| void { delete $(refStore* x) } |])-      (unlift . f)--storeUri :: MonadIO m => Ptr (Ref NixStore) -> m ByteString-storeUri store =-  unsafeMallocBS-    [C.block| const char* {-       std::string uri = (*$(refStore* store))->getUri();-       return strdup(uri.c_str());-     } |]--ensurePath :: Ptr (Ref NixStore) -> ByteString -> IO ()-ensurePath store path =-  [C.throwBlock| void {-    (*$(refStore* store))->ensurePath(std::string($bs-ptr:path, $bs-len:path));-  } |]--clearPathInfoCache :: Ptr (Ref NixStore) -> IO ()-clearPathInfoCache store =-  [C.throwBlock| void {-    (*$(refStore* store))->clearPathInfoCache();-  } |]--clearSubstituterCaches :: IO ()-clearSubstituterCaches =-  [C.throwBlock| void {-    auto subs = nix::getDefaultSubstituters();-    for (auto sub : subs) {-      sub->clearPathInfoCache();-    }-  } |]--buildPath :: Ptr (Ref NixStore) -> ByteString -> IO ()-buildPath store path =-  [C.throwBlock| void {-    PathSet ps({std::string($bs-ptr:path, $bs-len:path)});-    (*$(refStore* store))->buildPaths(ps);-   } |]--getDerivation :: Ptr (Ref NixStore) -> ByteString -> IO (ForeignPtr Derivation)-getDerivation store path = do-  ptr <--    [C.throwBlock| Derivation *{-      return new Derivation(-          (*$(refStore* store))->derivationFromPath(std::string($bs-ptr:path, $bs-len:path))-        );-    } |]-  newForeignPtr finalizeDerivation ptr---- Useful for testingg-getDerivationFromFile :: ByteString -> IO (ForeignPtr Derivation)-getDerivationFromFile path = do-  ptr <--    [C.throwBlock| Derivation *{-      return new Derivation(-          readDerivation(std::string($bs-ptr:path, $bs-len:path))-        );-    } |]-  newForeignPtr finalizeDerivation ptr--finalizeDerivation :: FinalizerPtr Derivation-{-# NOINLINE finalizeDerivation #-}-finalizeDerivation =-  unsafePerformIO-    [C.exp|-    void (*)(Derivation *) {-      [](Derivation *v) {-        delete v;-      }-    } |]---- | Throws when missing-getDerivationOutputPath :: ForeignPtr Derivation -> ByteString -> IO ByteString-getDerivationOutputPath fd outputName = withForeignPtr fd $ \d ->-  [C.throwBlock|-    const char *{-      std::string outputName($bs-ptr:outputName, $bs-len:outputName);-      Derivation *d = $(Derivation *d);-      return strdup(d->outputs.at(outputName).path.c_str());-    }-  |]-    >>= BS.unsafePackMallocCString--data DerivationOutput-  = DerivationOutput-      { derivationOutputName :: !ByteString,-        derivationOutputPath :: !ByteString,-        derivationOutputHashAlgo :: !ByteString,-        derivationOutputHash :: !ByteString-      }--getDerivationOutputs :: ForeignPtr Derivation -> IO [DerivationOutput]-getDerivationOutputs derivation =-  bracket-    [C.exp| DerivationOutputsIterator* {-      new DerivationOutputsIterator($fptr-ptr:(Derivation *derivation)->outputs.begin())-    }|]-    deleteDerivationOutputsIterator-    $ \i -> fix $ \continue -> do-      isEnd <- (0 /=) <$> [C.exp| bool { *$(DerivationOutputsIterator *i) == $fptr-ptr:(Derivation *derivation)->outputs.end() }|]-      if isEnd-        then pure []-        else do-          name <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->first.c_str()) }|] >>= BS.unsafePackMallocCString-          path <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.path.c_str()) }|] >>= BS.unsafePackMallocCString-          hash_ <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.hash.c_str()) }|] >>= BS.unsafePackMallocCString-          hashAlgo <- [C.exp| const char*{ strdup((*$(DerivationOutputsIterator *i))->second.hashAlgo.c_str()) }|] >>= BS.unsafePackMallocCString-          [C.block| void { (*$(DerivationOutputsIterator *i))++; }|]-          (DerivationOutput name path hashAlgo hash_ :) <$> continue--deleteDerivationOutputsIterator :: Ptr DerivationOutputsIterator -> IO ()-deleteDerivationOutputsIterator a = [C.block| void { delete $(DerivationOutputsIterator *a); }|]--getDerivationPlatform :: ForeignPtr Derivation -> IO ByteString-getDerivationPlatform derivation =-  unsafeMallocBS-    [C.exp| const char* {-       strdup($fptr-ptr:(Derivation *derivation)->platform.c_str())-     } |]--getDerivationSources :: ForeignPtr Derivation -> IO [ByteString]-getDerivationSources derivation =-  bracket-    [C.throwBlock| Strings* {-      Strings *r = new Strings();-      for (auto i : $fptr-ptr:(Derivation *derivation)->inputSrcs) {-        r->push_back(i);-      }-      return r;-    }|]-    deleteStrings-    toByteStrings--getDerivationInputs :: ForeignPtr Derivation -> IO [(ByteString, [ByteString])]-getDerivationInputs derivation =-  bracket-    [C.exp| DerivationInputsIterator* {-      new DerivationInputsIterator($fptr-ptr:(Derivation *derivation)->inputDrvs.begin())-    }|]-    deleteDerivationInputsIterator-    $ \i -> fix $ \continue -> do-      isEnd <- (0 /=) <$> [C.exp| bool { *$(DerivationInputsIterator *i) == $fptr-ptr:(Derivation *derivation)->inputDrvs.end() }|]-      if isEnd-        then pure []-        else do-          name <- [C.exp| const char*{ strdup((*$(DerivationInputsIterator *i))->first.c_str()) }|] >>= BS.unsafePackMallocCString-          outs <--            bracket-              [C.block| Strings*{ -                Strings *r = new Strings();-                for (auto i : (*$(DerivationInputsIterator *i))->second) {-                  r->push_back(i);-                }-                return r;-              }|]-              deleteStrings-              toByteStrings-          [C.block| void { (*$(DerivationInputsIterator *i))++; }|]-          ((name, outs) :) <$> continue--deleteDerivationInputsIterator :: Ptr DerivationInputsIterator -> IO ()-deleteDerivationInputsIterator a = [C.block| void { delete $(DerivationInputsIterator *a); }|]--getDerivationEnv :: ForeignPtr Derivation -> IO (Map ByteString ByteString)-getDerivationEnv derivation =-  [C.exp| StringPairs* { &($fptr-ptr:(Derivation *derivation)->env) }|]-    >>= toByteStringMap--getDerivationOutputNames :: ForeignPtr Derivation -> IO [ByteString]-getDerivationOutputNames derivation =-  bracket-    [C.throwBlock| Strings* {-      Strings *r = new Strings();-      for (auto i : $fptr-ptr:(Derivation *derivation)->outputs) {-        r->push_back(i.first);-      }-      return r;-    }|]-    deleteStrings-    toByteStrings--deleteStringPairs :: Ptr StringPairs -> IO ()-deleteStringPairs s = [C.block| void { delete $(StringPairs *s); }|]--deleteStrings :: Ptr Strings -> IO ()-deleteStrings s = [C.block| void { delete $(Strings *s); }|]--finalizeStrings :: FinalizerPtr Strings-{-# NOINLINE finalizeStrings #-}-finalizeStrings =-  unsafePerformIO-    [C.exp|-    void (*)(Strings *) {-      [](Strings *v) {-        delete v;-      }-    } |]--getStringsLength :: Ptr Strings -> IO C.CSize-getStringsLength strings = [C.exp| size_t { $(Strings *strings)->size() }|]--toByteStrings :: Ptr Strings -> IO [ByteString]-toByteStrings strings = do-  i <- [C.exp| StringsIterator *{ new StringsIterator($(Strings *strings)->begin()) } |]-  fix $ \go -> do-    isEnd <- (0 /=) <$> [C.exp| bool { *$(StringsIterator *i) == $(Strings *strings)->end() }|]-    if isEnd-      then pure []-      else do-        s <- [C.exp| const char*{ strdup((*$(StringsIterator *i))->c_str()) }|]-        bs <- BS.unsafePackMallocCString s-        [C.block| void { (*$(StringsIterator *i))++; }|]-        (bs :) <$> go--toByteStringMap :: Ptr StringPairs -> IO (Map ByteString ByteString)-toByteStringMap strings = M.fromList <$> do-  i <- [C.exp| StringPairsIterator *{ new StringPairsIterator($(StringPairs *strings)->begin()) } |]-  fix $ \go -> do-    isEnd <- (0 /=) <$> [C.exp| bool { *$(StringPairsIterator *i) == $(StringPairs *strings)->end() }|]-    if isEnd-      then pure []-      else do-        k <- [C.exp| const char*{ strdup((*$(StringPairsIterator *i))->first.c_str()) }|]-        v <- [C.exp| const char*{ strdup((*$(StringPairsIterator *i))->second.c_str()) }|]-        bk <- BS.unsafePackMallocCString k-        bv <- BS.unsafePackMallocCString v-        [C.block| void { (*$(StringPairsIterator *i))++; }|]-        ((bk, bv) :) <$> go--withStrings :: (Ptr Strings -> IO a) -> IO a-withStrings =-  bracket-    [C.exp| Strings *{ new Strings() }|]-    (\sp -> [C.block| void { delete $(Strings *sp); }|])--pushString :: Ptr Strings -> ByteString -> IO ()-pushString strings s =-  [C.block| void { $(Strings *strings)->push_back($bs-cstr:s); }|]--copyClosure :: Ptr (Ref NixStore) -> Ptr (Ref NixStore) -> [ByteString] -> IO ()-copyClosure src dest paths = do-  withStrings $ \pathStrings -> do-    paths & traverse_ (pushString pathStrings)-    [C.throwBlock| void {-      StringSet pathSet;-      for (auto path : *$(Strings *pathStrings)) {-        pathSet.insert(path);-      }-      nix::copyClosure(*$(refStore* src), *$(refStore* dest), pathSet);-    }|]--parseSecretKey :: ByteString -> IO (ForeignPtr SecretKey)-parseSecretKey bs =-  [C.throwBlock| SecretKey* {-    return new SecretKey($bs-cstr:bs);-  }|]-    >>= newForeignPtr finalizeSecretKey--finalizeSecretKey :: FinalizerPtr SecretKey-{-# NOINLINE finalizeSecretKey #-}-finalizeSecretKey =-  unsafePerformIO-    [C.exp|-    void (*)(SecretKey *) {-      [](SecretKey *v) {-        delete v;-      }-    } |]--signPath ::-  Ptr (Ref NixStore) ->-  -- | Secret signing key-  Ptr SecretKey ->-  -- | Store path-  ByteString ->-  -- | False if the signature was already present, True if the signature was added-  IO Bool-signPath store secretKey path = (== 1) <$> do-  [C.throwBlock| int {-    nix::ref<nix::Store> store = *$(refStore *store);-    std::string storePath($bs-cstr:path);-    auto currentInfo = store->queryPathInfo(storePath);--    auto info2(*currentInfo);-    info2.sigs.clear();-    info2.sign(*$(SecretKey *secretKey));-    assert(!info2.sigs.empty());-    auto sig = *info2.sigs.begin();--    if (currentInfo->sigs.count(sig)) {-      return 0;-    } else {-      store->addSignatures(storePath, info2.sigs);-      return 1;-    }-  }|]------- Hercules ------withHerculesStore ::-  Ptr (Ref NixStore) ->-  (Ptr (Ref HerculesStore) -> IO a) ->-  IO a-withHerculesStore wrappedStore =-  bracket-    ( liftIO $-        [C.block| refHerculesStore* {-          refStore &s = *$(refStore *wrappedStore);-          refHerculesStore hs(new HerculesStore({}, s));-          return new refHerculesStore(hs);-        } |]-    )-    (\x -> liftIO $ [C.exp| void { delete $(refHerculesStore* x) } |])--nixStore :: Ptr (Ref HerculesStore) -> Ptr (Ref NixStore)-nixStore = coerce--printDiagnostics :: Ptr (Ref HerculesStore) -> IO ()-printDiagnostics s =-  [C.throwBlock| void{-    (*$(refHerculesStore* s))->printDiagnostics();-  }|]---- TODO catch pure exceptions from displayException-setBuilderCallback :: Ptr (Ref HerculesStore) -> (ByteString -> IO ()) -> IO ()-setBuilderCallback s callback = do-  p <--    mkBuilderCallback $ \cstr exceptionToThrowPtr ->-      Control.Exception.catch (BS.unsafePackMallocCString cstr >>= callback) $ \e ->-        withCString (displayException (e :: SomeException)) $ \renderedException -> do-          stablePtr <- castStablePtrToPtr <$> newStablePtr e-          [C.block| void {-            (*$(exception_ptr *exceptionToThrowPtr)) = std::make_exception_ptr(HaskellException(std::string($(const char* renderedException)), $(void* stablePtr)));-          }|]-  [C.throwBlock| void {-    (*$(refHerculesStore* s))->setBuilderCallback($(void (*p)(const char *, exception_ptr *) ));-  }|]
− src-cnix/CNix/Internal/Typed.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}--module CNix.Internal.Typed where--import CNix.Internal.Context-import CNix.Internal.Raw-import Protolude hiding-  ( evalState,-    throwIO,-  )-import Prelude (userError)---- | Runtime-Typed Value. This implies that it has been forced,--- because otherwise the type would not be known.-newtype Value a = Value {rtValue :: RawValue}--data NixInt--data NixFloat--data NixString--data NixPath--data NixAttrs--data NixFunction--data NixList--data NixPrimOp--data NixPrimOpApp--data NixExternal---- TODO: actually encapsulate the constructor-unsafeAssertType :: RawValue -> Value a-unsafeAssertType = Value---- This is useful because you regain exhaustiveness checking.--- Otherwise a bunch of downcast functions might do.-data Match-  = IsInt (Value NixInt)-  | IsBool (Value Bool)-  | IsString (Value NixString)-  | IsPath (Value NixPath)-  | IsNull (Value ())-  | IsAttrs (Value NixAttrs)-  | IsList (Value NixList)-  | IsFunction (Value NixFunction)-  | IsExternal (Value NixExternal)-  | IsFloat (Value NixFloat)---- FIXME: errors don't provide any clue here-match :: Ptr EvalState -> RawValue -> IO (Either SomeException Match)-match es v = forceValue es v >>= \case-  Left e -> pure (Left e)-  Right _ -> rawValueType v <&> \case-    Int -> pure $ IsInt $ unsafeAssertType v-    Bool -> pure $ IsBool $ unsafeAssertType v-    String -> pure $ IsString $ unsafeAssertType v-    Path -> pure $ IsPath $ unsafeAssertType v-    Null -> pure $ IsNull $ unsafeAssertType v-    Attrs -> pure $ IsAttrs $ unsafeAssertType v-    List -> pure $ IsList $ unsafeAssertType v-    Thunk -> Left $ SomeException $ userError "Could not force Nix thunk" -- FIXME: custom exception?-    App -> Left $ SomeException $ userError "Could not force Nix thunk (App)"-    Blackhole ->-      Left $ SomeException $ userError "Could not force Nix thunk (Blackhole)"-    Lambda -> pure $ IsFunction $ unsafeAssertType v-    PrimOp -> pure $ IsFunction $ unsafeAssertType v-    PrimOpApp -> pure $ IsFunction $ unsafeAssertType v-    External -> pure $ IsExternal $ unsafeAssertType v-    Float -> pure $ IsFloat $ unsafeAssertType v-    Other ->-      Left $ SomeException $ userError "Unknown runtime type in Nix value"
− src-internal-ffi/Hercules/Agent/StoreFFI.hs 
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -fobject-code #-}-{-# LANGUAGE CPP #-}--module Hercules.Agent.StoreFFI where--import qualified Foreign.C-import Protolude--type BuilderCallback = Foreign.C.CString -> Ptr ExceptionPtr -> IO ()---- Work around a problem in ghcide with foreign imports.-#ifndef GHCIDE-foreign import ccall "wrapper"-  mkBuilderCallback :: BuilderCallback -> IO (FunPtr BuilderCallback)-#else-mkBuilderCallback :: BuilderCallback -> IO (FunPtr BuilderCallback)-mkBuilderCallback = panic "This is a stub to work around a ghcide issue. Please compile without -DGHCIDE"-#endif--data ExceptionPtr
src/Data/Conduit/Katip/Orphans.hs view
@@ -7,13 +7,11 @@ import Katip  instance Katip m => Katip (ConduitT i o m) where-   getLogEnv = lift getLogEnv    localLogEnv f = transPipe (localLogEnv f)  instance KatipContext m => KatipContext (ConduitT i o m) where-   getKatipContext = lift getKatipContext    getKatipNamespace = lift getKatipNamespace
+ src/Hercules/Agent/NixFile.hs view
@@ -0,0 +1,44 @@+module Hercules.Agent.NixFile+  ( findNixFile,+  )+where++import Protolude+import qualified System.Directory as Dir+import System.FilePath ((</>))++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
src/Hercules/Agent/Producer.hs view
@@ -20,11 +20,10 @@  -- | 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-      }+data Producer p r = Producer+  { producerQueueRead :: STM (Msg p r),+    producerThread :: ThreadId+  }   deriving (Functor)  data ProducerCancelled = ProducerCancelled@@ -164,13 +163,13 @@                   doPerformBatch buf                   beginReading          in beginReading-  liftIO-    $ withAsync+  liftIO $+    withAsync       ( forever $ do           threadDelay maxDelay           atomically $ writeTQueue flushes ()       )-    $ \_flusher -> unlift $ withProducer producer f+      $ \_flusher -> unlift $ withProducer producer f  syncer :: MonadIO m => (Syncing a -> m ()) -> m () syncer writer = do
+ src/Hercules/Agent/Sensitive.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hercules.Agent.Sensitive where++import Data.Binary+import Protolude+import Text.Show++-- | newtype wrapper to avoid leaking sensitive data through Show+newtype Sensitive a = Sensitive {reveal :: a}+  deriving (Generic)+  deriving newtype (Binary, Eq, Ord)+  deriving (Functor, Applicative, Monad) via Identity++-- | @const "<sensitive>"@+instance Show (Sensitive a) where+  show _ = "<sensitive>"++revealContainer :: Functor f => Sensitive (f a) -> f (Sensitive a)+revealContainer (Sensitive fa) = Sensitive <$> fa
src/Hercules/Agent/Socket.hs view
@@ -24,8 +24,8 @@ 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 qualified Hercules.API.Agent.Socket.Frame as 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)@@ -37,25 +37,23 @@ import UnliftIO.Timeout (timeout) import Wuss (runSecureClientWith) -data Socket r w-  = Socket-      { write :: w -> STM (),-        serviceChan :: TChan r,-        sync :: STM (STM ())-      }+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-      }+data SocketConfig ap sp m = SocketConfig+  { makeHello :: m ap,+    checkVersion :: (sp -> m (Either Text ())),+    baseURL :: URI,+    path :: Text,+    token :: ByteString+  }  requiredServiceVersion :: (Int, Int) requiredServiceVersion = (2, 0)@@ -74,15 +72,16 @@         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-        }+      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 ())@@ -136,11 +135,12 @@       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+          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]@@ -221,13 +221,13 @@             -- 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+  forever $+    handle logWarningPause $+      withConnection' socketConfig $+        \conn -> do+          katipAddNamespace "Handshake" do+            handshake conn+          readThread conn `race_` writeThread conn `race_` noAckCleanupThread  msgN :: Frame o a -> Maybe Integer msgN (Frame.Msg {n = n}) = Just n@@ -262,6 +262,7 @@  withTimeout :: (Exception e, MonadIO m, MonadUnliftIO m) => NominalDiffTime -> e -> m a -> m a withTimeout t e _ | t <= 0 = throwIO e-withTimeout t e m = timeout (ceiling $ t * 1_000_000) m >>= \case-  Nothing -> throwIO e-  Just a -> pure a+withTimeout t e m =+  timeout (ceiling $ t * 1_000_000) m >>= \case+    Nothing -> throwIO e+    Just a -> pure a
src/Hercules/Agent/WorkerProtocol/Command.hs view
@@ -5,6 +5,7 @@ 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.Effect as Effect import qualified Hercules.Agent.WorkerProtocol.Command.Eval as Eval import Protolude @@ -12,4 +13,5 @@   = Eval Eval.Eval   | BuildResult BuildResult.BuildResult   | Build Build.Build+  | Effect Effect.Effect   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Command/Build.hs view
@@ -6,11 +6,10 @@ import Hercules.Agent.WorkerProtocol.LogSettings import Protolude -data Build-  = Build-      { drvPath :: Text,-        inputDerivationOutputPaths :: [ByteString],-        logSettings :: LogSettings,-        materializeDerivation :: Bool-      }+data Build = Build+  { drvPath :: Text,+    inputDerivationOutputPaths :: [ByteString],+    logSettings :: LogSettings,+    materializeDerivation :: Bool+  }   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Command/BuildResult.hs view
@@ -7,11 +7,11 @@ import Protolude  data BuildResult = BuildResult Text UUID BuildStatus-  deriving (Generic, Binary, Show, Eq)+  deriving (Generic, Binary, Show, Eq, NFData)  -- | Subset of @DerivationStatus@, with a @Binary@ instance. data BuildStatus   = Success   | Failure   | DependencyFailure-  deriving (Generic, Binary, Show, Eq)+  deriving (Generic, Binary, Show, Eq, NFData)
+ src/Hercules/Agent/WorkerProtocol/Command/Effect.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveAnyClass #-}++module Hercules.Agent.WorkerProtocol.Command.Effect where++import Data.Binary+import Hercules.Agent.Sensitive+import Hercules.Agent.WorkerProtocol.LogSettings+import Protolude++data Effect = Effect+  { drvPath :: Text,+    apiBaseURL :: Text,+    logSettings :: LogSettings,+    inputDerivationOutputPaths :: [ByteString],+    materializeDerivation :: Bool,+    secretsPath :: FilePath,+    token :: Sensitive Text+  }+  deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Command/Eval.hs view
@@ -6,17 +6,16 @@ import Hercules.Agent.WorkerProtocol.LogSettings 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)],-        logSettings :: LogSettings-      }+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)],+    logSettings :: LogSettings+  }   deriving (Generic, Binary, Show, Eq)  data Arg
src/Hercules/Agent/WorkerProtocol/Event.hs view
@@ -17,5 +17,6 @@   | Error Text   | Build Text Text (Maybe UUID)   | BuildResult BuildResult+  | EffectResult Int   | Exception Text   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Event/Attribute.hs view
@@ -6,10 +6,17 @@ import Protolude import Prelude () -data Attribute-  = Attribute-      { path :: [ByteString],-        drv :: ByteString-        -- TODO: metadata-      }+data AttributeType+  = Regular+  | MustFail+  | MayFail+  | DependenciesOnly+  | Effect+  deriving (Generic, Binary, Show, Eq)++data Attribute = Attribute+  { path :: [ByteString],+    drv :: ByteString,+    typ :: AttributeType+  }   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Event/AttributeError.hs view
@@ -6,11 +6,10 @@ import Protolude import Prelude () -data AttributeError-  = AttributeError-      { path :: [ByteString],-        message :: Text,-        errorType :: Maybe Text,-        errorDerivation :: Maybe Text-      }+data AttributeError = AttributeError+  { path :: [ByteString],+    message :: Text,+    errorType :: Maybe Text,+    errorDerivation :: Maybe Text+  }   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/Event/BuildResult.hs view
@@ -10,15 +10,14 @@   | 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-      }+data OutputInfo = OutputInfo+  { -- | e.g. out, dev+    name :: ByteString,+    -- | store path+    path :: ByteString,+    -- | typically sha256:...+    hash :: ByteString,+    -- | nar size in bytes+    size :: Int64+  }   deriving (Generic, Binary, Show, Eq)
src/Hercules/Agent/WorkerProtocol/LogSettings.hs view
@@ -1,23 +1,17 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Hercules.Agent.WorkerProtocol.LogSettings where  import Data.Binary+import Hercules.Agent.Sensitive import Protolude-import Text.Show -data LogSettings-  = LogSettings-      { path :: Text,-        baseURL :: Text,-        token :: Sensitive Text-      }+data LogSettings = LogSettings+  { path :: Text,+    baseURL :: Text,+    token :: Sensitive Text+  }   deriving (Generic, Binary, Show, Eq)---- | newtype wrapper to avoid leaking sensitive data through Show-newtype Sensitive a = Sensitive {reveal :: a}-  deriving (Generic, Binary, Eq, Ord)---- | @const "<sensitive>"@-instance Show (Sensitive a) where-  show _ = "<sensitive>"
+ src/Hercules/Effect.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Effect where++import Control.Monad.Catch (MonadThrow)+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Foreign (ForeignPtr)+import Hercules.Agent.Sensitive (Sensitive (Sensitive, reveal), revealContainer)+import Hercules.CNix.Store (getDerivationArguments, getDerivationBuilder, getDerivationEnv)+import Hercules.CNix.Store.Context (Derivation)+import Hercules.Effect.Container (BindMount (BindMount))+import qualified Hercules.Effect.Container as Container+import Hercules.Error (escalateAs)+import qualified Hercules.Formats.Secret as Formats.Secret+import Katip (KatipContext, Severity (..), logLocM, logStr)+import Protolude+import System.FilePath+import UnliftIO.Directory (createDirectory, createDirectoryIfMissing)++parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text Text)+parseDrvSecretsMap drvEnv =+  case drvEnv & M.lookup "secretsMap" of+    Nothing -> pure mempty+    Just secretsMapText -> case A.eitherDecode (BL.fromStrict secretsMapText) of+      Left _ -> Left "Could not parse secretsMap variable in derivation. It must be a JSON dictionary of strings referencing agent secret names."+      Right r -> Right r++-- | Write secrets to file based on secretsMap value+writeSecrets :: (MonadIO m, KatipContext m) => FilePath -> Map Text Text -> Map Text (Sensitive Formats.Secret.Secret) -> FilePath -> m ()+writeSecrets sourceFile secretsMap extraSecrets destinationDirectory = write . fmap reveal . addExtra =<< gather+  where+    addExtra = flip M.union extraSecrets+    write = liftIO . BS.writeFile (destinationDirectory </> "secrets.json") . BL.toStrict . A.encode+    gather =+      if null secretsMap+        then pure mempty+        else do+          secretsBytes <- liftIO $ BS.readFile sourceFile+          r <- case A.eitherDecode $ BL.fromStrict secretsBytes of+            Left e -> do+              logLocM ErrorS $ "Could not parse secrets file " <> logStr sourceFile <> ": " <> logStr e+              throwIO $ FatalError "Could not parse secrets file as configured on agent."+            Right r -> pure (Sensitive r)+          createDirectoryIfMissing True destinationDirectory+          secretsMap & M.traverseWithKey \destinationName (secretName :: Text) -> do+            case revealContainer (r <&> M.lookup secretName) of+              Nothing ->+                liftIO $+                  throwIO $+                    FatalError $+                      "Secret " <> secretName <> " does not exist, so we can't find a secret for " <> destinationName <> ". Please make sure that the secret name matches a secret on your agents."+              Just ssecret ->+                pure do+                  secret <- ssecret+                  -- Currently this is `id` but we might want to fork the+                  -- format here or omit some fields.+                  pure $+                    Formats.Secret.Secret+                      { data_ = Formats.Secret.data_ secret+                      }++runEffect :: (MonadThrow m, KatipContext m) => ForeignPtr Derivation -> Sensitive Text -> FilePath -> Text -> FilePath -> m ExitCode+runEffect derivation token secretsPath apiBaseURL dir = do+  drvBuilder <- liftIO $ getDerivationBuilder derivation+  drvArgs <- liftIO $ getDerivationArguments derivation+  drvEnv <- liftIO $ getDerivationEnv derivation+  drvSecretsMap <- escalateAs FatalError $ parseDrvSecretsMap drvEnv+  let mkDir d = let newDir = dir </> d in toS newDir <$ createDirectory newDir+  buildDir <- mkDir "build"+  etcDir <- mkDir "etc"+  secretsDir <- mkDir "secrets"+  runcDir <- mkDir "runc-state"+  let extraSecrets =+        M.singleton+          "hercules-ci"+          ( do+              tok <- token+              pure $+                Formats.Secret.Secret+                  { data_ = M.singleton "token" $ A.String tok+                  }+          )+  writeSecrets secretsPath drvSecretsMap extraSecrets (toS secretsDir)+  liftIO $ do+    -- Nix sandbox sets tmp to buildTopDir+    -- Nix sandbox reference: https://github.com/NixOS/nix/blob/24e07c428f21f28df2a41a7a9851d5867f34753a/src/libstore/build.cc#L2545+    --+    -- TODO: what if we have structuredAttrs?+    -- TODO: implement passAsFile?+    let overridableEnv, onlyImpureOverridableEnv, fixedEnv :: Map Text Text+        overridableEnv =+          M.fromList+            [ ("PATH", "/path-not-set"),+              ("HOME", "/homeless-shelter"),+              ("NIX_STORE", "/nix/store"), -- TODO store.storeDir+              ("NIX_BUILD_CORES", "1"), -- not great+              ("NIX_REMOTE", "daemon"),+              ("IN_HERCULES_CI_EFFECT", "true"),+              ("HERCULES_CI_API_BASE_URL", apiBaseURL),+              ("HERCULES_CI_SECRETS_JSON", "/secrets/secrets.json")+            ]+        -- NB: this is lossy. Consider using ByteString-based process functions+        drvEnv' = drvEnv & M.mapKeys (decodeUtf8With lenientDecode) & fmap (decodeUtf8With lenientDecode)+        impureEnvVars = mempty -- TODO+        fixedEnv =+          M.fromList+            [ ("NIX_LOG_FD", "2"),+              ("TERM", "xterm-256color")+            ]+        onlyImpureOverridableEnv =+          M.fromList+            [ ("NIX_BUILD_TOP", "/build"),+              ("TMPDIR", "/build"),+              ("TEMPDIR", "/build"),+              ("TMP", "/build"),+              ("TEMP", "/build")+            ]+        (//) :: Ord k => Map k a -> Map k a -> Map k a+        (//) = flip M.union+    Container.run+      runcDir+      Container.Config+        { extraBindMounts =+            [ BindMount {pathInContainer = "/build", pathInHost = buildDir, readOnly = False},+              BindMount {pathInContainer = "/etc", pathInHost = etcDir, readOnly = False},+              BindMount {pathInContainer = "/secrets", pathInHost = secretsDir, readOnly = True},+              BindMount {pathInContainer = "/etc/resolv.conf", pathInHost = "/etc/resolv.conf", readOnly = True},+              BindMount {pathInContainer = "/nix/var/nix/daemon-socket/socket", pathInHost = "/nix/var/nix/daemon-socket/socket", readOnly = True}+            ],+          executable = decodeUtf8With lenientDecode drvBuilder,+          arguments = map (decodeUtf8With lenientDecode) drvArgs,+          environment = overridableEnv // drvEnv' // onlyImpureOverridableEnv // impureEnvVars // fixedEnv,+          workingDirectory = "/build",+          hostname = "hercules-ci",+          rootReadOnly = False+        }
+ src/Hercules/Effect/Container.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hercules.Effect.Container where++import Control.Lens+import Data.Aeson (Value (String), eitherDecode, encode, object, toJSON)+import Data.Aeson.Lens+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import qualified Data.UUID.V4 as UUID+import GHC.IO.Exception (IOErrorType (HardwareFault))+import Protolude+import System.Directory (createDirectory)+import System.FilePath ((</>))+import System.IO.Error (ioeGetErrorType)+import System.Posix.IO (closeFd, fdToHandle)+import System.Posix.Terminal (openPseudoTerminal)+import System.Process (CreateProcess (..), StdStream (UseHandle), proc, waitForProcess, withCreateProcess)+import System.Process.ByteString (readCreateProcessWithExitCode)++data BindMount = BindMount+  { pathInContainer :: Text,+    pathInHost :: Text,+    readOnly :: Bool+  }++defaultBindMount :: Text -> BindMount+defaultBindMount path = BindMount {pathInContainer = path, pathInHost = path, readOnly = True}++data Config = Config+  { extraBindMounts :: [BindMount],+    executable :: Text,+    arguments :: [Text],+    environment :: Map Text Text,+    workingDirectory :: Text,+    hostname :: Text,+    rootReadOnly :: Bool+  }++effectToRuncSpec :: Config -> Value -> Value+effectToRuncSpec config spec =+  let defaultMounts = [defaultBindMount "/nix/store"]+      mounts =+        foldMap+          ( \bindMount ->+              pure $+                object+                  [ ("destination", String $ pathInContainer bindMount),+                    ("source", String $ pathInHost bindMount),+                    ("type", "bind"),+                    ( "options",+                      toJSON $+                        ["bind" :: Text]+                          <> ["ro" | readOnly bindMount]+                    )+                  ]+          )+          (defaultMounts <> extraBindMounts config)+   in spec+        & key "process" . key "args" .~ toJSON ([executable config] <> arguments config)+        & key "mounts" . _Array %~ (<> mounts)+        & key "process" . key "terminal" .~ toJSON True+        & key "process" . key "env" .~ toJSON (config & environment & M.toList <&> \(k, v) -> k <> "=" <> v)+        & key "process" . key "cwd" .~ toJSON (config & workingDirectory)+        & key "hostname" .~ toJSON (config & hostname)+        & key "root" . key "readonly" .~ toJSON (config & rootReadOnly)++run :: FilePath -> Config -> IO ExitCode+run dir config = do+  let runcExe = "runc"+      createConfigJsonSpec =+        (System.Process.proc runcExe ["spec", "--rootless"])+          { cwd = Just dir+          }+      configJsonPath = dir </> "config.json"+  (exit, _out, err) <- readCreateProcessWithExitCode createConfigJsonSpec ""+  case exit of+    ExitSuccess -> pass+    ExitFailure e -> do+      putErrText (decodeUtf8With lenientDecode err)+      panic $ "Could not create container configuration template. runc terminated with exit code " <> show e+  templateBytes <- BS.readFile configJsonPath+  template <- case eitherDecode (BL.fromStrict templateBytes) of+    Right a -> pure a+    Left e -> throwIO (FatalError $ "decoding runc config.json template: " <> show e)+  let configJson = effectToRuncSpec config template+  BS.writeFile (dir </> "config.json") (BL.toStrict $ encode configJson)+  createDirectory (dir </> "rootfs")+  name <- do+    uuid <- UUID.nextRandom+    pure $ "hercules-ci-" <> show uuid+  (exitCode, _) <- bracket+    openPseudoTerminal+    ( \(fd1, fd2) -> handle (\(_e :: SomeException) -> pass) do+        closeFd fd1+        when (fd2 /= fd1) (closeFd fd2)+    )+    $ \(master, terminal) -> do+      concurrently+        ( do+            terminalHandle <- fdToHandle terminal+            let createProcSpec =+                  (System.Process.proc runcExe ["run", name])+                    { std_in = UseHandle terminalHandle, -- can't pass /dev/null :(+                      std_out = UseHandle terminalHandle,+                      std_err = UseHandle terminalHandle,+                      cwd = Just dir+                    }+            withCreateProcess createProcSpec \_subStdin _noOut _noErr processHandle -> do+              waitForProcess processHandle+                `onException` ( do+                                  putErrText "Terminating effect process..."+                                  _ <- System.Process.withCreateProcess (System.Process.proc runcExe ["kill", name]) \_ _ _ kh ->+                                    waitForProcess kh+                                  threadDelay 3_000_000+                                  _ <- System.Process.withCreateProcess (System.Process.proc runcExe ["kill", name, "KILL"]) \_ _ _ kh ->+                                    waitForProcess kh+                                  putErrText "Killed effect process."+                              )+        )+        ( do+            masterHandle <- fdToHandle master+            let shovel =+                  handleEOF (BS.hGetLine masterHandle) >>= \case+                    "" -> pass+                    someBytes | "@nix" `BS.isPrefixOf` someBytes -> do+                      -- TODO use it (example @nix { "action": "setPhase", "phase": "effectPhase" })+                      shovel+                    someBytes -> do+                      BS.hPut stderr (someBytes <> "\n")+                      shovel+                handleEOF = handle \e -> if ioeGetErrorType e == HardwareFault then pure "" else throwIO e+            shovel+        )+  pure exitCode
test/Hercules/Agent/Nix/RetrieveDerivationInfoSpec.hs view
@@ -2,10 +2,10 @@  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 Hercules.CNix import Protolude import Test.Hspec
test/TestMain.hs view
@@ -1,13 +1,13 @@ module Main where -import CNix+import Hercules.CNix (init) import Protolude import qualified Spec import Test.Hspec.Runner  main :: IO () main = do-  CNix.init+  init   hspecWith config Spec.spec   where     config = defaultConfig {configColorMode = ColorAlways}