Add compute-and-fix-broken-derivations-in-revision

It's an uphill struggle to generate these derivaitons to repair them in the
database, so copy lots of the code to try and make this easier.

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))
@@ -1386,6 +1387,11 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
 
 (define (find-broken-derivations-in-revision commit)
   (run-fibers
+   (lambda ()
+     (with-exception-handler
+         (lambda (exn)
+           (print-backtrace-and-exception/knots exn)
+           (raise-exception exn))
        (lambda ()
          (concatenate!
           (fibers-batch-map
@@ -1394,7 +1400,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
               (with-postgresql-connection
                "fix"
                (lambda (conn)
-             (peek system target)
+                 (simple-format #t "checking: ~A ~A\n" system target)
                  (map
                   car
                   (exec-query
@@ -1424,11 +1430,250 @@ WHERE builder != 'builtin:download'
                     (list-systems conn))
                (map (lambda (target)
                       (list "x86_64-linux" target))
-                (valid-targets conn))))))))
+                    (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)