hercules-ci-agent 0.9.12 → 0.9.13

raw patch · 35 files changed

+159/−103 lines, 35 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• cbits/hercules-aliases.h +2/−0
• cbits/nix-2.4/hercules-store.cxx +32/−2
• hercules-ci-agent-worker/Hercules/Agent/Worker.hs +8/−8
• hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger.hs +5/−5
• hercules-ci-agent-worker/Hercules/Agent/Worker/Build/Logger/Context.hs +6/−3
• hercules-ci-agent-worker/Hercules/Agent/Worker/Conduit.hs +5/−5
• hercules-ci-agent-worker/Hercules/Agent/Worker/Effect.hs +1/−1
• hercules-ci-agent-worker/Hercules/Agent/Worker/Evaluate.hs +26/−16
• hercules-ci-agent-worker/Hercules/Agent/Worker/HerculesStore/Context.hs +4/−2
• hercules-ci-agent-worker/Hercules/Agent/Worker/Logging.hs +1/−1
• hercules-ci-agent-worker/Hercules/Agent/Worker/STM.hs +2/−2
• hercules-ci-agent.cabal +1/−1
• hercules-ci-agent/Data/Functor/Partitioner.hs +1/−1
• hercules-ci-agent/Data/Map/Extras/Hercules.hs +2/−2
• hercules-ci-agent/Hercules/Agent/Config.hs +13/−13
• hercules-ci-agent/Hercules/Agent/Env.hs +2/−2
• hercules-ci-agent/Hercules/Agent/Evaluate.hs +2/−2
• hercules-ci-agent/Hercules/Agent/Evaluate/TraversalQueue.hs +5/−5
• hercules-ci-agent/Hercules/Agent/Files.hs +1/−1
• hercules-ci-agent/Hercules/Agent/Log.hs +2/−2
• hercules-ci-agent/Hercules/Agent/Nix.hs +1/−1
• hercules-ci-agent/Hercules/Agent/Nix/RetrieveDerivationInfo.hs +1/−1
• hercules-ci-agent/Hercules/Agent/Token.hs +1/−1
• src/Data/Conduit/Extras.hs +1/−1
• src/Data/Conduit/Katip/Orphans.hs +2/−2
• src/Hercules/Agent/Binary.hs +1/−1
• src/Hercules/Agent/NixFile.hs +7/−6
• src/Hercules/Agent/Producer.hs +5/−5
• src/Hercules/Agent/STM.hs +5/−5
• src/Hercules/Agent/Sensitive.hs +1/−1
• src/Hercules/Agent/Socket.hs +1/−1
• src/Hercules/Agent/WorkerProcess.hs +2/−2
• src/Hercules/Effect.hs +1/−1
• src/Hercules/Secrets.hs +1/−1

@@ -5,6 +5,14 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.9.13] - 2023-03-09++### Added++ - Nix 2.18 support++ - Nix 2.17 support+ ## [0.9.12] - 2022-06-28  ### Added

@@ -20,7 +20,9 @@  typedef nix::Strings::iterator StringsIterator; typedef nix::DerivationOutputs::iterator DerivationOutputsIterator;+#if ! MIN_VERSION_hercules_ci_cnix_store(0,3,5) typedef nix::DerivationInputs::iterator DerivationInputsIterator;+#endif typedef nix::StringPairs::iterator StringPairsIterator;  using namespace std;

@@ -308,9 +308,39 @@    // TODO: don't ignore the Opaques   for (auto & derivedPath : derivedPaths) {-#if NIX_IS_AT_LEAST(2,13,0)+#if NIX_IS_AT_LEAST(2,18,0)+    std::visit(overloaded {+        [&](const DerivedPathBuilt & b) {+            // TODO (RFC 92)+            // for now, we only support the non-inductive case+            std::visit(overloaded {+                [&](SingleDerivedPath::Opaque opaque) {+                    std::visit(overloaded {+                        [&](const OutputsSpec::All &) {+                            paths.emplace_back(StorePathWithOutputs {+                                .path = opaque.path,+                                .outputs = {}+                            });+                        },+                        [&](const OutputsSpec::Names & outs) {+                            paths.emplace_back(StorePathWithOutputs {+                                .path = opaque.path,+                                .outputs = outs+                            });+                        },+                    }, b.outputs.raw);+                },+                [&](SingleDerivedPath::Built built) {+                    throw nix::Error("hercules-ci-agent/buildPaths does not yet support dynamic derivation builds (outputOf)");+                },+            }, *b.drvPath);+        },+        [&](const DerivedPathOpaque & drvPath) {+            // should this be substituted?+        },+    }, derivedPath);+#elif NIX_IS_AT_LEAST(2,13,0)     auto sOrDrvPath = StorePathWithOutputs::tryFromDerivedPath(derivedPath);-    std::set<std::string> outputs;     std::visit(overloaded {         [&](const StorePathWithOutputs & s) {             // paths.push_back(StorePathWithOutputs { built.drvPath, built.outputs });

