cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make some sweeping changes to loading new revisions

Browse source 
Move in the direction of being able to run multiple inferior REPLs, and use
some vectors rather than lists in places (maybe this is more efficient).
This commit is contained in:
Christopher Baines 2023-11-01 21:08:22 +00:00
parent 89782b3449
commit f5acc60288
6 changed files with 500 additions and 520 deletions
Download patch file Download diff file Expand all files Collapse all files

849
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -18,6 +18,7 @@
(define-module (guix-data-service jobs load-new-guix-revision) (define-module (guix-data-service jobs load-new-guix-revision)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
@ -457,72 +458,78 @@ WHERE job_id = $1")
#f))) #f)))
(define (all-inferior-lint-warnings inf store packages) (define locales
(define locales '("cs_CZ.UTF-8"
'("cs_CZ.UTF-8" "da_DK.UTF-8"
"da_DK.UTF-8" "de_DE.UTF-8"
"de_DE.UTF-8" "eo_EO.UTF-8"
"eo_EO.UTF-8" "es_ES.UTF-8"
"es_ES.UTF-8" "fr_FR.UTF-8"
"fr_FR.UTF-8" "hu_HU.UTF-8"
"hu_HU.UTF-8" "nl_NL.UTF-8"
"nl_NL.UTF-8" "pl_PL.UTF-8"
"pl_PL.UTF-8" "pt_BR.UTF-8"
"pt_BR.UTF-8" ;;"sr_SR.UTF-8"
;;"sr_SR.UTF-8" "sv_SE.UTF-8"
"sv_SE.UTF-8" "vi_VN.UTF-8"
"vi_VN.UTF-8" "zh_CN.UTF-8"))
"zh_CN.UTF-8"))
(define (cleanup-inferior inf) (define (inferior-lint-checkers inf)
(format (current-error-port) (and
"inferior heap before cleanup: ~a MiB used (~a MiB heap)~%" (or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f)
(round (use-modules (guix lint))
(/ (inferior-eval #t)
'(let ((stats (gc-stats))) inf)
(- (assoc-ref stats 'heap-size) (begin
(assoc-ref stats 'heap-free-size))) (simple-format (current-error-port)
inf) "warning: no (guix lint) module found\n")
(expt 2. 20))) #f))
(round (inferior-eval
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf) `(begin
(expt 2. 20)))) (define (lint-descriptions-by-locale checker)
(let* ((source-locale "en_US.UTF-8")
(source-description
(begin
(setlocale LC_MESSAGES source-locale)
(G_ (lint-checker-description checker))))
(descriptions-by-locale
(filter-map
(lambda (locale)
(catch 'system-error
(lambda ()
(setlocale LC_MESSAGES locale))
(lambda (key . args)
(error
(simple-format
#f
"error changing locale to ~A: ~A ~A"
locale key args))))
(let ((description
(G_ (lint-checker-description checker))))
(setlocale LC_MESSAGES source-locale)
(if (string=? description source-description)
#f
(cons locale description))))
(list ,@locales))))
(cons (cons source-locale source-description)
descriptions-by-locale)))
;; Clean the cached store connections, as there are caches associated with (map (lambda (checker)
;; these that take up lots of memory (list (lint-checker-name checker)
(inferior-eval (lint-descriptions-by-locale checker)
'(when (defined? '%store-table) (hash-clear! %store-table)) (if (memq checker %network-dependent-checkers)
inf) #t
#f)))
%all-checkers))
inf)))
(catch (define (inferior-lint-warnings inf store checker-name)
'match-error (define lint-warnings-for-checker
(lambda ()
(inferior-eval '(invalidate-derivation-caches!) inf))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
(inferior-eval '(gc) inf)
(format (current-error-port)
"inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
(round
(/ (inferior-eval
'(let ((stats (gc-stats)))
(- (assoc-ref stats 'heap-size)
(assoc-ref stats 'heap-free-size)))
inf)
(expt 2. 20)))
(round
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
(expt 2. 20)))))
(define (lint-warnings-for-checker packages checker-name)
`(lambda (store) `(lambda (store)
(let* ((checker (find (lambda (checker) (let* ((checker-name (quote ,checker-name))
(checker (find (lambda (checker)
(eq? (lint-checker-name checker) (eq? (lint-checker-name checker)
',checker-name)) checker-name))
%local-checkers)) %local-checkers))
(check (lint-checker-check checker))) (check (lint-checker-check checker)))
@ -571,98 +578,32 @@ WHERE job_id = $1")
(cons (cons source-locale source-message) (cons (cons source-locale source-message)
messages-by-locale)))) messages-by-locale))))
(filter-map (vector-map
(lambda (package-id) (lambda (_ package)
(let* ((package (hashv-ref %package-table package-id)) (map process-lint-warning
(warnings (with-exception-handler
(map process-lint-warning (lambda (exn)
(with-exception-handler (simple-format (current-error-port)
(lambda (exn) "exception checking ~A with ~A checker: ~A\n"
(simple-format (current-error-port) package checker-name exn)
"exception checking ~A with ~A checker: ~A\n" (raise-exception exn))
package ',checker-name exn) (lambda ()
(raise-exception exn)) (if (and lint-checker-requires-store?-defined?
(lambda () (lint-checker-requires-store? checker))
(if (and lint-checker-requires-store?-defined?
(lint-checker-requires-store? checker))
(check package #:store store) (check package #:store store)
(check package))) (check package)))
#:unwind? #t)))) #:unwind? #t)))
(if (null? warnings) gds-inferior-packages))))
#f
(cons package-id warnings))))
(list ,@(map inferior-package-id packages))))))
(and (with-time-logging (simple-format #f "getting ~A lint warnings"
(or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f) checker-name)
(use-modules (guix lint)) (inferior-eval-with-store
#t) inf
inf) store
(begin lint-warnings-for-checker)))
(simple-format (current-error-port)
"warning: no (guix lint) module found\n")
#f))
(let ((checkers
(inferior-eval
`(begin
(define (lint-descriptions-by-locale checker)
(let* ((source-locale "en_US.UTF-8")
(source-description
(begin
(setlocale LC_MESSAGES source-locale)
(G_ (lint-checker-description checker))))
(descriptions-by-locale
(filter-map
(lambda (locale)
(catch 'system-error
(lambda ()
(setlocale LC_MESSAGES locale))
(lambda (key . args)
(error
(simple-format
#f
"error changing locale to ~A: ~A ~A"
locale key args))))
(let ((description
(G_ (lint-checker-description checker))))
(setlocale LC_MESSAGES source-locale)
(if (string=? description source-description)
#f
(cons locale description))))
(list ,@locales))))
(cons (cons source-locale source-description)
descriptions-by-locale)))
(map (lambda (checker) (define (inferior-fetch-system-target-pairs inf)
(list (lint-checker-name checker)
(lint-descriptions-by-locale checker)
(if (memq checker %network-dependent-checkers)
#t
#f)))
%all-checkers))
inf)))
(map
(match-lambda
((name description network-dependent?)
(cons
(list name description network-dependent?)
(if (or network-dependent?
(eq? name 'derivation))
'()
(let ((warnings
(with-time-logging (simple-format #f "getting ~A lint warnings"
name)
(inferior-eval-with-store
inf
store
(lint-warnings-for-checker packages
name)))))
(cleanup-inferior inf)
warnings)))))
checkers))))
(define (all-inferior-package-derivations store inf packages)
(define inf-systems (define inf-systems
(inferior-guix-systems inf)) (inferior-guix-systems inf))
@ -712,8 +653,15 @@ WHERE job_id = $1")
targets))) targets)))
cross-derivations)) cross-derivations))
(append supported-system-pairs
supported-system-cross-build-pairs))
(define (inferior-package-derivations store inf system target)
(define proc (define proc
'(lambda (store system-target-pair) `(lambda (store)
(define system-target-pair
(cons ,system ,target))
(define target-system-alist (define target-system-alist
(if (defined? 'platforms (resolve-module '(guix platform))) (if (defined? 'platforms (resolve-module '(guix platform)))
(filter-map (filter-map
@ -762,7 +710,7 @@ WHERE job_id = $1")
"error ~A: ~A\n" key args) "error ~A: ~A\n" key args)
#f)))) #f))))
(define (derivation-for-system-and-target inferior-package-id package system target) (define (derivation-for-system-and-target package system target)
(catch (catch
'misc-error 'misc-error
(lambda () (lambda ()
@ -776,13 +724,10 @@ WHERE job_id = $1")
(package-derivation store package system)))) (package-derivation store package system))))
;; You don't always get what you ask for, so check ;; You don't always get what you ask for, so check
(if (string=? system (derivation-system derivation)) (if (string=? system (derivation-system derivation))
(list inferior-package-id (let ((file-name
system (derivation-file-name derivation)))
target (add-temp-root store file-name)
(let ((file-name file-name)
(derivation-file-name derivation)))
(add-temp-root store file-name)
file-name))
(begin (begin
(simple-format (simple-format
(current-error-port) (current-error-port)
@ -801,140 +746,96 @@ WHERE job_id = $1")
args) args)
#f))) #f)))
(filter-map (vector-map
(lambda (inferior-package-id) (lambda (_ package)
(let ((package (hashv-ref %package-table inferior-package-id))) (catch
(catch #t
#t (lambda ()
(lambda () (let* ((system (car system-target-pair))
(let* ((system (car system-target-pair)) (target (cdr system-target-pair))
(target (cdr system-target-pair)) (supported-systems (get-supported-systems package system))
(supported-systems (get-supported-systems package system)) (system-supported?
(system-supported? (and supported-systems
(and supported-systems (->bool (member system supported-systems))))
(->bool (member system supported-systems)))) (target-supported?
(target-supported? (or (not target)
(or (not target) (let ((system-for-target
(let ((system-for-target (assoc-ref target-system-alist
(assoc-ref target-system-alist target)))
target))) (or (not system-for-target)
(or (not system-for-target) (->bool
(->bool (member system-for-target
(member system-for-target (package-supported-systems package)
(package-supported-systems package) string=?)))))))
string=?)))))))
(when (string=? (package-name package) "guix") (when (string=? (package-name package) "guix")
(simple-format
(current-error-port)
"looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n"
supported-systems
system-supported?
target-supported?))
(if system-supported?
(if target-supported?
(derivation-for-system-and-target package
system
target)
#f)
#f)))
(lambda (key . args)
(if (and (eq? key 'system-error)
(eq? (car args) 'fport_write))
(begin
(simple-format (simple-format
(current-error-port) (current-error-port)
"looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n" "error: while processing ~A, exiting: ~A: ~A\n"
supported-systems (package-name package)
system-supported? key
target-supported?)) args)
(exit 1))
(if system-supported? (begin
(if target-supported? (simple-format
(derivation-for-system-and-target inferior-package-id (current-error-port)
package "error: while processing ~A ignoring error: ~A: ~A\n"
system (package-name package)
target) key
#f) args)
#f))) #f)))))
(lambda (key . args) gds-inferior-packages)))
(if (and (eq? key 'system-error)
(eq? (car args) 'fport_write))
(begin
(simple-format
(current-error-port)
"error: while processing ~A, exiting: ~A: ~A\n"
(package-name package)
key
args)
(exit 1))
(begin
(simple-format
(current-error-port)
"error: while processing ~A ignoring error: ~A: ~A\n"
(package-name package)
key
args)
#f))))))
gds-inferior-package-ids)))
(inferior-eval (inferior-eval
'(when (defined? 'systems (resolve-module '(guix platform))) '(when (defined? 'systems (resolve-module '(guix platform)))
(use-modules (guix platform))) (use-modules (guix platform)))
inf) inf)
(inferior-eval (format (current-error-port)
`(define gds-inferior-package-ids "heap size: ~a MiB~%"
(list ,@(map inferior-package-id packages))) (round
inf) (/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(inferior-eval (catch
`(define gds-packages-proc ,proc) 'match-error
inf) (lambda ()
(inferior-eval '(invalidate-derivation-caches!) inf))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
(append-map! ;; Clean the cached store connections, as there are caches associated
(lambda (system-target-pair) ;; with these that take up lots of memory
(format (current-error-port) (inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf)
"heap size: ~a MiB~%"
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(format (current-error-port) (with-time-logging
"inferior heap before cleanup: ~a MiB used (~a MiB heap)~%" (simple-format #f "getting derivations for ~A" (cons system target))
(round (inferior-eval-with-store
(/ (inferior-eval inf
'(let ((stats (gc-stats))) store
(- (assoc-ref stats 'heap-size) proc)))
(assoc-ref stats 'heap-free-size)))
inf)
(expt 2. 20)))
(round
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
(expt 2. 20))))
(catch
'match-error
(lambda ()
(inferior-eval '(invalidate-derivation-caches!) inf))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
;; Clean the cached store connections, as there are caches associated (define (sort-and-deduplicate-inferior-packages packages)
;; with these that take up lots of memory
(inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf)
(inferior-eval '(gc) inf)
(format (current-error-port)
"inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
(round
(/ (inferior-eval
'(let ((stats (gc-stats)))
(- (assoc-ref stats 'heap-size)
(assoc-ref stats 'heap-free-size)))
inf)
(expt 2. 20)))
(round
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
(expt 2. 20))))
(with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pair)
(inferior-eval-with-store
inf
store
`(lambda (store)
(gds-packages-proc store (cons ,(car system-target-pair)
,(cdr system-target-pair)))))))
(append supported-system-pairs
supported-system-cross-build-pairs)))
(define (deduplicate-inferior-packages packages)
(pair-fold (pair-fold
(lambda (pair result) (lambda (pair result)
(if (null? (cdr pair)) (if (null? (cdr pair))
@ -997,20 +898,42 @@ WHERE job_id = $1")
;; same name and version, but different derivations. Guix will warn ;; same name and version, but different derivations. Guix will warn
;; about this case though, generally this means only one of the ;; about this case though, generally this means only one of the
;; packages should be exported. ;; packages should be exported.
(deduplicate-inferior-packages (sort-and-deduplicate-inferior-packages
(append! packages non-exported-replacements)))) (append! packages non-exported-replacements)))
(deduplicated-packages-length
(length deduplicated-packages)))
deduplicated-packages)) (inferior-eval
`(use-modules (srfi srfi-43))
inf)
(inferior-eval
`(define gds-inferior-packages
(make-vector ,deduplicated-packages-length))
inf)
(inferior-eval
`(for-each
(lambda (index id)
(vector-set! gds-inferior-packages
index
(or (hashv-ref %package-table id)
(error "missing package id"))))
(iota ,deduplicated-packages-length)
(list ,@(map inferior-package-id deduplicated-packages)))
inf)
(list->vector deduplicated-packages)))
(define* (all-inferior-packages-data inf packages #:key (process-replacements? #t)) (define* (all-inferior-packages-data inf packages #:key (process-replacements? #t))
(let* ((package-license-data (let* ((package-license-data
(with-time-logging "fetching inferior package license metadata" (with-time-logging "fetching inferior package license metadata"
(inferior-packages->license-data inf packages))) (inferior-packages->license-data inf)))
(package-metadata (package-metadata
(with-time-logging "fetching inferior package metadata" (with-time-logging "fetching inferior package metadata"
(map (vector-map
(lambda (package) (lambda (_ package)
(let ((translated-package-descriptions-and-synopsis (let ((translated-package-descriptions-and-synopsis
(inferior-packages->translated-package-descriptions-and-synopsis (inferior-packages->translated-package-descriptions-and-synopsis
inf package))) inf package)))
@ -1022,28 +945,31 @@ WHERE job_id = $1")
packages))) packages)))
(package-replacement-data (package-replacement-data
(if process-replacements? (if process-replacements?
(map (lambda (package) (vector-map
(let ((replacement (inferior-package-replacement package))) (lambda (_ package)
(if replacement (let ((replacement (inferior-package-replacement package)))
;; I'm not sure if replacements can themselves be (if replacement
;; replaced, but I do know for sure that there are ;; I'm not sure if replacements can themselves be
;; infinite chains of replacements (python(2)-urllib3 ;; replaced, but I do know for sure that there are
;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for ;; infinite chains of replacements (python(2)-urllib3
;; example). ;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for
;; ;; example).
;; This code currently just capures the first level ;;
;; of replacements ;; This code currently just capures the first level
(first ;; of replacements
(all-inferior-packages-data (first
inf (all-inferior-packages-data
(list replacement) inf
#:process-replacements? #f)) (vector replacement)
#f))) #:process-replacements? #f))
packages) #f)))
packages)
#f))) #f)))
`((names . ,(map inferior-package-name packages)) `((names . ,(vector-map (lambda (_ pkg) (inferior-package-name pkg))
(versions . ,(map inferior-package-version packages)) packages))
(versions . ,(vector-map (lambda (_ pkg) (inferior-package-version pkg))
packages))
(license-data . ,package-license-data) (license-data . ,package-license-data)
(metadata . ,package-metadata) (metadata . ,package-metadata)
(replacemnets . ,package-replacement-data)))) (replacemnets . ,package-replacement-data))))
@ -1055,25 +981,30 @@ WHERE job_id = $1")
conn conn
(inferior-packages->license-id-lists (inferior-packages->license-id-lists
conn conn
(assq-ref inferior-packages-data 'license-data)))) ;; TODO Don't needlessly convert
(vector->list
(assq-ref inferior-packages-data 'license-data)))))
((all-package-metadata-ids new-package-metadata-ids) ((all-package-metadata-ids new-package-metadata-ids)
(with-time-logging "inserting package metadata entries" (with-time-logging "inserting package metadata entries"
(inferior-packages->package-metadata-ids (inferior-packages->package-metadata-ids
conn conn
(assq-ref inferior-packages-data 'metadata) ;; TODO Don't needlessly convert
(vector->list
(assq-ref inferior-packages-data 'metadata))
package-license-set-ids))) package-license-set-ids)))
((replacement-ids) ((replacement-ids)
(or (and=> (assq-ref inferior-packages-data 'replacements) (or (and=> (assq-ref inferior-packages-data 'replacements)
(lambda (all-replacement-data) (lambda (all-replacement-data)
(with-time-logging "inserting package replacements" (with-time-logging "inserting package replacements"
(map (lambda (replacement-data) (vector-map
(if replacement-data (lambda (_ replacement-data)
(first (if replacement-data
(insert-packages conn (list replacement-data))) (first
(cons "integer" NULL))) (insert-packages conn (list replacement-data)))
all-replacement-data)))) (cons "integer" NULL)))
(make-list (length package-license-set-ids) all-replacement-data))))
(cons "integer" NULL))))) (make-vector (length package-license-set-ids)
(cons "integer" NULL)))))
(unless (null? new-package-metadata-ids) (unless (null? new-package-metadata-ids)
(with-time-logging "fetching package metadata tsvector entries" (with-time-logging "fetching package metadata tsvector entries"
@ -1083,75 +1014,80 @@ WHERE job_id = $1")
(with-time-logging "getting package-ids" (with-time-logging "getting package-ids"
(inferior-packages->package-ids (inferior-packages->package-ids
conn conn
(zip (assq-ref inferior-packages-data 'names) ;; TODO Do this more efficiently
(assq-ref inferior-packages-data 'versions) (zip (vector->list (assq-ref inferior-packages-data 'names))
(vector->list (assq-ref inferior-packages-data 'versions))
all-package-metadata-ids all-package-metadata-ids
replacement-ids))))) (vector->list replacement-ids))))))
(define (insert-lint-warnings conn inferior-package-id->package-database-id (define (insert-lint-warnings conn
package-ids
lint-checker-ids lint-checker-ids
lint-warnings-data) lint-warnings-data)
(lint-warnings-data->lint-warning-ids (lint-warnings-data->lint-warning-ids
conn conn
(append-map (append-map!
(lambda (lint-checker-id warnings-by-package-id) (lambda (lint-checker-id warnings-per-package)
(append-map (if warnings-per-package
(match-lambda (vector-fold
((package-id . warnings) (lambda (_ result package-id warnings)
(map (append!
(match-lambda result
((location-data messages-by-locale) (map
(let ((location-id (match-lambda
(location->location-id ((location-data messages-by-locale)
conn (let ((location-id
(apply location location-data))) (location->location-id
(lint-warning-message-set-id conn
(lint-warning-message-data->lint-warning-message-set-id (apply location location-data)))
conn (lint-warning-message-set-id
messages-by-locale))) (lint-warning-message-data->lint-warning-message-set-id
(list lint-checker-id conn
(inferior-package-id->package-database-id package-id) messages-by-locale)))
location-id (list lint-checker-id
lint-warning-message-set-id)))) package-id
(fold (lambda (location-and-messages result) location-id
(if (member location-and-messages result) lint-warning-message-set-id))))
(begin (fold (lambda (location-and-messages result)
(apply ;; TODO Sort to delete duplicates, rather than use member
simple-format (if (member location-and-messages result)
(current-error-port) (begin
"warning: skipping duplicate lint warning ~A ~A\n" (apply
location-and-messages) simple-format
result) (current-error-port)
(append result "warning: skipping duplicate lint warning ~A ~A\n"
(list location-and-messages)))) location-and-messages)
'() result)
warnings)))) (append! result
warnings-by-package-id)) (list location-and-messages))))
'()
warnings))))
'()
package-ids
warnings-per-package)
'()))
lint-checker-ids lint-checker-ids
(map cdr lint-warnings-data)))) lint-warnings-data)))
(define (inferior-data->package-derivation-ids (define (inferior-data->package-derivation-ids
conn inf conn inf
inferior-package-id->package-database-id package-ids
inferior-data-4-tuples) inferior-packages-system-and-target-to-derivations-alist)
(let ((derivation-ids (append-map!
(derivation-file-names->derivation-ids (lambda (data)
conn (let* ((system-and-target (car data))
(map fourth inferior-data-4-tuples))) (derivations-vector (cdr data))
(flat-package-ids-systems-and-targets (derivation-ids
(map (derivation-file-names->derivation-ids
(match-lambda conn
((inferior-package-id system target derivation-file-name) derivations-vector)))
(list (inferior-package-id->package-database-id
inferior-package-id)
system
(or target ""))))
inferior-data-4-tuples)))
(insert-package-derivations conn
(insert-package-derivations conn (car system-and-target)
flat-package-ids-systems-and-targets (or (cdr system-and-target) "")
derivation-ids))) package-ids
derivation-ids)))
inferior-packages-system-and-target-to-derivations-alist))
(define guix-store-path (define guix-store-path
(let ((store-path #f)) (let ((store-path #f))
@ -1516,12 +1452,35 @@ WHERE job_id = $1")
(let* ((packages (let* ((packages
(with-time-logging "fetching inferior packages" (with-time-logging "fetching inferior packages"
(inferior-packages-plus-replacements inf))) (inferior-packages-plus-replacements inf)))
(inferior-lint-warnings (inferior-lint-checkers-data
(with-time-logging "fetching inferior lint warnings" (inferior-lint-checkers inf))
(all-inferior-lint-warnings inf store packages))) (inferior-lint-warnings-data
(inferior-data-4-tuples (and inferior-lint-checkers-data
(with-time-logging "fetching inferior lint warnings"
(map
(match-lambda
((checker-name _ network-dependent?)
(and (and (not network-dependent?)
;; Running the derivation linter is
;; currently infeasible
(not (eq? checker-name 'derivation)))
(inferior-lint-warnings inf
store
checker-name))))
inferior-lint-checkers-data))))
(inferior-system-target-pairs
(inferior-fetch-system-target-pairs inf))
(inferior-packages-system-and-target-to-derivations-alist
(with-time-logging "getting inferior derivations" (with-time-logging "getting inferior derivations"
(all-inferior-package-derivations store inf packages))) (map
(match-lambda
((system . target)
(cons (cons system target)
(inferior-package-derivations store
inf
system
target))))
inferior-system-target-pairs)))
(inferior-system-tests (inferior-system-tests
(if skip-system-tests? (if skip-system-tests?
(begin (begin
@ -1544,84 +1503,70 @@ WHERE job_id = $1")
;; avoid any concurrency issues ;; avoid any concurrency issues
(obtain-advisory-transaction-lock conn (obtain-advisory-transaction-lock conn
'load-new-guix-revision-inserts)) 'load-new-guix-revision-inserts))
(let* ((package-ids (with-time-logging
(insert-packages conn packages-data)) "inserting data"
(inferior-package-id->package-database-id (let* ((package-ids
(let ((lookup-table (insert-packages conn packages-data)))
(alist->hashq-table (when inferior-lint-warnings
(map (lambda (package package-id) (let* ((lint-checker-ids
(cons (inferior-package-id package) (lint-checkers->lint-checker-ids
package-id)) conn
packages (map (match-lambda
package-ids)))) ((name descriptions-by-locale network-dependent)
(lambda (inferior-id) (list
(or name
(hashq-ref lookup-table inferior-id) network-dependent
(error (lint-checker-description-data->lint-checker-description-set-id
(simple-format conn descriptions-by-locale))))
#f inferior-lint-checkers-data)))
"error: inferior-package-id->package-database-id: ~A missing\n" (lint-warning-ids
inferior-id))))))) (insert-lint-warnings
conn
package-ids
lint-checker-ids
inferior-lint-warnings-data)))
(insert-guix-revision-lint-checkers conn
guix-revision-id
lint-checker-ids)
(chunk-for-each!
(lambda (lint-warning-ids-chunk)
(insert-guix-revision-lint-warnings conn
guix-revision-id
lint-warning-ids-chunk))
5000
lint-warning-ids)))
(when inferior-lint-warnings (when inferior-system-tests
(let* ((lint-checker-ids (insert-system-tests-for-guix-revision conn
(lint-checkers->lint-checker-ids
conn
(map (match-lambda
((name descriptions-by-locale network-dependent)
(list
name
network-dependent
(lint-checker-description-data->lint-checker-description-set-id
conn descriptions-by-locale))))
(map car inferior-lint-warnings))))
(lint-warning-ids
(insert-lint-warnings
conn
inferior-package-id->package-database-id
lint-checker-ids
inferior-lint-warnings)))
(insert-guix-revision-lint-checkers conn
guix-revision-id
lint-checker-ids)
(chunk-for-each!
(lambda (lint-warning-ids-chunk)
(insert-guix-revision-lint-warnings conn
guix-revision-id guix-revision-id
lint-warning-ids-chunk)) inferior-system-tests))
5000
lint-warning-ids)))
(when inferior-system-tests (let* ((package-derivation-ids
(insert-system-tests-for-guix-revision conn (with-time-logging "inferior-data->package-derivation-ids"
guix-revision-id (inferior-data->package-derivation-ids
inferior-system-tests)) conn
inf
package-ids
inferior-packages-system-and-target-to-derivations-alist)))
(ids-count
(length package-derivation-ids)))
(chunk-for-each! (lambda (package-derivation-ids-chunk)
(insert-guix-revision-package-derivations
conn
guix-revision-id
package-derivation-ids-chunk))
2000
package-derivation-ids)
(simple-format
#t "Successfully loaded ~A package/derivation pairs\n"
ids-count))
(let* ((package-derivation-ids (with-time-logging
(with-time-logging "inferior-data->package-derivation-ids" "insert-guix-revision-package-derivation-distribution-counts"
(inferior-data->package-derivation-ids (insert-guix-revision-package-derivation-distribution-counts
conn inf inferior-package-id->package-database-id conn
inferior-data-4-tuples))) guix-revision-id)))))
(ids-count
(length package-derivation-ids)))
(chunk-for-each! (lambda (package-derivation-ids-chunk)
(insert-guix-revision-package-derivations
conn
guix-revision-id
package-derivation-ids-chunk))
2000
package-derivation-ids)
(simple-format
#t "Successfully loaded ~A package/derivation pairs\n"
ids-count))
(with-time-logging
"insert-guix-revision-package-derivation-distribution-counts"
(insert-guix-revision-package-derivation-distribution-counts
conn
guix-revision-id))))
#t) #t)
(lambda (key . args) (lambda (key . args)
(simple-format (current-error-port) (simple-format (current-error-port)

5
guix-data-service/model/channel-instance.scm
View file

@ -33,7 +33,8 @@
(let ((derivation-ids (let ((derivation-ids
(derivation-file-names->derivation-ids (derivation-file-names->derivation-ids
conn conn
(map cdr derivations-by-system)))) (list->vector
(map cdr derivations-by-system)))))
(exec-query (exec-query
conn conn
@ -49,7 +50,7 @@ VALUES "
system system
derivation-id)) derivation-id))
(map car derivations-by-system) (map car derivations-by-system)
derivation-ids) (vector->list derivation-ids))
", ")))) ", "))))
#t) #t)

65
guix-data-service/model/derivation.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model derivation) (define-module (guix-data-service model derivation)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
@ -1545,7 +1546,8 @@ LIMIT $1"
(update-derivation-ids-hash-table! conn (update-derivation-ids-hash-table! conn
derivation-ids-hash-table derivation-ids-hash-table
input-derivation-file-names) (list->vector
input-derivation-file-names))
(simple-format (simple-format
#t #t
"debug: ensure-input-derivations-exist: checking for missing input derivations\n") "debug: ensure-input-derivations-exist: checking for missing input derivations\n")
@ -1743,18 +1745,20 @@ WHERE " criteria ";"))
(define (update-derivation-ids-hash-table! conn (define (update-derivation-ids-hash-table! conn
derivation-ids-hash-table derivation-ids-hash-table
file-names) file-names)
(define file-names-count (length file-names)) (define file-names-count (vector-length file-names))
(simple-format #t "debug: update-derivation-ids-hash-table!: ~A file-names\n" (simple-format #t "debug: update-derivation-ids-hash-table!: ~A file-names\n"
file-names-count) file-names-count)
(let ((missing-file-names (let ((missing-file-names
(fold (lambda (file-name result) (vector-fold
(if (hash-ref derivation-ids-hash-table (lambda (_ result file-name)
file-name) (if (and file-name
result (hash-ref derivation-ids-hash-table
(cons file-name result))) file-name))
'() result
file-names))) (cons file-name result)))
'()
file-names)))
(simple-format (simple-format
#t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n" #t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n"
@ -1773,6 +1777,9 @@ WHERE " criteria ";"))
(chunk! missing-file-names 1000))))) (chunk! missing-file-names 1000)))))
(define (derivation-file-names->derivation-ids conn derivation-file-names) (define (derivation-file-names->derivation-ids conn derivation-file-names)
(define derivations-count
(vector-length derivation-file-names))
(define (insert-source-files-missing-nars derivation-ids) (define (insert-source-files-missing-nars derivation-ids)
(define (derivation-ids->next-related-derivation-ids! ids seen-ids) (define (derivation-ids->next-related-derivation-ids! ids seen-ids)
(delete-duplicates/sort! (delete-duplicates/sort!
@ -1862,10 +1869,9 @@ INNER JOIN derivation_source_files
next-related-derivation-ids next-related-derivation-ids
seen-ids))))))) seen-ids)))))))
(if (null? derivation-file-names) (if (= 0 derivations-count)
'() #()
(let* ((derivations-count (length derivation-file-names)) (let* ((derivation-ids-hash-table (make-hash-table
(derivation-ids-hash-table (make-hash-table
;; Account for more derivations in ;; Account for more derivations in
;; the graph ;; the graph
(* 2 derivations-count)))) (* 2 derivations-count))))
@ -1879,10 +1885,16 @@ INNER JOIN derivation_source_files
(let ((missing-derivation-filenames (let ((missing-derivation-filenames
(deduplicate-strings (deduplicate-strings
(filter (lambda (derivation-file-name) (vector-fold
(not (hash-ref derivation-ids-hash-table (lambda (_ result derivation-file-name)
derivation-file-name))) (if (not derivation-file-name)
derivation-file-names)))) result
(if (hash-ref derivation-ids-hash-table
derivation-file-name)
result
(cons derivation-file-name result))))
'()
derivation-file-names))))
(chunk-for-each! (chunk-for-each!
(lambda (missing-derivation-filenames-chunk) (lambda (missing-derivation-filenames-chunk)
@ -1907,14 +1919,25 @@ INNER JOIN derivation_source_files
missing-derivation-filenames) missing-derivation-filenames)
(let ((all-ids (let ((all-ids
(map (lambda (derivation-file-name) (vector-map
(lambda (_ derivation-file-name)
(if derivation-file-name
(or (hash-ref derivation-ids-hash-table (or (hash-ref derivation-ids-hash-table
derivation-file-name) derivation-file-name)
(error "missing derivation id"))) (error "missing derivation id"))
derivation-file-names))) #f))
derivation-file-names)))
(with-time-logging "insert-source-files-missing-nars" (with-time-logging "insert-source-files-missing-nars"
(insert-source-files-missing-nars all-ids)) (insert-source-files-missing-nars
;; TODO Avoid this conversion
(vector-fold
(lambda (_ result x)
(if x
(cons x result)
result))
'()
all-ids)))
all-ids))))) all-ids)))))

62
guix-data-service/model/license.scm
View file

@ -28,39 +28,39 @@
(define inferior-package-id (define inferior-package-id
(@@ (guix inferior) inferior-package-id)) (@@ (guix inferior) inferior-package-id))
(define (inferior-packages->license-data inf packages) (define (inferior-packages->license-data inf)
(define (proc packages) (define proc
`(map (lambda (inferior-package-id) `(vector-map
(let ((package (hashv-ref %package-table inferior-package-id))) (lambda (_ package)
(match (package-license package) (match (package-license package)
((? license? license) ((? license? license)
(list (list
(list (license-name license) (list (license-name license)
(license-uri license) (license-uri license)
(license-comment license)))) (license-comment license))))
((values ...) ((values ...)
(map (match-lambda (map (match-lambda
((? license? license) ((? license? license)
(list (license-name license) (list (license-name license)
(license-uri license) (license-uri license)
(license-comment license))) (license-comment license)))
(x (x
(simple-format (simple-format
(current-error-port) (current-error-port)
"error: unknown license value ~A for package ~A" "error: unknown license value ~A for package ~A"
x package) x package)
'())) '()))
values)) values))
(x (x
(simple-format (simple-format
(current-error-port) (current-error-port)
"error: unknown license value ~A for package ~A" "error: unknown license value ~A for package ~A"
x package) x package)
'())))) '())))
(list ,@(map inferior-package-id packages)))) gds-inferior-packages))
(inferior-eval '(use-modules (guix licenses)) inf) (inferior-eval '(use-modules (guix licenses)) inf)
(inferior-eval (proc packages) inf)) (inferior-eval proc inf))
(define (inferior-packages->license-id-lists conn license-data) (define (inferior-packages->license-id-lists conn license-data)
(define (string-or-null v) (define (string-or-null v)

28
guix-data-service/model/package-derivation.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model package-derivation) (define-module (guix-data-service model package-derivation)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
@ -26,17 +27,26 @@
count-packages-derivations-in-revision)) count-packages-derivations-in-revision))
(define (insert-package-derivations conn (define (insert-package-derivations conn
package-ids-systems-and-targets system
target
package-ids
derivation-ids) derivation-ids)
(define system-id
(system->system-id conn system))
(define data-4-tuples (define data-4-tuples
(map (match-lambda* (vector-fold
(((package-id system target) derivation-id) (lambda (_ result package-id derivation-id)
(list package-id (if derivation-id
derivation-id (cons (list package-id
(system->system-id conn system) derivation-id
target))) system-id
package-ids-systems-and-targets target)
derivation-ids)) result)
result))
'()
package-ids
derivation-ids))
(if (null? data-4-tuples) (if (null? data-4-tuples)
'() '()

11
guix-data-service/model/package.scm
View file

@ -264,11 +264,12 @@ INSERT INTO packages (name, version, package_metadata_id) VALUES "
RETURNING id")) RETURNING id"))
(define (inferior-packages->package-ids conn package-entries) (define (inferior-packages->package-ids conn package-entries)
(insert-missing-data-and-return-all-ids (list->vector
conn (insert-missing-data-and-return-all-ids
"packages" conn
'(name version package_metadata_id replacement_package_id) "packages"
package-entries)) '(name version package_metadata_id replacement_package_id)
package-entries)))
(define (select-package-versions-for-revision conn (define (select-package-versions-for-revision conn
commit commit