diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index eb8f3d3..85f0c9b 100644 --- a/.github/workflows/ci.yaml +++ b/.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 diff --git a/README.md b/README.md index 8669639..57953d5 100644 --- a/README.md +++ b/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 +``` diff --git a/justfile b/justfile index ca08f0c..531d91f 100644 --- a/justfile +++ b/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) diff --git a/nix/modules/flake-parts/devshell.nix b/nix/modules/flake-parts/devshell.nix index 520790b..056966d 100644 --- a/nix/modules/flake-parts/devshell.nix +++ b/nix/modules/flake-parts/devshell.nix @@ -13,7 +13,6 @@ just nixd ghciwatch - sqlite ]; }; }; diff --git a/src/Vira/App/AcidState.hs b/src/Vira/App/AcidState.hs index 27a6eab..e0ed995 100644 --- a/src/Vira/App/AcidState.hs +++ b/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 diff --git a/src/Vira/App/LinkTo.hs b/src/Vira/App/LinkTo.hs index 858c5ac..cd8481a 100644 --- a/src/Vira/App/LinkTo.hs +++ b/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" diff --git a/src/Vira/Page/JobPage.hs b/src/Vira/Page/JobPage.hs index 53637ab..f4cf2bd 100644 --- a/src/Vira/Page/JobPage.hs +++ b/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,12 +17,11 @@ 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) @@ -30,21 +29,9 @@ data Routes mode = Routes 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 diff --git a/src/Vira/Page/RepoPage.hs b/src/Vira/Page/RepoPage.hs index 9d4c1c6..44fb2ca 100644 --- a/src/Vira/Page/RepoPage.hs +++ b/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" diff --git a/src/Vira/State/Acid.hs b/src/Vira/State/Acid.hs index 6cd55d9..b9359bb 100644 --- a/src/Vira/State/Acid.hs +++ b/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 ] ) diff --git a/src/Vira/State/Core.hs b/src/Vira/State/Core.hs index 9fbb9f7..088aa93 100644 --- a/src/Vira/State/Core.hs +++ b/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 diff --git a/src/Vira/State/Type.hs b/src/Vira/State/Type.hs index 37896c9..7f29dbc 100644 --- a/src/Vira/State/Type.hs +++ b/src/Vira/State/Type.hs @@ -54,6 +54,10 @@ 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 @@ -61,7 +65,7 @@ data Job = Job -- ^ 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) diff --git a/src/Vira/Supervisor.hs b/src/Vira/Supervisor.hs index 10f272d..e8b41bf 100644 --- a/src/Vira/Supervisor.hs +++ b/src/Vira/Supervisor.hs @@ -30,18 +30,27 @@ logSupervisorState supervisor = do startTask :: (Concurrent :> es, Process :> es, Log Message :> es, HasCallStack) => TaskSupervisor -> + TaskId -> String -> + -- Handler to call after the task finishes + (TaskOutput -> Eff es ()) -> Eff es TaskId -startTask supervisor cmd = do +startTask supervisor taskId cmd h = do logSupervisorState supervisor log Info $ "Starting task: " <> toText cmd modifyMVar (tasks supervisor) $ \tasks -> do - let taskId = maybe 0 (succ . fst) $ Map.lookupMax tasks - task <- async $ do - (exitCode, output, _) <- readProcessWithExitCode "sh" ["-c", cmd <> " 2>&1"] "" - log Info $ "Task " <> show taskId <> " finished with exit code " <> show exitCode - pure $ TaskOutput output exitCode - pure (Map.insert taskId task tasks, taskId) + if Map.member taskId tasks + then do + log Error $ "Task " <> show taskId <> " already exists" + pure (tasks, taskId) + else do + task <- async $ do + (exitCode, output, _) <- readProcessWithExitCode "sh" ["-c", cmd <> " 2>&1"] "" + 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) -- | Kill a task killTask :: TaskSupervisor -> TaskId -> Eff App.AppStack () diff --git a/src/Vira/Supervisor/Type.hs b/src/Vira/Supervisor/Type.hs index 2ae7ad7..89d5601 100644 --- a/src/Vira/Supervisor/Type.hs +++ b/src/Vira/Supervisor/Type.hs @@ -2,8 +2,10 @@ module Vira.Supervisor.Type where import Effectful.Concurrent.Async import System.Exit (ExitCode) +import Vira.State.Type (JobId) + +type TaskId = JobId -type TaskId = Int data TaskOutput = TaskOutput { output :: String -- stdout/stderr , exitCode :: ExitCode @@ -16,6 +18,7 @@ data TaskState | Killed deriving stock (Generic, Show) +-- TODO Use ixset-typed data TaskSupervisor = TaskSupervisor { tasks :: MVar (Map TaskId (Async TaskOutput)) , dummy :: () diff --git a/src/Vira/Toplevel.hs b/src/Vira/Toplevel.hs index c4a2f5d..ad942df 100644 --- a/src/Vira/Toplevel.hs +++ b/src/Vira/Toplevel.hs @@ -83,7 +83,7 @@ runVira = do bracket openViraState closeViraState $ \acid -> do supervisor <- Vira.Supervisor.newSupervisor let st = App.AppState {linkTo = linkTo, ..} - App.runApp st (app settings) + App.runApp st $ app settings -- Vira application for given `Settings` app :: (HasCallStack) => Settings -> Eff AppStack () @@ -103,5 +103,4 @@ 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 - RepoBranchJobs repo _branch -> fieldLink _repos // RegistryPage._repo /: repo // RepoPage._job // JobPage._list Build repo branch -> fieldLink _repos // RegistryPage._repo /: repo // RepoPage._job // JobPage._build /: branch diff --git a/static/tailwind.css b/static/tailwind.css index ca03f44..191fb60 100644 --- a/static/tailwind.css +++ b/static/tailwind.css @@ -792,6 +792,16 @@ select { margin-right: auto; } +.my-4 { + margin-top: 1rem; + margin-bottom: 1rem; +} + +.my-8 { + margin-top: 2rem; + margin-bottom: 2rem; +} + .mb-2 { margin-bottom: 0.5rem; } @@ -808,10 +818,18 @@ select { display: flex; } +.w-24 { + width: 6rem; +} + .items-center { align-items: center; } +.justify-start { + justify-content: flex-start; +} + .space-x-2 > :not([hidden]) ~ :not([hidden]) { --tw-space-x-reverse: 0; margin-right: calc(0.5rem * var(--tw-space-x-reverse)); @@ -824,6 +842,12 @@ select { margin-left: calc(0.75rem * calc(1 - var(--tw-space-x-reverse))); } +.space-x-4 > :not([hidden]) ~ :not([hidden]) { + --tw-space-x-reverse: 0; + margin-right: calc(1rem * var(--tw-space-x-reverse)); + margin-left: calc(1rem * calc(1 - var(--tw-space-x-reverse))); +} + .space-y-2 > :not([hidden]) ~ :not([hidden]) { --tw-space-y-reverse: 0; margin-top: calc(0.5rem * calc(1 - var(--tw-space-y-reverse))); @@ -884,6 +908,11 @@ select { padding: 1rem; } +.py-2 { + padding-top: 0.5rem; + padding-bottom: 0.5rem; +} + .text-2xl { font-size: 1.5rem; line-height: 2rem; @@ -899,6 +928,11 @@ select { line-height: 1.25rem; } +.text-xs { + font-size: 0.75rem; + line-height: 1rem; +} + .font-bold { font-weight: 700; } @@ -918,11 +952,31 @@ select { color: rgb(75 85 99 / var(--tw-text-opacity)); } +.text-gray-700 { + --tw-text-opacity: 1; + color: rgb(55 65 81 / var(--tw-text-opacity)); +} + +.text-green-700 { + --tw-text-opacity: 1; + color: rgb(21 128 61 / var(--tw-text-opacity)); +} + +.text-red-700 { + --tw-text-opacity: 1; + color: rgb(185 28 28 / var(--tw-text-opacity)); +} + .text-white { --tw-text-opacity: 1; color: rgb(255 255 255 / var(--tw-text-opacity)); } +.text-yellow-700 { + --tw-text-opacity: 1; + color: rgb(161 98 7 / var(--tw-text-opacity)); +} + .filter { filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow); } @@ -938,6 +992,11 @@ select { background-color: rgb(243 244 246 / var(--tw-bg-opacity)); } +.hover\:text-black:hover { + --tw-text-opacity: 1; + color: rgb(0 0 0 / var(--tw-text-opacity)); +} + .hover\:underline:hover { text-decoration-line: underline; } \ No newline at end of file