Release a multitude of fixes

nixos/roles/laminar/default.nix

@@ -36,6 +36,9 @@ in {
           PATH=${lib.makeBinPath [ pkgs.laminar pkgs.nix ]}:$PATH nix-jobs realise-here "$DERIVATION"
         '';
       };
+      contexts = {
+        "default.conf" = builtins.toFile "default.conf" "EXECUTORS=16";
+      };
     };
     users = {
       groups.laminar = { };

nixos/roles/laminar/kassandra.nix

@@ -9,8 +9,10 @@ let
     ${setup}
     export HOME=$PWD
     git clone git@localhost:kassandra2 kassandra
+    cd kassandra
+    git show -q
     echo "Evaluating nix-expression."
-    drv=$(readlink -f $(nix-instantiate kassandra/release.nix -A ${name} --add-root ./drv --indirect))
+    drv=$(readlink -f $(nix-instantiate release.nix -A ${name} --add-root ./drv --indirect))
     echo "Evaluation done."
     nix-jobs realise $drv
   '';

nixos/roles/laminar/nix-jobs.hs

@@ -11,13 +11,15 @@
 {-# OPTIONS_GHC -Wall -Werror -Wno-missing-signatures -Wno-type-defaults -Wno-orphans #-}
 
 import           Control.Concurrent             ( threadDelay )
-import           Control.Concurrent.Async       ( forConcurrently_ )
+import           Control.Concurrent.Async       ( forConcurrently_
+                                                , race_
+                                                , withAsync
+                                                )
 import           Control.Concurrent.STM         ( check )
 import           Control.Exception              ( bracket
                                                 , catch
                                                 , handle
                                                 , handleJust
-                                                , mapException
                                                 , throwIO
                                                 )
 import           Data.Bits                      ( Bits((.|.)) )
@@ -28,6 +30,9 @@ import           Data.Text                      ( isInfixOf
                                                 , strip
                                                 )
 import qualified Data.Text                     as T
+import           Data.Time                      ( diffUTCTime
+                                                , getCurrentTime
+                                                )
 import           Relude
 import           Say                            ( say
                                                 , sayErr
@@ -42,6 +47,7 @@ import           Shh                            ( (&!>)
                                                 )
 import           System.Directory               ( createDirectoryIfMissing
                                                 , doesFileExist
+                                                , getModificationTime
                                                 , removeFile
                                                 )
 import           System.Environment             ( getArgs )
@@ -93,6 +99,18 @@ whenSelf level = when (level >= Self)
 whenChildren level = when (level >= Children)
 levelPrec Children = Self
 levelPrec _        = None
+
+drvBasename derivationName =
+  fromMaybe derivationName . viaNonEmpty last $ splitOn "/" derivationName
+
+workspace, resultDir, runningDir :: String
+workspace = "/var/lib/laminar/run/nix-build/workspace"
+resultDir = [i|#{workspace}/completed-jobs|]
+runningDir = [i|#{workspace}/running-jobs|]
+runningPath, resultPath :: Text -> String
+runningPath p = [i|#{runningDir}/#{drvBasename p}|]
+resultPath p = [i|#{resultDir}/#{drvBasename p}|]
+
 getDependenciesFromNix :: Text -> IO (Seq Text)
 getDependenciesFromNix derivationName = do
   everythingToDo <- nixStoreRealiseDryRun derivationName
@@ -136,7 +154,7 @@ ensureDeps :: ReportLevel -> Text -> IO ()
 ensureDeps level derivationName = do
   dependencies <- getDependenciesFromNix derivationName
   whenChildren level $ forM_ dependencies $ \dep ->
-    say [i|Requiring build of #{dep}.|]
+    say [i|Requiring #{dep}.|]
   forConcurrently_ dependencies (realise $ levelPrec level)
     `catch` \(JobException e) ->
               throw [i|#{e}\nFailed dependency for #{derivationName}|]
@@ -172,90 +190,88 @@ tryQueue derivationName = getRunningJob derivationName >>= \case
   defaultMode =
     ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode
 
--- Nothing means a dependency failed.
 queueJobWithLaminarc :: ReportLevel -> Text -> IO Text
-queueJobWithLaminarc level derivationName = tryQueue derivationName >>= maybe
+queueJobWithLaminarc level derivationName =
-  (ensureRunningJob level derivationName)
+  whenNothingM (tryQueue derivationName) (ensureRunningJob level derivationName)
-  (\jobName -> jobName
-    <$ say [i|Job #{jobName} started for #{derivationName}. Waiting ...|]
-  )
 
 ensureRunningJob :: ReportLevel -> Text -> IO Text
-ensureRunningJob level derivationName = getRunningJob derivationName >>= maybe
+ensureRunningJob level derivationName = whenNothingM
+  (getRunningJob derivationName)
   (queueJobWithLaminarc level derivationName)
-  (\jobName -> jobName <$ whenSelf
-    level
-    (say [i|Job #{jobName} running for #{derivationName}. Waiting ...|])
-  )
-
-drvBasename derivationName =
-  fromMaybe derivationName . viaNonEmpty last $ splitOn "/" derivationName
-
-workspace, resultDir, runningDir :: String
-workspace = "/var/lib/laminar/run/nix-build/workspace"
-resultDir = [i|#{workspace}/completed-jobs|]
-runningDir = [i|#{workspace}/running-jobs|]
-runningPath :: Text -> String
-runningPath p = [i|#{runningDir}/#{drvBasename p}|]
-resultPath :: Text -> String
-resultPath p = [i|#{resultDir}/#{drvBasename p}|]
 
 -- Nothing means there is no running Job.
 getRunningJob :: Text -> IO (Maybe Text)
-getRunningJob p = do
+getRunningJob derivationName = poll
-  let path = runningPath p
+ where
-  pathExists <- doesFileExist path
+  path    = runningPath derivationName
-  if pathExists
+  request = do
-    then
+    pathExists <- doesFileExist path
-      handleJust (guard . isDoesNotExistError) (const $ pure Nothing)
+    if pathExists
-      $   Just
+      then
-      <$> readFileText path
+        handleJust (guard . isDoesNotExistError) (const $ pure Nothing)
-    else pure Nothing
+        $   Just
+        <$> readFileText path
+      else pure Nothing
+  poll = go 0
+   where
+    go count = do
+      mayJob <- request
+      if count < 50 && mayJob == Just ""
+        then threadDelay 10000 >> go (count + 1)
+        else pure mayJob
 
 realise :: ReportLevel -> Text -> IO ()
 realise level derivationName = do
   ensureDeps level derivationName
   jobName <- ensureRunningJob level derivationName
+  whenSelf level
+    $ say [i|Job #{jobName} running for #{derivationName}. Waiting ...|]
   handle
       (\(WaitException e) -> do
-        sayErr
+        whenSelf level
-          [i|Retrying to find or create a job for #{derivationName} after waiting for job failed with error "#{e}" |]
+          $ sayErr
+              [i|Retrying to find or create a job for #{derivationName} after waiting for job failed with error "#{e}" |]
         realise level derivationName
       )
     $ do
         waitForJob derivationName >>= \case
           Success -> whenSelf level
-            $ say [i|Job #{jobName} completed build for #{derivationName}.|]
+            $ say [i|Job #{jobName} completed #{derivationName}.|]
-          Failure -> throw [i|Job #{jobName} failed build #{derivationName}.|]
+          Failure -> throw [i|Job #{jobName} failed #{derivationName}.|]
+
+checkStaleness :: Text -> IO ()
+checkStaleness derivationName = forever $ do
+  whenJustM (getRunningJob derivationName) $ \jobName ->
+    handleJust (guard . isDoesNotExistError) (const pass) $ do
+      nothingQueued <-
+        T.null . decodeUtf8 <$> (laminarc "show-queued" |> captureTrim)
+      knownJobs <-
+        fmap strip
+        .   lines
+        .   decodeUtf8
+        <$> (laminarc "show-running" |> captureTrim)
+      now      <- getCurrentTime
+      fileTime <- getModificationTime (runningPath derivationName)
+      let notRunning = not $ any (`isInfixOf` jobName) knownJobs
+          oldEnough  = diffUTCTime now fileTime > 60
+          stale      = notRunning && nothingQueued && oldEnough
+      when stale $ do
+        removeFile (runningPath derivationName)
+        throwWait
+          [i|File #{runningPath derivationName} claiming job name "#{jobName}" seems to be stale. Deleting File.|]
+  threadDelay 10000000
 
 waitForJob :: Text -> IO JobResult
 waitForJob derivationName = do
   done <- newTVarIO False
   let finished = atomically (writeTVar done True)
-      getJob = go 0
-       where
-        go count = do
-          mayJob <- mapException (\(e :: JobException) -> (coerce e :: WaitException))
-             <$> getRunningJob derivationName
-          if count < 50 && mayJob == Just ""
-            then threadDelay 100 >> go (count + 1)
-            else pure mayJob
   withManager $ \manager -> do
-    _        <- watchDir manager runningDir fileDeleted (const finished)
+    _ <- watchDir manager runningDir fileDeleted (const finished)
-    mayJob <- getJob
+    withAsync
-    whenNothing_ mayJob finished
+      (whenNothingM_ (getRunningJob derivationName) finished)
-    whenJust mayJob $ \jobName -> do
+      (const $ race_ (atomically $ readTVar done >>= check)
-      runningJobs <-
+                     (checkStaleness derivationName)
-        fmap strip
+      )
-        .   lines
-        .   decodeUtf8
-        <$> (laminarc "show-running" |> captureTrim)
-      unless (any (`isInfixOf` jobName) runningJobs) $ do
-        handleJust (guard . isDoesNotExistError) (const pass)
-          $ removeFile (runningPath derivationName)
-        throwWait
-          [i|File #{runningPath derivationName} is stale. It contains the job name "#{jobName}", but running jobs are only #{runningJobs}. Deleting File.|]
-    atomically $ readTVar done >>= check
   resultText <-
     handleJust
         (guard . isDoesNotExistError)