diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | guix-data-service/builds.scm | 27 | ||||
| -rw-r--r-- | guix-data-service/substitutes.scm | 83 | ||||
| -rw-r--r-- | scripts/guix-data-service-query-substitute-servers.in | 72 |
6 files changed, 159 insertions, 27 deletions
@@ -22,6 +22,7 @@ scripts/guix-data-service scripts/guix-data-service-process-job scripts/guix-data-service-process-jobs scripts/guix-data-service-query-build-servers +scripts/guix-data-service-query-substitute-servers scripts/guix-data-service-manage-build-servers scripts/guix-data-service-process-branch-updated-email scripts/guix-data-service-process-branch-updated-mbox diff --git a/Makefile.am b/Makefile.am index dbb32c6..1545dbb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -28,6 +28,7 @@ bin_SCRIPTS = \ scripts/guix-data-service-process-branch-updated-mbox \ scripts/guix-data-service-manage-build-servers \ scripts/guix-data-service-query-build-servers \ + scripts/guix-data-service-query-substitute-servers \ scripts/guix-data-service-backup-database \ scripts/guix-data-service-create-small-backup @@ -72,6 +73,7 @@ SOURCES = \ guix-data-service/comparison.scm \ guix-data-service/config.scm \ guix-data-service/database.scm \ + guix-data-service/substitutes.scm \ guix-data-service/utils.scm \ guix-data-service/data-deletion.scm \ guix-data-service/jobs.scm \ diff --git a/configure.ac b/configure.ac index 19a31dd..b7b3aff 100644 --- a/configure.ac +++ b/configure.ac @@ -50,6 +50,7 @@ AC_CONFIG_FILES([scripts/guix-data-service-process-branch-updated-email], [chmod AC_CONFIG_FILES([scripts/guix-data-service-process-branch-updated-mbox], [chmod +x scripts/guix-data-service-process-branch-updated-mbox]) AC_CONFIG_FILES([scripts/guix-data-service-manage-build-servers], [chmod +x scripts/guix-data-service-manage-build-servers]) AC_CONFIG_FILES([scripts/guix-data-service-query-build-servers], [chmod +x scripts/guix-data-service-query-build-servers]) +AC_CONFIG_FILES([scripts/guix-data-service-query-substitute-servers], [chmod +x scripts/guix-data-service-query-substitute-servers]) AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm index bba5bb3..3182a07 100644 --- a/guix-data-service/builds.scm +++ b/guix-data-service/builds.scm @@ -172,8 +172,6 @@ WHERE derivation_output_details.path = $1" (simple-format #t "\nFetching pending builds\n") (process-pending-builds conn id url) - (simple-format #t "\nFetching narinfo files\n") - (fetch-narinfo-files conn id url revision-commits) (simple-format #t "\nFetching unseen derivations\n") (process-derivation-outputs conn id url @@ -617,28 +615,3 @@ LIMIT 30000")) result)))) vlist-null (exec-query conn query (list (number->string build-server-id))))) - -(define (fetch-narinfo-files conn build-server-id build-server-url revision-commits) - (define outputs - (select-outputs-without-known-nar-entries - conn - build-server-id - revision-commits)) - - (simple-format #t "Querying ~A outputs\n" - (length outputs)) - - (let ((narinfos - (lookup-narinfos (string-trim-right build-server-url #\/) outputs))) - - (simple-format #t "Got ~A narinfo files\n" - (length narinfos)) - - (unless (eq? (length narinfos) 0) - (with-postgresql-transaction - conn - (lambda (conn) - (record-narinfo-details-and-return-ids - conn - build-server-id - narinfos)))))) diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm new file mode 100644 index 0000000..6dd069e --- /dev/null +++ b/guix-data-service/substitutes.scm @@ -0,0 +1,83 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019, 2020 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program 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 +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service substitutes) + #:use-module (ice-9 match) + #:use-module (guix scripts substitute) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model build-server) + #:use-module (guix-data-service model nar) + #:export (query-build-server-substitutes)) + +(define verbose-output? + (make-parameter #f)) + +(define* (query-build-server-substitutes conn build-server-ids revision-commits + outputs + #:key verbose?) + (parameterize + ((verbose-output? verbose?)) + (while #t + (let ((build-servers (select-build-servers conn))) + (for-each + (match-lambda + ((id url lookup-all-derivations?) + (when (or (or (not build-servers) + (not build-server-ids)) + (member id build-server-ids)) + (when lookup-all-derivations? + (simple-format #t "\nQuerying ~A\n" url) + (catch #t + (lambda () + (simple-format #t "\nFetching narinfo files\n") + (fetch-narinfo-files conn id url revision-commits + #:specific-outputs + outputs)) + (lambda (key . args) + (simple-format + (current-error-port) + "exception in query-build-server: ~A ~A\n" + key args))))))) + build-servers))))) + +(define* (fetch-narinfo-files conn build-server-id build-server-url + revision-commits + #:key specific-outputs) + (define outputs + (or specific-outputs + (select-outputs-without-known-nar-entries + conn + build-server-id + revision-commits))) + + (simple-format #t "Querying ~A outputs\n" + (length outputs)) + + (let ((narinfos + (lookup-narinfos (string-trim-right build-server-url #\/) outputs))) + + (simple-format #t "Got ~A narinfo files\n" + (length narinfos)) + + (unless (eq? (length narinfos) 0) + (with-postgresql-transaction + conn + (lambda (conn) + (record-narinfo-details-and-return-ids + conn + build-server-id + narinfos)))))) diff --git a/scripts/guix-data-service-query-substitute-servers.in b/scripts/guix-data-service-query-substitute-servers.in new file mode 100644 index 0000000..2ae87ac --- /dev/null +++ b/scripts/guix-data-service-query-substitute-servers.in @@ -0,0 +1,72 @@ +#!@GUILE@ --no-auto-compile +-*- scheme -*- +-*- geiser-scheme-implementation: guile -*- +!# +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019, 2020 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 database) + (guix-data-service substitutes)) + +(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)))) + (option '("verbose") #f #f + (lambda (opt name _ result) + (alist-cons 'verbose #t result))))) + +(define %default-options + ;; Alist of default option values + '((revision-commits . ()))) + +(define (parse-options args) + (args-fold + args %options + (lambda (opt name arg result) + (error "unrecognized option" name)) + (lambda (arg result) + (let ((type (if (string-prefix? "/gnu/store/" arg) + 'outputs + 'revision-commits))) + (alist-cons + type + (cons arg + (or (assoc-ref result type) + '())) + (alist-delete type result)))) + %default-options)) + +(let ((opts (parse-options (cdr (program-arguments))))) + (with-postgresql-connection + "query-substitute-servers" + (lambda (conn) + (query-build-server-substitutes conn + (assq-ref opts 'build-server-ids) + (assq-ref opts 'revision-commits) + (assq-ref opts 'outputs) + #:verbose? (assq-ref opts 'verbose))))) |