Working copy dir; log file; Per-job page

src/Vira/App/LinkTo.hs

@@ -2,7 +2,7 @@
 module Vira.App.LinkTo where
 
 import Vira.Lib.Git (BranchName)
-import Vira.State.Type (RepoName)
+import Vira.State.Type (JobId, RepoName)
 
 {- | The part of the application the caller intends to link to
 
@@ -14,6 +14,7 @@ data LinkTo
   | Repo RepoName
   | RepoUpdate RepoName
   | Build RepoName BranchName
+  | Job JobId
   | About
 
 linkShortTitle :: LinkTo -> Text
@@ -23,4 +24,5 @@ linkShortTitle = \case
   Repo name -> toText . toString $ name
   RepoUpdate _ -> "Update" -- unused
   Build _ _ -> "Build" -- unused
+  Job jobId -> "Job " <> show jobId
   About -> "About"

src/Vira/App/Stack.hs

@@ -5,6 +5,7 @@ import Data.Acid (AcidState)
 import Effectful (Eff, IOE)
 import Effectful.Concurrent.Async (Concurrent, runConcurrent)
 import Effectful.Error.Static (Error, runErrorNoCallStack)
+import Effectful.FileSystem (FileSystem, runFileSystem)
 import Effectful.Process (Process, runProcess)
 import Effectful.Reader.Dynamic (Reader, runReader)
 import Servant (Handler (Handler), ServerError)
@@ -20,6 +21,7 @@ type AppStack =
   '[ Reader AppState
    , Concurrent
    , Process
+   , FileSystem
    , Log Message
    , IOE
    ]
@@ -28,12 +30,13 @@ type AppServantStack = (Error ServerError : AppStack)
 
 -- | Run the application stack in IO monad
 runApp :: AppState -> Eff AppStack a -> IO a
-runApp cfg f = do
-  runViraLog
+runApp cfg =
+  do
+    runViraLog
+    . runFileSystem
     . runProcess
     . runConcurrent
     . runReader cfg
-    $ f
 
 -- | Like `runApp`, but for Servant 'Handler'.
 runAppInServant :: AppState -> Eff (Error ServerError : AppStack) a -> Handler a

src/Vira/Lib/Git.hs

@@ -12,10 +12,6 @@ import Data.Data (Data)
 import Data.Map.Strict qualified as Map
 import Data.SafeCopy
 import Data.Text qualified as T
-import Database.Beam (FromBackendRow, HasSqlEqualityCheck)
-import Database.Beam.Backend (HasSqlValueSyntax)
-import Database.Beam.Sqlite.Connection (Sqlite)
-import Database.Beam.Sqlite.Syntax (SqliteValueSyntax)
 import Servant (FromHttpApiData, ToHttpApiData)
 import System.Process
 import System.Which (staticWhich)
@@ -35,8 +31,6 @@ newtype CommitID = CommitID {unCommitID :: Text}
     ( IsString
     , ToJSON
     , ToString
-    , FromBackendRow Sqlite
-    , HasSqlValueSyntax SqliteValueSyntax
     , ToHttpApiData
     , FromHttpApiData
     )
@@ -49,9 +43,6 @@ newtype BranchName = BranchName {unBranchName :: Text}
     ( IsString
     , ToJSON
     , ToString
-    , FromBackendRow Sqlite
-    , HasSqlValueSyntax SqliteValueSyntax
-    , HasSqlEqualityCheck Sqlite
     , ToHttpApiData
     , FromHttpApiData
     )

src/Vira/Page/JobPage.hs

@@ -4,32 +4,39 @@ module Vira.Page.JobPage where
 
 import Effectful (Eff)
 import Effectful.Error.Static (throwError)
-import Effectful.Reader.Dynamic (asks)
+import Effectful.Reader.Dynamic (ask, 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)
+import System.FilePath ((</>))
 import Vira.App qualified as App
+import Vira.App.LinkTo qualified as LinkTo
 import Vira.App.Logging
 import Vira.Lib.Git (BranchName)
+import Vira.Lib.Git qualified as Git
 import Vira.State.Acid qualified as St
 import Vira.State.Core qualified as St
