diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index d6ae89a..c0433e4 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -99,7 +99,8 @@ fix-derivation fix-derivation-source-file-nar - find-broken-derivations-in-revision)) + find-broken-derivations-in-revision + compute-and-fix-broken-derivations-in-revision)) (define inferior-package-id (@@ (guix inferior) inferior-package-id)) @@ -1387,25 +1388,30 @@ SELECT store_path FROM derivation_source_files WHERE id = $1" (define (find-broken-derivations-in-revision commit) (run-fibers (lambda () - (concatenate! - (fibers-batch-map - (match-lambda - ((system target) - (with-postgresql-connection - "fix" - (lambda (conn) - (peek system target) - (map - car - (exec-query - conn - (string-append - (get-sql-to-select-package-and-related-derivations-for-revision - conn - (commit->revision-id conn commit) - #:system-id (system->system-id conn system) - #:target target) - " + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (concatenate! + (fibers-batch-map + (match-lambda + ((system target) + (with-postgresql-connection + "fix" + (lambda (conn) + (simple-format #t "checking: ~A ~A\n" system target) + (map + car + (exec-query + conn + (string-append + (get-sql-to-select-package-and-related-derivations-for-revision + conn + (commit->revision-id conn commit) + #:system-id (system->system-id conn system) + #:target target) + " SELECT derivations.file_name FROM all_derivations INNER JOIN derivations ON all_derivations.derivation_id = derivations.id @@ -1414,21 +1420,260 @@ WHERE builder != 'builtin:download' AND NOT EXISTS ( SELECT 1 FROM derivation_inputs WHERE derivation_id = derivations.id )"))))))) - 6 - (with-postgresql-connection - "fix" - (lambda (conn) - (append! - (map (lambda (system) - (list system "")) - (list-systems conn)) - (map (lambda (target) - (list "x86_64-linux" target)) - (valid-targets conn)))))))) + 6 + (with-postgresql-connection + "fix" + (lambda (conn) + (append! + (map (lambda (system) + (list system "")) + (list-systems conn)) + (map (lambda (target) + (list "x86_64-linux" target)) + (valid-targets conn)))))))))) #:hz 0 #:parallelism 1 #:drain? #t)) +(define* (compute-and-fix-broken-derivations-in-revision + git-repository-id commit + #:key + (ignore-systems '()) + (ignore-targets '()) + (extra-inferior-environment-variables '()) + (parallelism 4)) + (let ((broken-derivations + (find-broken-derivations-in-revision commit))) + (run-fibers + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (let* ((guix-source + channel-derivations-by-system + (with-postgresql-connection + "channel->source-and-derivations-by-system" + (lambda (conn) + (let* ((git-repository-fields + (select-git-repository conn git-repository-id)) + (git-repository-url + (assq-ref git-repository-fields 'url)) + (fetch-with-authentication? + (assq-ref git-repository-fields 'fetch-with-authentication?))) + (channel->source-and-derivations-by-system + conn + (channel (name 'guix) + (url git-repository-url) + (commit commit)) + fetch-with-authentication? + #:parallelism parallelism + #:ignore-systems ignore-systems))))) + (store-item + guix-derivation + (channel-derivations-by-system->guix-store-item + channel-derivations-by-system)) + (guix-locpath + ;; Augment the GUIX_LOCPATH to include glibc-locales from + ;; the Guix at store-path, this should mean that the + ;; inferior Guix works, even if it's build using a different + ;; glibc version + (string-append + (with-store-connection + (lambda (store) + (glibc-locales-for-guix-store-path store store-item))) + "/lib/locale" + ":" (getenv "GUIX_LOCPATH")))) + + (define inf-and-store-pool + (make-resource-pool + (lambda () + (let* ((inferior-store (open-store-connection))) + (unless (valid-path? inferior-store store-item) + (simple-format #t "warning: store item missing (~A)\n" + store-item) + (simple-format #t "warning: building (~A)\n" + guix-derivation) + (build-derivations inferior-store + (list (read-derivation-from-file + guix-derivation)))) + ;; Use this more to keep the store-path alive so long as there's a + ;; inferior operating + (add-temp-root inferior-store store-item) + + (let ((inferior (start-inferior-for-data-extration + inferior-store + store-item + guix-locpath + extra-inferior-environment-variables))) + (ensure-non-blocking-store-connection inferior-store) + (make-inferior-non-blocking! inferior) + (simple-format #t "debug: started new inferior and store connection\n") + + (cons inferior inferior-store)))) + parallelism + #:min-size 0 + #:idle-seconds 20 + #:name "inferior" + #:destructor + (match-lambda + ((inferior . store) + (simple-format + #t "debug: closing inferior and associated store connection\n") + + (close-connection store) + (close-inferior inferior))))) + + (define (call-with-inferior proc) + (define (check-wal-size) + (define (get-wal-bytes) + (catch #t + (lambda () + (stat:size (stat "/var/guix/db/db.sqlite-wal"))) + (lambda _ 0))) + + (define threshold + (max + (* 4096 (expt 2 20)) + (* 0.8 + (- (free-disk-space "/var/guix/db/db.sqlite") + (get-wal-bytes))))) + + (if (< (get-wal-bytes) threshold) + #t + (let loop ((wal-bytes (get-wal-bytes))) + (if (> wal-bytes threshold) + (let ((stats (resource-pool-stats inf-and-store-pool))) + (simple-format + #t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n" + wal-bytes + (assq-ref stats 'resources)) + + (sleep 30) + (loop (get-wal-bytes))) + (begin + (simple-format + #t "debug: guix-daemon WAL now ~A bytes, continuing\n" + wal-bytes) + #t))))) + + (let loop () + (check-wal-size) + (match + (with-exception-handler + (lambda (exn) + (if (resource-pool-timeout-error? exn) + 'retry + (raise-exception exn))) + (lambda () + (call-with-resource-from-pool inf-and-store-pool + (match-lambda + ((inferior . inferior-store) + (call-with-values + (lambda () + (proc inferior inferior-store)) + (lambda vals + (simple-format #t "debug: returning inferior to pool\n") + (cons 'result vals))))) + #:timeout 20)) + #:unwind? #t) + ('retry (loop)) + (('result . vals) + (apply values vals))))) + + (define packages-count + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (inferior-eval '(vector-length gds-inferior-packages) inferior)))) + + (define chunk-size 1000) + + (define compute-derivations/parallelism-limiter + (make-parallelism-limiter parallelism)) + (define (compute-derivations system target) + ;; Limit concurrency here to keep focused on specific systems until + ;; they've been fully processed + (with-parallelism-limiter + compute-derivations/parallelism-limiter + (with-time-logging + (simple-format #f "getting derivations for ~A" + (cons system target)) + (let loop ((start-index 0)) + (let* ((last-chunk? + (>= (+ start-index chunk-size) packages-count)) + (count + (if last-chunk? + (- packages-count start-index) + chunk-size)) + (chunk + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (let ((result + (inferior-package-derivations + inferior-store + inferior + system + target + start-index + count))) + + (when last-chunk? + (inferior-cleanup inferior)) + + result))))) + (unless last-chunk? + (loop (+ start-index chunk-size)))))))) + + (with-time-logging "compute package derivations" + (fibers-map-with-progress + (match-lambda + ((system . target) + (compute-derivations system target))) + (list + (let ((all-system-target-pairs + (call-with-inferior + (lambda (inferior inferior-store) + (inferior-fetch-system-target-pairs inferior))))) + (filter + (match-lambda + ((system . target) + (if (or (member system ignore-systems) + (member target ignore-targets)) + (begin + (simple-format + (current-error-port) + "ignoring ~A ~A for package derivations\n" + system + target) + #f) + #t))) + all-system-target-pairs))) + #:report + (lambda (data) + (for-each + (match-lambda + ((result (system . target)) + (simple-format #t "~A ~A: ~A\n" + system target result))) + data)))) + (destroy-parallelism-limiter + compute-derivations/parallelism-limiter))))) + + #:hz 0 + #:parallelism 1 + #:drain? #t) + + (simple-format #t "fixing ~A derivations\n" + (length broken-derivations)) + + (for-each fix-derivation + broken-derivations))) + (define* (derivation-file-names->derivation-ids postgresql-connection-pool call-with-utility-thread read-derivations/serialised @@ -2023,6 +2268,73 @@ WHERE builder != 'builtin:download' inf)))) +(define (inferior-cleanup inferior) + (inferior-eval + '(let ((stats (gc-stats))) + (simple-format + (current-error-port) + "cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20))))) + inferior) + + (catch + 'match-error + (lambda () + (inferior-eval '(invalidate-derivation-caches!) + inferior)) + (lambda (key . args) + (simple-format + (current-error-port) + "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) + + ;; Generating derivations populates the derivation cache + (inferior-eval + '(hash-clear! (@@ (guix derivations) %derivation-cache)) + inferior) + + ;; Clean the cached store connections, as there are + ;; caches associated with these that take up lots of + ;; memory + (inferior-eval + '(when (defined? '%store-table) + (hash-clear! %store-table)) + inferior) + + (inferior-eval + '(hash-for-each + (lambda (key _) + ((@ (guix memoization) invalidate-memoization!) key)) + (@@ (guix memoization) %memoization-tables)) + inferior) + + (inferior-eval '(gc) inferior) + + (inferior-eval + '(let ((stats (gc-stats))) + (simple-format + (current-error-port) + "finished cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20))))) + inferior) + + ;; (inferior-eval + ;; '((@@ (guix memoization) show-memoization-tables)) + ;; inferior) + + *unspecified*) + (define* (extract-information-from db-conn guix-revision-id-promise commit guix-source store-item @@ -2257,73 +2569,6 @@ WHERE builder != 'builtin:download' (define chunk-size 1000) - (define (inferior-cleanup inferior) - (inferior-eval - '(let ((stats (gc-stats))) - (simple-format - (current-error-port) - "cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" - (round - (/ (- (assoc-ref stats 'heap-size) - (assoc-ref stats 'heap-free-size)) - (expt 2. 20))) - (round - (/ (assoc-ref stats 'heap-size) - (expt 2. 20))))) - inferior) - - (catch - 'match-error - (lambda () - (inferior-eval '(invalidate-derivation-caches!) - inferior)) - (lambda (key . args) - (simple-format - (current-error-port) - "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) - - ;; Generating derivations populates the derivation cache - (inferior-eval - '(hash-clear! (@@ (guix derivations) %derivation-cache)) - inferior) - - ;; Clean the cached store connections, as there are - ;; caches associated with these that take up lots of - ;; memory - (inferior-eval - '(when (defined? '%store-table) - (hash-clear! %store-table)) - inferior) - - (inferior-eval - '(hash-for-each - (lambda (key _) - ((@ (guix memoization) invalidate-memoization!) key)) - (@@ (guix memoization) %memoization-tables)) - inferior) - - (inferior-eval '(gc) inferior) - - (inferior-eval - '(let ((stats (gc-stats))) - (simple-format - (current-error-port) - "finished cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" - (round - (/ (- (assoc-ref stats 'heap-size) - (assoc-ref stats 'heap-free-size)) - (expt 2. 20))) - (round - (/ (assoc-ref stats 'heap-size) - (expt 2. 20))))) - inferior) - - ;; (inferior-eval - ;; '((@@ (guix memoization) show-memoization-tables)) - ;; inferior) - - *unspecified*) - (define get-derivations/parallelism-limiter (make-parallelism-limiter parallelism)) (define (get-derivations system target)