Add functionality to query build servers

.gitignore

@@ -11,4 +11,5 @@ configure
 guix-data-service/config.scm
 scripts/guix-data-service
 scripts/guix-data-service-process-jobs
+scripts/guix-data-service-query-build-servers
 pre-inst-env

Makefile.am

@@ -22,13 +22,15 @@ include guile.am
 
 bin_SCRIPTS =						\
   scripts/guix-data-service				\
-  scripts/guix-data-service-process-jobs
+  scripts/guix-data-service-process-jobs		\
+  scripts/guix-data-service-query-build-servers
 
 moddir = $(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
 godir  = $(moddir)
 assetsdir = $(datadir)/@PACKAGE@
 
 SOURCES =						\
+  guix-data-service/builds.scm				\
   guix-data-service/comparison.scm			\
   guix-data-service/config.scm				\
   guix-data-service/jobs.scm				\

configure.ac

@@ -35,6 +35,7 @@ AC_CONFIG_FILES([Makefile])
 AC_CONFIG_FILES([guix-data-service/config.scm])
 AC_CONFIG_FILES([scripts/guix-data-service], [chmod +x scripts/guix-data-service])
 AC_CONFIG_FILES([scripts/guix-data-service-process-jobs], [chmod +x scripts/guix-data-service-process-jobs])
+AC_CONFIG_FILES([scripts/guix-data-service-query-build-servers], [chmod +x scripts/guix-data-service-query-build-servers])
 AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
 
 AC_OUTPUT

guix-data-service/builds.scm

@@ -0,0 +1,163 @@
+(define-module (guix-data-service builds)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 iconv)
+  #:use-module (json parser)
+  #:use-module (web response)
+  #:use-module (web client)
+  #:use-module (squee)
+  #:use-module (guix-data-service builds)
+  #:use-module (guix-data-service model build)
+  #:use-module (guix-data-service model build-server)
+  #:use-module (guix-data-service model build-status)
+  #:export (query-build-servers))
+
+(define (query-build-servers conn)
+  (while #t
+    (let ((build-servers (select-build-servers conn)))
+      (for-each
+       (match-lambda
+         ((id url lookup-all-derivations?)
+          (when (string=? lookup-all-derivations? "t")
+            (query-build-server conn id url))))
+       build-servers))))
+
+(define (query-build-server conn id url)
+  (process-pending-builds conn id url)
+  (process-derivations conn id url))
+
+(define (process-pending-builds conn build-server-id url)
+  (for-each
+   (match-lambda
+     ((build-id internal-build-id derivation-id derivation-file-name)
+      (match (fetch-build url build-id)
+        (#f #f)
+        (() #f)
+        (status
+         (insert-build-status conn
+                              internal-build-id
+                              (assoc-ref status "starttime")
+                              (assoc-ref status "stoptime")
+                              (assq-ref build-statuses
+                                        (assoc-ref status "buildstatus")))))
+      (display ".")
+      ;; Try not to make to many requests at once
+      (usleep 200)))
+   (select-pending-builds conn build-server-id)))
+
+(define (process-derivations conn build-server-id url)
+  (for-each
+   (match-lambda
+     ((derivation-id derivation-file-name)
+      (and=> (fetch-build-for-derivation url derivation-file-name)
+             (lambda (status)
+               (let ((internal-build-id
+                      (ensure-build-exists conn
+                                           build-server-id
+                                           (assoc-ref status "id")
+                                           derivation-id
+                                           (assoc-ref status "timestamp"))))
+
+                 (insert-build-status conn
+                                      internal-build-id
+                                      (assoc-ref status "starttime")
+                                      (assoc-ref status "stoptime")
+                                      (assq-ref build-statuses
+                                                (assoc-ref status "buildstatus"))))))
+      (display ".")
+      ;; Try not to make to many requests at once
+      (usleep 200)))
+   (select-derivations-with-no-known-build conn)))
+
+(define (fetch-build-for-derivation url derivation-file-name)
+  (match (array->list
+          (fetch-latest-builds-for-derivation url derivation-file-name))
+    (#f #f)
+    (()
+     (match (array->list
+             (fetch-queued-builds-for-derivation url derivation-file-name))
+       (#f #f)
+       (() #f)
+       ((status)
+        status)))
+    ((status)
+     status)))
+
+(define (json-string->scm* string)
+  (catch
+    'json-invalid
+    (lambda ()
+      (json-string->scm string))
+    (lambda args
+      (display args)
+      (newline)
+      (simple-format #t "error parsing: ~A\n" string)
+      #f)))
+
+(define (fetch-latest-builds-for-derivation url derivation-file-name)
+  (let-values
+      (((response body)
+        (http-request (string-append
+                       url
+                       "api/latestbuilds?nr=10"
+                       "&derivation=" derivation-file-name))))
+
+    (cond
+     ((eq? (response-code response) 200)
+      (json-string->scm
+       (bytevector->string body "utf-8")))
+     (else #f))))
+
+(define (fetch-queued-builds-for-derivation url derivation-file-name)
+  (let-values
+      (((response body)
+        (http-request (string-append
+                       url
+                       "api/queue?nr=10"
+                       "&derivation=" derivation-file-name))))
+
+    (cond
+     ((eq? (response-code response) 200)
+      (json-string->scm
+       (bytevector->string body "utf-8")))
+     (else #f))))
+
+(define (fetch-build url id)
+  (let-values
+      (((response body)
+        (http-request (string-append url "build/" id))))
+
+    (cond
+     ((eq? (response-code response) 200)
+      (json-string->scm
+       (bytevector->string body "utf-8")))
+     (else #f))))
+
+(define (select-pending-builds conn build-server-id)
+  (define query
+    (string-append
+     "SELECT builds.id, builds.internal_id, derivations.id, derivations.file_name "
+     "FROM derivations "
+     "INNER JOIN builds "
+     "ON derivations.id = builds.derivation_id "
+     "INNER JOIN build_status "
+     "ON builds.internal_id = build_status.internal_build_id "
+     "WHERE builds.build_server_id = $1 AND "
+     "build_status.status IN ("
+     "'scheduled', 'started'"
+     ") "
+     "LIMIT 1000"))
+
+  (exec-query conn query (list build-server-id)))
+
+(define (select-derivations-with-no-known-build conn)
+  (define query
+    (string-append
+     "SELECT derivations.id, derivations.file_name "
+     "FROM derivations "
+     "WHERE derivations.id NOT IN ("
+     "SELECT derivation_id FROM builds"
+     ") "
+     "LIMIT 1000"))
+
+  (exec-query conn query))

scripts/guix-data-service-query-build-servers.in

@@ -0,0 +1,29 @@
+#!@GUILE@ --no-auto-compile
+-*- scheme -*-
+-*- geiser-scheme-implementation: guile -*-
+!#
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of guix-data-service.
+;;;
+;;; guix-data-service is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; guix-data-service is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-37)
+             (squee)
+             (guix-data-service builds))
+
+(let ((conn (connect-to-postgres-paramstring "dbname=guix_data_service")))
+  (query-build-servers conn))