Job building & status

.github/workflows/ci.yaml

@@ -10,7 +10,7 @@ jobs:
     runs-on: ${{ matrix.system }}
     strategy:
       matrix:
-        system: [x86_64-linux, aarch64-darwin, x86_64-darwin]
+        system: [x86_64-linux, aarch64-darwin]
     steps:
       - uses: actions/checkout@v4
       - name: Build all flake outputs

README.md

@@ -24,3 +24,12 @@ The project is currently in prototype phase. Contact [@srid](https://github.com/
 ## Roadmap
 
 TBD
+
+## Development
+
+```sh
+just run
+
+# Or, if you need to start from empty database (useful if you have changed the acid-state types)
+just resetdb run
+```

justfile

@@ -14,7 +14,7 @@ repl *ARGS:
 
 # Run the application, re-compiling if necessary.
 [group('1. vira')]
-run: resetdb
+run:
     vira-dev --no-server --tui=false
 
 # Run cabal tests (hspec)

nix/modules/flake-parts/devshell.nix

@@ -13,7 +13,6 @@
         just
         nixd
         ghciwatch
-        sqlite
       ];
     };
   };

src/Vira/App/AcidState.hs

@@ -36,3 +36,8 @@ update ::
 update event = do
   acid <- asks acid
   liftIO $ Acid.update acid event
+
+createCheckpoint :: (Reader AppState :> es, IOE :> es) => Eff es ()
+createCheckpoint = do
+  acid <- asks acid
+  liftIO $ Acid.createCheckpoint acid

src/Vira/App/LinkTo.hs

@@ -13,7 +13,6 @@ data LinkTo
   | RepoListing
   | Repo RepoName
   | RepoUpdate RepoName
-  | RepoBranchJobs RepoName BranchName
   | Build RepoName BranchName
   | About
 
@@ -23,6 +22,5 @@ linkShortTitle = \case
   RepoListing -> "Repos"
   Repo name -> toText . toString $ name
   RepoUpdate _ -> "Update" -- unused
-  RepoBranchJobs _ _ -> "Jobs" -- unused
   Build _ _ -> "Build" -- unused
   About -> "About"

src/Vira/Page/JobPage.hs

@@ -5,8 +5,8 @@ module Vira.Page.JobPage where
 import Effectful (Eff)
 import Effectful.Error.Static (throwError)
 import Effectful.Reader.Dynamic (asks)
+import GHC.IO.Exception (ExitCode (..))
 import Htmx.Servant.Response
-import Lucid
 import Servant hiding (throwError)
 import Servant.API.ContentTypes.Lucid (HTML)
 import Servant.Server.Generic (AsServer)
@@ -17,34 +17,21 @@ import Vira.State.Acid qualified as St
 import Vira.State.Core qualified as St
 import Vira.State.Type (RepoName)
 import Vira.Supervisor qualified as Supervisor
+import Vira.Supervisor.Type (TaskOutput (..))
 import Prelude hiding (ask, asks)
 
-data Routes mode = Routes
-  { -- List all jobs for a repo
-    _list :: mode :- Get '[HTML] (Html ())
-  , -- Trigger a new build
+newtype Routes mode = Routes
+  { -- Trigger a new build
     _build :: mode :- "new" :> Capture "branch" BranchName :> Post '[HTML] (Headers '[HXRefresh] Text)
   }
   deriving stock (Generic)
 
 handlers :: App.AppState -> RepoName -> Routes AsServer
 handlers cfg repoName = do
   Routes
