Make it possible to list builds via the command line interface

2 files changed, 136 insertions, 0 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 088ee34..b471c22 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -43,6 +43,7 @@
             send-submit-build-request
             send-cancel-build-request
             request-build-details
+            request-builds-list
             request-output-details
             request-agents-list
             request-failed-builds-with-blocking-count-list
@@ -438,6 +439,53 @@
                 'GET
                 (string-append "/build/" uuid)))
 
+(define* (request-builds-list coordinator-uri
+                              #:key
+                              (tags '())
+                              (not-tags '())
+                              (processed 'unset)
+                              (canceled 'unset)
+                              (after-id #f)
+                              (limit 1000))
+  (let ((query-parameters
+         `(,@(if (null? tags)
+                 '()
+                 (map (match-lambda
+                        ((key . value)
+                         (simple-format #f "tag=~A:~A" key value)))
+                      tags))
+           ,@(if (null? not-tags)
+                 '()
+                 (map (match-lambda
+                        ((key . value)
+                         (simple-format #f "not_tag=~A:~A" key value)))
+                      not-tags))
+           ,@(if (boolean? processed)
+                 (if processed
+                     '("processed=true")
+                     '("processed=false"))
+                 '())
+           ,@(if (boolean? canceled)
+                 (if canceled
+                     '("canceled=true")
+                     '("canceled=false"))
+                 '())
+           ,@(if after-id
+                 (list (string-append "after_id=" after-id))
+                 '())
+           ,@(if limit
+                 (list (simple-format #f "limit=~A" limit))
+                 '()))))
+    (send-request coordinator-uri
+                  'GET
+                  (string-append
+                   "/builds"
+                   (if (null? query-parameters)
+                       ""
+                       (string-append
+                        "?"
+                        (string-join query-parameters "&")))))))
+
 (define (request-output-details coordinator-uri
                                 output)
   (send-request coordinator-uri
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