@@ -167,7 +167,7 @@         logLocM DebugS "Writer done"         wait runnerAsync -- include the potential exception -printCommands :: KatipContext m => ConduitT Command Command m ()+printCommands :: (KatipContext m) => ConduitT Command Command m () printCommands =   mapMC     ( \x -> do@@ -300,7 +300,7 @@       Nothing -> panic "Could not push logs within 10 minutes after completion"     logLocM DebugS "Logger done" -dropMiddle :: MonadIO m => ConduitM (Flush LogEntry) (Flush LogEntry) m ()+dropMiddle :: (MonadIO m) => ConduitM (Flush LogEntry) (Flush LogEntry) m () dropMiddle = do   -- rich logging   _ <- takeCWhileStopEarly isChunk richLogLimit@@ -313,7 +313,7 @@ textOnlyLogLimit = 49_900 tailLimit = 10_000 -snipStart :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m ()+snipStart :: (Monad m) => ConduitT (Flush LogEntry) (Flush LogEntry) m () snipStart =   yield $     Chunk $@@ -324,7 +324,7 @@           msg = "hercules-ci-agent: Soft log limit has been reached. Final log lines will appear when done."         } -snipped :: Monad m => Int -> ConduitT (Flush LogEntry) (Flush LogEntry) m ()+snipped :: (Monad m) => Int -> ConduitT (Flush LogEntry) (Flush LogEntry) m () snipped n =   yield $     Chunk $@@ -335,7 +335,7 @@           msg = "hercules-ci-agent: " <> show n <> " log lines were omitted before the last " <> show tailLimit <> "."         } -snip :: Monad m => Int -> ConduitT (Flush LogEntry) (Flush LogEntry) m ()+snip :: (Monad m) => Int -> ConduitT (Flush LogEntry) (Flush LogEntry) m () snip n =   yield $     Chunk $@@ -346,7 +346,7 @@           msg = "hercules-ci-agent: skipping " <> show n <> " log lines."         } -visibleLinesOnly :: Monad m => ConduitM (Flush LogEntry) (Flush LogEntry) m ()+visibleLinesOnly :: (Monad m) => ConduitM (Flush LogEntry) (Flush LogEntry) m () visibleLinesOnly =   filterC isVisible @@ -361,7 +361,7 @@ isChunk Chunk {} = True isChunk _ = False -socketSink :: MonadIO m => Socket.Socket r w -> ConduitT w o m ()+socketSink :: (MonadIO m) => Socket.Socket r w -> ConduitT w o m () socketSink socket = awaitForever $ liftIO . atomically . Socket.write socket  -- | Perform a foldMap while yielding the original values ("tap").@@ -377,7 +377,7 @@           yield a           go (b <> f a) -makeSocketConfig :: MonadIO m => LogSettings.LogSettings -> Int -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m)+makeSocketConfig :: (MonadIO m) => LogSettings.LogSettings -> Int -> IO (Socket.SocketConfig LogMessage Hercules.API.Agent.LifeCycle.ServiceInfo.ServiceInfo m) makeSocketConfig l storeProtocolVersionValue = do   clientProtocolVersionValue <- liftIO getClientProtocolVersion   baseURL <- case Network.URI.parseURI $ toS $ LogSettings.baseURL l of

@@ -262,13 +262,13 @@ -- TODO: Use 'nubProgress' instead?  -- | Remove spammy progress results.-filterProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m ()+filterProgress :: (Monad m) => ConduitT (Flush LogEntry) (Flush LogEntry) m () filterProgress = filterC \case   Chunk LogEntry.Result {rtype = LogEntry.ResultTypeProgress} -> False   Chunk LogEntry.Result {rtype = LogEntry.ResultTypeSetExpected} -> False   _ -> True -nubProgress :: Monad m => ConduitT (Flush LogEntry) (Flush LogEntry) m ()+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}@@ -281,7 +281,7 @@   for_ l $ \a -> yield $ Chunk a   yield Flush -batch :: Monad m => ConduitT (Flush a) [a] m ()+batch :: (Monad m) => ConduitT (Flush a) [a] m () batch = go []   where     go acc =@@ -317,7 +317,7 @@           yield a         nubSubset1 toKey ak -tryReadLine :: MonadUnliftIO m => Handle -> m (Either () ByteString)+tryReadLine :: (MonadUnliftIO m) => Handle -> m (Either () ByteString) tryReadLine s = tryJust (guard . isEOFError) (liftIO (BSC.hGetLine s))  tapper :: (KatipContext m, MonadUnliftIO m) => TapState -> m ()@@ -359,7 +359,7 @@ -- @withTappedStderr tapper mainAction@ -- -- 'readableStderrEnd' receives EOF when your action terminates (unless you 'dup' the write end, aka 'stdError')-withTappableStderr :: MonadUnliftIO m => (TapState -> m a) -> m a+withTappableStderr :: (MonadUnliftIO m) => (TapState -> m a) -> m a withTappableStderr = bracket (liftIO tapStderrPipe) (liftIO . revertTap)  revertTap :: TapState -> IO ()

