diff --git a/src/Vira/App/LinkTo.hs b/src/Vira/App/LinkTo.hs index cd8481a..4151f11 100644 --- a/src/Vira/App/LinkTo.hs +++ b/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" diff --git a/src/Vira/App/Stack.hs b/src/Vira/App/Stack.hs index 0ff782a..f139634 100644 --- a/src/Vira/App/Stack.hs +++ b/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 diff --git a/src/Vira/Lib/Git.hs b/src/Vira/Lib/Git.hs index f8ebf93..c46615f 100644 --- a/src/Vira/Lib/Git.hs +++ b/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 ) diff --git a/src/Vira/Page/JobPage.hs b/src/Vira/Page/JobPage.hs index f4cf2bd..a900ddc 100644 --- a/src/Vira/Page/JobPage.hs +++ b/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 diff --git a/src/Vira/Page/RepoPage.hs b/src/Vira/Page/RepoPage.hs index 44fb2ca..4f6a327 100644 --- a/src/Vira/Page/RepoPage.hs +++ b/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 diff --git a/src/Vira/State/Acid.hs b/src/Vira/State/Acid.hs index b9359bb..48279c4 100644 --- a/src/Vira/State/Acid.hs +++ b/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,7 +95,6 @@ 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 @@ -98,12 +102,12 @@ addNewJobA jobRepo jobBranch jobCommit = do } 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 () @@ -111,8 +115,8 @@ 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 diff --git a/src/Vira/State/Type.hs b/src/Vira/State/Type.hs index 7f29dbc..6d2dd20 100644 --- a/src/Vira/State/Type.hs +++ b/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) diff --git a/src/Vira/Supervisor.hs b/src/Vira/Supervisor.hs index e8b41bf..1952c57 100644 --- a/src/Vira/Supervisor.hs +++ b/src/Vira/Supervisor.hs @@ -4,10 +4,15 @@ module Vira.Supervisor where import Data.Map.Strict qualified as Map -import Effectful (Eff, (:>)) +import Effectful (Eff, IOE, (:>)) import Effectful.Concurrent.Async import Effectful.Concurrent.MVar (modifyMVar, modifyMVar_, readMVar) -import Effectful.Process (Process, readProcessWithExitCode) +import Effectful.FileSystem (FileSystem, createDirectory) +import Effectful.FileSystem.IO (openFile) +import Effectful.Process (CreateProcess (cwd, std_err, std_out), Process, StdStream (UseHandle), createProcess, shell, waitForProcess) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory, makeAbsolute) +import System.Exit (ExitCode) +import System.FilePath (()) import Vira.App qualified as App import Vira.App.Logging import Vira.Supervisor.Type @@ -16,7 +21,10 @@ import Prelude hiding (readMVar) newSupervisor :: (MonadIO m) => m TaskSupervisor newSupervisor = do tasks <- newMVar mempty - pure $ TaskSupervisor tasks () + pwd <- liftIO getCurrentDirectory + workDir <- liftIO $ makeAbsolute $ pwd "state" "workspace" -- keep it alongside acid-state db + liftIO $ createDirectoryIfMissing True workDir + pure $ TaskSupervisor tasks workDir logSupervisorState :: (HasCallStack, Concurrent :> es, Log Message :> es) => TaskSupervisor -> Eff es () logSupervisorState supervisor = do @@ -26,15 +34,26 @@ logSupervisorState supervisor = do taskState <- getTaskStatus supervisor taskId withFrozenCallStack $ log Debug $ "Task " <> show taskId <> " state: " <> show taskState --- | Start a new task +-- | Start a new a task, returning its working directory. startTask :: - (Concurrent :> es, Process :> es, Log Message :> es, HasCallStack) => + ( Concurrent :> es + , Process :> es + , Log Message :> es + , FileSystem :> es + , IOE :> es + , HasCallStack + ) => TaskSupervisor -> TaskId -> String -> -- Handler to call after the task finishes - (TaskOutput -> Eff es ()) -> - Eff es TaskId + ( -- \| Working directory + FilePath -> + -- \| Exit code + ExitCode -> + Eff es () + ) -> + Eff es FilePath startTask supervisor taskId cmd h = do logSupervisorState supervisor log Info $ "Starting task: " <> toText cmd @@ -42,15 +61,25 @@ startTask supervisor taskId cmd h = do if Map.member taskId tasks then do log Error $ "Task " <> show taskId <> " already exists" - pure (tasks, taskId) + die $ "Task " <> show taskId <> " already exists" else do + let pwd = workDir supervisor show taskId + createDirectory pwd task <- async $ do - (exitCode, output, _) <- readProcessWithExitCode "sh" ["-c", cmd <> " 2>&1"] "" + -- Send all output to a file under working directory. + outputHandle <- openFile (pwd "output.log") WriteMode + let process = + (shell cmd) + { cwd = Just pwd + , std_out = UseHandle outputHandle + , std_err = UseHandle outputHandle + } + (_, _, _, ph) <- createProcess process + exitCode <- waitForProcess ph log Info $ "Task " <> show taskId <> " finished with exit code " <> show exitCode - let out = TaskOutput output exitCode - h out - pure out - pure (Map.insert taskId task tasks, taskId) + h pwd exitCode + pure exitCode + pure (Map.insert taskId task tasks, pwd) -- | Kill a task killTask :: TaskSupervisor -> TaskId -> Eff App.AppStack () diff --git a/src/Vira/Supervisor/Type.hs b/src/Vira/Supervisor/Type.hs index 89d5601..c2ef197 100644 --- a/src/Vira/Supervisor/Type.hs +++ b/src/Vira/Supervisor/Type.hs @@ -1,25 +1,21 @@ module Vira.Supervisor.Type where -import Effectful.Concurrent.Async +import Effectful.Concurrent.Async (Async) import System.Exit (ExitCode) import Vira.State.Type (JobId) type TaskId = JobId -data TaskOutput = TaskOutput - { output :: String -- stdout/stderr - , exitCode :: ExitCode - } - deriving stock (Generic, Show) - data TaskState = Running - | Finished TaskOutput + | Finished ExitCode | Killed deriving stock (Generic, Show) -- TODO Use ixset-typed data TaskSupervisor = TaskSupervisor - { tasks :: MVar (Map TaskId (Async TaskOutput)) - , dummy :: () + { tasks :: MVar (Map TaskId (Async ExitCode)) + -- ^ Current tasks, running or not + , workDir :: FilePath + -- ^ Base working directory for all tasks. This assigns `${workDir}/${taskId}/` as $PWD for each task. } diff --git a/src/Vira/Toplevel.hs b/src/Vira/Toplevel.hs index ad942df..c5fcda0 100644 --- a/src/Vira/Toplevel.hs +++ b/src/Vira/Toplevel.hs @@ -40,6 +40,7 @@ import Prelude hiding (Reader, ask, runReader) data Routes mode = Routes { _home :: mode :- Get '[HTML] (Html ()) , _repos :: mode :- "r" Servant.API.:> NamedRoutes RegistryPage.Routes + , _jobs :: mode :- "j" Servant.API.:> NamedRoutes JobPage.Routes , _about :: mode :- "about" Servant.API.:> Get '[HTML] (Html ()) } deriving stock (Generic) @@ -55,6 +56,7 @@ handlers cfg = a_ [href_ url, class_ "flex items-center p-3 space-x-3 text-blue-700 font-bold transition-colors rounded-md hover:bg-gray-100"] $ do name , _repos = RegistryPage.handlers cfg + , _jobs = JobPage.handlers cfg , _about = do pure $ W.layout cfg.linkTo "About Vira" [About] $ do div_ $ do @@ -103,4 +105,5 @@ linkTo = \case RepoListing -> fieldLink _repos // RegistryPage._listing Repo name -> fieldLink _repos // RegistryPage._repo /: name // RepoPage._view RepoUpdate name -> fieldLink _repos // RegistryPage._repo /: name // RepoPage._update - Build repo branch -> fieldLink _repos // RegistryPage._repo /: repo // RepoPage._job // JobPage._build /: branch + Build repo branch -> fieldLink _jobs // JobPage._build /: repo /: branch + Job jobId -> fieldLink _jobs // JobPage._view /: jobId diff --git a/static/tailwind.css b/static/tailwind.css index 191fb60..8137e74 100644 --- a/static/tailwind.css +++ b/static/tailwind.css @@ -987,6 +987,11 @@ select { transition-duration: 150ms; } +.hover\:bg-blue-100:hover { + --tw-bg-opacity: 1; + background-color: rgb(219 234 254 / var(--tw-bg-opacity)); +} + .hover\:bg-gray-100:hover { --tw-bg-opacity: 1; background-color: rgb(243 244 246 / var(--tw-bg-opacity));