Add options to the query-build-servers script

So you can select to query specific build servers.

2 files changed, 42 insertions, 8 deletions

diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index be9f421..1a1c7bb 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -17,15 +17,17 @@
   #:use-module (guix-data-service model nar)
   #:export (query-build-servers))
 
-(define (query-build-servers conn revision-commits)
+(define (query-build-servers conn build-server-ids revision-commits)
   (while #t
     (let ((build-servers (select-build-servers conn)))
       (for-each
        (match-lambda
          ((id url lookup-all-derivations?)
-          (when lookup-all-derivations?
-            (simple-format #t "\nQuerying ~A\n" url)
-            (query-build-server conn id url revision-commits))))
+          (when (or (not build-servers)
+                    (member id build-server-ids))
+            (when lookup-all-derivations?
+              (simple-format #t "\nQuerying ~A\n" url)
+              (query-build-server conn id url revision-commits)))))
        build-servers))))
 
 (define (query-build-server conn id url revision-commits)
diff --git a/scripts/guix-data-service-query-build-servers.in b/scripts/guix-data-service-query-build-servers.in
index aa66a9f..9ef8347 100644
--- a/scripts/guix-data-service-query-build-servers.in
+++ b/scripts/guix-data-service-query-build-servers.in
@@ -26,7 +26,39 @@
              (guix-data-service database)
              (guix-data-service builds))
 
-(with-postgresql-connection
- "query-build-servers"
- (lambda (conn)
-   (query-build-servers conn (cdr (command-line)))))
+(define %options
+  ;; Specifications of the command-line options
+  (list (option '("build-server-id") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons
+                   'build-server-ids
+                   (cons (string->number arg)
+                         (or (assoc-ref result 'build-server-ids)
+                             '()))
+                   (alist-delete 'build-server-ids result))))))
+
+(define %default-options
+  ;; Alist of default option values
+  '())
+
+(define (parse-options args)
+  (args-fold
+   args %options
+   (lambda (opt name arg result)
+     (error "unrecognized option" name))
+   (lambda (arg result)
+     (alist-cons
+      'revision-commits
+      (cons arg
+            (or (assoc-ref result 'revision-commits)
+                '()))
+      (alist-delete 'revision-commits result)))
+   %default-options))
+
+(let ((opts (parse-options (cdr (program-arguments)))))
+  (with-postgresql-connection
+   "query-build-servers"
+   (lambda (conn)
+     (query-build-servers conn
+                          (assq-ref opts 'build-server-ids)
+                          (assq-ref opts 'revision-commits)))))