Add a page for queued jobs

guix-data-service/jobs/load-new-guix-revision.scm

@@ -36,6 +36,7 @@
             process-load-new-guix-revision-job
             select-job-for-commit
             select-jobs-and-events
+            select-unprocessed-jobs-and-events
             select-jobs-and-events-for-commit
             record-job-event
             enqueue-load-new-guix-revision-job
@@ -1041,6 +1042,62 @@ ORDER BY load_new_guix_revision_jobs.id DESC")
             (string=? log-exists? "t"))))
    (exec-query conn query)))
 
+(define (select-unprocessed-jobs-and-events conn)
+  (define query
+    "
+SELECT
+  load_new_guix_revision_jobs.id,
+  load_new_guix_revision_jobs.commit,
+  load_new_guix_revision_jobs.source,
+  load_new_guix_revision_jobs.git_repository_id,
+  load_new_guix_revision_jobs.created_at,
+  (
+    SELECT JSON_AGG(
+      json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC
+    )
+    FROM load_new_guix_revision_job_events
+    WHERE job_id = load_new_guix_revision_jobs.id
+  ),
+  EXISTS (
+    SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id
+  ) AS log_exists,
+  commit IN (
+    SELECT commit FROM (
+      SELECT DISTINCT ON (name)
+        name, git_branches.commit
+      FROM git_branches
+      WHERE
+        git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id AND
+        git_branches.commit IS NOT NULL
+      ORDER BY name, datetime DESC
+    ) branches_and_latest_commits
+  ) AS latest_branch_commit
+FROM load_new_guix_revision_jobs
+WHERE
+  succeeded_at IS NULL AND
+  (
+    SELECT COUNT(*)
+    FROM load_new_guix_revision_job_events
+    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry'
+  ) >= (
+    SELECT COUNT(*)
+    FROM load_new_guix_revision_job_events
+    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure'
+  )
+ORDER BY latest_branch_commit DESC, id DESC")
+
+  (map
+   (match-lambda
+     ((id commit source git-repository-id created-at
+          events-json log-exists? latest-branch-commit)
+      (list id commit source git-repository-id created-at
+            (if (string-null? events-json)
+                #()
+                (json-string->scm events-json))
+            (string=? log-exists? "t")
+            (string=? latest-branch-commit "t"))))
+   (exec-query conn query)))
+
 (define (select-jobs-and-events-for-commit conn commit)
   (define query
     "

guix-data-service/web/controller.scm

@@ -731,6 +731,11 @@
    #:sxml (view-jobs
            (select-jobs-and-events conn))))
 
+(define (render-job-queue mime-types conn)
+  (render-html
+   #:sxml (view-job-queue
+           (select-unprocessed-jobs-and-events conn))))
+
 (define (render-job mime-types conn job-id query-parameters)
   (render-html
    #:sxml (view-job
@@ -1132,6 +1137,9 @@
     (('GET "jobs")
      (render-jobs mime-types
                   conn))
+    (('GET "jobs" "queue")
+     (render-job-queue mime-types
+                       conn))
     (('GET "job" job-id)
      (let ((parsed-query-parameters
             (parse-query-parameters

guix-data-service/web/view/html.scm

@@ -46,6 +46,7 @@
             view-derivation
             view-store-item
             view-jobs
+            view-job-queue
             view-job
             compare
             compare/derivations
@@ -1491,6 +1492,78 @@
                              '())))))
                  jobs-and-events)))))))))
 
+(define (view-job-queue jobs-and-events)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h1 "Queued jobs ("
+            ,(length jobs-and-events)
+            ")")))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th "Commit")
+           (th "Source")
+           (th "Events")
+           (th "")))
+         (tdata
+          ,@(map (match-lambda
+                   ((id commit source git-repository-id created-at
+                        events log-exists? latest-branch-commit?)
+                    `(tr
+                      (@ (class
+                           ,(let ((event-names
+                                   (map (lambda (event)
+                                          (assoc-ref event "event"))
+                                        (vector->list events))))
+                              (cond
+                               ((member "success" event-names)
+                                "success")
+                               ((member "failure" event-names)
+                                "danger")
+                               ((member "start" event-names)
+                                "info")
+                               (else
+                                "")))))
+                      (td (a (@ (href
+                                 ,(string-append
+                                   "/revision/" commit)))
+                             (samp ,commit)
+                             ,@(if latest-branch-commit?
+                                   '((br)
+                                     (span (@ (class "text-danger"))
+                                           "(latest branch commit)"))
+                                   '())))
+                      (td ,source)
+                      (td
+                       (dl
+                        (@ (class "dl-horizontal"))
+                        ,@(map
+                           (lambda (event)
+                             `((dt ,(assoc-ref event "event"))
+                               (dd ,(assoc-ref event "occurred_at"))))
+                           (cons
+                            `(("event" . "created")
+                              ("occurred_at" . ,created-at))
+                            (vector->list events)))))
+                      (td
+                       ,@(if log-exists?
+                             `((a (@ (href ,(string-append "/job/" id)))
+                                  "View log"))
+                             '())))))
+                 jobs-and-events)))))))))
+
 (define (view-job job-id query-parameters log)
   (layout
    #:body