@@ -36,7 +36,10 @@ loggerContext =   mempty     { C.ctxTypesTable =-        C.TypeName "HerculesLoggerEntry" =: [t|HerculesLoggerEntry|]-          <> C.TypeName "LogEntryQueue" =: [t|LogEntryQueue|]-          <> C.TypeName "LoggerFields" =: [t|Fields|]+        C.TypeName "HerculesLoggerEntry"+          =: [t|HerculesLoggerEntry|]+          <> C.TypeName "LogEntryQueue"+          =: [t|LogEntryQueue|]+          <> C.TypeName "LoggerFields"+          =: [t|Fields|]     }

@@ -7,13 +7,13 @@ import Data.Sequence qualified as Seq import Protolude hiding (pred, yield) -tailC :: Monad m => Int -> ConduitT i i m ()+tailC :: (Monad m) => Int -> ConduitT i i m () tailC n = do   buf <- sinkTail n   for_ buf yield  -- | Return the last @n@ items-sinkTail :: Monad m => Int -> ConduitT i o m (Seq i)+sinkTail :: (Monad m) => Int -> ConduitT i o m (Seq i) sinkTail n = do   doBuffer mempty   where@@ -26,7 +26,7 @@ -- even if the next item does not match the predicate. -- -- Return the number of counted messages and the total number of messages written.-takeCWhileStopEarly :: Monad m => (i -> Bool) -> Int -> ConduitT i i m (Int, Int)+takeCWhileStopEarly :: (Monad m) => (i -> Bool) -> Int -> ConduitT i i m (Int, Int) takeCWhileStopEarly counts limit = go 0 0   where     go counted total | counted >= limit = pure (counted, total)@@ -45,14 +45,14 @@     increment i | pred i = liftIO $ modifyIORef counter (+ 1)     increment _ = pass -withInputProductionCount :: MonadIO m => (i -> Bool) -> ConduitT i o m a -> ConduitT i o m (Int, a)+withInputProductionCount :: (MonadIO m) => (i -> Bool) -> ConduitT i o m a -> ConduitT i o m (Int, a) withInputProductionCount pred conduit = do   counter <- liftIO $ newIORef 0   r <- countProduction pred counter .| conduit   (,r) <$> liftIO (readIORef counter)  withMessageLimit ::-  MonadIO m =>+  (MonadIO m) =>   (a -> Bool) ->   -- | First limit   Int ->

@@ -37,7 +37,7 @@         runEffectFriendly = False       } -prepareDerivation :: MonadIO m => Store -> Command.Effect.Effect -> m Derivation+prepareDerivation :: (MonadIO m) => Store -> Command.Effect.Effect -> m Derivation prepareDerivation store command = do   let extraPaths = Command.Effect.inputDerivationOutputPaths command       drvPath = encodeUtf8 $ Command.Effect.drvPath command

