Revert "Lookup storePath producers and better activity reporting"

This reverts commit 7e6d28c2d5.
This reverts commit 90fd896e82.
This commit is contained in:
maralorn 2023-11-26 13:41:03 +01:00
parent 8a257f5f43
commit 1356aa5c5b
7 changed files with 158 additions and 207 deletions

View File

@ -1,4 +1,3 @@
- ignore: {name: Avoid lambda}
- ignore: {name: Avoid lambda using `infix`}
- ignore: {name: Redundant irrefutable pattern}
- ignore: {name: Eta reduce}

View File

@ -15,8 +15,7 @@ mkDerivation {
ansi-terminal async attoparsec base bytestring cassava containers
data-default directory extra filepath hermes-json lock-file
MemoTrie nix-derivation optics relude safe stm streamly-core strict
strict-types terminal-size text time transformers typed-process
word8
strict-types terminal-size text time transformers word8
];
executableHaskellDepends = [
ansi-terminal async attoparsec base bytestring cassava containers

View File

@ -28,6 +28,7 @@ import NOM.State (
DerivationSet,
EvalInfo (..),
InputDerivation (..),
InterestingActivity (..),
NOMState,
NOMV1State (..),
ProgressState (..),
@ -114,6 +115,14 @@ data Config = MkConfig
printSections :: NonEmpty Text -> Text
printSections = (upperleft <>) . Text.intercalate (toText (setSGRCode [Reset]) <> "\n" <> leftT) . toList
printInterestingActivities :: Maybe Text -> IntMap InterestingActivity -> (ZonedTime, Double) -> Text
printInterestingActivities message activities (_, now) =
prependLines
""
(vertical <> " ")
(vertical <> " ")
(horizontal <> markup bold " Build Planning:" :| maybeToList message <> (IntMap.elems activities <&> \activity -> unwords (activity.text : ifTimeDiffRelevant now activity.start id)))
printErrors :: Seq Text -> Int -> Text
printErrors errors maxHeight =
prependLines
@ -149,7 +158,8 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
sections =
fmap snd
. filter fst
$ [ (not (Seq.null nixErrors), const errorDisplay)
$ [ (not (IntMap.null interestingActivities) || isJust evalMessage, printInterestingActivities evalMessage interestingActivities)
, (not (Seq.null nixErrors), const errorDisplay)
, (not (Seq.null forestRoots), buildsDisplay . snd)
]
maxHeight = case maybeWindow of
@ -162,21 +172,13 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
(vertical <> " ")
(printBuilds buildState hostNums maxHeight now)
errorDisplay = printErrors nixErrors maxHeight
-- evalMessage = case evaluationState.lastFileName of
-- Strict.Just file_name -> Just ("Evaluated " <> show (evaluationState.count) <> " files, last one was '" <> file_name <> "'")
-- Strict.Nothing -> Nothing
evalMessage = case evaluationState.lastFileName of
Strict.Just file_name -> Just ("Evaluated " <> show (evaluationState.count) <> " files, last one was '" <> file_name <> "'")
Strict.Nothing -> Nothing
runTime now = timeDiff now startTime
time = case progressState of
Finished -> \(nowClock, now) -> finishMarkup (" at " <> toText (formatTime defaultTimeLocale "%H:%M:%S" nowClock) <> " after " <> runTime now)
InputReceived -> \(_, now) -> clock <> " " <> runTime now <> " Nix is starting …"
Evaluating -> \(_, now) ->
clock <> " " <> runTime now <> " evaluating, " <> show (evaluationState.count) <> " files so far" <> case evaluationState.lastFileName of
Strict.Just file_name -> ", last one was '" <> file_name <> "'"
Strict.Nothing -> ""
Planning paths drvs -> \(_, now) -> clock <> " " <> runTime now <> " planning " <> Text.intercalate " and " (["builds" | not (Set.null drvs)] <> ["downloads" | not (Set.null paths)]) <> ""
QueryingSubstituers -> \(_, now) -> clock <> " " <> runTime now <> " looking for store paths on substituters …"
JustStarted -> \(_, now) -> clock <> " " <> runTime now <> " waiting for Nix to start …"
Realising -> \(_, now) -> clock <> " " <> runTime now
time
| progressState == Finished = \(nowClock, now) -> finishMarkup (" at " <> toText (formatTime defaultTimeLocale "%H:%M:%S" nowClock) <> " after " <> runTime now)
| otherwise = \(_, now) -> clock <> " " <> runTime now
MkDependencySummary{..} = fullSummary
runningBuilds' = (.host) <$> runningBuilds
completedBuilds' = (.host) <$> completedBuilds
@ -325,7 +327,7 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
| not (CSet.member thisDrv seen_ids) && CSet.member thisDrv derivationsToShow = do
let drvInfo = get' (getDerivationInfos thisDrv)
childs = children thisDrv
modify' (CSet.insert thisDrv)
modify (CSet.insert thisDrv)
subforest <- goBuildForest childs
pure (Node drvInfo subforest :)
| otherwise = pure id

View File

@ -208,18 +208,12 @@ data NOMV1State = MkNOMV1State
, activities :: IntMap ActivityStatus
, nixErrors :: Seq Text
, buildPlatform :: Strict.Maybe Text
, interestingActivities :: IntMap InterestingActivity
, evaluationState :: EvalInfo
}
deriving stock (Show, Eq, Ord, Generic)
data ProgressState
= JustStarted
| InputReceived
| Evaluating
| QueryingSubstituers
| Planning (Set StorePath) (Set Derivation)
| Realising
| Finished
data ProgressState = JustStarted | InputReceived | Finished
deriving stock (Show, Eq, Ord, Generic)
data BuildFail = MkBuildFail
@ -271,6 +265,7 @@ initalStateFromBuildPlatform platform = do
mempty
mempty
(Strict.toStrict platform)
mempty
MkEvalInfo{count = 0, at = 0, lastFileName = Strict.Nothing}
instance Semigroup DependencySummary where

View File

@ -29,6 +29,7 @@ import NOM.State (
DerivationSet,
EvalInfo (..),
InputDerivation (..),
InterestingActivity (..),
NOMState,
NOMStateT,
NOMV1State (..),
@ -77,6 +78,13 @@ getReportName drv = case drv.pname of
Strict.Just pname -> pname
Strict.Nothing -> Text.dropWhileEnd (`Set.member` fromList ".1234567890-") drv.name.storePath.name
setInputReceived :: NOMState Bool
setInputReceived = do
s <- get
let change = s.progressState == JustStarted
when change (put s{progressState = InputReceived})
pure change
maintainState :: Double -> NOMV1State -> NOMV1State
maintainState now = execState $ do
currentState <- get
@ -93,18 +101,30 @@ minTimeBetweenPollingNixStore = 0.2 -- in seconds
{-# INLINE updateStateNixJSONMessage #-}
updateStateNixJSONMessage :: forall m. (UpdateMonad m) => NixJSONMessage -> NOMV1State -> m (([NOMError], ByteString), Maybe NOMV1State)
updateStateNixJSONMessage input inputState =
{-# SCC "updateStateNixJSONMessage" #-}
do
((hasChanged, msgs), outputState) <-
runStateT (runWriterT (processJsonMessage input)) inputState
let retval = if hasChanged then Just outputState else Nothing
{-# SCC "run_state" #-}
runStateT
( runWriterT
( sequence
[ {-# SCC "input_received" #-} setInputReceived
, {-# SCC "processing" #-} processJsonMessage input
]
)
)
inputState
let retval = if or hasChanged then Just outputState else Nothing
errors = lefts msgs
pure ((errors, ByteString.unlines (rights msgs)), retval)
{-# SCC "emitting_new_state" #-} pure ((errors, ByteString.unlines (rights msgs)), retval)
updateStateNixOldStyleMessage :: forall m. (UpdateMonad m) => (Maybe NixOldStyleMessage, ByteString) -> (Maybe Double, NOMV1State) -> m (([NOMError], ByteString), (Maybe Double, Maybe NOMV1State))
updateStateNixOldStyleMessage (result, input) (inputAccessTime, inputState) = do
now <- getNow
let processing = maybe noChange (\result' -> processResult result') result
let processing = case result of
Just result' -> processResult result'
Nothing -> pure False
(outputAccessTime, check)
| maybe True ((>= minTimeBetweenPollingNixStore) . realToFrac . (now -)) inputAccessTime = (Just now, detectLocalFinishedBuilds)
| otherwise = (inputAccessTime, pure False)
@ -113,7 +133,9 @@ updateStateNixOldStyleMessage (result, input) (inputAccessTime, inputState) = do
( runWriterT
( or
<$> sequence
[ -- Update the state if any changes where parsed.
[ -- First check if this is the first time that we receive input (for error messages).
setInputReceived
, -- Update the state if any changes where parsed.
processing
, -- Check if any local builds have finished, because nix-build would not tell us.
-- If we havent done so in the last minTimeBetweenPollingNixStore seconds.
@ -135,69 +157,41 @@ derivationIsCompleted drvId =
detectLocalFinishedBuilds :: ProcessingT m Bool
detectLocalFinishedBuilds = do
runningLocalBuilds <- CMap.toList <$> getRunningBuildsByHost Localhost
runningLocalBuilds <- CMap.toList <$> getRunningBuildsByHost Localhost -- .> traceShowId
newCompletedOutputs <- filterM (\(x, _) -> derivationIsCompleted x) runningLocalBuilds
let anyBuildsFinished = not (null newCompletedOutputs)
when anyBuildsFinished (finishBuilds Localhost newCompletedOutputs)
pure anyBuildsFinished
data ProgressUpdate
= PlanDownloads (Set StorePath)
| PlanBuilds (Set Derivation)
| Evaluation
| Query
| Other
| Irrelevant
deriving stock (Show)
withChange :: (Functor f) => f b -> f Bool
withChange = (True <$)
withChange :: ProgressUpdate -> ProcessingT m b -> ProcessingT m Bool
withChange update action = do
current_state <- gets (.progressState)
new_progress_state <- case (current_state, update) of
(Planning store_paths derivations, PlanDownloads new_store_paths) -> pure (Planning (new_store_paths <> store_paths) derivations)
(Planning store_paths derivations, PlanBuilds new_derivations) -> pure (Planning store_paths (new_derivations <> derivations))
(_, PlanDownloads store_paths) -> pure (Planning store_paths mempty)
(_, PlanBuilds derivations) -> pure (Planning mempty derivations)
(Planning store_paths derivations, _) -> do
let store_paths_list = toList store_paths
derivations_list = toList derivations
lookupDerivations derivations_list >>= (\p -> planBuilds p) . fromList
forM store_paths_list (\s -> lookupStorePath s) >>= (\p -> planDownloads p) . fromList
pure Realising
(_, Evaluation) -> pure Evaluating
(Evaluating, Query) -> pure QueryingSubstituers
_ -> pure current_state
let change = case (current_state, update) of
(JustStarted, _) -> True
(_, Irrelevant) -> False
_ -> True
when (change && new_progress_state /= current_state) do
modify' (gfield @"progressState" .~ new_progress_state)
void action
pure change
noChange :: ProcessingT m Bool
noChange = withChange Irrelevant pass
noChange :: (Applicative f) => f Bool
noChange = pure False
processResult :: (UpdateMonad m) => NixOldStyleMessage -> ProcessingT m Bool
processResult result = do
now <- getNow
case result of
OldStyleMessage.Uploading path host -> withChange Other do
pathId <- lookupStorePath path
OldStyleMessage.Uploading path host -> withChange do
pathId <- getStorePathId path
uploaded host pathId now
OldStyleMessage.Downloading path host -> withChange Other do
pathId <- lookupStorePath path
OldStyleMessage.Downloading path host -> withChange do
pathId <- getStorePathId path
downloaded host pathId now
finishBuildByPathId host pathId
OldStyleMessage.PlanCopies _ -> noChange
OldStyleMessage.Build drvName host -> withChange Other do
OldStyleMessage.Build drvName host -> withChange do
building host drvName now Nothing
OldStyleMessage.PlanBuilds planned_builds _lastBuild -> withChange (PlanBuilds planned_builds) pass
OldStyleMessage.PlanDownloads _download _unpacked planned_downloads -> withChange (PlanDownloads planned_downloads) pass
OldStyleMessage.Checking drvName -> withChange Other do
OldStyleMessage.PlanBuilds plannedBuilds _lastBuild -> withChange do
plannedDrvIds <- forM (toList plannedBuilds) (\x -> lookupDerivation x)
planBuilds (fromList plannedDrvIds)
OldStyleMessage.PlanDownloads _download _unpacked plannedDownloads -> withChange do
plannedDownloadIds <- forM (toList plannedDownloads) (\x -> getStorePathId x)
planDownloads (fromList plannedDownloadIds)
OldStyleMessage.Checking drvName -> withChange do
building Localhost drvName now Nothing
OldStyleMessage.Failed drv code -> withChange Other do
OldStyleMessage.Failed drv code -> withChange do
drvId <- lookupDerivation drv
failedBuild now drvId code
@ -207,13 +201,22 @@ processJsonMessage = \case
let message' = encodeUtf8 message
tell [Right message']
case parseIndentedStoreObject message of
Just (Right download) -> withChange (PlanDownloads (one download)) pass
Just (Left build) -> withChange (PlanBuilds (one build)) pass
Just (Right download) ->
{-# SCC "plan_download" #-}
withChange do
plannedDownloadId <- getStorePathId download
planDownloads $ one plannedDownloadId
Just (Left build) ->
{-# SCC "plan_build" #-}
withChange do
plannedDrvId <- lookupDerivation build
planBuilds (one plannedDrvId)
_ -> noChange
Message MkMessageAction{message, level = Error}
| stripped <- stripANSICodes message
, Text.isPrefixOf "error:" stripped ->
withChange Other do
{-# SCC "pass_through_error" #-}
withChange do
errors <- gets (.nixErrors)
unless (any (Text.isInfixOf (Text.drop 7 stripped) . stripANSICodes) errors) do
modify' (gfield @"nixErrors" %~ (<> (message Seq.<| mempty)))
@ -221,56 +224,66 @@ processJsonMessage = \case
whenJust
(snd <$> parseOneText Parser.oldStyleParser (stripped <> "\n"))
(\old_style_parse_result -> void $ processResult old_style_parse_result)
Message MkMessageAction{message} | Just suffix <- Text.stripPrefix "evaluating file '" message -> withChange Evaluation do
Message MkMessageAction{message} | Just suffix <- Text.stripPrefix "evaluating file '" message -> withChange do
let file_name = Text.dropEnd 1 suffix
now <- getNow
modify' (gfield @"evaluationState" %~ \old -> old{count = old.count + 1, lastFileName = Strict.Just file_name, at = now})
Result MkResultAction{result = BuildLogLine line, id = id'} ->
{-# SCC "pass_through_build_line" #-}
do
nomState <- get
prefix <- activityPrefix ((.activity) <$> IntMap.lookup id'.value nomState.activities)
tell [Right (encodeUtf8 (prefix <> line))]
noChange
Result MkResultAction{result = SetPhase phase, id = id'} ->
withChange Other $ modify' (gfield @"activities" %~ IntMap.adjust (gfield @"phase" .~ Strict.Just phase) id'.value)
{-# SCC "updating_phase" #-} withChange $ modify' (gfield @"activities" %~ IntMap.adjust (gfield @"phase" .~ Strict.Just phase) id'.value)
Result MkResultAction{result = Progress progress, id = id'} ->
withChange Other $ modify' (gfield @"activities" %~ IntMap.adjust (gfield @"progress" .~ Strict.Just progress) id'.value)
Start startAction@MkStartAction{id = id'} -> do
prefix <- activityPrefix $ Just startAction.activity
when (not (Text.null startAction.text) && startAction.level <= Info) $ tell [Right . encodeUtf8 $ prefix <> startAction.text]
changed <- case startAction.activity of
JSON.Build drvName host -> withChange Other do
now <- getNow
building host drvName now (Just id')
JSON.CopyPath path from Localhost -> withChange Other do
now <- getNow
pathId <- lookupStorePath path
downloading from pathId now
JSON.CopyPath path Localhost to -> withChange Other do
now <- getNow
pathId <- lookupStorePath path
uploading to pathId now
JSON.Unknown | Text.isPrefixOf "querying info" startAction.text -> withChange Query pass
JSON.QueryPathInfo{} -> withChange Query pass
_ -> noChange -- tell [Right (encodeUtf8 (markup yellow "unused activity: " <> show startAction.id <> " " <> show startAction.activity))]
when changed $ modify' (gfield @"activities" %~ IntMap.insert id'.value (MkActivityStatus startAction.activity Strict.Nothing Strict.Nothing))
pure changed
Stop MkStopAction{id = id'} -> do
activity <- gets (\s -> IntMap.lookup id'.value s.activities)
case activity of
Just (MkActivityStatus{activity = JSON.CopyPath path from Localhost}) -> withChange Other do
now <- getNow
pathId <- lookupStorePath path
downloaded from pathId now
Just (MkActivityStatus{activity = JSON.CopyPath path Localhost to}) -> withChange Other do
now <- getNow
pathId <- lookupStorePath path
uploaded to pathId now
Just (MkActivityStatus{activity = JSON.Build drv host}) -> do
drvId <- lookupDerivation drv
isCompleted <- derivationIsCompleted drvId
if isCompleted then withChange Other $ finishBuildByDrvId host drvId else noChange
_ -> noChange
{-# SCC "updating_progress" #-} withChange $ modify' (gfield @"activities" %~ IntMap.adjust (gfield @"progress" .~ Strict.Just progress) id'.value)
Start startAction@MkStartAction{id = id'} ->
{-# SCC "starting_action" #-}
do
prefix <- activityPrefix $ Just startAction.activity
when (not (Text.null startAction.text) && startAction.level <= Info) $ tell [Right . encodeUtf8 $ prefix <> startAction.text]
let set_interesting = withChange do
now <- getNow
modify' (gfield @"interestingActivities" %~ IntMap.insert id'.value (MkInterestingUnknownActivity startAction.text now))
changed <- case startAction.activity of
JSON.Build drvName host -> withChange do
now <- getNow
building host drvName now (Just id')
JSON.CopyPath path from Localhost -> withChange do
now <- getNow
pathId <- getStorePathId path
downloading from pathId now
JSON.CopyPath path Localhost to -> withChange do
now <- getNow
pathId <- getStorePathId path
uploading to pathId now
JSON.Unknown | Text.isPrefixOf "querying info" startAction.text -> set_interesting
JSON.QueryPathInfo{} -> set_interesting
_ -> noChange -- tell [Right (encodeUtf8 (markup yellow "unused activity: " <> show startAction.id <> " " <> show startAction.activity))]
when changed $ modify' (gfield @"activities" %~ IntMap.insert id'.value (MkActivityStatus startAction.activity Strict.Nothing Strict.Nothing))
pure changed
Stop MkStopAction{id = id'} ->
{-# SCC "stoping_action" #-}
do
activity <- gets (\s -> IntMap.lookup id'.value s.activities)
interesting_activity <- gets (\s -> IntMap.lookup id'.value s.interestingActivities)
modify' (gfield @"interestingActivities" %~ IntMap.delete id'.value)
case activity of
Just (MkActivityStatus{activity = JSON.CopyPath path from Localhost}) -> withChange do
now <- getNow
pathId <- getStorePathId path
downloaded from pathId now
Just (MkActivityStatus{activity = JSON.CopyPath path Localhost to}) -> withChange do
now <- getNow
pathId <- getStorePathId path
uploaded to pathId now
Just (MkActivityStatus{activity = JSON.Build drv host}) -> do
drvId <- lookupDerivation drv
isCompleted <- derivationIsCompleted drvId
if isCompleted then withChange $ finishBuildByDrvId host drvId else noChange
_ -> pure (isJust interesting_activity)
Plain msg -> tell [Right msg] >> noChange
ParseError err -> tell [Left err] >> noChange
Result _other_result -> noChange
@ -333,22 +346,6 @@ failedBuild now drv code = updateDerivationState drv update
Building a -> State.Failed (a $> MkBuildFail now code)
x -> x
lookupStorePath :: StorePath -> ProcessingT m StorePathId
lookupStorePath !path = do
lookupProducers (one path) >>= (\derivations -> void $ lookupDerivations (toList derivations))
getStorePathId path
lookupProducers :: [StorePath] -> ProcessingT m [Derivation]
lookupProducers paths = do
storePathIds <- gets (.storePathIds)
let missing_paths =
paths
& filter (\path -> not $ Map.member path storePathIds)
getProducers missing_paths
lookupDerivations :: [Derivation] -> ProcessingT m [DerivationId]
lookupDerivations derivations = mapM (\derivation -> lookupDerivation derivation) derivations
lookupDerivation :: Derivation -> ProcessingT m DerivationId
lookupDerivation drv = do
drvId <- getDerivationId drv
@ -365,58 +362,38 @@ lookupDerivationInfos drvName = do
drvId <- lookupDerivation drvName
getDerivationInfos drvId
forceList :: [a] -> [a]
forceList [] = []
forceList (!a : rest) = a : forced_rest
where
!forced_rest = forceList rest
insertDerivation :: Nix.Derivation FilePath Text -> DerivationId -> ProcessingT m ()
insertDerivation nix_derivation drvId = do
insertDerivation derivation drvId = do
-- We need to be really careful in this function. The Nix.Derivation keeps the
-- read-in derivation file in memory. When using Texts from it we must make
-- sure we destroy sharing with the original file, so that it can be garbage
-- collected.
let !unshared_outputs =
nix_derivation.outputs
& Map.mapKeys (parseOutputName . Text.copy)
& Map.mapMaybe (parseStorePath . toText . Nix.path)
!unshared_inputSrcs =
nix_derivation.inputSrcs
& toList
& mapMaybe (parseStorePath . toText)
& Set.fromList
unshared_inputDrvs :: [(Derivation, Set OutputName)]
!unshared_inputDrvs =
nix_derivation.inputDrvs
& Map.toList
& mapMaybe
( \(drvPath, outputs_of_input) ->
let !unshared_outputs_of_input = Set.map (parseOutputName . Text.copy) outputs_of_input
in (,unshared_outputs_of_input) <$> parseDerivation (toText drvPath)
)
& forceList
!unshared_platform = Strict.Just (Text.copy nix_derivation.platform)
!unshared_pname = Strict.toStrict (Text.copy <$> Map.lookup "pname" nix_derivation.env)
outputs <-
unshared_outputs & Map.traverseWithKey \_ pathName -> do
pathId <- getStorePathId pathName
modify' (gfield @"storePathInfos" %~ CMap.adjust (gfield @"producer" .~ Strict.Just drvId) pathId)
pure pathId
derivation.outputs & Map.mapKeys (parseOutputName . Text.copy) & Map.traverseMaybeWithKey \_ path ->
parseStorePath (toText (Nix.path path)) & mapM \pathName -> do
pathId <- getStorePathId pathName
modify' (gfield @"storePathInfos" %~ CMap.adjust (gfield @"producer" .~ Strict.Just drvId) pathId)
pure pathId
inputSources <-
unshared_inputSrcs & flip foldlM mempty \acc pathName -> do
pathId <- getStorePathId pathName
modify' (gfield @"storePathInfos" %~ CMap.adjust (gfield @"inputFor" %~ CSet.insert drvId) pathId)
pure $ CSet.insert pathId acc
derivation.inputSrcs & flip foldlM mempty \acc path -> do
pathIdMay <-
parseStorePath (toText path) & mapM \pathName -> do
pathId <- getStorePathId pathName
modify' (gfield @"storePathInfos" %~ CMap.adjust (gfield @"inputFor" %~ CSet.insert drvId) pathId)
pure pathId
pure $ maybe id CSet.insert pathIdMay acc
inputDerivationsList <-
unshared_inputDrvs & mapM \(dep_name, outputs_of_input) -> do
depId <- lookupDerivation dep_name
modify' (gfield @"derivationInfos" %~ CMap.adjust (gfield @"derivationParents" %~ CSet.insert drvId) depId)
modify' (gfield @"forestRoots" %~ Seq.filter (/= depId))
pure (MkInputDerivation{derivation = depId, outputs = outputs_of_input})
derivation.inputDrvs & Map.toList & mapMaybeM \(drvPath, outputs_of_input) -> do
depIdMay <-
parseDerivation (toText drvPath) & mapM \depName -> do
depId <- lookupDerivation depName
modify' (gfield @"derivationInfos" %~ CMap.adjust (gfield @"derivationParents" %~ CSet.insert drvId) depId)
modify' (gfield @"forestRoots" %~ Seq.filter (/= depId))
pure depId
pure $ (\derivation_id -> MkInputDerivation{derivation = derivation_id, outputs = Set.map (parseOutputName . Text.copy) outputs_of_input}) <$> depIdMay
let inputDerivations = Seq.fromList inputDerivationsList
modify'
modify
( gfield @"derivationInfos"
%~ CMap.adjust
( \derivation_info ->
@ -425,8 +402,8 @@ insertDerivation nix_derivation drvId = do
, inputSources
, inputDerivations
, cached = True
, platform = unshared_platform
, pname = unshared_pname
, platform = Strict.Just (Text.copy derivation.platform)
, pname = Strict.toStrict (Text.copy <$> Map.lookup "pname" derivation.env)
}
)
drvId
@ -495,7 +472,7 @@ updateDerivationState drvId updateStatus = do
clear_summary = clearDerivationIdFromSummary oldStatus drvId
-- Update summaries of all parents and sort them
updateParents False update_summary clear_summary derivation_infos.derivationParents
updateParents False update_summary clear_summary (derivation_infos.derivationParents)
-- Update fullSummary
modify' (gfield @"fullSummary" %~ update_summary)
@ -504,7 +481,7 @@ updateParents :: Bool -> (DependencySummary -> DependencySummary) -> (Dependency
updateParents force_direct update_func clear_func direct_parents = do
relevant_parents <- (if force_direct then CSet.union direct_parents else id) <$> collect_parents True mempty direct_parents
parents <- collect_parents False mempty direct_parents
modify'
modify
( gfield @"derivationInfos"
%~ apply_to_all_summaries update_func relevant_parents
. apply_to_all_summaries clear_func (CSet.difference parents relevant_parents)

View File

@ -11,17 +11,17 @@ module NOM.Update.Monad (
import Control.Exception (try)
import Control.Monad.Trans.Writer.CPS (WriterT)
-- attoparsec
import Data.Attoparsec.Text (eitherResult, parse)
import Data.Text qualified as Text
import Data.Text.IO qualified as TextIO
import GHC.Clock qualified
import NOM.Builds (Derivation, StorePath, parseDerivation)
import NOM.Builds (Derivation, StorePath)
import NOM.Error (NOMError (..))
import NOM.Update.Monad.CacheBuildReports
-- nix-derivation
import Nix.Derivation qualified as Nix
import Relude
import System.Directory (doesPathExist)
import System.Process.Typed qualified as Process
type UpdateMonad m = (Monad m, MonadNow m, MonadReadDerivation m, MonadCacheBuildReports m, MonadCheckStorePath m)
@ -41,7 +41,7 @@ class (Monad m) => MonadReadDerivation m where
getDerivation :: Derivation -> m (Either NOMError (Nix.Derivation FilePath Text))
instance MonadReadDerivation IO where
getDerivation = do
getDerivation =
fmap
( first DerivationReadError
>=> first (DerivationParseError . toText)
@ -63,35 +63,15 @@ instance (MonadReadDerivation m) => MonadReadDerivation (WriterT a m) where
class (Monad m) => MonadCheckStorePath m where
storePathExists :: StorePath -> m Bool
getProducers :: [StorePath] -> m [Derivation]
instance MonadCheckStorePath IO where
storePathExists = doesPathExist . toString
getProducers = \case
[] -> pure mempty
paths -> do
(exit_code, producer_bs) <-
Process.readProcessStdout
$ Process.setStdin Process.nullStream
$ Process.setStderr Process.nullStream
$ Process.proc "nix" (["path-info", "--derivation"] <> fmap toString paths)
pure
if Process.ExitSuccess == exit_code
then
producer_bs
& decodeUtf8
& Text.strip
& Text.lines
& mapMaybe parseDerivation
else mempty
instance (MonadCheckStorePath m) => MonadCheckStorePath (StateT a m) where
storePathExists = lift . storePathExists
getProducers = lift . getProducers
instance (MonadCheckStorePath m) => MonadCheckStorePath (WriterT a m) where
storePathExists = lift . storePathExists
getProducers = lift . getProducers
instance (MonadState s m) => MonadState s (WriterT w m) where
get = lift get

View File

@ -84,7 +84,6 @@ common common-config
, text
, time
, transformers
, typed-process
, word8
default-language: GHC2021