Revert "Lookup storePath producers and better activity reporting"

This reverts commit 7e6d28c2d5.
This reverts commit 90fd896e82.

.hlint.yaml

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

default.nix

@@ -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

lib/NOM/Print.hs

@@ -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

lib/NOM/State.hs

@@ -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

lib/NOM/Update.hs

@@ -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 haven‘t 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)

lib/NOM/Update/Monad.hs

@@ -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

nix-output-monitor.cabal

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