@@ -103,7 +103,7 @@ -- -- (It does not happen, but this de-escalates a potential recursion bug to just --  an error.)-withDrvInProgress :: MonadUnliftIO m => HerculesState -> StorePath -> m a -> m a+withDrvInProgress :: (MonadUnliftIO m) => HerculesState -> StorePath -> m a -> m a withDrvInProgress HerculesState {drvsInProgress = ref} drvPath =   bracket acquire release . const   where@@ -122,7 +122,7 @@ anyAlternative :: (Foldable l, Alternative f) => l a -> f a anyAlternative = getAlt . foldMap (Alt . pure) -yieldAttributeError :: MonadIO m => Store -> [ByteString] -> SomeException -> ConduitT i Event m ()+yieldAttributeError :: (MonadIO m) => Store -> [ByteString] -> SomeException -> ConduitT i Event m () yieldAttributeError store path e = do   exceptionText <- liftIO $ renderException e   drvPath <- liftIO $ traverse (storePathToPath store) (exceptionTextDerivationPath exceptionText)@@ -136,7 +136,7 @@           AttributeError.trace = exceptionTextTrace exceptionText         } -maybeThrowBuildException :: MonadIO m => BuildResult.BuildStatus -> StorePath -> m ()+maybeThrowBuildException :: (MonadIO m) => BuildResult.BuildStatus -> StorePath -> m () maybeThrowBuildException result drv =   case result of     BuildResult.Failure -> liftIO $ throwBuildError ("Could not build derivation " <> show drv <> ", which is required during evaluation.") drv@@ -189,13 +189,20 @@       drvPath <- liftIO $ CNix.storePathToPath store drvStorePath       cachingBuilt drvPath do         let pathText = decode drvPath-        outputs <- liftIO $ getOutputs storePathWithOutputs+        outputs0 <- liftIO $ getOutputs storePathWithOutputs+        derivation <- liftIO $ getDerivation store drvStorePath+        drvName <- liftIO $ getDerivationNameFromPath drvStorePath+        drvOutputs <- liftIO $ getDerivationOutputs store drvName derivation+        let outputs =+              -- Empty outputs suggests that the intent was to build all outputs+              -- Tests do not confirm, but better be sure.+              -- TODO: move away from StorePathWithOutputs; feasible since 2.4?+              if null outputs0+                then map (.derivationOutputName) drvOutputs+                else outputs0         katipAddContext (sl "fullpath" pathText) $           for_ outputs $ \outputName -> do             withDrvInProgress st drvStorePath $ do-              derivation <- liftIO $ getDerivation store drvStorePath-              drvName <- liftIO $ getDerivationNameFromPath drvStorePath-              drvOutputs <- liftIO $ getDerivationOutputs store drvName derivation               outputPath <-                 case find (\o -> derivationOutputName o == outputName) drvOutputs of                   Nothing -> panic $ "output " <> show outputName <> " does not exist on " <> pathText@@ -358,7 +365,7 @@     (API.ImmutableGitInput.ref git)     (API.ImmutableGitInput.rev git) -sendConfig :: MonadIO m => Ptr EvalState -> Bool -> PSObject HerculesCISchema -> ConduitT i Event m ()+sendConfig :: (MonadIO m) => Ptr EvalState -> Bool -> PSObject HerculesCISchema -> ConduitT i Event m () sendConfig evalState isFlake herculesCI = flip runReaderT evalState $ do   herculesCI #? #onPush >>= traverse_ \onPushes -> do     attrs <- dictionaryToMap onPushes@@ -391,7 +398,7 @@ noConstraints :: TimeConstraints noConstraints = TimeConstraints Nothing Nothing Nothing Nothing -parseWhen :: MonadEval m => PSObject NixFile.TimeConstraintsSchema -> m Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent.TimeConstraints+parseWhen :: (MonadEval m) => PSObject NixFile.TimeConstraintsSchema -> m Hercules.API.Agent.Evaluate.EvaluateEvent.OnScheduleHandlerEvent.TimeConstraints parseWhen w = do   minute_ <-     w #?? #minute >>= traverse \obj -> do@@ -407,7 +414,8 @@           else throwIO $ Schema.InvalidValue (provenance obj) $ "hour value " <> show v <> " is out of range [0..23]."    hour_ <--    w #?? #hour+    w+      #?? #hour       >>= traverse         ( (\oneInt -> validateHour oneInt <&> \x -> [x])             |! ( \hours -> do@@ -418,7 +426,8 @@                )         )   dayOfWeek <--    w #?? #dayOfWeek+    w+      #?? #dayOfWeek       >>= traverse         ( \dayStringsObject -> do             days <- traverseArray parseDayOfWeek dayStringsObject@@ -427,7 +436,8 @@             pure days         )   dayOfMonth <--    w #?? #dayOfMonth+    w+      #?? #dayOfMonth       >>= traverse \daysOfMonth -> do         v <-           daysOfMonth & traverseArray \obj -> do@@ -621,7 +631,7 @@         }  withIFDQueue ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   EvalEnv ->   ( ([ByteString] -> AsyncRealisationRequired -> (Either SomeException () -> ConduitT i Event m ()) -> ConduitT i Event m ()) ->     ConduitT i Event m ()@@ -629,7 +639,7 @@   ConduitT i Event m () withIFDQueue evalEnv doIt = do   let poller ::-        MonadIO m =>+        (MonadIO m) =>         Map (StorePath, ByteString) x ->         ConduitT i Event m (Map (StorePath, ByteString) (Either SomeException ()))       poller q = do@@ -751,7 +761,7 @@  -- | Documented in @docs/modules/ROOT/pages/evaluation.adoc@. walkDerivation ::-  MonadIO m =>+  (MonadIO m) =>   Store ->   Ptr EvalState ->   Bool ->@@ -809,7 +819,7 @@     inEffects ("effects" : _) = True     inEffects _ = False -liftEitherAs :: MonadError e m => (e0 -> e) -> Either e0 a -> m a+liftEitherAs :: (MonadError e m) => (e0 -> e) -> Either e0 a -> m a liftEitherAs f = liftEither . rmap   where     rmap (Left e) = Left (f e)

