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

433
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,7 +458,6 @@ 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"
@ -474,55 +474,62 @@ WHERE job_id = $1")
"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)))
(- (assoc-ref stats 'heap-size)
(assoc-ref stats 'heap-free-size)))
inf) inf)
(expt 2. 20))) (begin
(round (simple-format (current-error-port)
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf) "warning: no (guix lint) module found\n")
(expt 2. 20)))) #f))
;; Clean the cached store connections, as there are caches associated with
;; these that take up lots of memory
(inferior-eval (inferior-eval
'(when (defined? '%store-table) (hash-clear! %store-table)) `(begin
inf) (define (lint-descriptions-by-locale checker)
(let* ((source-locale "en_US.UTF-8")
(catch (source-description
'match-error (begin
(setlocale LC_MESSAGES source-locale)
(G_ (lint-checker-description checker))))
(descriptions-by-locale
(filter-map
(lambda (locale)
(catch 'system-error
(lambda () (lambda ()
(inferior-eval '(invalidate-derivation-caches!) inf)) (setlocale LC_MESSAGES locale))
(lambda (key . args) (lambda (key . args)
(error
(simple-format (simple-format
(current-error-port) #f
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) "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)))
(inferior-eval '(gc) inf) (map (lambda (checker)
(list (lint-checker-name checker)
(lint-descriptions-by-locale checker)
(if (memq checker %network-dependent-checkers)
#t
#f)))
%all-checkers))
inf)))
(format (current-error-port) (define (inferior-lint-warnings inf store checker-name)
"inferior heap after cleanup: ~a MiB used (~a MiB heap)~%" (define lint-warnings-for-checker
(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,16 +578,14 @@ 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))
(warnings
(map process-lint-warning (map process-lint-warning
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (current-error-port) (simple-format (current-error-port)
"exception checking ~A with ~A checker: ~A\n" "exception checking ~A with ~A checker: ~A\n"
package ',checker-name exn) package checker-name exn)
(raise-exception exn)) (raise-exception exn))
(lambda () (lambda ()
(if (and lint-checker-requires-store?-defined? (if (and lint-checker-requires-store?-defined?
@ -588,81 +593,17 @@ WHERE job_id = $1")
(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
(or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f)
(use-modules (guix lint))
#t)
inf)
(begin
(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)
(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" (with-time-logging (simple-format #f "getting ~A lint warnings"
name) checker-name)
(inferior-eval-with-store (inferior-eval-with-store
inf inf
store store
(lint-warnings-for-checker packages lint-warnings-for-checker)))
name)))))
(cleanup-inferior inf)
warnings)))))
checkers))))
(define (all-inferior-package-derivations store inf packages) (define (inferior-fetch-system-target-pairs inf)
(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
system
target
(let ((file-name (let ((file-name
(derivation-file-name derivation))) (derivation-file-name derivation)))
(add-temp-root store file-name) (add-temp-root store file-name)
file-name)) file-name)
(begin (begin
(simple-format (simple-format
(current-error-port) (current-error-port)
@ -801,9 +746,8 @@ 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 ()
@ -834,8 +778,7 @@ WHERE job_id = $1")
(if system-supported? (if system-supported?
(if target-supported? (if target-supported?
(derivation-for-system-and-target inferior-package-id (derivation-for-system-and-target package
package
system system
target) target)
#f) #f)
@ -858,43 +801,20 @@ WHERE job_id = $1")
(package-name package) (package-name package)
key key
args) args)
#f)))))) #f)))))
gds-inferior-package-ids))) gds-inferior-packages)))
(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
`(define gds-inferior-package-ids
(list ,@(map inferior-package-id packages)))
inf)
(inferior-eval
`(define gds-packages-proc ,proc)
inf)
(append-map!
(lambda (system-target-pair)
(format (current-error-port) (format (current-error-port)
"heap size: ~a MiB~%" "heap size: ~a MiB~%"
(round (round
(/ (assoc-ref (gc-stats) 'heap-size) (/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20)))) (expt 2. 20))))
(format (current-error-port)
"inferior heap before 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))))
(catch (catch
'match-error 'match-error
(lambda () (lambda ()
@ -908,33 +828,14 @@ WHERE job_id = $1")
;; with these that take up lots of memory ;; with these that take up lots of memory
(inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf) (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 (with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pair) (simple-format #f "getting derivations for ~A" (cons system target))
(inferior-eval-with-store (inferior-eval-with-store
inf inf
store store
`(lambda (store) proc)))
(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) (define (sort-and-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,7 +945,8 @@ WHERE job_id = $1")
packages))) packages)))
(package-replacement-data (package-replacement-data
(if process-replacements? (if process-replacements?
(map (lambda (package) (vector-map
(lambda (_ package)
(let ((replacement (inferior-package-replacement package))) (let ((replacement (inferior-package-replacement package)))
(if replacement (if replacement
;; I'm not sure if replacements can themselves be ;; I'm not sure if replacements can themselves be
@ -1036,14 +960,16 @@ WHERE job_id = $1")
(first (first
(all-inferior-packages-data (all-inferior-packages-data
inf inf
(list replacement) (vector replacement)
#:process-replacements? #f)) #:process-replacements? #f))
#f))) #f)))
packages) 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,24 +981,29 @@ 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
(lambda (_ replacement-data)
(if replacement-data (if replacement-data
(first (first
(insert-packages conn (list replacement-data))) (insert-packages conn (list replacement-data)))
(cons "integer" NULL))) (cons "integer" NULL)))
all-replacement-data)))) all-replacement-data))))
(make-list (length package-license-set-ids) (make-vector (length package-license-set-ids)
(cons "integer" NULL))))) (cons "integer" NULL)))))
(unless (null? new-package-metadata-ids) (unless (null? new-package-metadata-ids)
@ -1083,21 +1014,25 @@ 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)
(append!
result
(map (map
(match-lambda (match-lambda
((location-data messages-by-locale) ((location-data messages-by-locale)
@ -1110,10 +1045,11 @@ WHERE job_id = $1")
conn conn
messages-by-locale))) messages-by-locale)))
(list lint-checker-id (list lint-checker-id
(inferior-package-id->package-database-id package-id) package-id
location-id location-id
lint-warning-message-set-id)))) lint-warning-message-set-id))))
(fold (lambda (location-and-messages result) (fold (lambda (location-and-messages result)
;; TODO Sort to delete duplicates, rather than use member
(if (member location-and-messages result) (if (member location-and-messages result)
(begin (begin
(apply (apply
@ -1122,36 +1058,36 @@ WHERE job_id = $1")
"warning: skipping duplicate lint warning ~A ~A\n" "warning: skipping duplicate lint warning ~A ~A\n"
location-and-messages) location-and-messages)
result) result)
(append result (append! result
(list location-and-messages)))) (list location-and-messages))))
'() '()
warnings)))) warnings))))
warnings-by-package-id)) '()
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!
(lambda (data)
(let* ((system-and-target (car data))
(derivations-vector (cdr data))
(derivation-ids
(derivation-file-names->derivation-ids (derivation-file-names->derivation-ids
conn conn
(map fourth inferior-data-4-tuples))) derivations-vector)))
(flat-package-ids-systems-and-targets
(map
(match-lambda
((inferior-package-id system target derivation-file-name)
(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
flat-package-ids-systems-and-targets (car system-and-target)
(or (cdr system-and-target) "")
package-ids
derivation-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
(inferior-lint-checkers inf))
(inferior-lint-warnings-data
(and inferior-lint-checkers-data
(with-time-logging "fetching inferior lint warnings" (with-time-logging "fetching inferior lint warnings"
(all-inferior-lint-warnings inf store packages))) (map
(inferior-data-4-tuples (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,26 +1503,10 @@ 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))
(with-time-logging
"inserting data"
(let* ((package-ids (let* ((package-ids
(insert-packages conn packages-data)) (insert-packages conn packages-data)))
(inferior-package-id->package-database-id
(let ((lookup-table
(alist->hashq-table
(map (lambda (package package-id)
(cons (inferior-package-id package)
package-id))
packages
package-ids))))
(lambda (inferior-id)
(or
(hashq-ref lookup-table inferior-id)
(error
(simple-format
#f
"error: inferior-package-id->package-database-id: ~A missing\n"
inferior-id)))))))
(when inferior-lint-warnings (when inferior-lint-warnings
(let* ((lint-checker-ids (let* ((lint-checker-ids
(lint-checkers->lint-checker-ids (lint-checkers->lint-checker-ids
@ -1575,13 +1518,13 @@ WHERE job_id = $1")
network-dependent network-dependent
(lint-checker-description-data->lint-checker-description-set-id (lint-checker-description-data->lint-checker-description-set-id
conn descriptions-by-locale)))) conn descriptions-by-locale))))
(map car inferior-lint-warnings)))) inferior-lint-checkers-data)))
(lint-warning-ids (lint-warning-ids
(insert-lint-warnings (insert-lint-warnings
conn conn
inferior-package-id->package-database-id package-ids
lint-checker-ids lint-checker-ids
inferior-lint-warnings))) inferior-lint-warnings-data)))
(insert-guix-revision-lint-checkers conn (insert-guix-revision-lint-checkers conn
guix-revision-id guix-revision-id
lint-checker-ids) lint-checker-ids)
@ -1602,8 +1545,10 @@ WHERE job_id = $1")
(let* ((package-derivation-ids (let* ((package-derivation-ids
(with-time-logging "inferior-data->package-derivation-ids" (with-time-logging "inferior-data->package-derivation-ids"
(inferior-data->package-derivation-ids (inferior-data->package-derivation-ids
conn inf inferior-package-id->package-database-id conn
inferior-data-4-tuples))) inf
package-ids
inferior-packages-system-and-target-to-derivations-alist)))
(ids-count (ids-count
(length package-derivation-ids))) (length package-derivation-ids)))
(chunk-for-each! (lambda (package-derivation-ids-chunk) (chunk-for-each! (lambda (package-derivation-ids-chunk)
@ -1621,7 +1566,7 @@ WHERE job_id = $1")
"insert-guix-revision-package-derivation-distribution-counts" "insert-guix-revision-package-derivation-distribution-counts"
(insert-guix-revision-package-derivation-distribution-counts (insert-guix-revision-package-derivation-distribution-counts
conn conn
guix-revision-id)))) 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)

53
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,14 +1745,16 @@ 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
(hash-ref derivation-ids-hash-table
file-name))
result result
(cons file-name result))) (cons file-name result)))
'() '()
@ -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,9 +1885,15 @@ 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)
result
(if (hash-ref derivation-ids-hash-table
derivation-file-name)
result
(cons derivation-file-name result))))
'()
derivation-file-names)))) derivation-file-names))))
(chunk-for-each! (chunk-for-each!
@ -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"))
#f))
derivation-file-names))) 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)))))

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

@ -28,10 +28,10 @@
(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
@ -56,11 +56,11 @@
(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)

24
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,16 +27,25 @@
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
(cons (list package-id
derivation-id derivation-id
(system->system-id conn system) system-id
target))) target)
package-ids-systems-and-targets result)
result))
'()
package-ids
derivation-ids)) derivation-ids))
(if (null? data-4-tuples) (if (null? data-4-tuples)

3
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)
(list->vector
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn
"packages" "packages"
'(name version package_metadata_id replacement_package_id) '(name version package_metadata_id replacement_package_id)
package-entries)) package-entries)))
(define (select-package-versions-for-revision conn (define (select-package-versions-for-revision conn
commit commit