Make it possible to list builds via the command line interface

1 files changed, 88 insertions, 0 deletions

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index a5e97bd..cb8c492 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -124,6 +124,51 @@
     (ensure-all-related-derivation-outputs-have-builds . #f)
     (tags                                              . ())))
 
+(define %builds-list-options
+  (list (option '("tag") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'tags
+                              (cons (match (string-split arg #\=)
+                                      ((key value) (cons key value)))
+                                    (or (assq-ref result 'tags)
+                                        '()))
+                              (alist-delete 'tags result))))
+        (option '("not-tag") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'not-tags
+                              (cons (match (string-split arg #\=)
+                                      ((key value) (cons key value)))
+                                    (or (assq-ref result 'not-tags)
+                                        '()))
+                              (alist-delete 'not-tags result))))
+        (option '("processed") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'processed
+                              (string=? arg "true")
+                              result)))
+        (option '("canceled") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'canceled
+                              (string=? arg "true")
+                              result)))
+        (option '("after-id") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'after-id
+                              arg
+                              result)))
+        (option '("limit") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'limit
+                              (string->number arg)
+                              result)))))
+
+(define %builds-list-option-defaults
+  `((tags         . ())
+    (not-tags     . ())
+    (processed    . 'unset)
+    (canceled     . 'unset)
+    (limit        . 1000)))
+
 (define %service-options
   (list (option '("pid-file") #t #f
                 (lambda (opt name arg result)
@@ -299,6 +344,49 @@ canceled?:       ~A
                          build-id)))
           (display-build `(("uuid" . ,build-id)
                            ,@response)))))))
+  (("build" "list" rest ...)
+   (let ((opts (parse-options (append %base-options
+                                      %client-options
+                                      %builds-list-options)
+                              (append %base-option-defaults
+                                      %client-option-defaults
+                                      %builds-list-option-defaults)
+                              rest)))
+     (let ((response (request-builds-list
+                      (assq-ref opts 'coordinator)
+                      #:tags (assq-ref opts 'tags)
+                      #:not-tags (assq-ref opts 'not-tags)
+                      #:processed (assq-ref opts 'processed)
+                      #:canceled (assq-ref opts 'canceled)
+                      #:after-id (assq-ref opts 'after-id)
+                      #:limit (assq-ref opts 'limit))))
+       (for-each
+        (lambda (build-details)
+          (simple-format (current-output-port)
+                         "id: ~A
+derivation: ~A
+processed: ~A
+canceled: ~A
+priority: ~A
+tags:
+~A
+\n"
+                         (assoc-ref build-details "uuid")
+                         (assoc-ref build-details "derivation-name")
+                         (if (assoc-ref build-details "processed")
+                             "true"
+                             "false")
+                         (if (assoc-ref build-details "canceled")
+                             "true"
+                             "false")
+                         (assoc-ref build-details "priority")
+                         (string-join
+                          (map (match-lambda
+                                 ((key . val)
+                                  (string-append "  " key ": " val)))
+                               (assoc-ref build-details "tags"))
+                          "\n")))
+        (vector->list (assoc-ref response "builds"))))))
   (("build" "show-blocking" rest ...)
    (let ((opts (parse-options %base-options
                               (append %base-option-defaults