@@ -38,6 +38,8 @@ herculesStoreContext =   mempty     { C.ctxTypesTable =-        C.TypeName "refHerculesStore" =: [t|Ref HerculesStore|]-          <> C.TypeName "exception_ptr" =: [t|ExceptionPtr|]+        C.TypeName "refHerculesStore"+          =: [t|Ref HerculesStore|]+          <> C.TypeName "exception_ptr"+          =: [t|ExceptionPtr|]     }

@@ -9,7 +9,7 @@  withKatip :: (MonadUnliftIO m) => KatipContextT m a -> m a withKatip m = do-  let format :: forall a. LogItem a => ItemFormatter a+  let format :: forall a. (LogItem a) => ItemFormatter a       format = (\_ _ _ -> "@katip ") <> jsonFormat   -- Use a duplicate of stderr, to make sure we keep logging there, even after   -- we reassign stderr to catch output from git and other subprocesses of Nix.

@@ -25,7 +25,7 @@     Right b -> do       async (io b) -ensureTVarMapItem :: Ord k => k -> STM v -> TVar (Map k v) -> STM (Bool, v)+ensureTVarMapItem :: (Ord k) => k -> STM v -> TVar (Map k v) -> STM (Bool, v) ensureTVarMapItem key mkValue mapVar = do   map0 <- readTVar mapVar   case M.lookup key map0 of@@ -36,7 +36,7 @@     Just value0 -> do       pure (True, value0) -asyncInTVarMap :: Ord k => k -> TVar (Map k (Async a)) -> IO a -> IO (Async a)+asyncInTVarMap :: (Ord k) => k -> TVar (Map k (Async a)) -> IO a -> IO (Async a) asyncInTVarMap key mapVar action =   asyncIfSTM     ( \asy -> do

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           hercules-ci-agent-version:        0.9.12+version:        0.9.13 synopsis:       Runs Continuous Integration tasks on your machines category:       Nix, CI, Testing, DevOps homepage:       https://docs.hercules-ci.com

@@ -67,7 +67,7 @@ newtype WithKey k v = WithKey (k, v)  partWithKey ::-  Ord k =>+  (Ord k) =>   (k -> v -> Maybe a) ->   Partitioner (WithKey k v) (Map k a) partWithKey f =

@@ -6,10 +6,10 @@ import Data.Map qualified as M import Protolude hiding (groupBy) -groupOn :: Ord k => (a -> k) -> [a] -> M.Map k [a]+groupOn :: (Ord k) => (a -> k) -> [a] -> M.Map k [a] groupOn f = fmap toList . groupOnNEL f -groupOnNEL :: Ord k => (a -> k) -> [a] -> M.Map k (NEL.NonEmpty a)+groupOnNEL :: (Ord k) => (a -> k) -> [a] -> M.Map k (NEL.NonEmpty a) groupOnNEL f =   M.fromList     . map (fst . NEL.head &&& map snd)

@@ -69,34 +69,34 @@ tomlCodec =   Config     <$> dioptional (Toml.text "apiBaseUrl")-    .= herculesApiBaseURL+      .= herculesApiBaseURL     <*> dioptional (Toml.bool "nixUserIsTrusted")-    .= nixUserIsTrusted+      .= nixUserIsTrusted     <*> dioptional       ( Toml.dimatch matchRight Right (Toml.int "concurrentTasks")           <|> Toml.dimatch matchLeft Left (Toml.textBy (\() -> "auto") isAuto "concurrentTasks")       )-    .= concurrentTasks+      .= concurrentTasks     <*> dioptional (Toml.string keyBaseDirectory)-    .= baseDirectory+      .= baseDirectory     <*> dioptional (Toml.string "staticSecretsDirectory")-    .= staticSecretsDirectory+      .= staticSecretsDirectory     <*> dioptional (Toml.string "workDirectory")-    .= workDirectory+      .= workDirectory     <*> dioptional (Toml.string keyClusterJoinTokenPath)-    .= clusterJoinTokenPath+      .= clusterJoinTokenPath     <*> dioptional (Toml.string "binaryCachesPath")-    .= binaryCachesPath+      .= binaryCachesPath     <*> dioptional (Toml.string "secretsJsonPath")-    .= secretsJsonPath+      .= secretsJsonPath     <*> dioptional (Toml.enumBounded "logLevel")-    .= logLevel+      .= logLevel     <*> dioptional (Toml.enumBounded "nixVerbosity")-    .= nixVerbosity+      .= nixVerbosity     <*> dioptional (Toml.tableMap _KeyText embedJson "labels")-    .= labels+      .= labels     <*> dioptional (Toml.bool "allowInsecureBuiltinFetchers")-    .= allowInsecureBuiltinFetchers+      .= allowInsecureBuiltinFetchers  embedJson :: Key -> TomlCodec A.Value embedJson key =

@@ -72,14 +72,14 @@ runApp env (App m) = runReaderT m env  runHerculesClient ::-  NFData a =>+  (NFData a) =>   (Servant.Auth.Client.Token -> Servant.Client.Streaming.ClientM a) ->   App a runHerculesClient f = do   tok <- asks currentToken   runHerculesClient' (f tok) -runHerculesClient' :: NFData a => Servant.Client.Streaming.ClientM a -> App a+runHerculesClient' :: (NFData a) => Servant.Client.Streaming.ClientM a -> App a runHerculesClient' m = do   clientEnv <- asks herculesClientEnv   escalate =<< liftIO (Servant.Client.Streaming.runClientM m clientEnv)

@@ -112,7 +112,7 @@       fix $ \continue ->         joinSTM $ listen batchProducer (\b -> withSync b (postBatch task' . catMaybes) *> continue) pure -getSrcInput :: MonadIO m => EvaluateTask.EvaluateTask -> m (Maybe ImmutableGitInput)+getSrcInput :: (MonadIO m) => EvaluateTask.EvaluateTask -> m (Maybe ImmutableGitInput) getSrcInput task = case M.lookup "src" (EvaluateTask.inputs task) of   Just (ImmutableInput.Git x) ->     purer x@@ -131,7 +131,7 @@   msgCounter <- liftIO $ newIORef 0    let fixIndex ::-        MonadIO m =>+        (MonadIO m) =>         EvaluateEvent.EvaluateEvent ->         m EvaluateEvent.EvaluateEvent       fixIndex (EvaluateEvent.Message m) = do

@@ -36,23 +36,23 @@     size :: TVar Int   } -with :: MonadBaseControl IO m => (Queue a -> m ()) -> m ()+with :: (MonadBaseControl IO m) => (Queue a -> m ()) -> m () with = Control.Exception.Lifted.bracket new close -new :: MonadBase IO m => m (Queue a)+new :: (MonadBase IO m) => m (Queue a) new = Queue <$> newChan <*> newIORef Set.empty <*> liftBase (newTVarIO 0) -close :: MonadBase IO m => Queue a -> m ()+close :: (MonadBase IO m) => Queue a -> m () close env = writeChan (chan env) Nothing -enqueue :: MonadBase IO m => Queue a -> a -> m ()+enqueue :: (MonadBase IO m) => Queue a -> a -> m () enqueue env msg = do   liftBase $ atomically $ modifyTVar (size env) (+ 1)   -- Not transactional but shouldn't hurt much since we fail the whole thing   -- in erlang style anyway using the async library.   writeChan (chan env) (Just msg) -waitUntilDone :: MonadBase IO m => Queue a -> m ()+waitUntilDone :: (MonadBase IO m) => Queue a -> m () waitUntilDone env = liftBase $   atomically $ do     n <- readTVar (size env)

@@ -17,7 +17,7 @@   workDir <- asks (Config.workDirectory . config)   liftIO $ withTempDirectory workDir (toS hint) $ unlift . f -readFileMaybe :: MonadIO m => FilePath -> m (Maybe Text)+readFileMaybe :: (MonadIO m) => FilePath -> m (Maybe Text) readFileMaybe fp = liftIO do   exists <- doesFileExist fp   guard exists & traverse \_ -> readFile fp

@@ -26,12 +26,12 @@ withContext = katipAddContext  -- TODO: Support context for all exceptions and use plain @panic@ instead.-panicWithLog :: KatipContext m => Text -> m a+panicWithLog :: (KatipContext m) => Text -> m a panicWithLog msg = do   logLocM ErrorS $ logStr msg   panic msg -stderrLineHandler :: KatipContext m => Map Text Value -> Text -> Int -> ByteString -> m ()+stderrLineHandler :: (KatipContext m) => Map Text Value -> Text -> Int -> ByteString -> m () stderrLineHandler callerContext _processRole _ ln   | "@katip " `BS.isPrefixOf` ln,     Just item <- A.decode (LBS.fromStrict $ BS.drop 7 ln) =

@@ -18,7 +18,7 @@           }     } -askExtraOptions :: MonadReader Agent.Env.Env m => m [(Text, Text)]+askExtraOptions :: (MonadReader Agent.Env.Env m) => m [(Text, Text)] askExtraOptions = asks (extraOptions . nixEnv)  getNetrcLines :: App [Text]

