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).
This commit is contained in:
parent
89782b3449
commit
f5acc60288
6 changed files with 500 additions and 520 deletions
|
|
@ -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,8 +458,7 @@ WHERE job_id = $1")
|
|||
|
||||
#f)))
|
||||
|
||||
(define (all-inferior-lint-warnings inf store packages)
|
||||
(define locales
|
||||
(define locales
|
||||
'("cs_CZ.UTF-8"
|
||||
"da_DK.UTF-8"
|
||||
"de_DE.UTF-8"
|
||||
|
|
@ -474,55 +474,62 @@ WHERE job_id = $1")
|
|||
"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)))
|
||||
(define (inferior-lint-checkers inf)
|
||||
(and
|
||||
(or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f)
|
||||
(use-modules (guix lint))
|
||||
#t)
|
||||
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
|
||||
(begin
|
||||
(simple-format (current-error-port)
|
||||
"warning: no (guix lint) module found\n")
|
||||
#f))
|
||||
(inferior-eval
|
||||
'(when (defined? '%store-table) (hash-clear! %store-table))
|
||||
inf)
|
||||
|
||||
(catch
|
||||
'match-error
|
||||
`(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 ()
|
||||
(inferior-eval '(invalidate-derivation-caches!) inf))
|
||||
(setlocale LC_MESSAGES locale))
|
||||
(lambda (key . args)
|
||||
(error
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
|
||||
#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)))
|
||||
|
||||
(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)
|
||||
"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 (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,16 +578,14 @@ 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
|
||||
(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)
|
||||
package checker-name exn)
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(if (and lint-checker-requires-store?-defined?
|
||||
|
|
@ -588,81 +593,17 @@ WHERE job_id = $1")
|
|||
|
||||
(check package #:store store)
|
||||
(check package)))
|
||||
#:unwind? #t))))
|
||||
(if (null? warnings)
|
||||
#f
|
||||
(cons package-id warnings))))
|
||||
(list ,@(map inferior-package-id packages))))))
|
||||
#:unwind? #t)))
|
||||
gds-inferior-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)
|
||||
checker-name)
|
||||
(inferior-eval-with-store
|
||||
inf
|
||||
store
|
||||
(lint-warnings-for-checker packages
|
||||
name)))))
|
||||
(cleanup-inferior inf)
|
||||
warnings)))))
|
||||
checkers))))
|
||||
lint-warnings-for-checker)))
|
||||
|
||||
(define (all-inferior-package-derivations store inf packages)
|
||||
(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))
|
||||
file-name)
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
|
|
@ -801,9 +746,8 @@ WHERE job_id = $1")
|
|||
args)
|
||||
#f)))
|
||||
|
||||
(filter-map
|
||||
(lambda (inferior-package-id)
|
||||
(let ((package (hashv-ref %package-table inferior-package-id)))
|
||||
(vector-map
|
||||
(lambda (_ package)
|
||||
(catch
|
||||
#t
|
||||
(lambda ()
|
||||
|
|
@ -834,8 +778,7 @@ WHERE job_id = $1")
|
|||
|
||||
(if system-supported?
|
||||
(if target-supported?
|
||||
(derivation-for-system-and-target inferior-package-id
|
||||
package
|
||||
(derivation-for-system-and-target package
|
||||
system
|
||||
target)
|
||||
#f)
|
||||
|
|
@ -858,43 +801,20 @@ WHERE job_id = $1")
|
|||
(package-name package)
|
||||
key
|
||||
args)
|
||||
#f))))))
|
||||
gds-inferior-package-ids)))
|
||||
#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)
|
||||
|
||||
(inferior-eval
|
||||
`(define gds-packages-proc ,proc)
|
||||
inf)
|
||||
|
||||
(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 ()
|
||||
|
|
@ -908,33 +828,14 @@ WHERE job_id = $1")
|
|||
;; 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)
|
||||
(simple-format #f "getting derivations for ~A" (cons system target))
|
||||
(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)))
|
||||
proc)))
|
||||
|
||||
(define (deduplicate-inferior-packages packages)
|
||||
(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)))
|
||||
|
||||
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))
|
||||
(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,7 +945,8 @@ WHERE job_id = $1")
|
|||
packages)))
|
||||
(package-replacement-data
|
||||
(if process-replacements?
|
||||
(map (lambda (package)
|
||||
(vector-map
|
||||
(lambda (_ package)
|
||||
(let ((replacement (inferior-package-replacement package)))
|
||||
(if replacement
|
||||
;; I'm not sure if replacements can themselves be
|
||||
|
|
@ -1036,14 +960,16 @@ WHERE job_id = $1")
|
|||
(first
|
||||
(all-inferior-packages-data
|
||||
inf
|
||||
(list replacement)
|
||||
(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,24 +981,29 @@ 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)
|
||||
(vector-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)
|
||||
(make-vector (length package-license-set-ids)
|
||||
(cons "integer" NULL)))))
|
||||
|
||||
(unless (null? new-package-metadata-ids)
|
||||
|
|
@ -1083,21 +1014,25 @@ 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)
|
||||
(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)
|
||||
|
|
@ -1110,10 +1045,11 @@ WHERE job_id = $1")
|
|||
conn
|
||||
messages-by-locale)))
|
||||
(list lint-checker-id
|
||||
(inferior-package-id->package-database-id package-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
|
||||
|
|
@ -1122,36 +1058,36 @@ WHERE job_id = $1")
|
|||
"warning: skipping duplicate lint warning ~A ~A\n"
|
||||
location-and-messages)
|
||||
result)
|
||||
(append result
|
||||
(append! result
|
||||
(list location-and-messages))))
|
||||
'()
|
||||
warnings))))
|
||||
warnings-by-package-id))
|
||||
'()
|
||||
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
|
||||
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
|
||||
(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)))
|
||||
|
||||
derivations-vector)))
|
||||
|
||||
(insert-package-derivations conn
|
||||
flat-package-ids-systems-and-targets
|
||||
(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
|
||||
(inferior-lint-checkers-data
|
||||
(inferior-lint-checkers inf))
|
||||
(inferior-lint-warnings-data
|
||||
(and inferior-lint-checkers-data
|
||||
(with-time-logging "fetching inferior lint warnings"
|
||||
(all-inferior-lint-warnings inf store packages)))
|
||||
(inferior-data-4-tuples
|
||||
(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,26 +1503,10 @@ WHERE job_id = $1")
|
|||
;; avoid any concurrency issues
|
||||
(obtain-advisory-transaction-lock conn
|
||||
'load-new-guix-revision-inserts))
|
||||
(with-time-logging
|
||||
"inserting data"
|
||||
(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)))))))
|
||||
|
||||
|
||||
(insert-packages conn packages-data)))
|
||||
(when inferior-lint-warnings
|
||||
(let* ((lint-checker-ids
|
||||
(lint-checkers->lint-checker-ids
|
||||
|
|
@ -1575,13 +1518,13 @@ WHERE job_id = $1")
|
|||
network-dependent
|
||||
(lint-checker-description-data->lint-checker-description-set-id
|
||||
conn descriptions-by-locale))))
|
||||
(map car inferior-lint-warnings))))
|
||||
inferior-lint-checkers-data)))
|
||||
(lint-warning-ids
|
||||
(insert-lint-warnings
|
||||
conn
|
||||
inferior-package-id->package-database-id
|
||||
package-ids
|
||||
lint-checker-ids
|
||||
inferior-lint-warnings)))
|
||||
inferior-lint-warnings-data)))
|
||||
(insert-guix-revision-lint-checkers conn
|
||||
guix-revision-id
|
||||
lint-checker-ids)
|
||||
|
|
@ -1602,8 +1545,10 @@ WHERE job_id = $1")
|
|||
(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)))
|
||||
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)
|
||||
|
|
@ -1621,7 +1566,7 @@ WHERE job_id = $1")
|
|||
"insert-guix-revision-package-derivation-distribution-counts"
|
||||
(insert-guix-revision-package-derivation-distribution-counts
|
||||
conn
|
||||
guix-revision-id))))
|
||||
guix-revision-id)))))
|
||||
#t)
|
||||
(lambda (key . args)
|
||||
(simple-format (current-error-port)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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,14 +1745,16 @@ 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)
|
||||
(vector-fold
|
||||
(lambda (_ result file-name)
|
||||
(if (and file-name
|
||||
(hash-ref derivation-ids-hash-table
|
||||
file-name))
|
||||
result
|
||||
(cons file-name result)))
|
||||
'()
|
||||
|
|
@ -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,9 +1885,15 @@ 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)))
|
||||
(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!
|
||||
|
|
@ -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")))
|
||||
(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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@
|
|||
(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)))
|
||||
(define (inferior-packages->license-data inf)
|
||||
(define proc
|
||||
`(vector-map
|
||||
(lambda (_ package)
|
||||
(match (package-license package)
|
||||
((? license? license)
|
||||
(list
|
||||
|
|
@ -56,11 +56,11 @@
|
|||
(current-error-port)
|
||||
"error: unknown license value ~A for package ~A"
|
||||
x package)
|
||||
'()))))
|
||||
(list ,@(map inferior-package-id packages))))
|
||||
'())))
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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,16 +27,25 @@
|
|||
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
|
||||
(vector-fold
|
||||
(lambda (_ result package-id derivation-id)
|
||||
(if derivation-id
|
||||
(cons (list package-id
|
||||
derivation-id
|
||||
(system->system-id conn system)
|
||||
target)))
|
||||
package-ids-systems-and-targets
|
||||
system-id
|
||||
target)
|
||||
result)
|
||||
result))
|
||||
'()
|
||||
package-ids
|
||||
derivation-ids))
|
||||
|
||||
(if (null? data-4-tuples)
|
||||
|
|
|
|||
|
|
@ -264,11 +264,12 @@ INSERT INTO packages (name, version, package_metadata_id) VALUES "
|
|||
RETURNING id"))
|
||||
|
||||
(define (inferior-packages->package-ids conn package-entries)
|
||||
(list->vector
|
||||
(insert-missing-data-and-return-all-ids
|
||||
conn
|
||||
"packages"
|
||||
'(name version package_metadata_id replacement_package_id)
|
||||
package-entries))
|
||||
package-entries)))
|
||||
|
||||
(define (select-package-versions-for-revision conn
|
||||
commit
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue