Improve laminar nix-jobs

nixos/roles/git.nix

@@ -28,8 +28,8 @@ let
         git "push" "--all" "-f" mirror
       jobMay <- lookupEnv "GL_OPTION_CI_JOB"
       whenJust jobMay $ \job -> do
-        say "Queuing job:"
+        jobName <- decodeUtf8 <$> (laminarc "queue" job |> captureTrim)
-        laminarc "queue" job
+        say [i|Queued job #{jobName}.\nSee https://ci.maralorn.de/jobs/#{T.replace ":" "/" jobName}|]
       deployMay <- lookupEnv "GL_OPTION_WEB_DEPLOY"
       whenJust deployMay $ \deploy -> do
         (maybe [] (\x -> ["-A", x]) -> target) <- lookupEnv "GL_OPTION_WEB_DEPLOY_NIX_TARGET"

nixos/roles/laminar/default.nix

@@ -33,7 +33,7 @@ in {
       jobs = {
         "nix-build.run" = pkgs.writeShellScript "nix-build" ''
           set -e
-          nix-jobs realize-here "$DERIVATION"
+          PATH=${lib.makeBinPath [ pkgs.laminar pkgs.nix ]}:$PATH nix-jobs realise-here "$DERIVATION"
         '';
       };
     };

nixos/roles/laminar/kassandra.nix

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

nixos/roles/laminar/nix-jobs.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -6,40 +7,52 @@
 {-# LANGUAGE ExtendedDefaultRules #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# 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_ )
-import           Control.Exception              ( IOException
+import           Control.Concurrent.STM         ( check )
-                                                , bracket
+import           Control.Exception              ( bracket
                                                 , catch
                                                 , handle
+                                                , handleJust
+                                                , mapException
+                                                , throwIO
                                                 )
 import           Data.Bits                      ( Bits((.|.)) )
 import qualified Data.Sequence                 as Seq
 import           Data.String.Interpolate        ( i )
+import           Data.Text                      ( isInfixOf
+                                                , splitOn
+                                                , strip
+                                                )
 import qualified Data.Text                     as T
 import           Relude
 import           Say                            ( say
                                                 , sayErr
                                                 )
-import           Shh                            ( ExecArg
+import           Shh                            ( (&!>)
+                                                , ExecArg(..)
                                                 , ExecReference(Absolute)
+                                                , Stream(StdOut)
                                                 , captureTrim
                                                 , load
                                                 , (|>)
                                                 )
-import           System.Directory               ( doesFileExist
+import           System.Directory               ( createDirectoryIfMissing
+                                                , doesFileExist
                                                 , removeFile
                                                 )
-import           System.Environment             ( getArgs
+import           System.Environment             ( getArgs )
-                                                , getEnv
-                                                )
 import           System.FSNotify                ( Event(Removed)
-                                                , stopManager
                                                 , watchDir
                                                 , withManager
                                                 )
+import           System.IO                      ( BufferMode(LineBuffering)
+                                                , hSetBuffering
+                                                )
+import           System.IO.Error
 import           System.Posix.Files             ( groupReadMode
                                                 , otherReadMode
                                                 , ownerReadMode
@@ -58,191 +71,218 @@ load Absolute ["laminarc", "nix-store"]
 
 data JobResult = Success | Failure deriving (Show, Read, Eq, Ord, Enum)
 
+data ReportLevel = None | Self | Children deriving (Show, Eq, Ord, Enum)
+
+newtype JobException = JobException Text deriving (Show, Exception)
+throw = throwIO . JobException
+newtype WaitException = WaitException Text deriving (Show, Exception)
+throwWait = throwIO . WaitException
+
 instance Semigroup JobResult where
   Success <> Success = Success
   _       <> _       = Failure
 
 instance Monoid JobResult where
   mempty = Success
--- 2 Entry points
--- 1. Realise i.e. "wait-for-and-trigger-build-if-necessary"
--- 2. Job i.e. "the actual realisation"
 
 instance ExecArg Text where
+  asArg         = asArg . toString
+  asArgFromList = asArgFromList . fmap toString
 
+whenSelf level = when (level >= Self)
+whenChildren level = when (level >= Children)
+levelPrec Children = Self
+levelPrec _        = None
 getDependenciesFromNix :: Text -> IO (Seq Text)
 getDependenciesFromNix derivationName = do
   everythingToDo <- nixStoreRealiseDryRun derivationName
   pure (Seq.filter (/= derivationName) everythingToDo)
 
 nixStoreRealiseDryRun :: Text -> IO (Seq Text)
-nixStoreRealiseDryRun derivationName =
+nixStoreRealiseDryRun derivationName = do
-  process <$> (nix_store "-r" derivationName "--dry-run" |> captureTrim)
+  process
+    <$> (nix_store "-r" derivationName "--dry-run" &!> StdOut |> captureTrim)
  where
   process =
     fromList
+      . drop 1
       . dropWhile (/= "these derivations will be built:")
-      . fmap T.strip
+      . fmap strip
       . lines
       . decodeUtf8
 
 job :: Text -> IO ()
 job derivationName = do
-  say [i|Initiating realisation for #{derivationName}.|]
+  say [i|Building #{derivationName}.|]
-  pathInfo <- getPathInfo derivationName
   let setResult result = do
-        writeFileText (resultPath pathInfo) (show result)
+        createDirectoryIfMissing True resultDir
-        removeFile (runningPath pathInfo)
+        writeFileText (resultPath derivationName) (show result)
-  ensureDeps True derivationName >>= \case
+        removeFile (runningPath derivationName)
-    Success -> do
+  ensureDeps Children derivationName
-      say [i|All dependencies provided, starting build for #{derivationName}.|]
+  catch
-      catch
+    (nixStoreRealise derivationName)
-        (nixStoreRealise derivationName)
+    (\(err :: SomeException) -> do
-        (\(err :: SomeException) -> do
+      setResult Failure
-          setResult Failure
+      sayErr [i|nix-build failed with error #{err}.|]
-          sayErr [i|nix-build failed with error #{err}.|]
+      exitFailure
-          exitFailure
+    )
-        )
+  setResult Success
-      setResult Success
+  say [i|Build for #{derivationName} successful.|]
-      say [i|Build for #{derivationName} successful. Finishing.|]
-    Failure -> do
-      sayErr
-        [i|Couldn‘t build #{derivationName} because of failing dependency.|]
 
 nixStoreRealise :: Text -> IO ()
 nixStoreRealise = nix_store "-r"
 
-ensureDeps :: Bool -> Text -> IO JobResult
+ensureDeps :: ReportLevel -> Text -> IO ()
-ensureDeps topLevel derivationName = do
+ensureDeps level derivationName = do
   dependencies <- getDependenciesFromNix derivationName
-  when topLevel $ forM_ dependencies $ \dep ->
+  whenChildren level $ forM_ dependencies $ \dep ->
     say [i|Requiring build of #{dep}.|]
-  fold <$> forConcurrently dependencies (realise topLevel)
+  forConcurrently_ dependencies (realise $ levelPrec level)
+    `catch` \(JobException e) ->
+              throw [i|#{e}\nFailed dependency for #{derivationName}|]
 
 -- Nothing means failing to acquire lock on the derivation name for starting the job.
-tryQueue :: PathInfo -> IO (Maybe Text)
+tryQueue :: Text -> IO (Maybe Text)
-tryQueue pathInfo@(_, _, derivationName) = getRunningJob pathInfo >>= \case
+tryQueue derivationName = getRunningJob derivationName >>= \case
-  Nothing -> handle handleIOException $ bracket openNewFile closeFd $ \fd -> do
+  Nothing -> do
-    jobName <-
+    createDirectoryIfMissing True runningDir
-      decodeUtf8
+    handleJust (\x -> if isAlreadyExistsError x then Just x else Nothing)
-        <$> (  laminarc "queue" "nix-build" ([i|DERIVATION=#{derivationName}|] :: Text)
+               (const (pure Nothing))
-            |> captureTrim
+      $ bracket openNewFile closeFd
-            )
+      $ \fd -> do
-    writeCount <- fdWrite fd (toString jobName)
+          jobName <-
-    when (writeCount == 0) $ sayErr
+            decodeUtf8
-      [i|Wrote 0 bytes of jobName "#{jobName}" to #{runningPath pathInfo}|]
+              <$> (  laminarc "queue"
-    pure (Just jobName)
+                              "nix-build"
+                              ([i|DERIVATION=#{derivationName}|] :: Text)
+                  |> captureTrim
+                  )
+          when (T.null jobName) $ throw [i|Laminarc returned an empty jobName.|]
+          writeCount <- fdWrite fd (toString jobName)
+          when (writeCount == 0)
+            $ throw
+                [i|Wrote 0 bytes of jobName "#{jobName}" to #{runningPath derivationName}|]
+          pure . Just $ jobName
   Just _ -> pure Nothing
  where
-  openNewFile = openFd (runningPath pathInfo)
+  openNewFile = openFd (runningPath derivationName)
                        WriteOnly
                        (Just defaultMode)
                        defaultFileFlags { exclusive = True }
   defaultMode =
     ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode
-  handleIOException :: IOException -> IO (Maybe Text)
-  handleIOException _ = pure Nothing
 
 -- Nothing means a dependency failed.
-queueJobWithLaminarc :: Bool -> PathInfo -> IO (Maybe Text)
+queueJobWithLaminarc :: ReportLevel -> Text -> IO Text
-queueJobWithLaminarc topLevel pathInfo@(_, _, derivationName) =
+queueJobWithLaminarc level derivationName = tryQueue derivationName >>= maybe
-  tryQueue pathInfo >>= \case
+  (ensureRunningJob level derivationName)
-    Nothing -> ensureRunningJob topLevel pathInfo
+  (\jobName -> jobName
-    a       -> do
+    <$ say [i|Job #{jobName} started for #{derivationName}. Waiting ...|]
-      say [i|Queued build job ${jobName} for #{derivationName}.|]
+  )
-      pure a
 
-ensureRunningJob :: Bool -> PathInfo -> IO (Maybe Text)
+ensureRunningJob :: ReportLevel -> Text -> IO Text
-ensureRunningJob topLevel pathInfo@(_, _, derivationName) =
+ensureRunningJob level derivationName = getRunningJob derivationName >>= maybe
-  getRunningJob pathInfo >>= \case
+  (queueJobWithLaminarc level derivationName)
-    Nothing -> do
+  (\jobName -> jobName <$ whenSelf
-      ensureDeps False derivationName >>= \case
+    level
-        Success -> queueJobWithLaminarc topLevel pathInfo
+    (say [i|Job #{jobName} running for #{derivationName}. Waiting ...|])
-        Failure -> do
+  )
-          sayErr
-            [i|Could not realise #{derivationName} because of failed dependency.|]
-          pure Nothing
-    Just jobName -> do
-      when topLevel
-        $ say [i|Waiting for job #{jobName} running for #{derivationName}|]
-      pure (Just jobName)
 
+drvBasename derivationName =
+  fromMaybe derivationName . viaNonEmpty last $ splitOn "/" derivationName
 
-type PathInfo = (Text, Text, Text)
+workspace, resultDir, runningDir :: String
-
+workspace = "/var/lib/laminar/run/nix-build/workspace"
-getPathInfo :: Text -> IO PathInfo
+resultDir = [i|#{workspace}/completed-jobs|]
-getPathInfo derivationName = do
+runningDir = [i|#{workspace}/running-jobs|]
-  workSpace <- toText <$> getEnv "WORKSPACE"
+runningPath :: Text -> String
-  (workSpace, , derivationName)
+runningPath p = [i|#{runningDir}/#{drvBasename p}|]
-    .   decodeUtf8
+resultPath :: Text -> String
-    <$> (nix_store "-q" "--hash" derivationName |> captureTrim)
+resultPath p = [i|#{resultDir}/#{drvBasename p}|]
-
-runningDir :: PathInfo -> String
-runningDir (workSpace, _, _) = [i|#{workSpace}/running-jobs|]
-runningPath :: PathInfo -> String
-runningPath (workSpace, drvHash, _) = [i|#{workSpace}/running-jobs/#{drvHash}|]
-resultPath :: PathInfo -> String
-resultPath (workSpace, drvHash, _) =
-  [i|#{workSpace}/completed-jobs/#{drvHash}|]
 
 -- Nothing means there is no running Job.
-getRunningJob :: PathInfo -> IO (Maybe Text)
+getRunningJob :: Text -> IO (Maybe Text)
 getRunningJob p = do
   let path = runningPath p
   pathExists <- doesFileExist path
   if pathExists
-    then catch (Just <$> readFileText path)
+    then
-               (\(_ :: IOException) -> getRunningJob p)
+      handleJust (guard . isDoesNotExistError) (const $ pure Nothing)
+      $   Just
+      <$> readFileText path
     else pure Nothing
 
-realise :: Bool -> Text -> IO JobResult
+realise :: ReportLevel -> Text -> IO ()
-realise topLevel derivationName = do
+realise level derivationName = do
-  pathInfo   <- getPathInfo derivationName
+  ensureDeps level derivationName
-  jobNameMay <- ensureRunningJob topLevel pathInfo
+  jobName <- ensureRunningJob level derivationName
-  case jobNameMay of
+  handle
-    Just jobName -> do
+      (\(WaitException e) -> do
-      result <- waitForJob pathInfo
+        sayErr
-      case result of
+          [i|Retrying to find or create a job for #{derivationName} after waiting for job failed with error "#{e}" |]
-        Success -> when topLevel
+        realise level derivationName
-          $ say [i|#{derivationName} succesfully realised by job #{jobName}|]
+      )
-        Failure -> sayErr [i|#{derivationName} failed in job #{jobName}|]
+    $ do
-      pure result
+        waitForJob derivationName >>= \case
-    Nothing -> pure Failure
+          Success -> whenSelf level
+            $ say [i|Job #{jobName} completed build for #{derivationName}.|]
+          Failure -> throw [i|Job #{jobName} failed build #{derivationName}.|]
 
-waitForJob :: PathInfo -> IO JobResult
+waitForJob :: Text -> IO JobResult
-waitForJob pathInfo = do
+waitForJob derivationName = do
-  _ <- withManager $ \manager -> do
+  done <- newTVarIO False
-    _ <- watchDir manager
+  let finished = atomically (writeTVar done True)
-                  (runningDir pathInfo)
+      getJob = go 0
-                  fileDeleted
+       where
-                  (const $ stopManager manager)
+        go count = do
-    maybeJob <- getRunningJob pathInfo
+          mayJob <- mapException (\(e :: JobException) -> (coerce e :: WaitException))
-    whenNothing_ maybeJob $ stopManager manager
+             <$> getRunningJob derivationName
-    forever $ threadDelay 1000000
+          if count < 50 && mayJob == Just ""
-  readFileText (resultPath pathInfo)
+            then threadDelay 100 >> go (count + 1)
-    >>= (\case
+            else pure mayJob
-          Nothing -> do
+  withManager $ \manager -> do
-            sayErr [i|Failed to parse result from #{resultPath pathInfo}|]
+    _        <- watchDir manager runningDir fileDeleted (const finished)
-            pure Failure
+    mayJob <- getJob
-          Just a -> pure a
+    whenNothing_ mayJob finished
+    whenJust mayJob $ \jobName -> do
+      runningJobs <-
+        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)
+        (const $ throwWait
+          [i|Job result file #{resultPath derivationName} does not exist.|]
         )
-    .   readMaybe
+      $ readFile (resultPath derivationName)
-    .   toString
+  maybe
+      (throwWait [i|Failed to parse result from #{resultPath derivationName}.|])
+      pure
+    . readMaybe
+    . toString
+    $ resultText
  where
-  fileDeleted (Removed a _ _) | a == runningPath pathInfo = True
+  fileDeleted (Removed a _ _) | a == runningPath derivationName = True
   fileDeleted _ = False
 
 
 main :: IO ()
 main = do
+  hSetBuffering stdout LineBuffering
   whenNotNullM missingExecutables $ \x -> do
     sayErr [i|Missing executables #{show x}|]
     exitFailure
   args <- fmap toText <$> getArgs
   case args of
     ["realise-here", derivationName] -> job derivationName
-    ["realise"     , derivationName] -> realise True derivationName >>= \case
+    ["realise"     , derivationName] -> realise Children derivationName
-      Success -> exitSuccess
-      Failure -> exitFailure
     _ ->
       sayErr "Usage: realise-here <derivationName> | realise <derivationName>"