@@ -12,7 +12,7 @@ import Protolude  retrieveDerivationInfo ::-  MonadIO m =>+  (MonadIO m) =>   Store ->   StorePath ->   m DerivationInfo

@@ -29,7 +29,7 @@   liftIO $ writeFile (dir </> "session.key") (toS tok)  -- | Reads a token file, strips whitespace-readTokenFile :: MonadIO m => FilePath -> m Text+readTokenFile :: (MonadIO m) => FilePath -> m Text readTokenFile fp = liftIO $ sanitize <$> readFile fp   where     sanitize = T.map subst . T.strip

@@ -31,7 +31,7 @@       awaitForever $ \msg -> liftIO $ writeChan ch (Just msg)  -- | Read a channel until @Nothing@ is encountered-sourceChan :: MonadIO m => Chan (Maybe a) -> ConduitT i a m ()+sourceChan :: (MonadIO m) => Chan (Maybe a) -> ConduitT i a m () sourceChan ch = do   mmsg <- liftIO $ readChan ch   case mmsg of

@@ -6,12 +6,12 @@ import Data.Conduit import Katip -instance Katip m => Katip (ConduitT i o m) where+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+instance (KatipContext m) => KatipContext (ConduitT i o m) where   getKatipContext = lift getKatipContext    getKatipNamespace = lift getKatipNamespace

