diff options
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 875 | ||||
| -rw-r--r-- | guix-data-service/model/channel-instance.scm | 5 | ||||
| -rw-r--r-- | guix-data-service/model/derivation.scm | 65 | ||||
| -rw-r--r-- | guix-data-service/model/license.scm | 62 | ||||
| -rw-r--r-- | guix-data-service/model/package-derivation.scm | 28 | ||||
| -rw-r--r-- | 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 |