-import Vira.State.Type (RepoName)
+import Vira.State.Type (JobId, RepoName, jobWorkingDir)
 import Vira.Supervisor qualified as Supervisor
-import Vira.Supervisor.Type (TaskOutput (..))
+import Vira.Widgets qualified as W
 import Prelude hiding (ask, asks)
 
-newtype Routes mode = Routes
+data Routes mode = Routes
   { -- Trigger a new build
-    _build :: mode :- "new" :> Capture "branch" BranchName :> Post '[HTML] (Headers '[HXRefresh] Text)
+    _build :: mode :- "new" :> Capture "repo" RepoName :> Capture "branch" BranchName :> Post '[HTML] (Headers '[HXRefresh] Text)
+  , -- View a job
+    _view :: mode :- Capture "job" JobId :> Get '[HTML] (Html ())
   }
   deriving stock (Generic)
 
-handlers :: App.AppState -> RepoName -> Routes AsServer
-handlers cfg repoName = do
+handlers :: App.AppState -> Routes AsServer
+handlers cfg = do
   Routes
-    { _build = App.runAppInServant cfg . buildHandler repoName
+    { _build = \x -> App.runAppInServant cfg . buildHandler x
+    , _view = App.runAppInServant cfg . viewHandler
     }
 
 buildHandler :: RepoName -> BranchName -> Eff App.AppServantStack (Headers '[HXRefresh] Text)
@@ -38,6 +45,43 @@ buildHandler repoName branch = do
     Nothing -> throwError err404
     Just () -> pure $ addHeader True "Ok"
 
+viewHandler :: JobId -> Eff App.AppServantStack (Html ())
+viewHandler jobId = do
+  cfg <- ask
+  job <- App.query (St.GetJobA jobId) >>= maybe (throwError err404) pure
+  logText <- case jobWorkingDir job.jobStatus of
+    Nothing -> pure ""
+    Just workDir -> do
+      -- TODO: Streaming!
+      liftIO $ readFileBS $ workDir </> "output.log"
+  pure $ W.layout cfg.linkTo (show jobId) [LinkTo.Job jobId] $ do
+    viewJob cfg.linkTo job
+    div_ $ do
+      pre_ [class_ "bg-black text-white p-2 text-xs"] $ code_ $ do
+        toHtml logText
+
+viewJob :: (LinkTo.LinkTo -> Link) -> St.Job -> Html ()
+viewJob linkTo job = do
+  a_ [title_ "View Job Details", href_ $ show . linkURI $ linkTo $ LinkTo.Job job.jobId] $ do
+    div_ [class_ "flex items-center justify-start space-x-4 hover:bg-blue-100"] $ do
+      div_ [class_ "w-24"] $ do
+        b_ $ "Job #" <> toHtml (show @Text job.jobId)
+      viewCommit job.jobCommit
+      viewJobStatus job.jobStatus
+
+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"
+
 -- TODO:
 -- 1. Fail if a build is already happening (until we support queuing)
 -- 2. Contact supervisor to spawn a new build, with it status going to DB.
@@ -49,16 +93,14 @@ triggerNewBuild repoName branchName = do
   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.
     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
+    workDir <- Supervisor.startTask supervisor job.jobId cmd $ \workDir exitCode -> do
+      let status = case exitCode of
+            ExitSuccess -> St.JobFinished workDir St.JobSuccess
+            ExitFailure _code -> St.JobFinished workDir St.JobFailure
+      App.update $ St.JobUpdateStatusA job.jobId status
+    App.update $ St.JobUpdateStatusA job.jobId $ St.JobRunning workDir
+    log Info $ "Started task " <> show job.jobId
   pure $ Just ()
   where
     gitFlakeUrl :: Text -> Text

src/Vira/Page/RepoPage.hs

@@ -27,7 +27,6 @@ import Prelude hiding (ask, asks)
 data Routes mode = Routes
   { _view :: mode :- Get '[HTML] (Html ())
   , _update :: mode :- "fetch" :> Post '[HTML] (Headers '[HXRefresh] Text)
-  , _job :: mode :- "job" :> NamedRoutes JobPage.Routes
   }
   deriving stock (Generic)
 
@@ -39,7 +38,6 @@ handlers cfg name = do
   Routes
     { _view = App.runAppInServant cfg $ viewHandler name
     , _update = App.runAppInServant cfg $ updateHandler name
-    , _job = JobPage.handlers cfg name
     }
 
 viewHandler :: RepoName -> Eff App.AppServantStack (Html ())
@@ -80,7 +78,7 @@ viewRepo linkTo repo branches = do
     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
+        "Head Commit: " <> JobPage.viewCommit branch.headCommit
         div_ $
           W.viraButton_
             [ hxPostSafe_ $ linkTo $ LinkTo.Build repo.name branch.branchName
@@ -89,27 +87,4 @@ viewRepo linkTo repo branches = do
             "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"
+            JobPage.viewJob linkTo job

src/Vira/State/Acid.hs

@@ -81,6 +81,11 @@ getJobsByBranchA repo branch = do
   ViraState {jobs} <- ask
   pure $ Ix.toList $ jobs @= repo @= branch
 
+getJobA :: JobId -> Query ViraState (Maybe Job)
+getJobA jobId = do
+  ViraState {jobs} <- ask
+  pure $ Ix.getOne $ jobs @= jobId
+
 -- | Create a new job returning it.
 addNewJobA :: RepoName -> BranchName -> CommitID -> Update ViraState Job
 addNewJobA jobRepo jobBranch jobCommit = do
@@ -90,29 +95,28 @@ addNewJobA jobRepo jobBranch jobCommit = do
       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
+jobUpdateStatusA :: JobId -> JobStatus -> Update ViraState ()
+jobUpdateStatusA jobId status = 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
+      { jobs = Ix.updateIx jobId (job {jobStatus = status}) 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 ""
+      JobRunning path -> do
+        jobUpdateStatusA job.jobId $ JobKilled path
       _ -> pass
 
 $( makeAcidic
@@ -124,6 +128,7 @@ $( makeAcidic
     , 'setRepoA
     , 'setRepoBranchesA
     , 'getJobsByBranchA
+    , 'getJobA
     , 'addNewJobA
     , 'jobUpdateStatusA
     , 'markRunningJobsAsStaleA

src/Vira/State/Type.hs

@@ -56,7 +56,14 @@ instance Indexable BranchIxs Branch where
 
 newtype JobId = JobId {unJobId :: Int}
   deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Ord, Num)
+  deriving newtype
+    ( Show
+    , Eq
+    , Ord
+    , Num
+    , ToHttpApiData
+    , FromHttpApiData
+    )
 
 data Job = Job
   { jobRepo :: RepoName
@@ -69,8 +76,6 @@ data Job = Job
   -- ^ The unique identifier of the job
   , jobStatus :: JobStatus
   -- ^ The status of the job
-  , jobLog :: Text
-  -- ^ The log of the job (updates as the job runs, semi-periodically)
   }
   deriving stock (Generic, Show, Typeable, Data, Eq, Ord)
 
@@ -85,12 +90,23 @@ instance Indexable JobIxs Job where
       (ixFun $ \Job {jobCommit} -> [jobCommit])
       (ixFun $ \Job {jobId} -> [jobId])
 
-data JobStatus = JobPending | JobRunning | JobFinished JobResult | JobKilled
+data JobStatus
+  = JobPending
+  | JobRunning FilePath
+  | JobFinished FilePath JobResult
+  | JobKilled FilePath
   deriving stock (Generic, Show, Typeable, Data, Eq, Ord)
 
 data JobResult = JobSuccess | JobFailure
   deriving stock (Generic, Show, Typeable, Data, Eq, Ord)
 
+jobWorkingDir :: JobStatus -> Maybe FilePath
+jobWorkingDir = \case
+  JobPending -> Nothing
+  JobRunning dir -> Just dir
+  JobFinished dir _ -> Just dir
+  JobKilled dir -> Just dir
+
 $(deriveSafeCopy 0 'base ''JobResult)
 $(deriveSafeCopy 0 'base ''JobStatus)
 $(deriveSafeCopy 0 'base ''RepoName)