@@ -11,7 +11,7 @@  -- | Decode a value from a 'Handle'. Returning 'Left' on failure and 'Right' on success. -- In case of failure, the unconsumed input and a human-readable error message will be returned.-decodeBinaryFromHandle :: Binary a => Handle -> IO (Either (BS.ByteString, ByteOffset, String) a)+decodeBinaryFromHandle :: (Binary a) => Handle -> IO (Either (BS.ByteString, ByteOffset, String) a) decodeBinaryFromHandle = feed (runGetIncremental get)   where     feed (Done _ _ x) _ = pure (Right x)

@@ -127,7 +127,7 @@       homeExpr <- liftIO $ autoCallFunction evalState rootValueOrFunction args       pure (CiNix nixFile homeExpr) -getHomeExprObject :: MonadEval m => HomeExpr -> m (PSObject HomeSchema)+getHomeExprObject :: (MonadEval m) => HomeExpr -> m (PSObject HomeSchema) getHomeExprObject (Flake attrs) = pure PSObject {value = rtValue attrs, provenance = Schema.File "flake.nix"} getHomeExprObject (CiNix f obj) = pure PSObject {value = obj, provenance = Schema.File f} @@ -191,19 +191,20 @@     '[ "addDefaults" ::. Attrs '[] ->. Attrs '[] ->. HerculesCISchema      ] -exprString :: forall a m. MonadEval m => ByteString -> m (PSObject a)+exprString :: forall a m. (MonadEval m) => ByteString -> m (PSObject a) exprString bs = do   evalState <- ask   value <- liftIO $ valueFromExpressionString evalState bs "/var/lib/empty/hercules-ci-agent-builtin"   pure PSObject {value = value, provenance = Schema.Other "hercules-ci-agent built-in expression"} -getHerculesCI :: MonadEval m => HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema))+getHerculesCI :: (MonadEval m) => HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema)) getHerculesCI homeExpr args = do   home <- getHomeExprObject homeExpr   args' <- Schema.uncheckedCast <$> toPSObject args   case homeExpr of     CiNix {} ->-      home #? #herculesCI+      home+        #? #herculesCI         >>= traverse @Maybe \herculesCI ->           herculesCI $? args'     Flake flake ->@@ -222,10 +223,10 @@         hci <- fn .$ flakeObj >>$. pure args''         pure hci {Schema.provenance = Other "the herculesCI attribute of your flake (after adding defaults)"} -parseExtraInputs :: MonadEval m => PSObject ExtraInputsSchema -> m (Map ByteString InputDeclaration)+parseExtraInputs :: (MonadEval m) => PSObject ExtraInputsSchema -> m (Map ByteString InputDeclaration) parseExtraInputs eis = dictionaryToMap eis >>= traverse parseInputDecl -parseInputDecl :: MonadEval m => PSObject InputDeclSchema -> m InputDeclaration+parseInputDecl :: (MonadEval m) => PSObject InputDeclSchema -> m InputDeclaration parseInputDecl d = do   project <- d #. #project >>= fromPSObject   ref <- d #? #ref >>= traverse fromPSObject

