;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2019, 2020 Christopher Baines ;;; ;;; 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 ;;; . (define-module (guix-data-service substitutes) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers channels) #:use-module (guix substitutes) #:use-module (guix narinfo) #:use-module ((guix build syscalls) #:select (set-thread-name)) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service model build) #:use-module (guix-data-service model build-server) #:use-module (guix-data-service model git-branch) #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service model nar) #:export (query-build-server-substitutes start-substitute-query-threads request-query-of-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?)) (let ((build-servers (select-build-servers conn))) (for-each (match-lambda ((id url lookup-all-derivations? lookup-builds?) (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) (with-throw-handler #t (lambda () (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) (backtrace))))))) build-servers)))) (define %narinfo-max-size (- (expt 2 (- (* 8 8) ;; 8 bytes 1)) 1)) (define* (fetch-narinfo-files conn build-server-id build-server-url revision-commits #:key specific-outputs) (let loop ((last-id #f) (requests 0) (success-responses 0)) (let ((outputs-chunk (or specific-outputs (select-outputs-without-known-nar-entries conn build-server-id revision-commits #:build-success-after (if (null? revision-commits) (time-utc->date (subtract-duration (current-time) (make-time time-duration 0 (* 60 5))) 0) ; tz-offset #f) #:after-id last-id)))) (unless (null? outputs-chunk) (let* ((narinfos (lookup-narinfos (string-trim-right build-server-url #\/) (map car outputs-chunk))) (narinfos-count (length narinfos)) (total-requested (+ requests (length outputs-chunk))) (total-narinfos (+ success-responses narinfos-count))) (simple-format #t "Fetched ~A narinfos from ~A (total requested: ~A, total narinfos: ~A)\n" (length narinfos) build-server-url total-requested total-narinfos) (let ((filtered-narinfos (filter-map (lambda (narinfo) (if (> (narinfo-size narinfo) %narinfo-max-size) (begin (simple-format (current-error-port) "narinfo ~A has excessive size ~A\n" (narinfo-path narinfo) (narinfo-size narinfo)) #f) narinfo)) narinfos))) (unless (null? filtered-narinfos) (with-postgresql-transaction conn (lambda (conn) (record-narinfo-details-and-return-ids conn build-server-id filtered-narinfos))))) (unless specific-outputs (loop (false-if-exception (second (last outputs-chunk))) total-requested total-narinfos))))))) (define %substitute-query-channel #f) (define (request-query-of-build-server-substitutes build-server-id build-ids) (spawn-fiber (lambda () (and=> %substitute-query-channel (lambda (channel) (put-message channel (cons build-server-id build-ids))))))) (define (start-substitute-query-threads) (define channel (make-channel)) (set! %substitute-query-channel channel) (call-with-new-thread (lambda () (catch 'system-error (lambda () (set-thread-name "request substitute query")) (const #t)) (while #t (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception in request substitute query thread: ~A\n" exn)) (lambda () (with-throw-handler #t (lambda () (with-postgresql-connection "request-substitute-query-thread" (lambda (conn) (while #t (match (get-message channel) ((build-server-id . build-ids) (let ((outputs (delete-duplicates! (append-map! (lambda (build-id) (select-build-outputs conn build-id)) build-ids)))) (simple-format (current-output-port) "querying for ~A outputs from build server ~A\n" (length outputs) build-server-id) (query-build-server-substitutes conn (list build-server-id) #f outputs)))))))) (lambda _ (backtrace)))) #:unwind? #t)))) (call-with-new-thread (lambda () (catch 'system-error (lambda () (set-thread-name "bulk substitute query")) (const #t)) (while #t (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception when querying substitutes: ~A\n" exn)) (lambda () (with-postgresql-connection "substitute-query-thread" (lambda (conn) (for-each (match-lambda ((git-repository-id rest ...) (when (git-repository-query-substitutes? conn git-repository-id) (for-each (match-lambda ((branch-name rest ...) (and=> (latest-processed-commit-for-branch conn (number->string git-repository-id) branch-name) (lambda (commit) (query-build-server-substitutes conn #f ;; All build servers (list commit) #f))))) (all-branches-with-most-recent-commit conn git-repository-id))))) (all-git-repositories conn)))) (simple-format #t "finished checking substitutes, now sleeping\n") (sleep (* 60 30))) #:unwind? #t)))))