-    { _list = App.runAppInServant cfg $ listHandler repoName
-    , _build = App.runAppInServant cfg . buildHandler repoName
+    { _build = App.runAppInServant cfg . buildHandler repoName
     }
 
-listHandler :: RepoName -> Eff App.AppServantStack (Html ())
-listHandler repoName = do
-  branches <- App.query $ St.GetBranchesByRepoA repoName
-  xs <- forM branches $ \branch -> do
-    jobs <- App.query $ St.GetJobsByBranchA repoName branch.branchName
-    pure (branch, jobs)
-  pure $ forM_ xs $ \(branch, jobs) -> do
-    h2_ $ toHtml $ "Jobs for " <> show @Text branch.branchName
-    ul_ $ forM_ jobs $ \job -> do
-      li_ $ toHtml $ show @Text job
-
 buildHandler :: RepoName -> BranchName -> Eff App.AppServantStack (Headers '[HXRefresh] Text)
 buildHandler repoName branch = do
   triggerNewBuild repoName branch >>= \case
@@ -60,9 +47,17 @@ triggerNewBuild repoName branchName = do
   branch <- App.query (St.GetBranchByNameA repoName branchName) >>= maybe (throwError err404) pure
   log Info $ "Building commit " <> show (repoName, branch.headCommit)
   asks App.supervisor >>= \supervisor -> do
+    job <- App.update $ St.AddNewJobA repoName branchName branch.headCommit
+    log Info $ "Added job " <> show job
     -- TODO We need a concept of 'working copy' to which source should be checked out. Then `nix build .` on that.
-    taskId <- Supervisor.startTask supervisor $ "nix build --no-link --print-out-paths " <> toString (gitFlakeUrl repo.cloneUrl) <> "/" <> toString branch.headCommit
-    -- TODO: Update db with new job
+    let cmd = "nix build -L --no-link --print-out-paths " <> toString (gitFlakeUrl repo.cloneUrl) <> "/" <> toString branch.headCommit
+    taskId <- Supervisor.startTask supervisor job.jobId cmd $ \taskOutput -> do
+      -- TODO: Set stdout
+      let status = case taskOutput.exitCode of
+            ExitSuccess -> St.JobFinished St.JobSuccess
+            ExitFailure _code -> St.JobFinished St.JobFailure
+      App.update $ St.JobUpdateStatusA job.jobId status $ toText taskOutput.output
+    App.update $ St.JobUpdateStatusA job.jobId St.JobRunning ""
     log Info $ "Started task " <> show taskId
   pure $ Just ()
   where

src/Vira/Page/RepoPage.hs

@@ -47,13 +47,16 @@ viewHandler name = do
   cfg <- ask
   repo <- App.query (St.GetRepoByNameA name) >>= maybe (throwError err404) pure
   branches <- App.query $ St.GetBranchesByRepoA name
+  xs <- forM branches $ \branch -> do
+    jobs <- App.query $ St.GetJobsByBranchA repo.name branch.branchName
+    pure (branch, jobs)
   pure
     $ W.layout
       cfg.linkTo
       (toHtml . toString $ name)
       (crumbs <> [LinkTo.Repo name])
     $ do
-      viewRepo cfg.linkTo repo branches
+      viewRepo cfg.linkTo repo xs
 
 updateHandler :: RepoName -> Eff App.AppServantStack (Headers '[HXRefresh] Text)
 updateHandler name = do
@@ -63,7 +66,7 @@ updateHandler name = do
   pure $ addHeader True "Ok"
 
 -- TODO: Can we use `HtmlT (ReaderT ..) ()` to avoid threading the linkTo function?
-viewRepo :: (LinkTo.LinkTo -> Link) -> St.Repo -> [St.Branch] -> Html ()
+viewRepo :: (LinkTo.LinkTo -> Link) -> St.Repo -> [(St.Branch, [St.Job])] -> Html ()
 viewRepo linkTo repo branches = do
   W.viraButton_
     [ hxPostSafe_ $ linkTo $ RepoUpdate repo.name
@@ -73,21 +76,40 @@ viewRepo linkTo repo branches = do
   div_ $ do
     p_ "To clone this repo"
     pre_ [class_ "bg-black text-white"] $ code_ $ toHtml $ "git clone " <> repo.cloneUrl
-    h2_ [class_ "text-2xl font-bold"] "Branches"
-    table_ $ do
-      forM_ branches $ \branch -> do
-        tr_ $ do
-          td_ $ b_ $ toHtml . toString $ branch.branchName
-          td_ $ do
-            let branchJobs = linkTo $ LinkTo.RepoBranchJobs repo.name branch.branchName
-            a_ [href_ $ show $ linkURI branchJobs] $
-              pre_ $
-                toHtml . toString $
-                  branch.headCommit
-          -- Add a button to trigger building of this commit
-          td_ $
-            W.viraButton_
-              [ hxPostSafe_ $ linkTo $ LinkTo.Build repo.name branch.branchName
-              , hxSwapS_ AfterEnd
-              ]
-              "Build"
+    h2_ [class_ "text-3xl font-bold my-8"] "Branches"
+    div_ [class_ "my-8"] $ do
+      forM_ branches $ \(branch, jobs) -> do
+        h2_ [class_ "text-2xl py-2 my-4 border-b-2"] $ code_ $ toHtml $ toString branch.branchName
+        "Head Commit: " <> viewCommit branch.headCommit
+        div_ $
+          W.viraButton_
+            [ hxPostSafe_ $ linkTo $ LinkTo.Build repo.name branch.branchName
+            , hxSwapS_ AfterEnd
+            ]
+            "Build"
+        ul_ $ forM_ jobs $ \job -> do
+          li_ [class_ "my-4 py-2"] $ do
+            viewJob job
+
+viewJob :: St.Job -> Html ()
+viewJob job = do
+  div_ [class_ "flex items-center justify-start space-x-4"] $ do
+    div_ [class_ "w-24"] $ b_ $ "Job #" <> toHtml (show @Text job.jobId)
+    viewCommit job.jobCommit
+    viewJobStatus job.jobStatus
+  div_ $ do
+    pre_ [class_ "bg-black text-white p-2 text-xs"] $ code_ $ do
+      toHtml job.jobLog
+
+viewCommit :: Git.CommitID -> Html ()
+viewCommit (Git.CommitID commit) = do
+  code_ [class_ "text-gray-700 hover:text-black"] $ toHtml commit
+
+viewJobStatus :: St.JobStatus -> Html ()
+viewJobStatus status = do
+  case status of
+    St.JobRunning -> span_ [class_ "text-blue-700"] "🚧 Running"
+    St.JobPending -> span_ [class_ "text-yellow-700"] "⏳ Pending"
+    St.JobFinished St.JobSuccess -> span_ [class_ "text-green-700"] "✅ Success"
+    St.JobFinished St.JobFailure -> span_ [class_ "text-red-700"] "❌ Failure"
+    St.JobKilled -> span_ [class_ "text-red-700"] "💀 Killed"

src/Vira/State/Acid.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}
 
 -- | acid-state implementation for Vira state
@@ -9,10 +11,12 @@ module Vira.State.Acid where
 import Data.Acid (Query, Update, makeAcidic)
 import Data.IxSet.Typed
 import Data.IxSet.Typed qualified as Ix
+import Data.List (maximum)
 import Data.Map.Strict qualified as Map
 import Data.SafeCopy (base, deriveSafeCopy)
 import Vira.Lib.Git (BranchName, CommitID)
 import Vira.State.Type
+import Vira.State.Type qualified as T
 
 {- | Application that gets persisted to disk through acid-state
 
@@ -55,12 +59,6 @@ getBranchByNameA repo branch = do
   ViraState {branches} <- ask
   pure $ Ix.getOne $ branches @= repo @= branch
 
--- | Get all jobs of a repo's branch
-getJobsByBranchA :: RepoName -> BranchName -> Query ViraState [Job]
-getJobsByBranchA repo branch = do
-  ViraState {jobs} <- ask
-  pure $ Ix.toList $ jobs @= repo @= branch
-
 -- | Set a repository
 setRepoA :: Repo -> Update ViraState ()
 setRepoA repo = do
@@ -77,14 +75,57 @@ setRepoBranchesA repo branches = do
       { branches = Ix.insertList (Map.toList branches <&> uncurry (Branch repo)) s.branches
       }
 
+-- | Get all jobs of a repo's branch
+getJobsByBranchA :: RepoName -> BranchName -> Query ViraState [Job]
+getJobsByBranchA repo branch = do
+  ViraState {jobs} <- ask
+  pure $ Ix.toList $ jobs @= repo @= branch
+
+-- | Create a new job returning it.
+addNewJobA :: RepoName -> BranchName -> CommitID -> Update ViraState Job
+addNewJobA jobRepo jobBranch jobCommit = do
+  jobs <- Ix.toList <$> gets jobs
+  let
+    jobId =
+      let ids = T.jobId <$> jobs
+       in if Prelude.null ids then JobId 1 else JobId 1 + maximum ids
+    jobStatus = JobPending
+    jobLog = ""
+    job = Job {..}
+  modify $ \s ->
+    s
+      { jobs = Ix.insert job s.jobs
+      }
+  pure job
+
+jobUpdateStatusA :: JobId -> JobStatus -> Text -> Update ViraState ()
+jobUpdateStatusA jobId status log = do
+  modify $ \s -> do
+    let job = fromMaybe (error $ "No such job: " <> show jobId) $ Ix.getOne $ s.jobs @= jobId
+    s
+      { jobs = Ix.updateIx jobId (job {jobStatus = status, jobLog = log}) s.jobs
+      }
+
+markRunningJobsAsStaleA :: Update ViraState ()
+markRunningJobsAsStaleA = do
+  jobs <- Ix.toList <$> gets jobs
+  forM_ jobs $ \job -> do
+    case job.jobStatus of
+      JobRunning -> do
+        jobUpdateStatusA job.jobId JobKilled ""
+      _ -> pass
+
 $( makeAcidic
     ''ViraState
     [ 'getAllReposA
     , 'getRepoByNameA
     , 'getBranchesByRepoA
     , 'getBranchByNameA
-    , 'getJobsByBranchA
     , 'setRepoA
     , 'setRepoBranchesA
+    , 'getJobsByBranchA
+    , 'addNewJobA
+    , 'jobUpdateStatusA
+    , 'markRunningJobsAsStaleA
     ]
  )

src/Vira/State/Core.hs

@@ -19,7 +19,10 @@ import Vira.State.Type
 
 -- | Open vira database
 openViraState :: IO (AcidState ViraState)
-openViraState = openLocalState $ ViraState sampleRepos mempty mempty
+openViraState = do
+  st <- openLocalState $ ViraState sampleRepos mempty mempty
+  update st MarkRunningJobsAsStaleA
+  pure st
   where
     sampleRepos =
       Ix.fromList

src/Vira/State/Type.hs

@@ -54,14 +54,18 @@ instance Indexable BranchIxs Branch where
       (ixFun $ \Branch {repoName} -> [repoName])
       (ixFun $ \Branch {branchName} -> [branchName])
 
+newtype JobId = JobId {unJobId :: Int}
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Ord, Num)
+
 data Job = Job
   { jobRepo :: RepoName
   -- ^ The name of the repository this job belongs to
   , jobBranch :: BranchName
   -- ^ The name of the branch this job is running on
   , jobCommit :: CommitID
   -- ^ The commit this job is running on
-  , jobId :: Int
+  , jobId :: JobId
   -- ^ The unique identifier of the job
   , jobStatus :: JobStatus
   -- ^ The status of the job
@@ -70,7 +74,7 @@ data Job = Job
   }
   deriving stock (Generic, Show, Typeable, Data, Eq, Ord)
 
-type JobIxs = '[RepoName, BranchName, CommitID, Int]
+type JobIxs = '[RepoName, BranchName, CommitID, JobId]
 type IxJob = IxSet JobIxs Job
 
 instance Indexable JobIxs Job where
@@ -81,7 +85,7 @@ instance Indexable JobIxs Job where
       (ixFun $ \Job {jobCommit} -> [jobCommit])
       (ixFun $ \Job {jobId} -> [jobId])
 
-data JobStatus = JobPending | JobRunning | JobFinished JobResult
+data JobStatus = JobPending | JobRunning | JobFinished JobResult | JobKilled
   deriving stock (Generic, Show, Typeable, Data, Eq, Ord)
 
 data JobResult = JobSuccess | JobFailure
@@ -90,6 +94,7 @@ data JobResult = JobSuccess | JobFailure
 $(deriveSafeCopy 0 'base ''JobResult)
 $(deriveSafeCopy 0 'base ''JobStatus)
 $(deriveSafeCopy 0 'base ''RepoName)
+$(deriveSafeCopy 0 'base ''JobId)
 $(deriveSafeCopy 0 'base ''Job)
 $(deriveSafeCopy 0 'base ''Branch)
 $(deriveSafeCopy 0 'base ''Repo)