diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | guix-data-service/builds.scm | 163 | ||||
| -rw-r--r-- | scripts/guix-data-service-query-build-servers.in | 29 |
5 files changed, 197 insertions, 1 deletions
@@ -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 diff --git a/Makefile.am b/Makefile.am index d440bb6..a60542e 100644 --- a/Makefile.am +++ b/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 \ diff --git a/configure.ac b/configure.ac index 8eb14ab..e471696 100644 --- a/configure.ac +++ b/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 diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm new file mode 100644 index 0000000..a9a945c --- /dev/null +++ b/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)) diff --git a/scripts/guix-data-service-query-build-servers.in b/scripts/guix-data-service-query-build-servers.in new file mode 100644 index 0000000..e39932b --- /dev/null +++ b/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)) |