[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: Make some sweeping changes to loading new revisions
|
From: |
Christopher Baines |
|
Subject: |
01/04: Make some sweeping changes to loading new revisions |
|
Date: |
Sun, 5 Nov 2023 10:44:16 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit f5acc60288e0ad9f0c1093f3d50af1347e4df1df
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Wed Nov 1 21:08:22 2023 +0000
Make some sweeping changes to loading new revisions
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).
---
guix-data-service/jobs/load-new-guix-revision.scm | 875 ++++++++++------------
guix-data-service/model/channel-instance.scm | 5 +-
guix-data-service/model/derivation.scm | 65 +-
guix-data-service/model/license.scm | 62 +-
guix-data-service/model/package-derivation.scm | 28 +-
guix-data-service/model/package.scm | 11 +-
6 files changed, 513 insertions(+), 533 deletions(-)
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm
b/guix-data-service/jobs/load-new-guix-revision.scm
index d54afea..796bfc5 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -18,6 +18,7 @@
(define-module (guix-data-service jobs load-new-guix-revision)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (ice-9 textual-ports)
@@ -457,72 +458,78 @@ WHERE job_id = $1")
#f)))
-(define (all-inferior-lint-warnings inf store packages)
- (define locales
- '("cs_CZ.UTF-8"
- "da_DK.UTF-8"
- "de_DE.UTF-8"
- "eo_EO.UTF-8"
- "es_ES.UTF-8"
- "fr_FR.UTF-8"
- "hu_HU.UTF-8"
- "nl_NL.UTF-8"
- "pl_PL.UTF-8"
- "pt_BR.UTF-8"
- ;;"sr_SR.UTF-8"
- "sv_SE.UTF-8"
- "vi_VN.UTF-8"
- "zh_CN.UTF-8"))
-
- (define (cleanup-inferior inf)
- (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))))
-
- ;; 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))
- inf)
-
- (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")))
-
- (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)
+(define locales
+ '("cs_CZ.UTF-8"
+ "da_DK.UTF-8"
+ "de_DE.UTF-8"
+ "eo_EO.UTF-8"
+ "es_ES.UTF-8"
+ "fr_FR.UTF-8"
+ "hu_HU.UTF-8"
+ "nl_NL.UTF-8"
+ "pl_PL.UTF-8"
+ "pt_BR.UTF-8"
+ ;;"sr_SR.UTF-8"
+ "sv_SE.UTF-8"
+ "vi_VN.UTF-8"
+ "zh_CN.UTF-8"))
+
+(define (inferior-lint-checkers inf)
+ (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))
+ (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)))
+
+(define (inferior-lint-warnings inf store checker-name)
+ (define lint-warnings-for-checker
`(lambda (store)
- (let* ((checker (find (lambda (checker)
+ (let* ((checker-name (quote ,checker-name))
+ (checker (find (lambda (checker)
(eq? (lint-checker-name checker)
- ',checker-name))
+ checker-name))
%local-checkers))
(check (lint-checker-check checker)))
@@ -571,98 +578,32 @@ WHERE job_id = $1")
(cons (cons source-locale source-message)
messages-by-locale))))
- (filter-map
- (lambda (package-id)
- (let* ((package (hashv-ref %package-table package-id))
- (warnings
- (map process-lint-warning
- (with-exception-handler
- (lambda (exn)
- (simple-format (current-error-port)
- "exception checking ~A with ~A
checker: ~A\n"
- package ',checker-name exn)
- (raise-exception exn))
- (lambda ()
- (if (and lint-checker-requires-store?-defined?
- (lint-checker-requires-store? checker))
-
- (check package #:store store)
- (check package)))
- #:unwind? #t))))
- (if (null? warnings)
- #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"
- 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)
+ (vector-map
+ (lambda (_ package)
+ (map process-lint-warning
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format (current-error-port)
+ "exception checking ~A with ~A checker:
~A\n"
+ package checker-name exn)
+ (raise-exception exn))
+ (lambda ()
+ (if (and lint-checker-requires-store?-defined?
+ (lint-checker-requires-store? checker))
+
+ (check package #:store store)
+ (check package)))
+ #:unwind? #t)))
+ gds-inferior-packages))))
+
+ (with-time-logging (simple-format #f "getting ~A lint warnings"
+ checker-name)
+ (inferior-eval-with-store
+ inf
+ store
+ lint-warnings-for-checker)))
+
+(define (inferior-fetch-system-target-pairs inf)
(define inf-systems
(inferior-guix-systems inf))
@@ -712,8 +653,15 @@ WHERE job_id = $1")
targets)))
cross-derivations))
+ (append supported-system-pairs
+ supported-system-cross-build-pairs))
+
+(define (inferior-package-derivations store inf system target)
(define proc
- '(lambda (store system-target-pair)
+ `(lambda (store)
+ (define system-target-pair
+ (cons ,system ,target))
+
(define target-system-alist
(if (defined? 'platforms (resolve-module '(guix platform)))
(filter-map
@@ -762,7 +710,7 @@ WHERE job_id = $1")
"error ~A: ~A\n" key args)
#f))))
- (define (derivation-for-system-and-target inferior-package-id package
system target)
+ (define (derivation-for-system-and-target package system target)
(catch
'misc-error
(lambda ()
@@ -776,13 +724,10 @@ WHERE job_id = $1")
(package-derivation store package system))))
;; You don't always get what you ask for, so check
(if (string=? system (derivation-system derivation))
- (list inferior-package-id
- system
- target
- (let ((file-name
- (derivation-file-name derivation)))
- (add-temp-root store file-name)
- file-name))
+ (let ((file-name
+ (derivation-file-name derivation)))
+ (add-temp-root store file-name)
+ file-name)
(begin
(simple-format
(current-error-port)
@@ -801,140 +746,96 @@ WHERE job_id = $1")
args)
#f)))
- (filter-map
- (lambda (inferior-package-id)
- (let ((package (hashv-ref %package-table inferior-package-id)))
- (catch
- #t
- (lambda ()
- (let* ((system (car system-target-pair))
- (target (cdr system-target-pair))
- (supported-systems (get-supported-systems package
system))
- (system-supported?
- (and supported-systems
- (->bool (member system supported-systems))))
- (target-supported?
- (or (not target)
- (let ((system-for-target
- (assoc-ref target-system-alist
- target)))
- (or (not system-for-target)
- (->bool
- (member system-for-target
- (package-supported-systems package)
- string=?)))))))
-
- (when (string=? (package-name package) "guix")
+ (vector-map
+ (lambda (_ package)
+ (catch
+ #t
+ (lambda ()
+ (let* ((system (car system-target-pair))
+ (target (cdr system-target-pair))
+ (supported-systems (get-supported-systems package system))
+ (system-supported?
+ (and supported-systems
+ (->bool (member system supported-systems))))
+ (target-supported?
+ (or (not target)
+ (let ((system-for-target
+ (assoc-ref target-system-alist
+ target)))
+ (or (not system-for-target)
+ (->bool
+ (member system-for-target
+ (package-supported-systems package)
+ string=?)))))))
+
+ (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
(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 inferior-package-id
- package
- system
- target)
- #f)
- #f)))
- (lambda (key . args)
- (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)))
+ "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-packages)))
(inferior-eval
'(when (defined? 'systems (resolve-module '(guix platform)))
(use-modules (guix platform)))
inf)
- (inferior-eval
- `(define gds-inferior-package-ids
- (list ,@(map inferior-package-id packages)))
- inf)
+ (format (current-error-port)
+ "heap size: ~a MiB~%"
+ (round
+ (/ (assoc-ref (gc-stats) 'heap-size)
+ (expt 2. 20))))
- (inferior-eval
- `(define gds-packages-proc ,proc)
- inf)
+ (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")))
- (append-map!
- (lambda (system-target-pair)
- (format (current-error-port)
- "heap size: ~a MiB~%"
- (round
- (/ (assoc-ref (gc-stats) 'heap-size)
- (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
- '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
- ;; 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)
+ ;; 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))
inf)
+
+ (with-time-logging
+ (simple-format #f "getting derivations for ~A" (cons system target))
+ (inferior-eval-with-store
+ inf
+ store
+ proc)))
+
+(define (sort-and-deduplicate-inferior-packages packages)
(pair-fold
(lambda (pair result)
(if (null? (cdr pair))
@@ -997,20 +898,42 @@ WHERE job_id = $1")
;; same name and version, but different derivations. Guix will warn
;; about this case though, generally this means only one of the
;; packages should be exported.
- (deduplicate-inferior-packages
- (append! packages non-exported-replacements))))
+ (sort-and-deduplicate-inferior-packages
+ (append! packages non-exported-replacements)))
+
+ (deduplicated-packages-length
+ (length 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)
- deduplicated-packages))
+ (list->vector deduplicated-packages)))
(define* (all-inferior-packages-data inf packages #:key (process-replacements?
#t))
(let* ((package-license-data
(with-time-logging "fetching inferior package license metadata"
- (inferior-packages->license-data inf packages)))
+ (inferior-packages->license-data inf)))
(package-metadata
(with-time-logging "fetching inferior package metadata"
- (map
- (lambda (package)
+ (vector-map
+ (lambda (_ package)
(let ((translated-package-descriptions-and-synopsis
(inferior-packages->translated-package-descriptions-and-synopsis
inf package)))
@@ -1022,28 +945,31 @@ WHERE job_id = $1")
packages)))
(package-replacement-data
(if process-replacements?
- (map (lambda (package)
- (let ((replacement (inferior-package-replacement
package)))
- (if replacement
- ;; I'm not sure if replacements can themselves be
- ;; replaced, but I do know for sure that there are
- ;; infinite chains of replacements
(python(2)-urllib3
- ;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for
- ;; example).
- ;;
- ;; This code currently just capures the first level
- ;; of replacements
- (first
- (all-inferior-packages-data
- inf
- (list replacement)
- #:process-replacements? #f))
- #f)))
- packages)
+ (vector-map
+ (lambda (_ package)
+ (let ((replacement (inferior-package-replacement package)))
+ (if replacement
+ ;; I'm not sure if replacements can themselves be
+ ;; replaced, but I do know for sure that there are
+ ;; infinite chains of replacements (python(2)-urllib3
+ ;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for
+ ;; example).
+ ;;
+ ;; This code currently just capures the first level
+ ;; of replacements
+ (first
+ (all-inferior-packages-data
+ inf
+ (vector replacement)
+ #:process-replacements? #f))
+ #f)))
+ packages)
#f)))
- `((names . ,(map inferior-package-name packages))
- (versions . ,(map inferior-package-version packages))
+ `((names . ,(vector-map (lambda (_ pkg) (inferior-package-name pkg))
+ packages))
+ (versions . ,(vector-map (lambda (_ pkg) (inferior-package-version
pkg))
+ packages))
(license-data . ,package-license-data)
(metadata . ,package-metadata)
(replacemnets . ,package-replacement-data))))
@@ -1055,25 +981,30 @@ WHERE job_id = $1")
conn
(inferior-packages->license-id-lists
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)
(with-time-logging "inserting package metadata entries"
(inferior-packages->package-metadata-ids
conn
- (assq-ref inferior-packages-data 'metadata)
+ ;; TODO Don't needlessly convert
+ (vector->list
+ (assq-ref inferior-packages-data 'metadata))
package-license-set-ids)))
((replacement-ids)
(or (and=> (assq-ref inferior-packages-data 'replacements)
(lambda (all-replacement-data)
(with-time-logging "inserting package replacements"
- (map (lambda (replacement-data)
- (if replacement-data
- (first
- (insert-packages conn (list
replacement-data)))
- (cons "integer" NULL)))
- all-replacement-data))))
- (make-list (length package-license-set-ids)
- (cons "integer" NULL)))))
+ (vector-map
+ (lambda (_ replacement-data)
+ (if replacement-data
+ (first
+ (insert-packages conn (list replacement-data)))
+ (cons "integer" NULL)))
+ all-replacement-data))))
+ (make-vector (length package-license-set-ids)
+ (cons "integer" NULL)))))
(unless (null? new-package-metadata-ids)
(with-time-logging "fetching package metadata tsvector entries"
@@ -1083,75 +1014,80 @@ WHERE job_id = $1")
(with-time-logging "getting package-ids"
(inferior-packages->package-ids
conn
- (zip (assq-ref inferior-packages-data 'names)
- (assq-ref inferior-packages-data 'versions)
+ ;; TODO Do this more efficiently
+ (zip (vector->list (assq-ref inferior-packages-data 'names))
+ (vector->list (assq-ref inferior-packages-data 'versions))
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-warnings-data)
(lint-warnings-data->lint-warning-ids
conn
- (append-map
- (lambda (lint-checker-id warnings-by-package-id)
- (append-map
- (match-lambda
- ((package-id . warnings)
- (map
- (match-lambda
- ((location-data messages-by-locale)
- (let ((location-id
- (location->location-id
- conn
- (apply location location-data)))
- (lint-warning-message-set-id
- (lint-warning-message-data->lint-warning-message-set-id
- conn
- messages-by-locale)))
- (list lint-checker-id
- (inferior-package-id->package-database-id package-id)
- location-id
- lint-warning-message-set-id))))
- (fold (lambda (location-and-messages result)
- (if (member location-and-messages result)
- (begin
- (apply
- simple-format
- (current-error-port)
- "warning: skipping duplicate lint warning ~A ~A\n"
- location-and-messages)
- result)
- (append result
- (list location-and-messages))))
- '()
- warnings))))
- warnings-by-package-id))
+ (append-map!
+ (lambda (lint-checker-id warnings-per-package)
+ (if warnings-per-package
+ (vector-fold
+ (lambda (_ result package-id warnings)
+ (append!
+ result
+ (map
+ (match-lambda
+ ((location-data messages-by-locale)
+ (let ((location-id
+ (location->location-id
+ conn
+ (apply location location-data)))
+ (lint-warning-message-set-id
+
(lint-warning-message-data->lint-warning-message-set-id
+ conn
+ messages-by-locale)))
+ (list lint-checker-id
+ package-id
+ location-id
+ lint-warning-message-set-id))))
+ (fold (lambda (location-and-messages result)
+ ;; TODO Sort to delete duplicates, rather than use
member
+ (if (member location-and-messages result)
+ (begin
+ (apply
+ simple-format
+ (current-error-port)
+ "warning: skipping duplicate lint warning ~A
~A\n"
+ location-and-messages)
+ result)
+ (append! result
+ (list location-and-messages))))
+ '()
+ warnings))))
+ '()
+ package-ids
+ warnings-per-package)
+ '()))
lint-checker-ids
- (map cdr lint-warnings-data))))
+ lint-warnings-data)))
(define (inferior-data->package-derivation-ids
conn inf
- inferior-package-id->package-database-id
- inferior-data-4-tuples)
- (let ((derivation-ids
- (derivation-file-names->derivation-ids
- conn
- (map fourth inferior-data-4-tuples)))
- (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)))
-
+ package-ids
+ inferior-packages-system-and-target-to-derivations-alist)
+ (append-map!
+ (lambda (data)
+ (let* ((system-and-target (car data))
+ (derivations-vector (cdr data))
+ (derivation-ids
+ (derivation-file-names->derivation-ids
+ conn
+ derivations-vector)))
- (insert-package-derivations conn
- flat-package-ids-systems-and-targets
- derivation-ids)))
+ (insert-package-derivations conn
+ (car system-and-target)
+ (or (cdr system-and-target) "")
+ package-ids
+ derivation-ids)))
+ inferior-packages-system-and-target-to-derivations-alist))
(define guix-store-path
(let ((store-path #f))
@@ -1516,12 +1452,35 @@ WHERE job_id = $1")
(let* ((packages
(with-time-logging "fetching inferior packages"
(inferior-packages-plus-replacements inf)))
- (inferior-lint-warnings
- (with-time-logging "fetching inferior lint warnings"
- (all-inferior-lint-warnings inf store packages)))
- (inferior-data-4-tuples
+ (inferior-lint-checkers-data
+ (inferior-lint-checkers inf))
+ (inferior-lint-warnings-data
+ (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"
- (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
(if skip-system-tests?
(begin
@@ -1544,84 +1503,70 @@ WHERE job_id = $1")
;; avoid any concurrency issues
(obtain-advisory-transaction-lock conn
'load-new-guix-revision-inserts))
- (let* ((package-ids
- (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
- (let* ((lint-checker-ids
- (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
+ (with-time-logging
+ "inserting data"
+ (let* ((package-ids
+ (insert-packages conn packages-data)))
+ (when inferior-lint-warnings
+ (let* ((lint-checker-ids
+ (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))))
+ inferior-lint-checkers-data)))
+ (lint-warning-ids
+ (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-system-tests
+ (insert-system-tests-for-guix-revision conn
guix-revision-id
- lint-warning-ids-chunk))
- 5000
- lint-warning-ids)))
-
- (when inferior-system-tests
- (insert-system-tests-for-guix-revision conn
- guix-revision-id
- inferior-system-tests))
-
- (let* ((package-derivation-ids
- (with-time-logging "inferior-data->package-derivation-ids"
- (inferior-data->package-derivation-ids
- conn inf inferior-package-id->package-database-id
- inferior-data-4-tuples)))
- (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))))
+ inferior-system-tests))
+
+ (let* ((package-derivation-ids
+ (with-time-logging
"inferior-data->package-derivation-ids"
+ (inferior-data->package-derivation-ids
+ 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))
+
+ (with-time-logging
+ "insert-guix-revision-package-derivation-distribution-counts"
+ (insert-guix-revision-package-derivation-distribution-counts
+ conn
+ guix-revision-id)))))
#t)
(lambda (key . args)
(simple-format (current-error-port)
diff --git a/guix-data-service/model/channel-instance.scm
b/guix-data-service/model/channel-instance.scm
index 956018e..84fc901 100644
--- a/guix-data-service/model/channel-instance.scm
+++ b/guix-data-service/model/channel-instance.scm
@@ -33,7 +33,8 @@
(let ((derivation-ids
(derivation-file-names->derivation-ids
conn
- (map cdr derivations-by-system))))
+ (list->vector
+ (map cdr derivations-by-system)))))
(exec-query
conn
@@ -49,7 +50,7 @@ VALUES "
system
derivation-id))
(map car derivations-by-system)
- derivation-ids)
+ (vector->list derivation-ids))
", "))))
#t)
diff --git a/guix-data-service/model/derivation.scm
b/guix-data-service/model/derivation.scm
index 20f481a..98c2178 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -17,6 +17,7 @@
(define-module (guix-data-service model derivation)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -1545,7 +1546,8 @@ LIMIT $1"
(update-derivation-ids-hash-table! conn
derivation-ids-hash-table
- input-derivation-file-names)
+ (list->vector
+ input-derivation-file-names))
(simple-format
#t
"debug: ensure-input-derivations-exist: checking for missing input
derivations\n")
@@ -1743,18 +1745,20 @@ WHERE " criteria ";"))
(define (update-derivation-ids-hash-table! conn
derivation-ids-hash-table
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"
file-names-count)
(let ((missing-file-names
- (fold (lambda (file-name result)
- (if (hash-ref derivation-ids-hash-table
- file-name)
- result
- (cons file-name result)))
- '()
- file-names)))
+ (vector-fold
+ (lambda (_ result file-name)
+ (if (and file-name
+ (hash-ref derivation-ids-hash-table
+ file-name))
+ result
+ (cons file-name result)))
+ '()
+ file-names)))
(simple-format
#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)))))
(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 (derivation-ids->next-related-derivation-ids! ids seen-ids)
(delete-duplicates/sort!
@@ -1862,10 +1869,9 @@ INNER JOIN derivation_source_files
next-related-derivation-ids
seen-ids)))))))
- (if (null? derivation-file-names)
- '()
- (let* ((derivations-count (length derivation-file-names))
- (derivation-ids-hash-table (make-hash-table
+ (if (= 0 derivations-count)
+ #()
+ (let* ((derivation-ids-hash-table (make-hash-table
;; Account for more derivations in
;; the graph
(* 2 derivations-count))))
@@ -1879,10 +1885,16 @@ INNER JOIN derivation_source_files
(let ((missing-derivation-filenames
(deduplicate-strings
- (filter (lambda (derivation-file-name)
- (not (hash-ref derivation-ids-hash-table
- derivation-file-name)))
- derivation-file-names))))
+ (vector-fold
+ (lambda (_ result 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))))
(chunk-for-each!
(lambda (missing-derivation-filenames-chunk)
@@ -1907,14 +1919,25 @@ INNER JOIN derivation_source_files
missing-derivation-filenames)
(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
derivation-file-name)
- (error "missing derivation id")))
- derivation-file-names)))
+ (error "missing derivation id"))
+ #f))
+ derivation-file-names)))
(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)))))
diff --git a/guix-data-service/model/license.scm
b/guix-data-service/model/license.scm
index 9104882..ebca0eb 100644
--- a/guix-data-service/model/license.scm
+++ b/guix-data-service/model/license.scm
@@ -28,39 +28,39 @@
(define inferior-package-id
(@@ (guix inferior) inferior-package-id))
-(define (inferior-packages->license-data inf packages)
- (define (proc packages)
- `(map (lambda (inferior-package-id)
- (let ((package (hashv-ref %package-table inferior-package-id)))
- (match (package-license package)
- ((? license? license)
- (list
- (list (license-name license)
- (license-uri license)
- (license-comment license))))
- ((values ...)
- (map (match-lambda
- ((? license? license)
- (list (license-name license)
- (license-uri license)
- (license-comment license)))
- (x
- (simple-format
- (current-error-port)
- "error: unknown license value ~A for package ~A"
- x package)
- '()))
- values))
- (x
- (simple-format
- (current-error-port)
- "error: unknown license value ~A for package ~A"
- x package)
- '()))))
- (list ,@(map inferior-package-id packages))))
+(define (inferior-packages->license-data inf)
+ (define proc
+ `(vector-map
+ (lambda (_ package)
+ (match (package-license package)
+ ((? license? license)
+ (list
+ (list (license-name license)
+ (license-uri license)
+ (license-comment license))))
+ ((values ...)
+ (map (match-lambda
+ ((? license? license)
+ (list (license-name license)
+ (license-uri license)
+ (license-comment license)))
+ (x
+ (simple-format
+ (current-error-port)
+ "error: unknown license value ~A for package ~A"
+ x package)
+ '()))
+ values))
+ (x
+ (simple-format
+ (current-error-port)
+ "error: unknown license value ~A for package ~A"
+ x package)
+ '())))
+ gds-inferior-packages))
(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 (string-or-null v)
diff --git a/guix-data-service/model/package-derivation.scm
b/guix-data-service/model/package-derivation.scm
index 109e0f1..2008409 100644
--- a/guix-data-service/model/package-derivation.scm
+++ b/guix-data-service/model/package-derivation.scm
@@ -17,6 +17,7 @@
(define-module (guix-data-service model package-derivation)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
@@ -26,17 +27,26 @@
count-packages-derivations-in-revision))
(define (insert-package-derivations conn
- package-ids-systems-and-targets
+ system
+ target
+ package-ids
derivation-ids)
+ (define system-id
+ (system->system-id conn system))
+
(define data-4-tuples
- (map (match-lambda*
- (((package-id system target) derivation-id)
- (list package-id
- derivation-id
- (system->system-id conn system)
- target)))
- package-ids-systems-and-targets
- derivation-ids))
+ (vector-fold
+ (lambda (_ result package-id derivation-id)
+ (if derivation-id
+ (cons (list package-id
+ derivation-id
+ system-id
+ target)
+ result)
+ result))
+ '()
+ package-ids
+ derivation-ids))
(if (null? data-4-tuples)
'()
diff --git a/guix-data-service/model/package.scm
b/guix-data-service/model/package.scm
index 7ec2b09..263f46c 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -264,11 +264,12 @@ INSERT INTO packages (name, version, package_metadata_id)
VALUES "
RETURNING id"))
(define (inferior-packages->package-ids conn package-entries)
- (insert-missing-data-and-return-all-ids
- conn
- "packages"
- '(name version package_metadata_id replacement_package_id)
- package-entries))
+ (list->vector
+ (insert-missing-data-and-return-all-ids
+ conn
+ "packages"
+ '(name version package_metadata_id replacement_package_id)
+ package-entries)))
(define (select-package-versions-for-revision conn
commit