diff options
Diffstat (limited to 'guix-data-service/substitutes.scm')
-rw-r--r-- | guix-data-service/substitutes.scm | 83 |
1 files changed, 83 insertions, 0 deletions
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)))))) |