@@ -44,7 +44,7 @@ forkProducer :: forall m p r. (MonadUnliftIO m) => ((p -> m ()) -> m r) -> m (Producer p r) forkProducer f = do   q <- liftIO newTQueueIO-  let write :: MonadIO m' => Msg p r -> m' ()+  let write :: (MonadIO m') => Msg p r -> m' ()       write = liftIO . atomically . writeTQueue q   f' <- toIO (f (write . Payload))   t <- liftIO $ forkFinally f' (write . toResult)@@ -55,7 +55,7 @@  -- | Throws 'ProducerCancelled' as an async exception to the producer thread. -- Blocks until exception is raised. See 'throwTo'.-cancel :: MonadIO m => Producer p r -> m ()+cancel :: (MonadIO m) => Producer p r -> m () cancel p = liftIO $ throwTo (producerThread p) ProducerCancelled  -- | Perform an computation while @withProducer@ takes care of forking and cleaning up.@@ -69,7 +69,7 @@ withProducer f = bracket (forkProducer f) cancel  listen ::-  MonadIO m =>+  (MonadIO m) =>   Producer p r ->   (p -> m a) ->   (r -> m a) ->@@ -81,7 +81,7 @@     f (Exception e) = throwIO e     f (Close r) = fResult r -joinSTM :: MonadIO m => STM (m a) -> m a+joinSTM :: (MonadIO m) => STM (m a) -> m a joinSTM = join . liftIO . atomically  data Syncing a = Syncable a | Syncer (Maybe SomeException -> STM ())@@ -170,7 +170,7 @@       )     $ \_flusher -> unlift $ withProducer producer f -syncer :: MonadIO m => (Syncing a -> m ()) -> m ()+syncer :: (MonadIO m) => (Syncing a -> m ()) -> m () syncer writer = do   v <- liftIO newEmptyTMVarIO   writer (Syncer $ putTMVar v)

@@ -15,22 +15,22 @@ import Control.Concurrent.STM qualified as STM import Protolude hiding (atomically) -atomically :: MonadIO m => STM a -> m a+atomically :: (MonadIO m) => STM a -> m a atomically = liftIO . STM.atomically -readTVarIO :: MonadIO m => TVar a -> m a+readTVarIO :: (MonadIO m) => TVar a -> m a readTVarIO = liftIO . STM.readTVarIO -newTVarIO :: MonadIO m => a -> m (TVar a)+newTVarIO :: (MonadIO m) => a -> m (TVar a) newTVarIO = liftIO . STM.newTVarIO  -- | Drop-in replacement for atomicModifyIORef-modifyTVarIO :: MonadIO m => TVar a -> (a -> (a, b)) -> m b+modifyTVarIO :: (MonadIO m) => TVar a -> (a -> (a, b)) -> m b modifyTVarIO tvar f = atomically $ do   a0 <- readTVar tvar   let (a1, b) = f a0   writeTVar tvar a1   pure b -newTChanIO :: MonadIO m => m (TChan a)+newTChanIO :: (MonadIO m) => m (TChan a) newTChanIO = liftIO STM.newTChanIO

@@ -17,5 +17,5 @@ instance Show (Sensitive a) where   show _ = "<sensitive>" -revealContainer :: Functor f => Sensitive (f a) -> f (Sensitive a)+revealContainer :: (Functor f) => Sensitive (f a) -> f (Sensitive a) revealContainer (Sensitive fa) = Sensitive <$> fa

@@ -87,7 +87,7 @@           }   race socketThread (f socket) <&> either identity identity -checkVersion' :: Applicative m => ServiceInfo -> m (Either Text ())+checkVersion' :: (Applicative m) => ServiceInfo -> m (Either Text ()) checkVersion' si =   if ServiceInfo.version si < requiredServiceVersion     then pure $ Left $ "Expected service version " <> show requiredServiceVersion

@@ -63,11 +63,11 @@   envMap <- M.fromList <$> getEnvironment   pure $ M.toList $ modifyEnv workerEnvSettings envMap -getWorkerExe :: MonadIO m => m [Char]+getWorkerExe :: (MonadIO m) => m [Char] getWorkerExe = do   liftIO getBinDir <&> (</> "hercules-ci-agent-worker") -getDaemonExe :: MonadIO m => m [Char]+getDaemonExe :: (MonadIO m) => m [Char] getDaemonExe = do   liftIO getBinDir <&> (</> "hercules-ci-nix-daemon") 

@@ -216,7 +216,7 @@               ("TMP", "/build"),               ("TEMP", "/build")             ]-        (//) :: Ord k => Map k a -> Map k a -> Map k a+        (//) :: (Ord k) => Map k a -> Map k a -> Map k a         (//) = flip M.union     let (withNixDaemonProxyPerhaps, forwardedSocketPath) =           if runEffectUseNixDaemonProxy p

@@ -93,7 +93,7 @@ class MonadMiniWriter w m | m -> w where   tell :: w -> m () -instance Monoid w => MonadMiniWriter w ((,) w) where+instance (Monoid w) => MonadMiniWriter w ((,) w) where   tell = Control.Monad.Writer.tell  instance MonadMiniWriter w (Tagged w) where