diff options
74 files changed, 4379 insertions, 3591 deletions
diff --git a/Makefile.am b/Makefile.am index dac2943..d58fac2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -75,6 +75,7 @@ SOURCES = \ guix-data-service/config.scm \ guix-data-service/database.scm \ guix-data-service/metrics.scm \ + guix-data-service/heap-profiler.scm \ guix-data-service/substitutes.scm \ guix-data-service/utils.scm \ guix-data-service/data-deletion.scm \ diff --git a/guix-data-service/branch-updated-emails.scm b/guix-data-service/branch-updated-emails.scm index aeb1570..2c0e992 100644 --- a/guix-data-service/branch-updated-emails.scm +++ b/guix-data-service/branch-updated-emails.scm @@ -59,12 +59,10 @@ conn git-repository-id))) (let ((excluded-branch? - (branch-in-list? excluded-branches branch-name)) - (included-branch? - (branch-in-list? included-branches branch-name))) + (branch-in-list? excluded-branches branch-name))) (when (and (not excluded-branch?) - (or (null? included-branches) - included-branch?)) + (or (NULL? included-branches) + (branch-in-list? included-branches branch-name))) (if (string=? commit-all-zeros x-git-newrev) (insert-git-commit-entry conn (or (git-branch-for-repository-and-name diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm index 2fe31ce..342a802 100644 --- a/guix-data-service/builds.scm +++ b/guix-data-service/builds.scm @@ -418,7 +418,7 @@ WHERE derivation_output_details.path = $1" (http-request build-url))) (cond - ((eq? (response-code response) 200) + ((= (response-code response) 200) (json-string->scm (bytevector->string body "utf-8"))) (else @@ -439,7 +439,7 @@ WHERE derivation_output_details.path = $1" (read-to-eof port)))) (handler (cond - ((eq? (response-code response) 200) + ((= (response-code response) 200) (json-string->scm (bytevector->string response-body "utf-8"))) @@ -475,7 +475,7 @@ WHERE derivation_output_details.path = $1" (read-to-eof port)))) (handler (cond - ((eq? (response-code response) 200) + ((= (response-code response) 200) (json-string->scm (bytevector->string response-body "utf-8"))) diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm index 10a5ce7..51d35c2 100644 --- a/guix-data-service/comparison.scm +++ b/guix-data-service/comparison.scm @@ -24,6 +24,7 @@ #:use-module (json) #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) + #:use-module (guix-data-service model system) #:use-module (guix-data-service model derivation) #:export (derivation-differences-data @@ -60,7 +61,7 @@ (define group-by-last-element (lambda (vals) (let ((groups (last vals))) - (cons (if (eq? (length groups) 2) + (cons (if (= (length groups) 2) 'common (first groups)) (drop-right vals 1))))) @@ -255,7 +256,7 @@ GROUP BY derivation_source_files.store_path")) base_guix_revision_id target_guix_revision_id #:key - (systems #f) + (system #f) (targets #f) (include-builds? #t) (exclude-unchanged-outputs? #t) @@ -267,15 +268,10 @@ GROUP BY derivation_source_files.store_path")) after-name) (define extra-constraints (string-append - (if systems + (if system (string-append - " AND systems.system IN (" - (string-join (map - (lambda (s) - (string-append "'" s "'")) - systems) - ", ") - ")") + " AND package_derivations.system_id = " + (number->string (lookup-system-id conn system))) "") (if targets (string-append @@ -292,13 +288,11 @@ GROUP BY derivation_source_files.store_path")) (string-append " WITH base_packages AS ( SELECT packages.*, derivations.id AS derivation_id, derivations.file_name, - systems.system, package_derivations.target, + package_derivations.target, derivations_by_output_details_set.derivation_output_details_set_id FROM packages INNER JOIN package_derivations ON packages.id = package_derivations.package_id - INNER JOIN systems - ON package_derivations.system_id = systems.id INNER JOIN derivations ON package_derivations.derivation_id = derivations.id INNER JOIN derivations_by_output_details_set @@ -310,13 +304,11 @@ WITH base_packages AS ( )" extra-constraints " ), target_packages AS ( SELECT packages.*, derivations.id AS derivation_id, derivations.file_name, - systems.system, package_derivations.target, + package_derivations.target, derivations_by_output_details_set.derivation_output_details_set_id FROM packages INNER JOIN package_derivations ON packages.id = package_derivations.package_id - INNER JOIN systems - ON package_derivations.system_id = systems.id INNER JOIN derivations ON package_derivations.derivation_id = derivations.id INNER JOIN derivations_by_output_details_set @@ -329,7 +321,7 @@ WITH base_packages AS ( ) SELECT base_packages.name, base_packages.version, base_packages.package_metadata_id, base_packages.file_name, - base_packages.system, base_packages.target," + '" system "', base_packages.target," (if include-builds? " ( @@ -360,7 +352,7 @@ SELECT base_packages.name, base_packages.version, " target_packages.name, target_packages.version, target_packages.package_metadata_id, target_packages.file_name, - target_packages.system, target_packages.target" + '" system "', target_packages.target" (if include-builds? ", ( @@ -393,7 +385,6 @@ FROM base_packages FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version - AND base_packages.system = target_packages.system AND base_packages.target = target_packages.target AND ( ( @@ -644,27 +635,32 @@ ORDER BY coalesce(base_packages.name, target_packages.name) ASC, base_packages.v package-data))) (define (package-derivation-data->names-and-versions package-data) - (reverse + (reverse! (pair-fold (lambda (pair result) (match pair - (((name . version)) - (cons (cons name version) - result)) - (((name1 . version1) (name2 . version2) rest ...) - (if (and (string=? name1 name2) - (string=? version1 version2)) + ((p1 p2 rest ...) + (if (and (string=? (car p1) (car p2)) + (string=? (cdr p1) (cdr p2))) result - (cons (cons name1 version1) - result))))) + (cons p1 result))) + ((pair) + (cons pair result)))) '() - (map (match-lambda - ((base-name base-version _ _ _ _ _ target-name target-version _ _ _ _ _) - (if (or (and (string? base-name) (string-null? base-name)) - (eq? base-name #f)) - (cons target-name target-version) - (cons base-name base-version)))) - package-data)))) + (sort! + (map (match-lambda + ((base-name base-version _ _ _ _ _ target-name target-version _ _ _ _ _) + (if (or (and (string? base-name) (string-null? base-name)) + (eq? base-name #f)) + (cons target-name target-version) + (cons base-name base-version)))) + package-data) + (lambda (a b) + (let ((a-name (car a)) + (b-name (car b))) + (if (string=? a-name b-name) + (string<? (cdr a) (cdr b)) + (string<? a-name b-name)))))))) (define (package-derivation-data-vhash->derivations conn packages-vhash) (define (vhash->derivation-ids vhash) @@ -714,7 +710,7 @@ ORDER BY coalesce(base_packages.name, target_packages.name) ASC, base_packages.v (or (hash-ref result key) '()))) result)) - (make-hash-table) + (make-hash-table 30000) vhash)) (define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash) diff --git a/guix-data-service/data-deletion.scm b/guix-data-service/data-deletion.scm index c9dc631..d25c2ae 100644 --- a/guix-data-service/data-deletion.scm +++ b/guix-data-service/data-deletion.scm @@ -146,7 +146,7 @@ AND id NOT IN ( (delete-unreferenced-lint-checkers)))) (define (delete-revisions-from-branch conn git-repository-id branch-name commits) - (define (delete-jobs conn) + (define (delete-jobs conn commits) (for-each (lambda (table) (exec-query @@ -217,9 +217,7 @@ WHERE id IN ( 'delete-revisions-from-branch) (exec-query conn "SET LOCAL lock_timeout = '5s';") - (delete-from-git-commits conn) - (delete-jobs conn) (let ((git-branch-id (git-branch-for-repository-and-name conn @@ -232,7 +230,28 @@ WHERE id IN ( DROP TABLE IF EXISTS package_derivations_by_guix_revision_range_git_branch_" (number->string git-branch-id) ";"))) - (delete-guix-revisions conn git-repository-id commits)))) + (let ((now-unreferenced-commits + (filter + (lambda (commit) + (let ((result + (or + (string-null? commit) + (null? + (exec-query + conn + "SELECT 1 FROM git_commits WHERE commit = $1" + (list commit)))))) + (unless result + (simple-format (current-error-port) + "skipping ~A because it's still referenced\n" + commit)) + result)) + commits))) + (unless (null? now-unreferenced-commits) + (delete-jobs conn now-unreferenced-commits) + (delete-guix-revisions conn + git-repository-id + now-unreferenced-commits)))))) (lambda (key . args) (simple-format (current-error-port) @@ -255,10 +274,11 @@ WHERE git_repository_id = $1 (list (number->string git-repository-id) branch-name)))) - (delete-revisions-from-branch conn - git-repository-id - branch-name - commits) + (unless (null? commits) + (delete-revisions-from-branch conn + git-repository-id + branch-name + commits)) (exec-query conn @@ -434,10 +454,9 @@ DELETE FROM derivation_source_files WHERE id IN ( SELECT id FROM derivation_source_files - WHERE NOT EXISTS ( - SELECT 1 + WHERE id NOT IN ( + SELECT derivation_source_file_id FROM derivation_sources - WHERE derivation_source_file_id = derivation_source_files.id ) LIMIT 100 ) @@ -551,6 +570,7 @@ DELETE FROM derivations WHERE id = $1" 1))) (define deleted-count 0) + (define ignored-derivation-ids (make-hash-table)) (define channel (make-channel)) (define (delete-batch conn) @@ -588,7 +608,8 @@ WHERE NOT EXISTS ( (set! deleted-count 0) (for-each (lambda (derivation-id) - (put-message channel derivation-id)) + (unless (hash-ref ignored-derivation-ids derivation-id) + (put-message channel derivation-id))) derivations)) (simple-format (current-error-port) @@ -635,6 +656,11 @@ SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED") 0)))) + (when (= 0 val) + (hash-set! ignored-derivation-ids + derivation-id + #t)) + ;; This is safe as all fibers are in the same ;; thread and cooperative. (set! deleted-count @@ -651,15 +677,30 @@ SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED") (let loop ((total-deleted 0)) (let ((batch-deleted-count (delete-batch conn))) - (if (eq? 0 batch-deleted-count) + (if (= 0 batch-deleted-count) (begin - (with-time-logging - "Deleting unused derivation_source_files entries" - (delete-unreferenced-derivations-source-files conn)) - (simple-format - (current-output-port) - "Finished deleting derivations, deleted ~A in total\n" - total-deleted)) + (hash-clear! ignored-derivation-ids) + (let ((batch-deleted-count (delete-batch conn))) + (if (= 0 batch-deleted-count) + (begin + (with-time-logging + "VACUUM derivation_inputs" + (exec-query conn "VACUUM (VERBOSE) derivation_inputs;")) + (with-time-logging + "VACUUM derivations" + (exec-query conn "VACUUM (VERBOSE) derivations;")) + (with-time-logging + "Deleting unused derivation_source_files entries" + (delete-unreferenced-derivations-source-files conn)) + (with-time-logging + "VACUUM derivation_source_file_nars" + (exec-query + conn "VACUUM (VERBOSE) derivation_source_file_nars;")) + (simple-format + (current-output-port) + "Finished deleting derivations, deleted ~A in total\n" + total-deleted)) + (loop (+ total-deleted batch-deleted-count))))) (loop (+ total-deleted batch-deleted-count)))))))) #:hz 0 #:parallelism 1)) diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm index 8af53da..86747e0 100644 --- a/guix-data-service/database.scm +++ b/guix-data-service/database.scm @@ -41,6 +41,8 @@ with-advisory-session-lock/log-time obtain-advisory-transaction-lock + NULL + NULL? exec-query-with-null-handling)) ;; TODO This isn't exported for some reason @@ -170,7 +172,7 @@ (simple-format #t "running command: ~A\n" (string-join command)) (let ((pid (spawn (%config 'sqitch) command))) - (unless (= 0 (status:exit-val (cdr (waitpid pid)))) + (unless (= 0 (status:exit-val (cdr (waitpid pid)))) ;; TODO Don't use waitppid (simple-format (current-error-port) "error: sqitch command failed\n") @@ -178,8 +180,11 @@ (define* (with-postgresql-connection name f #:key (statement-timeout #f)) (let ((conn (open-postgresql-connection name statement-timeout))) - (with-throw-handler - #t + (with-exception-handler + (lambda (exn) + (pg-conn-finish conn) + (decrement-connection-gauge name) + (raise-exception exn)) (lambda () (call-with-values (lambda () @@ -189,10 +194,7 @@ (decrement-connection-gauge name) - (apply values vals)))) - (lambda (key . args) - (pg-conn-finish conn) - (decrement-connection-gauge name))))) + (apply values vals))))))) (define %postgresql-connection-parameters (make-parameter #f)) @@ -207,15 +209,22 @@ #:key always-rollback?) (exec-query conn "BEGIN;") - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (with-exception-handler + (const #f) + (lambda () + (exec-query conn "ROLLBACK;")) + #:unwind? #t) + ;; TODO Include the stack in the exception via knots + (raise-exception exn)) (lambda () (let ((result (f conn))) (exec-query conn (if always-rollback? "ROLLBACK;" "COMMIT;")) result)) - (lambda (key . args) - (exec-query conn "ROLLBACK;")))) + #:unwind? #t)) (define (check-test-database! conn) (match (exec-query conn "SELECT current_database()") @@ -245,17 +254,22 @@ (exec-query conn "SELECT pg_advisory_lock($1)" (list lock-number)) - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (with-exception-handler + (const #f) + (lambda () + (exec-query conn + "SELECT pg_advisory_unlock($1)" + (list lock-number))) + #:unwind? #t) + (raise-exception exn)) (lambda () (let ((result (f))) (exec-query conn "SELECT pg_advisory_unlock($1)" (list lock-number)) - result)) - (lambda (key . args) - (exec-query conn - "SELECT pg_advisory_unlock($1)" - (list lock-number)))))) + result))))) (define (with-advisory-session-lock/log-time conn lock f) (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock) @@ -279,6 +293,10 @@ "SELECT pg_advisory_xact_lock($1)" (list lock-number)))) +(define NULL (make-symbol "null")) + +(define NULL? (lambda (s) (eq? s NULL))) + (define squee/libpq (@@ (squee) libpq)) @@ -300,11 +318,11 @@ (lambda (col-i) (let ((val (result-get-value result-ptr row-i col-i))) (cond - ((eq? #f val) '()) + ((eq? #f val) NULL) ((string-null? val) - (if (eq? 1 (%PQgetisnull + (if (= 1 (%PQgetisnull (squee/unwrap-result-ptr result-ptr) row-i col-i)) - '() + NULL val)) (else val)))) cols-range)) diff --git a/guix-data-service/heap-profiler.scm b/guix-data-service/heap-profiler.scm new file mode 100644 index 0000000..fa838f5 --- /dev/null +++ b/guix-data-service/heap-profiler.scm @@ -0,0 +1,225 @@ +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; Distributed under the GNU Lesser General Public License, version 3 or (at +;;; your option) any later version. + +(define-module (guix-data-service heap-profiler) + #:use-module (system foreign) + #:use-module (system base types internal) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:export (profile-heap)) + +(define-immutable-record-type <memory-mapping> + (memory-mapping start end permissions name) + memory-mapping? + (start memory-mapping-start) + (end memory-mapping-end) + (permissions memory-mapping-permissions) + (name memory-mapping-name)) + +(define (memory-mappings pid) ;based on Guile's 'gc-profile.scm' + "Return an list of alists, each of which contains information about a memory +mapping of process @var{pid}. This information is obtained by reading +@file{/proc/PID/maps} on Linux. See `procs(5)' for details." + + (define mapping-line-rx + ;; As of Linux 2.6.32.28, an `maps' line looks like this: + ;; "00400000-0041d000 r--p 00000000 fd:00 7926441 /bin/cat". + (make-regexp + "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) (fd|[[:xdigit:]]{2}):[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$")) + + (call-with-input-file (format #f "/proc/~a/maps" pid) + (lambda (port) + (let loop ((result '())) + (match (read-line port) + ((? eof-object?) + (reverse result)) + (line + (cond ((regexp-exec mapping-line-rx line) + => + (lambda (match) + (let ((start (string->number (match:substring match 1) + 16)) + (end (string->number (match:substring match 2) + 16)) + (perms (match:substring match 3)) + (name (match:substring match 6))) + (loop (cons (memory-mapping + start end perms + (if (string=? name "") + #f + name)) + result))))) + (else + (loop result))))))))) + +;; (define random-valid-address +;; ;; XXX: This is only in libgc with back pointers. +;; (let ((ptr (false-if-exception +;; (dynamic-func "GC_generate_random_valid_address" (dynamic-link))))) +;; (if ptr +;; (pointer->procedure '* ptr '()) +;; (const #f)))) + +(define (heap-sections) + (filter (lambda (mapping) + (and (not (memory-mapping-name mapping)) + (string=? "rw-p" (memory-mapping-permissions mapping)))) + (memory-mappings (getpid)))) + +(define (random-valid-address heap-sections) + ;; Mimic 'GC_generate_random_valid_address', which is only available with + ;; '-DBACK_PTRS' builds of libgc. + (define heap-size + (fold (lambda (mapping size) + (+ size (- (memory-mapping-end mapping) + (memory-mapping-start mapping)))) + 0 + heap-sections)) + + (let loop ((sections heap-sections) + (size 0) + (offset (random heap-size))) + (match sections + (() #f) + ((section . rest) + (let* ((start (memory-mapping-start section)) + (end (memory-mapping-end section)) + (section-size (- end start))) + (if (< offset section-size) + (let ((result (base-pointer (+ start offset)))) + ;; (pk 'p (number->string (+ start offset) 16) result) + (if (null-pointer? result) + (loop heap-sections 0 (random heap-size)) ;retry + result)) + (loop rest + (+ size section-size) + (- offset section-size)))))))) + +(define object-size + (pointer->procedure size_t + (dynamic-func "GC_size" (dynamic-link)) + '(*))) + +(define base-pointer + (pointer->procedure '* + (dynamic-func "GC_base" (dynamic-link)) + (list uintptr_t))) + +(define (heap-tag->type-name word) + "Return the type name as a symbol corresponding to the tag WORD." + (match (let/ec return + (let-syntax ((tag-name (syntax-rules () + ((_ name pred mask tag) + (when (= (logand word mask) tag) + (return 'name)))))) + (visit-heap-tags tag-name) + 'unknown)) + ('program + (cond ((= (logand word #x1000) #x1000) + 'partial-continuation) + ((= (logand word #x2000) #x2000) + 'foreign-program) + ((= (logand word #x800) #x800) + 'continuation) + ((= (logand word #x400) #x400) + 'primitive-generic) + ((= (logand word #x200) #x200) + 'primitive) + ((= (logand word #x100) #x100) + 'boot-program) + (else + 'program))) + (type + type))) + +(define* (profile-heap #:key (sample-count 100000)) + "Pick SAMPLE-COUNT addresses in the GC-managed heap and display a profile +of this sample per data type." + (define heap-size + (assoc-ref (gc-stats) 'heap-size)) + + (define heap + (heap-sections)) + + (let ((objects (make-hash-table 57)) + (visited (make-hash-table))) + (let loop ((i sample-count)) + (unless (zero? i) + (let ((address (random-valid-address heap))) + (if (hashv-ref visited (pointer-address address)) + (loop i) + (begin + (hashv-set! visited (pointer-address address) #t) + (let* ((tag (pointer-address (dereference-pointer address))) + (type (heap-tag->type-name tag)) + (size (match type + ('pair (* 2 (sizeof '*))) + ('vector + (min (ash tag -8) + (object-size address))) + (_ (object-size address))))) + ;; (when (eq? 'unknown type) + ;; (pk (object-size address))) + ;; (when (eq? 'vector type) + ;; (pk 'vector size 'tag tag 'addr address 'vs (object-size address))) + (hashq-set! objects type + (match (hashq-ref objects type '(0 . 0)) + ((count . total) + (cons (+ count 1) (+ total size)))))) + (loop (- i 1))))))) + (let ((grand-total (hash-fold (lambda (type stats result) + (match stats + ((_ . total) + (+ total result)))) + 0 + objects))) + (format (current-error-port) + " % type self avg obj size~%") + (for-each (match-lambda + ((type . (count . total)) + (format (current-error-port) "~5,1f ~30a ~14h ~7,1f~%" + (* 100. (/ total grand-total)) + type total + (/ total count 1.)))) + (sort (hash-map->list cons objects) + (match-lambda* + (((_ . (count1 . total1)) (_ . (count2 . total2))) + (or (> total1 total2) + (and (= total1 total2) + (> count1 count2))))))) + (format (current-error-port) "sampled heap: ~h MiB (heap size: ~h MiB)~%" + (/ grand-total (expt 2. 20)) + (/ heap-size (expt 2. 20)))))) + +(define (heap-samples type count) + "Sample COUNT objects of the given TYPE, a symbol such as 'vector, and +return them. + +WARNING: This can crash your application as this could pick bogus or +finalized objects." + (define heap + (heap-sections)) + + (let ((visited (make-hash-table))) + (let loop ((i count) + (objects '())) + (if (zero? i) + objects + (let ((address (random-valid-address heap))) + (if (hashv-ref visited (pointer-address address)) + (loop i objects) + (begin + (hashv-set! visited (pointer-address address) #t) + (let ((tag (pointer-address (dereference-pointer address)))) + (if (eq? type (heap-tag->type-name tag)) + (loop (- i 1) + (cons (pointer->scm address) objects)) + (loop i objects)))))))))) + diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 7d62be3..3ea1ebf 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -30,6 +30,8 @@ count-log-parts combine-log-parts! + guix-revision-id-for-job + process-jobs default-max-processes)) @@ -124,13 +126,33 @@ guix-data-service: error: missing log line: ~A (with-time-logging "vacuuming log parts" (vacuum-log-parts-table conn))) +(define (guix-revision-id-for-job conn job-id) + (match (exec-query + conn + " +SELECT guix_revisions.id +FROM guix_revisions +INNER JOIN load_new_guix_revision_jobs + ON guix_revisions.git_repository_id = load_new_guix_revision_jobs.git_repository_id + AND guix_revisions.commit = load_new_guix_revision_jobs.commit +WHERE load_new_guix_revision_jobs.id = $1" + (list (simple-format #f "~A" job-id))) + (((id)) id))) + (define* (process-jobs conn #:key max-processes latest-branch-revision-max-processes skip-system-tests? - per-job-parallelism) + extra-inferior-environment-variables + per-job-parallelism + ignore-systems + ignore-targets + (free-space-requirement + ;; 2G + (* 2 (expt 2 30))) + timeout) (define (fetch-new-jobs) (let ((free-space (free-disk-space "/gnu/store"))) - (if (< free-space (* 2 (expt 2 30))) ; 2G + (if (< free-space free-space-requirement) (begin (simple-format (current-error-port) @@ -148,9 +170,22 @@ guix-data-service: error: missing log line: ~A ,@(if skip-system-tests? '("--skip-system-tests") '()) + ,@(map (match-lambda + ((key . val) + (simple-format #f "--inferior-set-environment-variable=~A=~A" + key val))) + extra-inferior-environment-variables) ,@(if per-job-parallelism (list (simple-format #f "--parallelism=~A" per-job-parallelism)) - '())) + '()) + ,@(if (null? ignore-systems) + '() + (list (simple-format #f "--ignore-systems=~A" + (string-join ignore-systems ",")))) + ,@(if (null? ignore-targets) + '() + (list (simple-format #f "--ignore-targets=~A" + (string-join ignore-targets ","))))) #:output log-port #:error log-port))) @@ -171,7 +206,8 @@ guix-data-service: error: missing log line: ~A handle-job-failure #:max-processes max-processes #:priority-max-processes - latest-branch-revision-max-processes)) + latest-branch-revision-max-processes + #:timeout timeout)) (define* (log-for-job conn job-id @@ -279,10 +315,6 @@ WHERE job_id = $1") 4)) 1)) -(define default-timeout - (* (* 60 60) ;; 1 hour in seconds - 72)) - (define* (process-jobs-concurrently fetch-new-jobs process-job @@ -291,7 +323,7 @@ WHERE job_id = $1") #:key (max-processes default-max-processes) (priority-max-processes (* 2 max-processes)) - (timeout default-timeout)) + timeout) (define processes (make-hash-table)) @@ -302,9 +334,9 @@ WHERE job_id = $1") "\n\n" (let ((running-jobs (hash-count (const #t) processes))) (cond - ((eq? running-jobs 0) + ((= running-jobs 0) "status: 0 running jobs") - ((eq? running-jobs 1) + ((= running-jobs 1) "status: 1 running job") (else (simple-format #f "status: ~A running jobs" @@ -331,7 +363,7 @@ WHERE job_id = $1") (match (hash-ref processes pid) ((_ (id)) (post-job id) - (unless (eq? status 0) + (unless (= status 0) (simple-format (current-error-port) "pid ~A (job: ~A) failed with status ~A\n" pid id status) @@ -391,7 +423,8 @@ WHERE job_id = $1") (atomic-box-set! exit? #t))) (while #t - (kill-long-running-processes) + (when timeout + (kill-long-running-processes)) (wait-on-processes) (display-status) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index d821157..618ec25 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -22,16 +22,31 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 threads) + #:use-module (ice-9 format) + #:use-module (ice-9 exceptions) #:use-module (ice-9 textual-ports) #:use-module (ice-9 hash-table) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 binary-ports) #:use-module ((ice-9 ports internal) #:select (port-poll)) + #:use-module (rnrs bytevectors) #:use-module (rnrs exceptions) + #:use-module (lzlib) #:use-module (json) #:use-module (squee) + #:use-module (gcrypt hash) #:use-module (fibers) + #:use-module (fibers timers) #:use-module (fibers channels) + #:use-module (fibers operations) + #:use-module (knots) + #:use-module (knots queue) + #:use-module (knots promise) + #:use-module (knots thread-pool) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix monads) + #:use-module (guix base32) #:use-module (guix store) #:use-module (guix channels) #:use-module (guix inferior) @@ -41,14 +56,17 @@ #:use-module (guix progress) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix serialization) #:use-module (guix build utils) #:use-module ((guix build syscalls) - #:select (set-thread-name)) + #:select (free-disk-space)) + #:use-module (guix-data-service jobs) #:use-module (guix-data-service config) #:use-module (guix-data-service database) #:use-module (guix-data-service utils) #:use-module (guix-data-service model utils) #:use-module (guix-data-service model build) + #:use-module (guix-data-service model system) #:use-module (guix-data-service model channel-instance) #:use-module (guix-data-service model channel-news) #:use-module (guix-data-service model package) @@ -77,7 +95,10 @@ guix-revision-loaded-successfully? record-job-event enqueue-load-new-guix-revision-job - most-recent-n-load-new-guix-revision-jobs)) + most-recent-n-load-new-guix-revision-jobs + + fix-derivation + fix-derivation-source-file-nar)) (define inferior-package-id (@@ (guix inferior) inferior-package-id)) @@ -94,6 +115,42 @@ (simple-format #t "debug: Finished ~A, took ~A seconds\n" action time-taken))))) +(define-exception-type &missing-store-item-error &error + make-missing-store-item-error + missing-store-item-error? + (item missing-store-item-error-item)) + +(define* (retry-on-missing-store-item thunk #:key on-exception) + (with-exception-handler + (lambda (exn) + (simple-format (current-error-port) + "missing store item ~A, retrying ~A\n" + (missing-store-item-error-item exn) + thunk) + (when on-exception (on-exception)) + (retry-on-missing-store-item + thunk + #:on-exception on-exception)) + thunk + #:unwind? #t + #:unwind-for-type &missing-store-item-error)) + +(define* (retry-on-missing-derivation-output thunk #:key on-exception) + (with-exception-handler + (lambda (exn) + (simple-format (current-error-port) + "missing derivation output ~A ~A, retrying ~A\n" + (missing-derivation-output-error-name exn) + (missing-derivation-output-error-path exn) + thunk) + (when on-exception (on-exception)) + (retry-on-missing-derivation-output + thunk + #:on-exception on-exception)) + thunk + #:unwind? #t + #:unwind-for-type &missing-derivation-output-error)) + (define (inferior-guix-systems inf) ;; The order shouldn't matter here, but bugs in Guix can lead to different ;; results depending on the order, so sort the systems to try and provide @@ -120,8 +177,7 @@ inf))) string<?)) -(define (all-inferior-system-tests inf store guix-source guix-commit - add-temp-root/long-running-store) +(define (all-inferior-system-tests inf store guix-source guix-commit) (define inf-systems (inferior-guix-systems inf)) @@ -190,14 +246,6 @@ (let ((system-test-data (with-time-logging "getting system tests" (inferior-eval-with-store/non-blocking inf store extract)))) - - (for-each (lambda (derivation-file-names-by-system) - (for-each (lambda (derivation-file-name) - (add-temp-root/long-running-store - derivation-file-name)) - (map cdr derivation-file-names-by-system))) - (map third system-test-data)) - system-test-data)) (lambda (key . args) (display (backtrace) (current-error-port)) @@ -337,7 +385,8 @@ (simple-format (current-error-port) "exception checking ~A with ~A checker: ~A\n" package checker-name exn) - (raise-exception exn)) + ;; TODO Record and report this exception + '()) (lambda () (if (and lint-checker-requires-store?-defined? (lint-checker-requires-store? checker)) @@ -414,7 +463,7 @@ (append supported-system-pairs supported-system-cross-build-pairs)) -(define (inferior-package-derivations store inf system target) +(define (inferior-package-derivations store inf system target start-index count) (define proc `(lambda (store) (define system-target-pair @@ -473,6 +522,10 @@ 'misc-error (lambda () (guard (c ((package-cross-build-system-error? c) + #f) + ((package-unsupported-target-error? c) + #f) + ((unsupported-cross-compilation-target-error? c) #f)) (let ((derivation (if target @@ -482,10 +535,7 @@ (package-derivation store package system)))) ;; You don't always get what you ask for, so check (if (string=? system (derivation-system derivation)) - (let ((file-name - (derivation-file-name derivation))) - (add-temp-root store file-name) - file-name) + (derivation-file-name derivation) (begin (simple-format (current-error-port) @@ -497,8 +547,9 @@ (lambda args (simple-format (current-error-port) - "warning: error when computing ~A derivation for system ~A (~A): ~A\n" + "warning: error when computing ~A@~A derivation for system ~A (~A): ~A\n" (package-name package) + (package-version package) system (or target "no target") args) @@ -516,139 +567,182 @@ (/ (assoc-ref stats 'heap-size) (expt 2. 20))))) - (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) - "error: while processing ~A, exiting: ~A: ~A\n" - (package-name package) - key - args) - (exit 1)) - (begin + (let ((vec (make-vector ,count))) + (vector-fold + (lambda (i index _) + (vector-set! vec i index) + (1+ index)) + ,start-index + vec) + (vector-map! + (lambda (_ index) + (define package (vector-ref gds-inferior-packages index)) + + (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) - "error: while processing ~A ignoring error: ~A: ~A\n" - (package-name package) - key - args) - #f))))) - gds-inferior-packages))) + "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) + "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 (~A) ignoring error: ~A: ~A\n" + (package-name package) + system-target-pair + key + args) + #f))))) + vec) + vec))) (inferior-eval '(when (defined? 'systems (resolve-module '(guix platform))) (use-modules (guix platform))) inf) - (format (current-error-port) - "heap size: ~a MiB~%" - (round - (/ (assoc-ref (gc-stats) 'heap-size) - (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) + (unless (inferior-eval + '(defined? 'package-unsupported-target-error? + (resolve-module '(guix packages))) + inf) + (inferior-eval + '(define package-unsupported-target-error? (const #f)) + inf) + (inferior-eval + '(define unsupported-cross-compilation-target-error? (const #f)) + inf)) (inferior-eval-with-store/non-blocking inf store proc)) -(define (sort-and-deduplicate-inferior-packages packages - pkg-to-replacement-hash-table) - (pair-fold - (lambda (pair result) - (if (null? (cdr pair)) - (cons (first pair) result) - (let* ((a (first pair)) - (b (second pair)) - (a-name (inferior-package-name a)) - (b-name (inferior-package-name b)) - (a-version (inferior-package-version a)) - (b-version (inferior-package-version b)) - (a-replacement (hashq-ref pkg-to-replacement-hash-table a)) - (b-replacement (hashq-ref pkg-to-replacement-hash-table b))) - (if (and (string=? a-name b-name) - (string=? a-version b-version) - (eq? a-replacement b-replacement)) - (begin - (simple-format (current-error-port) - "warning: ignoring duplicate package: ~A (~A)\n" - a-name - a-version) - result) - (cons a result))))) - '() - (sort packages - (lambda (a b) - (let ((a-name (inferior-package-name a)) - (b-name (inferior-package-name b))) - (if (string=? a-name b-name) - (let ((a-version (inferior-package-version a)) - (b-version (inferior-package-version b))) - (if (string=? a-version b-version) - ;; The name and version are the same, so try and pick - ;; the same package each time, by looking at the - ;; location. - (let ((a-location (inferior-package-location a)) - (b-location (inferior-package-location b))) - (> (location-line a-location) - (location-line b-location))) - (string<? a-version - b-version))) - (string<? a-name - b-name))))))) - -(define (inferior-packages-plus-replacements inf) +(define* (sort-and-deduplicate-inferior-packages packages + pkg-to-replacement-hash-table + #:key log-duplicates?) + (let ((sorted-packages + (sort packages + (lambda (a b) + (let ((a-name (inferior-package-name a)) + (b-name (inferior-package-name b))) + (if (string=? a-name b-name) + (let ((a-version (inferior-package-version a)) + (b-version (inferior-package-version b))) + (if (string=? a-version b-version) + (let ((a-replacement (hashq-ref pkg-to-replacement-hash-table a)) + (b-replacement (hashq-ref pkg-to-replacement-hash-table b))) + (if (or (and a-replacement b-replacement) + (and (eq? #f a-replacement) + (eq? #f b-replacement))) + ;; The name and version are the same, so try and + ;; pick the same package each time, by looking at + ;; the location. + (let ((a-location (inferior-package-location a)) + (b-location (inferior-package-location b))) + (> (location-line a-location) + (location-line b-location))) + (->bool a-replacement))) + (string<? a-version + b-version))) + (string<? a-name + b-name))))))) + + (define (print-packages-matching-name-and-version name version) + (simple-format (current-error-port) "packages matching: ~A@~A\n" + name version) + (for-each + (lambda (pkg) + (when (and (string=? (inferior-package-name pkg) + name) + (string=? (inferior-package-version pkg) + version)) + (simple-format + (current-error-port) + " - ~A@~A (replacement: ~A, location: ~A)\n" + name + version + (hashq-ref pkg-to-replacement-hash-table pkg) + (inferior-package-location pkg)))) + sorted-packages)) + + (pair-fold + (lambda (pair result) + (if (null? (cdr pair)) + (cons (first pair) result) + (let* ((a (first pair)) + (b (second pair)) + (a-name (inferior-package-name a)) + (b-name (inferior-package-name b)) + (a-version (inferior-package-version a)) + (b-version (inferior-package-version b)) + (a-replacement (hashq-ref pkg-to-replacement-hash-table a)) + (b-replacement (hashq-ref pkg-to-replacement-hash-table b)) + (a-location (inferior-package-location a)) + (b-location (inferior-package-location b))) + (if (and (string=? a-name b-name) + (string=? a-version b-version) + (or + (and a-replacement b-replacement) + (and (eq? #f a-replacement) + (eq? #f b-replacement)))) + (begin + (when log-duplicates? + (simple-format (current-error-port) + "warning: ignoring duplicate package: ~A@~A (replacement: ~A, location: ~A)\n" + a-name + a-version + a-replacement + (location-line a-location)) + (print-packages-matching-name-and-version + a-name + a-version)) + result) + (cons a result))))) + '() + sorted-packages))) + +(define* (inferior-packages-plus-replacements inf + #:key log-duplicates?) (let* ((packages ;; The use of force in (guix inferior) introduces a continuation ;; barrier @@ -707,25 +801,38 @@ ;; TODO Sort introduces a continuation barrier (sort-and-deduplicate-inferior-packages (append! packages non-exported-replacements) - pkg-to-replacement-hash-table))))) + pkg-to-replacement-hash-table + #:log-duplicates? log-duplicates?))))) (deduplicated-packages-length (length deduplicated-packages))) (inferior-eval `(define gds-inferior-packages - (make-vector ,deduplicated-packages-length)) + (vector ,@(map inferior-package-id deduplicated-packages))) + inf) + (inferior-eval + '(begin + (vector-map! + (lambda (_ id) + (or (hashv-ref %package-table id) + (error "missing package id"))) + gds-inferior-packages) + #t) 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))) + '(let ((stats (gc-stats))) + (simple-format + (current-error-port) + "post gds-inferior-packages inferior heap: ~a MiB used (~a MiB heap)~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20))))) inf) (values (list->vector deduplicated-packages) @@ -805,116 +912,538 @@ conn (inferior-packages->license-id-lists conn - ;; TODO Don't needlessly convert - (vector->list - (assq-ref inferior-packages-data 'license-data)))))) + (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 - ;; TODO Don't needlessly convert - (vector->list - (assq-ref inferior-packages-data 'metadata)) + (assq-ref inferior-packages-data 'metadata) package-license-set-ids))) (replacement-package-ids (vector-map (lambda (_ package-index-or-false) (if package-index-or-false - (first + (vector-ref (inferior-packages->package-ids conn - (list (list (vector-ref names package-index-or-false) - (vector-ref versions package-index-or-false) - (list-ref all-package-metadata-ids - package-index-or-false) - (cons "integer" NULL))))) + (vector + (list (vector-ref names package-index-or-false) + (vector-ref versions package-index-or-false) + (vector-ref all-package-metadata-ids + package-index-or-false) + (cons "integer" NULL)))) + 0) (cons "integer" NULL))) (assq-ref inferior-packages-data 'replacements)))) - (unless (null? new-package-metadata-ids) + (unless (= 0 (vector-length new-package-metadata-ids)) (with-time-logging "inserting package metadata tsvector entries" (insert-package-metadata-tsvector-entries conn new-package-metadata-ids))) (with-time-logging "getting package-ids (without replacements)" - (list->vector - (inferior-packages->package-ids - conn - ;; TODO Do this more efficiently - (zip (vector->list names) - (vector->list versions) - all-package-metadata-ids - (vector->list replacement-package-ids))))))) + (inferior-packages->package-ids + conn + ;; Similar to zip, but generating a vector of lists + (vector-map (lambda (index . vals) vals) + names + versions + all-package-metadata-ids + replacement-package-ids))))) (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-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 + (vector-fold + (lambda (_ result lint-checker-id warnings-per-package) + (if warnings-per-package + (vector-fold + (lambda (_ result package-id warnings) + (if (null? warnings) + result + (cons + (lint-warnings-data->lint-warning-ids + conn + (list->vector + (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)))) + warnings))) + result))) + result + package-ids + warnings-per-package) + result)) + '() + lint-checker-ids + lint-warnings-data)) + +(define (update-derivation-ids-hash-table! conn + derivation-ids-hash-table + derivations-or-file-names) + (define derivations-count (vector-length derivations-or-file-names)) + + (let ((missing-file-names + (vector-fold + (lambda (_ result file-name-or-drv) + (if file-name-or-drv + (let ((file-name + (if (string? file-name-or-drv) + file-name-or-drv + (derivation-file-name file-name-or-drv)))) + (if (hash-ref derivation-ids-hash-table + file-name) + result + (cons file-name + result))) + result)) + '() + derivations-or-file-names))) + + (simple-format + #t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n" + derivations-count (length missing-file-names)) + + (unless (null? missing-file-names) + (chunk-for-each! + (lambda (chunk) + (for-each + (match-lambda + ((id file-name) + (hash-set! derivation-ids-hash-table + file-name + (string->number id)))) + (exec-query conn (select-existing-derivations chunk)))) + 1000 + missing-file-names)))) + +(define (compute-and-update-derivation-source-file-nar + postgresql-connection-pool + id + source-file) + (let ((nar-bytevector + (call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (port get-bytevector) + (unless (file-exists? source-file) + (raise-exception + (make-missing-store-item-error + source-file))) + (write-file source-file port) + (let ((res (get-bytevector))) + (close-port port) ; maybe reduces memory? + res))))) + (let ((compressed-nar-bytevector + (call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (port get-bytevector) + (call-with-lzip-output-port port + (lambda (port) + (put-bytevector port nar-bytevector)) + #:level 9) + (let ((res (get-bytevector))) + (close-port port) ; maybe reduces memory? + res)))) + (hash + (bytevector->nix-base32-string + (sha256 nar-bytevector))) + (uncompressed-size + (bytevector-length nar-bytevector))) + (with-resource-from-pool postgresql-connection-pool conn + (update-derivation-source-file-nar + conn + id + hash + compressed-nar-bytevector + uncompressed-size))))) + +(define* (derivations-insert-sources postgresql-connection-pool + call-with-utility-thread + derivations + derivation-ids + #:key (log-tag "unspecified")) + (with-time-logging + (string-append "insert-missing-derivations: inserting sources (" log-tag ")") + (fibers-for-each + (lambda (derivation-id derivation) + (let ((sources (derivation-sources derivation))) + (unless (null? sources) + (let ((sources-ids + (with-resource-from-pool postgresql-connection-pool conn + (insert-derivation-sources conn + derivation-id + sources)))) + (fibers-for-each + (lambda (id source-file) + (when + (with-resource-from-pool postgresql-connection-pool conn + (match + (exec-query + conn + " +SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" + (list (number->string id))) + (() + ;; Insert a placeholder to avoid other fibers + ;; working on this source file + (insert-placeholder-derivation-source-file-nar 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 - lint-warnings-data))) - -(define (inferior-data->package-derivation-ids - conn inf - 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))) + id) + #t) + (_ #f))) + ;; Use a utility thread to control concurrency here, to + ;; avoid using too much memory + (call-with-utility-thread + (lambda () + (compute-and-update-derivation-source-file-nar + postgresql-connection-pool + id + source-file))))) + sources-ids + sources))))) + derivation-ids + derivations))) + +(define* (insert-missing-derivations postgresql-connection-pool + call-with-utility-thread + derivation-ids-hash-table + unfiltered-derivations + #:key (log-tag "unspecified")) + + (define (insert-into-derivations conn drvs) + (insert-missing-data-and-return-all-ids + conn + "derivations" + '(file_name builder args env_vars system_id) + (vector-map (match-lambda* + ((_ ($ <derivation> outputs inputs sources + system builder args env-vars file-name)) + (list file-name + builder + (cons "varchar[]" + (list->vector args)) + (cons "varchar[][]" + (list->vector + (map (match-lambda + ((key . value) + (vector key value))) + env-vars))) + (system->system-id conn system)))) + drvs))) + + (define (insert-derivations) + (with-resource-from-pool postgresql-connection-pool conn + (update-derivation-ids-hash-table! + conn + derivation-ids-hash-table + (list->vector unfiltered-derivations)) + + (let ((derivations + ;; Do this while holding the PostgreSQL connection to + ;; avoid conflicts with other fibers + (list->vector + (delete-duplicates + (filter-map (lambda (derivation) + (if (hash-ref derivation-ids-hash-table + (derivation-file-name + derivation)) + #f + derivation)) + unfiltered-derivations))))) + (if (= 0 (vector-length derivations)) + (values #() #()) + (begin + (simple-format + (current-error-port) + "insert-missing-derivations: inserting ~A derivations (~A)\n" + (vector-length derivations) + log-tag) + (let ((derivation-ids + (insert-into-derivations conn derivations))) + + ;; Do this while holding the connection so that other + ;; fibers don't also try inserting the same derivations + (with-time-logging + (string-append "insert-missing-derivations: updating hash table (" log-tag ")") + (vector-for-each (lambda (_ derivation derivation-id) + (hash-set! derivation-ids-hash-table + (derivation-file-name derivation) + derivation-id)) + derivations + derivation-ids)) + + (simple-format + (current-error-port) + "insert-missing-derivations: finished inserting ~A derivations (~A)\n" + (vector-length derivations) + log-tag) + + (values derivations + derivation-ids))))))) + + (define (insert-input-derivations derivations) + (with-time-logging + (string-append + "insert-missing-derivations: ensure-input-derivations-exist (" + log-tag ")") + (let ((input-derivations + (vector-fold + (lambda (_ result drv) + (append! (map derivation-input-derivation + (derivation-inputs drv)) + result)) + '() + derivations))) + (unless (null? input-derivations) + ;; Ensure all the input derivations exist + (chunk-for-each! + (lambda (chunk) + (insert-missing-derivations + postgresql-connection-pool + call-with-utility-thread + derivation-ids-hash-table + chunk + #:log-tag log-tag)) + 1000 + input-derivations))))) + + (let ((derivations + derivation-ids + (insert-derivations))) + + (unless (= 0 (vector-length derivations)) + (fibers-parallel + (derivations-insert-sources postgresql-connection-pool + call-with-utility-thread + derivations + derivation-ids + #:log-tag log-tag) + (with-time-logging + (string-append "insert-missing-derivations: inserting outputs (" + log-tag ")") + (with-resource-from-pool postgresql-connection-pool conn + (vector-for-each + (lambda (_ derivation-id derivation) + (insert-derivation-outputs conn + derivation-id + (derivation-outputs derivation))) + derivation-ids + derivations))) + (insert-input-derivations derivations)) - (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)) + (simple-format + (current-error-port) + "debug: insert-missing-derivations: done parallel (~A)\n" log-tag) + (retry-on-missing-derivation-output + (lambda () + (with-resource-from-pool postgresql-connection-pool conn + (with-time-logging + (simple-format + #f "insert-missing-derivations: inserting inputs for ~A derivations (~A)" + (vector-length derivations) + log-tag) + (insert-derivation-inputs conn + derivation-ids + derivations)))) + #:on-exception + (lambda () + ;; If this has happened because derivations have been removed, it + ;; might be necessary to insert them in the database where they + ;; previously existed. Clear the hash table while having the + ;; PostgreSQL connection to avoid issues with it being used at the + ;; same time. + (with-resource-from-pool postgresql-connection-pool conn + (hash-clear! derivation-ids-hash-table)) + (insert-input-derivations derivations)))))) + +(define (fix-derivation file-name) + (define (derivation-missing-inputs? conn drv-id) + (let ((inputs (select-derivation-inputs-by-derivation-id + conn + drv-id))) + ;; TODO Detect missing inputs, as well as them all missing + (null? inputs))) + + (define (derivation-missing-sources? conn drv-id) + (let ((sources (select-derivation-sources-by-derivation-id + conn + drv-id))) + ;; TODO Detect missing inputs, as well as them all missing + (null? sources))) + + (run-fibers + (lambda () + (with-exception-handler + ;; Fibers get's stuck if it handles an exception, so handle + ;; exceptions here so this procedure actually finishes + (const #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (with-postgresql-connection + "fix" + (lambda (conn) + (let ((drv (read-derivation-from-file file-name)) + (postgresql-connection-pool + (make-resource-pool + (const conn) + 1 + #:name "postgres")) + (call-with-utility-thread + (lambda (thunk) + (thunk))) + (derivation-ids-hash-table + (make-hash-table))) + + (match (select-derivation-by-file-name conn (derivation-file-name drv)) + ((drv-id rest ...) + (when (and (derivation-missing-sources? conn drv-id) + (not (null? (derivation-sources drv)))) + (with-postgresql-transaction + conn + (lambda (conn) + (derivations-insert-sources postgresql-connection-pool + call-with-utility-thread + (vector drv) + (vector drv-id))))) + + (when (and (derivation-missing-inputs? conn drv-id) + (not (null? (derivation-inputs drv)))) + (with-postgresql-transaction + conn + (lambda (conn) + (let ((input-derivations + (map derivation-input-derivation + (derivation-inputs drv)))) + (unless (null? input-derivations) + ;; Ensure all the input derivations exist + (chunk-for-each! + (lambda (chunk) + (insert-missing-derivations + postgresql-connection-pool + call-with-utility-thread + derivation-ids-hash-table + chunk)) + 1000 + input-derivations))))) + + (fix-derivation-inputs conn drv)))))))))) + #:unwind? #t)) + #:hz 0 + #:parallelism 1)) + +(define (fix-derivation-source-file-nar id) + (run-fibers + (lambda () + (with-postgresql-connection + "fix" + (lambda (conn) + (let ((postgresql-connection-pool + (make-resource-pool + (const conn) + 1 + #:name "postgres"))) + (match (exec-query + conn + " +SELECT store_path FROM derivation_source_files WHERE id = $1" + (list (number->string id))) + (((store-path)) + (compute-and-update-derivation-source-file-nar + postgresql-connection-pool + id + store-path))))))) + #:hz 0 + #:parallelism 1)) + +(define* (derivation-file-names->derivation-ids postgresql-connection-pool + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + derivation-file-names + #:key (log-tag "unspecified")) + (define derivations-count + (vector-length derivation-file-names)) + + (if (= 0 derivations-count) + #() + (begin + (with-resource-from-pool postgresql-connection-pool conn + (update-derivation-ids-hash-table! + conn + derivation-ids-hash-table + derivation-file-names)) + + (let ((missing-derivation-filenames + (deduplicate-strings + (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)))) + (simple-format + #t "debug: derivation-file-names->derivation-ids: processing ~A missing derivations (~A)\n" + (length missing-derivation-filenames) + log-tag) + + (let ((chunk-counter 0)) + (chunk-for-each! + (lambda (missing-derivation-file-names-chunk) + (let ((missing-derivations-chunk + (read-derivations/fiberized + missing-derivation-file-names-chunk))) + (simple-format + #t "debug: derivation-file-names->derivation-ids: processing chunk ~A (~A)\n" + chunk-counter + log-tag) + (set! chunk-counter (+ 1 chunk-counter)) + (insert-missing-derivations postgresql-connection-pool + call-with-utility-thread + derivation-ids-hash-table + missing-derivations-chunk + #:log-tag log-tag))) + 1000 + missing-derivation-filenames)) + + (let ((all-ids + (vector-map + (lambda (_ derivation-file-name) + (if derivation-file-name + (or (hash-ref derivation-ids-hash-table + derivation-file-name) + (error + (simple-format #f "missing derivation id (~A)" + derivation-file-name))) + #f)) + derivation-file-names))) + + all-ids))))) + +(prevent-inlining-for-tests derivation-file-names->derivation-ids) (define guix-store-path (let ((store-path #f)) @@ -989,6 +1518,8 @@ (let ((channel (make-channel))) (call-with-new-thread (lambda () + (set-thread-name "ds temp") + (parameterize ((current-read-waiter (lambda (port) (port-poll port "r"))) (current-write-waiter (lambda (port) (port-poll port "w")))) @@ -997,13 +1528,14 @@ (lambda (exn) (put-message channel `(exception . ,exn))) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (call-with-values thunk (lambda values - (put-message channel `(values ,@values))))) - (lambda _ - (backtrace)))) + (put-message channel `(values ,@values))))))) #:unwind? #t)))) (match (get-message channel) @@ -1018,9 +1550,9 @@ (inferior-eval-with-store inferior store proc)))) (define* (channel->source-and-derivation-file-names-by-system - conn store channel + conn channel fetch-with-authentication? - #:key parallelism) + #:key parallelism ignore-systems) (define use-container? (defined? 'open-inferior/container @@ -1070,42 +1602,22 @@ (derivation-file-name (manifest-entry-item (first - (manifest-entries manifest))))))) - (profile - . ,(catch #t - (lambda () - (and manifest - (add-tmp-root-and-return-drv - (derivation-file-name - (parameterize ((%current-system system)) - (run-with-store store - (profile-derivation - manifest - #:hooks %channel-profile-hooks))))))) - (lambda (key . args) - (simple-format - (current-error-port) - "error: while computing profile derivation for ~A\n" - system) - (simple-format - (current-error-port) - "error ~A: ~A\n" key args) - #f)))))))) + (manifest-entries manifest)))))))))))) (define (start-inferior inferior-store) (let ((inferior (if use-container? (open-inferior/container - store - (guix-store-path store) + inferior-store + (guix-store-path inferior-store) #:extra-shared-directories '("/gnu/store") #:extra-environment-variables (list (string-append - "SSL_CERT_DIR=" (nss-certs-store-path store)))) + "SSL_CERT_DIR=" (nss-certs-store-path inferior-store)))) (begin (simple-format #t "debug: using open-inferior\n") - (open-inferior (guix-store-path store) + (open-inferior (guix-store-path inferior-store) #:error-port (current-error-port)))))) ;; /etc is only missing if open-inferior/container has been used @@ -1145,19 +1657,21 @@ conn 'latest-channel-instances (lambda () - ;; TODO (guix serialization) uses dynamic-wind - (call-with-temporary-thread - (lambda () - (first - (latest-channel-instances store - (list channel) - #:authenticate? - fetch-with-authentication?))))))) + (with-store-connection + (lambda (store) + ;; TODO (guix serialization) uses dynamic-wind + (call-with-temporary-thread + (lambda () + (first + (latest-channel-instances store + (list channel) + #:authenticate? + fetch-with-authentication?))))))))) (pool-store-connections '()) (inferior-and-store-pool (make-resource-pool (lambda () - (let* ((inferior-store (open-connection)) + (let* ((inferior-store (open-store-connection)) (inferior (start-inferior inferior-store))) (ensure-non-blocking-store-connection inferior-store) (set-build-options inferior-store #:fallback? #t) @@ -1169,21 +1683,33 @@ (cons inferior inferior-store))) parallelism #:min-size 0 - #:idle-seconds 10 + #:name "inferior" + #:idle-seconds 30 #:destructor (match-lambda ((inferior . store) - ;; Just close the inferior here, close the store - ;; connection later to keep the temporary roots - ;; alive - (close-inferior inferior))))) + (close-inferior inferior) + (close-connection store))))) (systems (with-resource-from-pool inferior-and-store-pool res (match res ((inferior . inferior-store) - (inferior-eval '(@ (guix packages) %supported-systems) - inferior))))) + (let* ((systems + (inferior-eval '(@ (guix packages) %supported-systems) + inferior)) + (ignored-systems + (lset-intersection string=? + systems + ignore-systems))) + (unless (null? ignored-systems) + (simple-format + (current-error-port) + "ignoring systems: ~A\n" + ignored-systems)) + (lset-difference string=? + systems + ignored-systems)))))) (result - (par-map& + (fibers-map (lambda (system) (with-resource-from-pool inferior-and-store-pool res (match res @@ -1199,51 +1725,38 @@ (cons system #f)) (raise-exception exn))) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "failed to compute channel instance derivation for ~A\n" + system) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (cons system (inferior-eval-with-store/non-blocking inferior inferior-store - (inferior-code channel-instance system)))) - (lambda _ - (simple-format - (current-error-port) - "failed to compute channel instance derivation for ~A\n" - system)))) + (inferior-code channel-instance system)))))) #:unwind? #t))))) systems))) - (for-each - (match-lambda - ((_ . manifest-and-profile) - (when manifest-and-profile - (and=> (assq-ref manifest-and-profile 'manifest-entry-item) - (lambda (drv) - (add-temp-root store drv))) - (and=> (assq-ref manifest-and-profile 'profile) - (lambda (drv) - (add-temp-root store drv)))))) - result) - - ;; Now the roots have been added to the main store connection, close the - ;; pool ones - (for-each close-connection pool-store-connections) - (cons (channel-instance-checkout channel-instance) result))) -(define* (channel->source-and-derivations-by-system conn store channel +(define* (channel->source-and-derivations-by-system conn channel fetch-with-authentication? - #:key parallelism) + #:key parallelism + ignore-systems) (match (with-time-logging "computing the channel derivation" (channel->source-and-derivation-file-names-by-system conn - store channel fetch-with-authentication? - #:parallelism parallelism)) + #:parallelism parallelism + #:ignore-systems ignore-systems)) ((source . derivation-file-names-by-system) (for-each (match-lambda @@ -1254,33 +1767,30 @@ derivation-file-name))) derivation-file-names-by-system) - (cons source derivation-file-names-by-system)))) + (values source derivation-file-names-by-system)))) (prevent-inlining-for-tests channel->source-and-derivations-by-system) (define (channel-derivations-by-system->guix-store-item - store channel-derivations-by-system) - (define (store-item->guix-store-item filename) - (dirname - (readlink - (string-append filename "/bin")))) - (let ((derivation-file-name-for-current-system (assoc-ref (assoc-ref channel-derivations-by-system (%current-system)) - 'profile))) + 'manifest-entry-item))) (if derivation-file-name-for-current-system (let ((derivation-for-current-system (read-derivation-from-file derivation-file-name-for-current-system))) (with-time-logging "building the channel derivation" - (build-derivations store (list derivation-for-current-system))) + (with-store-connection + (lambda (store) + (build-derivations store (list derivation-for-current-system))))) - (store-item->guix-store-item - (derivation->output-path derivation-for-current-system))) - #f))) + (values + (derivation->output-path derivation-for-current-system) + derivation-file-name-for-current-system)) + (values #f #f)))) (prevent-inlining-for-tests channel-derivations-by-system->guix-store-item) @@ -1328,83 +1838,136 @@ output))) -(define (start-inferior-for-data-extration store store-path guix-locpath) - (let* ((original-guix-locpath (getenv "GUIX_LOCPATH")) - (inf (begin - ;; Unset the GUILE_LOAD_PATH and GUILE_LOAD_COMPILED_PATH to - ;; avoid the values for these being used in the - ;; inferior. Even though the inferior %load-path and - ;; %load-compiled-path has the inferior modules first, this - ;; can cause issues when there are modules present outside - ;; of the inferior Guix which aren't present in the inferior - ;; Guix (like the new (guix lint) module - (unsetenv "GUILE_LOAD_PATH") - (unsetenv "GUILE_LOAD_COMPILED_PATH") - (simple-format (current-error-port) "debug: set GUIX_LOCPATH to ~A\n" - guix-locpath) - (if (defined? - 'open-inferior/container - (resolve-module '(guix inferior))) - (open-inferior/container store store-path - #:extra-shared-directories - '("/gnu/store") - #:extra-environment-variables - (list (string-append - "GUIX_LOCPATH=" - guix-locpath))) - (begin - (setenv "GUIX_LOCPATH" guix-locpath) - (simple-format #t "debug: using open-inferior\n") - (open-inferior store-path - #:error-port (current-error-port))))))) - (setenv "GUIX_LOCPATH" original-guix-locpath) ; restore GUIX_LOCPATH - - (when (eq? inf #f) - (error "error: inferior is #f")) - - ;; Normalise the locale for the inferior process - (with-exception-handler - (lambda (key . args) - (simple-format - (current-error-port) - "warning: failed to set locale to en_US.UTF-8: ~A ~A\n" - key args)) - (lambda () - (inferior-eval '(setlocale LC_ALL "en_US.UTF-8") inf))) - - (inferior-eval '(use-modules (srfi srfi-1) - (srfi srfi-34) - (srfi srfi-43) - (ice-9 history) - (guix grafts) - (guix derivations) - (gnu tests)) - inf) - - (inferior-eval '(disable-value-history!) - inf) - - ;; For G_ and P_ - (or (inferior-eval '(and (resolve-module '(guix i18n) #:ensure #f) - (use-modules (guix i18n)) - #t) - inf) - (inferior-eval '(use-modules (guix ui)) - inf)) - - (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf) - - ;; TODO Have Guix make this easier - ((@@ (guix inferior) ensure-store-bridge!) inf) - (non-blocking-port ((@@ (guix inferior) inferior-bridge-socket) inf)) +(define (start-inferior-for-data-extration store store-path guix-locpath + extra-inferior-environment-variables) + (call-with-blocked-asyncs + (lambda () + (let* ((original-guix-locpath (getenv "GUIX_LOCPATH")) + (original-extra-env-vars-values + (map (match-lambda + ((key . _) + (getenv key))) + extra-inferior-environment-variables)) + (inf (begin + ;; Unset the GUILE_LOAD_PATH and GUILE_LOAD_COMPILED_PATH to + ;; avoid the values for these being used in the + ;; inferior. Even though the inferior %load-path and + ;; %load-compiled-path has the inferior modules first, this + ;; can cause issues when there are modules present outside + ;; of the inferior Guix which aren't present in the inferior + ;; Guix (like the new (guix lint) module + (unsetenv "GUILE_LOAD_PATH") + (unsetenv "GUILE_LOAD_COMPILED_PATH") + (simple-format (current-error-port) "debug: set GUIX_LOCPATH to ~A\n" + guix-locpath) + (for-each + (match-lambda + ((key . val) + (simple-format (current-error-port) + "debug: set ~A to ~A\n" + key val) + (setenv key val))) + extra-inferior-environment-variables) + + (if (defined? + 'open-inferior/container + (resolve-module '(guix inferior))) + (open-inferior/container store store-path + #:extra-shared-directories + '("/gnu/store") + #:extra-environment-variables + (list (string-append + "GUIX_LOCPATH=" + guix-locpath))) + (begin + (setenv "GUIX_LOCPATH" guix-locpath) + (simple-format #t "debug: using open-inferior\n") + (open-inferior store-path + #:error-port (current-error-port))))))) + (setenv "GUIX_LOCPATH" original-guix-locpath) ; restore GUIX_LOCPATH + (for-each + (lambda (key val) + (setenv key val)) + (map car extra-inferior-environment-variables) + original-extra-env-vars-values) + + (when (eq? inf #f) + (error "error: inferior is #f")) + + ;; Normalise the locale for the inferior process + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "warning: failed to set locale to en_US.UTF-8: ~A\n" + exn)) + (lambda () + (inferior-eval '(setlocale LC_ALL "en_US.UTF-8") inf))) + + (inferior-eval '(use-modules (srfi srfi-1) + (srfi srfi-34) + (srfi srfi-43) + (ice-9 history) + (guix grafts) + (guix derivations) + (gnu tests)) + inf) - inf)) + (inferior-eval '(disable-value-history!) + inf) -(define* (extract-information-from conn long-running-store-connection - guix-revision-id commit - guix-source store-path + ;; For G_ and P_ + (or (inferior-eval '(and (resolve-module '(guix i18n) #:ensure #f) + (use-modules (guix i18n)) + #t) + inf) + (inferior-eval '(use-modules (guix ui)) + inf)) + + (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf) + + ;; Load the heap-profiler + (for-each + (lambda (exp) + (inferior-eval exp inf)) + (call-with-input-file + (%search-load-path "guix-data-service/heap-profiler.scm") + (lambda (port) + (let loop ((result '())) + (let ((exp (read port))) + (if (eof-object? exp) + (reverse! result) + (loop (cons (if (eq? (car exp) 'define-module) + `(use-modules + ,@(let loop ((lst (cddr exp)) + (result '())) + (match lst + ('() result) + (('#:use-module mod rest ...) + (loop rest + (cons mod result))) + (rest + (loop (cdr lst) result))))) + exp) + result)))))))) + + ;; TODO Have Guix make this easier + ((@@ (guix inferior) ensure-store-bridge!) inf) + (non-blocking-port ((@@ (guix inferior) inferior-bridge-socket) inf)) + + inf)))) + +(define* (extract-information-from db-conn guix-revision-id-promise + commit + guix-source store-item + guix-derivation + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table #:key skip-system-tests? - parallelism) + extra-inferior-environment-variables + parallelism + ignore-systems ignore-targets) (define guix-locpath ;; Augment the GUIX_LOCPATH to include glibc-locales from @@ -1414,26 +1977,46 @@ (string-append (with-store-connection (lambda (store) - (glibc-locales-for-guix-store-path store store-path))) + (glibc-locales-for-guix-store-path store store-item))) "/lib/locale" ":" (getenv "GUIX_LOCPATH"))) (define inf-and-store-pool (make-resource-pool (lambda () - (let* ((inferior-store (open-connection)) - (inferior (start-inferior-for-data-extration inferior-store - store-path - guix-locpath))) - (ensure-non-blocking-store-connection inferior-store) - (make-inferior-non-blocking! inferior) - - (simple-format #t "debug: started new inferior and store connection\n") - - (cons inferior inferior-store))) + (let* ((inferior-store (open-store-connection))) + (unless (valid-path? inferior-store store-item) + (simple-format #t "warning: store item missing (~A)\n" + store-item) + (unless (valid-path? inferior-store guix-derivation) + (simple-format #t "warning: attempting to substitute guix derivation (~A)\n" + guix-derivation) + ;; Wait until the derivations are in the database + (fibers-force guix-revision-id-promise) + (ensure-path inferior-store guix-derivation)) + (simple-format #t "warning: building (~A)\n" + guix-derivation) + (build-derivations inferior-store + (list (read-derivation-from-file + guix-derivation)))) + ;; Use this more to keep the store-path alive so long as there's a + ;; inferior operating + (add-temp-root inferior-store store-item) + + (let ((inferior (start-inferior-for-data-extration + inferior-store + store-item + guix-locpath + extra-inferior-environment-variables))) + (ensure-non-blocking-store-connection inferior-store) + (make-inferior-non-blocking! inferior) + (simple-format #t "debug: started new inferior and store connection\n") + + (cons inferior inferior-store)))) parallelism #:min-size 0 - #:idle-seconds 2 + #:idle-seconds 20 + #:name "inferior" #:destructor (match-lambda ((inferior . store) @@ -1443,183 +2026,416 @@ (close-connection store) (close-inferior inferior))))) - (define add-temp-root/long-running-store - (let ((channel (make-channel))) + (define (call-with-inferior proc) + (define (check-wal-size) + (define (get-wal-bytes) + (catch #t + (lambda () + (stat:size (stat "/var/guix/db/db.sqlite-wal"))) + (lambda _ 0))) + + (define threshold + (max + (* 4096 (expt 2 20)) + (* 0.8 + (- (free-disk-space "/var/guix/db/db.sqlite") + (get-wal-bytes))))) + + (if (< (get-wal-bytes) threshold) + #t + (let loop ((wal-bytes (get-wal-bytes))) + (if (> wal-bytes threshold) + (let ((stats (resource-pool-stats inf-and-store-pool))) + (simple-format + #t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n" + wal-bytes + (assq-ref stats 'resources)) - (spawn-fiber - (lambda () - (let loop ((filename (get-message channel))) - (add-temp-root long-running-store-connection filename) - (loop (get-message channel))))) - - (lambda (filename) - (put-message channel filename)))) - - (simple-format #t "debug: extract-information-from: ~A\n" store-path) - - (letpar& ((inferior-lint-checkers-and-warnings-data - (let ((inferior-lint-checkers-data - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (inferior-lint-checkers inferior)))))) - (cons - inferior-lint-checkers-data - (and inferior-lint-checkers-data - (par-map& - (match-lambda - ((checker-name _ network-dependent?) - (and (and (not network-dependent?) - ;; Running the derivation linter is - ;; currently infeasible - (not (eq? checker-name 'derivation))) - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (inferior-lint-warnings inferior - inferior-store - checker-name))))))) - inferior-lint-checkers-data))))) - (inferior-packages-system-and-target-to-derivations-alist - (par-map& - (match-lambda - ((system . target) - (let loop ((wal-bytes (stat:size (stat "/var/guix/db/db.sqlite-wal")))) - (when (> wal-bytes (* 2048 (expt 2 20))) - (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n" - wal-bytes) - - (sleep 30) - (loop (stat:size (stat "/var/guix/db/db.sqlite-wal"))))) - - (with-resource-from-pool inf-and-store-pool res - (with-time-logging - (simple-format #f "getting derivations for ~A" (cons system target)) - (match res - ((inferior . inferior-store) - (ensure-gds-inferior-packages-defined! inferior) - - (let ((drvs - (inferior-package-derivations - inferior-store - inferior - system - target))) - - (vector-for-each - (lambda (_ drv) - (and=> drv add-temp-root/long-running-store)) - drvs) - - (cons (cons system target) - drvs)))))))) - (with-resource-from-pool inf-and-store-pool res - (match res + (sleep 30) + (loop (get-wal-bytes))) + (begin + (simple-format + #t "debug: guix-daemon WAL now ~A bytes, continuing\n" + wal-bytes) + #t))))) + + (let loop () + (check-wal-size) + (match + (with-exception-handler + (lambda (exn) + (if (resource-pool-timeout-error? exn) + 'retry + (raise-exception exn))) + (lambda () + (call-with-resource-from-pool inf-and-store-pool + (match-lambda ((inferior . inferior-store) - (inferior-fetch-system-target-pairs inferior)))))) - (inferior-system-tests - (if skip-system-tests? - (begin - (simple-format #t "debug: skipping system tests\n") - '()) - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (with-time-logging "getting inferior system tests" - (all-inferior-system-tests inferior inferior-store - guix-source commit - add-temp-root/long-running-store))))))) - (packages-data - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (with-time-logging "getting all inferior package data" - (let ((packages - pkg-to-replacement-hash-table - (inferior-packages-plus-replacements inferior))) - (all-inferior-packages-data inferior - packages - pkg-to-replacement-hash-table)))))))) + (call-with-values + (lambda () + (proc inferior inferior-store)) + (lambda vals + (simple-format #t "debug: returning inferior to pool\n") + (cons 'result vals))))) + #:timeout 20)) + #:unwind? #t) + ('retry (loop)) + (('result . vals) + (apply values vals))))) + + (define postgresql-connection-pool + (make-resource-pool + (lambda () + (with-time-logging + "waiting for guix-revision-id" + ;; This uses the transaction lock, so wait until the transaction has + ;; committed + (fibers-force guix-revision-id-promise)) + (with-time-logging + "extract information, acquiring advisory transaction lock: load-new-guix-revision-inserts" + ;; Wait until this is the only transaction inserting data, to + ;; avoid any concurrency issues + (obtain-advisory-transaction-lock db-conn + 'load-new-guix-revision-inserts)) + db-conn) + 1 + #:name "postgres")) + + (define package-ids-promise + (fibers-delay + (lambda () + (let ((packages-data + (call-with-inferior + (lambda (inferior inferior-store) + (with-time-logging "getting all inferior package data" + (let ((packages + pkg-to-replacement-hash-table + (inferior-packages-plus-replacements + inferior + #:log-duplicates? #t))) + (all-inferior-packages-data + inferior + packages + pkg-to-replacement-hash-table))))))) + (with-resource-from-pool postgresql-connection-pool conn + (insert-packages conn packages-data)))))) + + (define (extract-and-store-lint-checkers-and-warnings) + (define inferior-lint-checkers-data + (call-with-inferior + (lambda (inferior inferior-store) + (list->vector + (inferior-lint-checkers inferior))))) + + (when inferior-lint-checkers-data + (fibers-let ((lint-checker-ids + (with-resource-from-pool postgresql-connection-pool conn + (lint-checkers->lint-checker-ids + conn + (vector-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-warnings-data + (fibers-map + (match-lambda + ((checker-name _ network-dependent?) + (and (and (not network-dependent?) + ;; Running the derivation linter is + ;; currently infeasible + (not (eq? checker-name 'derivation))) + (begin + (call-with-inferior + (lambda (inferior inferior-store) + (inferior-lint-warnings inferior + inferior-store + checker-name))))))) + inferior-lint-checkers-data))) + + (let ((package-ids (fibers-force package-ids-promise))) + (with-resource-from-pool postgresql-connection-pool conn + (insert-guix-revision-lint-checkers + conn + (fibers-force guix-revision-id-promise) + lint-checker-ids) - (destroy-resource-pool inf-and-store-pool) + (let ((lint-warning-id-vectors + (with-time-logging "inserting lint warnings" + (insert-lint-warnings + conn + package-ids + lint-checker-ids + lint-warnings-data)))) + (with-time-logging "inserting guix revision lint warnings" + (for-each + (lambda (lint-warning-ids) + (insert-guix-revision-lint-warnings + conn + (fibers-force guix-revision-id-promise) + lint-warning-ids)) + lint-warning-id-vectors)))))))) + + (define (extract-and-store-package-derivations) + (define packages-count + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (inferior-eval '(vector-length gds-inferior-packages) inferior)))) + + (define chunk-size 1000) + + (define (inferior-cleanup inferior) + (inferior-eval + '(let ((stats (gc-stats))) + (simple-format + (current-error-port) + "cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20))))) + inferior) + + (catch + 'match-error + (lambda () + (inferior-eval '(invalidate-derivation-caches!) + inferior)) + (lambda (key . args) + (simple-format + (current-error-port) + "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) - (simple-format - #t "debug: finished loading information from inferior\n") + ;; Generating derivations populates the derivation cache + (inferior-eval + '(hash-clear! (@@ (guix derivations) %derivation-cache)) + inferior) - (with-time-logging - "acquiring advisory transaction lock: load-new-guix-revision-inserts" - ;; Wait until this is the only transaction inserting data, to - ;; 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))) - (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)))) - (car inferior-lint-checkers-and-warnings-data)))) - (lint-warning-ids - (insert-lint-warnings - conn - package-ids - lint-checker-ids - (cdr inferior-lint-checkers-and-warnings-data)))) - (insert-guix-revision-lint-checkers conn - guix-revision-id - lint-checker-ids) + ;; 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)) + inferior) - (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 - 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)) + (inferior-eval + '(hash-for-each + (lambda (key _) + ((@ (guix memoization) invalidate-memoization!) key)) + (@@ (guix memoization) %memoization-tables)) + inferior) + + (inferior-eval '(gc) inferior) + (inferior-eval + '(let ((stats (gc-stats))) + (simple-format + (current-error-port) + "finished cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20))))) + inferior) + + ;; (inferior-eval + ;; '((@@ (guix memoization) show-memoization-tables)) + ;; inferior) + + *unspecified*) + + (define (get-derivations system target) + (let ((derivations-vector (make-vector packages-count))) (with-time-logging - "insert-guix-revision-package-derivation-distribution-counts" - (insert-guix-revision-package-derivation-distribution-counts - conn - guix-revision-id)))))) + (simple-format #f "getting derivations for ~A" (cons system target)) + (let loop ((start-index 0)) + (let* ((last-chunk? + (>= (+ start-index chunk-size) packages-count)) + (count + (if last-chunk? + (- packages-count start-index) + chunk-size)) + (chunk + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (let ((result + (inferior-package-derivations + inferior-store + inferior + system + target + start-index + count))) + + (when last-chunk? + (inferior-cleanup inferior)) + + result))))) + (vector-copy! derivations-vector + start-index + chunk) + (unless last-chunk? + (loop (+ start-index chunk-size)))))) + derivations-vector)) + + (define (process-system-and-target system target get-derivations) + (with-time-logging + (simple-format #f "processing derivations for ~A" (cons system target)) + (let* ((derivations-vector (get-derivations system target)) + (derivation-ids + (with-time-logging + (simple-format #f "derivation-file-names->derivation-ids (~A ~A)" + system target) + (derivation-file-names->derivation-ids + postgresql-connection-pool + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + derivations-vector + #:log-tag (simple-format #f "~A:~A" system target)))) + (guix-revision-id + (fibers-force guix-revision-id-promise)) + (package-ids (fibers-force package-ids-promise)) + (package-derivation-ids + (with-resource-from-pool postgresql-connection-pool conn + (with-time-logging + (simple-format #f "insert-package-derivations (~A ~A)" + system target) + (insert-package-derivations conn + system + (or target "") + package-ids + derivation-ids))))) + (chunk-for-each! + (lambda (package-derivation-ids-chunk) + (with-resource-from-pool postgresql-connection-pool conn + (insert-guix-revision-package-derivations + conn + guix-revision-id + package-derivation-ids-chunk))) + 2000 + ;; TODO Chunk more efficiently + (vector->list package-derivation-ids)))) + + 'finished) + + (let ((get-derivations/fiberized + (fiberize get-derivations + ;; Limit concurrency here to keep focused on specific + ;; systems until they've been fully processed + #:parallelism parallelism))) + (with-time-logging "extract-and-store-package-derivations" + (fibers-map-with-progress + (match-lambda + ((system . target) + (retry-on-missing-store-item + (lambda () + (process-system-and-target system target + get-derivations/fiberized))))) + (list + (let ((all-system-target-pairs + (call-with-inferior + (lambda (inferior inferior-store) + (inferior-fetch-system-target-pairs inferior))))) + (filter + (match-lambda + ((system . target) + (if (or (member system ignore-systems) + (member target ignore-targets)) + (begin + (simple-format + (current-error-port) + "ignoring ~A ~A for package derivations\n" + system + target) + #f) + #t))) + all-system-target-pairs))) + #:report + (lambda (data) + (for-each + (match-lambda + ((result (system . target)) + (simple-format #t "~A ~A: ~A\n" + system target result))) + data)))))) + + (define (extract-and-store-system-tests) + (if skip-system-tests? + (begin + (simple-format #t "debug: skipping system tests\n") + '()) + (with-time-logging "extract-and-store-system-tests" + (let ((data-with-derivation-file-names + (call-with-inferior + (lambda (inferior inferior-store) + (with-time-logging "getting inferior system tests" + (all-inferior-system-tests + inferior + inferior-store + guix-source + commit)))))) + (when data-with-derivation-file-names + (let ((data-with-derivation-ids + (map (match-lambda + ((name description derivation-file-names-by-system location-data) + (list name + description + (let ((systems + (map car derivation-file-names-by-system)) + (derivation-ids + (derivation-file-names->derivation-ids + postgresql-connection-pool + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + (list->vector + (map cdr derivation-file-names-by-system)) + #:log-tag "channel-instances"))) + (map cons systems derivation-ids)) + location-data))) + data-with-derivation-file-names))) + (with-resource-from-pool postgresql-connection-pool conn + (insert-system-tests-for-guix-revision + conn + (fibers-force guix-revision-id-promise) + data-with-derivation-ids)))))))) + + (with-time-logging + (simple-format #f "extract-information-from: ~A\n" store-item) + (fibers-parallel + (begin + (fibers-force package-ids-promise) + #f) + (extract-and-store-package-derivations) + (retry-on-missing-store-item extract-and-store-system-tests) + (with-time-logging "extract-and-store-lint-checkers-and-warnings" + (extract-and-store-lint-checkers-and-warnings)))) + + #t) (prevent-inlining-for-tests extract-information-from) -(define (load-channel-instances git-repository-id commit +(define (load-channel-instances call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + git-repository-id commit channel-derivations-by-system) ;; Load the channel instances in a different transaction, so that this can ;; commit prior to the outer transaction @@ -1631,7 +2447,7 @@ (lambda (channel-instances-conn) (with-time-logging - "acquiring advisory transaction lock: load-new-guix-revision-inserts" + "channel instances, acquiring advisory transaction lock: load-new-guix-revision-inserts" ;; Wait until this is the only transaction inserting data, to avoid ;; any concurrency issues (obtain-advisory-transaction-lock channel-instances-conn @@ -1644,19 +2460,37 @@ (guix-revision-id (or existing-guix-revision-id (insert-guix-revision channel-instances-conn - git-repository-id commit)))) + git-repository-id commit))) + (postgresql-connection-pool + (make-resource-pool + (const channel-instances-conn) + 1 + #:name "postgres"))) + (unless existing-guix-revision-id - (insert-channel-instances channel-instances-conn - guix-revision-id - (filter-map - (match-lambda - ((system . derivations) - (and=> - (assoc-ref derivations - 'manifest-entry-item) - (lambda (drv) - (cons system drv))))) - channel-derivations-by-system)) + (let* ((derivations-by-system + (filter-map + (match-lambda + ((system . derivations) + (and=> + (assoc-ref derivations + 'manifest-entry-item) + (lambda (drv) + (cons system drv))))) + channel-derivations-by-system)) + (derivation-ids + (derivation-file-names->derivation-ids + postgresql-connection-pool + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + (list->vector (map cdr derivations-by-system))))) + + (insert-channel-instances channel-instances-conn + guix-revision-id + (map cons + (map car derivations-by-system) + (vector->list derivation-ids)))) (simple-format (current-error-port) "guix-data-service: saved the channel instance derivations to the database\n")) @@ -1666,7 +2500,41 @@ (prevent-inlining-for-tests load-channel-instances) (define* (load-new-guix-revision conn git-repository-id commit - #:key skip-system-tests? parallelism) + #:key skip-system-tests? parallelism + extra-inferior-environment-variables + ignore-systems ignore-targets) + (define call-with-utility-thread + (let* ((thread-pool + (make-thread-pool parallelism)) + (queued-channel + ;; There might be high demand for this, so order the requests + (spawn-queueing-fiber + (thread-pool-channel thread-pool)))) + (lambda (thunk) + (call-with-thread + thread-pool + thunk + #:channel queued-channel)))) + + (define (read-derivations filenames) + (call-with-utility-thread + (lambda () + (map (lambda (filename) + (if (file-exists? filename) + (read-derivation-from-file filename) + (raise-exception + (make-missing-store-item-error + filename)))) + filenames)))) + (define read-derivations/fiberized + (fiberize read-derivations + ;; Don't do this in parallel as there's caching involved with + ;; read-derivation-from-file + #:parallelism 1)) + + (define derivation-ids-hash-table + (make-hash-table)) + (let* ((git-repository-fields (select-git-repository conn git-repository-id)) (git-repository-url @@ -1676,68 +2544,100 @@ (channel-for-commit (channel (name 'guix) (url git-repository-url) - (commit commit))) - (initial-store-connection - (open-store-connection)) - (source-and-channel-derivations-by-system - (channel->source-and-derivations-by-system - conn - initial-store-connection - channel-for-commit - fetch-with-authentication? - #:parallelism parallelism)) - (guix-source - (car source-and-channel-derivations-by-system)) - (channel-derivations-by-system - (cdr source-and-channel-derivations-by-system)) - (guix-revision-id - (load-channel-instances git-repository-id commit - channel-derivations-by-system))) - (let ((store-item - (channel-derivations-by-system->guix-store-item - initial-store-connection - channel-derivations-by-system))) + (commit commit)))) + + (define channel-derivations-by-system-promise + (fibers-delay + (lambda () + (with-postgresql-connection + "load-new-guix-revision channel->source-and-derivations-by-system" + (lambda (channel-conn) + (channel->source-and-derivations-by-system + channel-conn + channel-for-commit + fetch-with-authentication? + #:parallelism parallelism + #:ignore-systems ignore-systems)))))) + + (define guix-revision-id-promise + (fibers-delay + (lambda () + (retry-on-missing-store-item + (lambda () + (let ((guix-source + channel-derivations-by-system + (fibers-force channel-derivations-by-system-promise))) + (load-channel-instances call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + git-repository-id commit + channel-derivations-by-system))) + #:on-exception + (lambda () + (fibers-promise-reset channel-derivations-by-system-promise)))))) + + ;; Prompt getting the guix-revision-id as soon as possible + (spawn-fiber + (lambda () + (fibers-force guix-revision-id-promise))) + + (let* ((guix-source + channel-derivations-by-system + (fibers-force channel-derivations-by-system-promise)) + (store-item + guix-derivation + (channel-derivations-by-system->guix-store-item + channel-derivations-by-system))) (if store-item (and - (with-store-connection - (lambda (store) - (add-temp-root store store-item) - - ;; Close the initial connection now that the store-item has a - ;; root - (close-connection initial-store-connection) - - (extract-information-from conn store - guix-revision-id - commit guix-source store-item - #:skip-system-tests? - skip-system-tests? - #:parallelism parallelism))) - - (if (defined? 'channel-news-for-commit - (resolve-module '(guix channels))) - (with-time-logging "inserting channel news entries" - (insert-channel-news-entries-for-guix-revision - conn - guix-revision-id - (channel-news-for-commit channel-for-commit commit))) - (begin - (simple-format - #t "debug: importing channel news not supported\n") - #t)) - - (update-package-derivations-table conn - git-repository-id - guix-revision-id - commit) - (with-time-logging "updating builds.derivation_output_details_set_id" - (update-builds-derivation-output-details-set-id - conn - (string->number guix-revision-id)))) + (extract-information-from conn + guix-revision-id-promise + commit guix-source store-item + guix-derivation + call-with-utility-thread + read-derivations/fiberized + derivation-ids-hash-table + #:skip-system-tests? + skip-system-tests? + #:extra-inferior-environment-variables + extra-inferior-environment-variables + #:ignore-systems ignore-systems + #:ignore-targets ignore-targets + #:parallelism parallelism) + (let ((guix-revision-id + (fibers-force guix-revision-id-promise))) + (and + (if (defined? 'channel-news-for-commit + (resolve-module '(guix channels))) + (with-time-logging "inserting channel news entries" + (insert-channel-news-entries-for-guix-revision + conn + guix-revision-id + (channel-news-for-commit channel-for-commit commit))) + (begin + (simple-format + #t "debug: importing channel news not supported\n") + #t)) + + (with-time-logging "updating builds.derivation_output_details_set_id" + (update-builds-derivation-output-details-set-id + conn + guix-revision-id)) + (update-package-derivations-table + conn + git-repository-id + guix-revision-id + commit) + (let ((stats (gc-stats))) + (format (current-error-port) + "gc-stats: time taken: ~3fs, times: ~d~%" + (/ (assq-ref stats 'gc-time-taken) + internal-time-units-per-second) + (assq-ref stats 'gc-times)) + #t)))) (begin (simple-format #t "Failed to generate store item for ~A\n" commit) - (close-connection initial-store-connection) #f))))) (define (enqueue-load-new-guix-revision-job conn git-repository-id commit source) @@ -2097,108 +2997,216 @@ SKIP LOCKED") (exec-query conn query))) (define (open-store-connection) - (let ((store (open-connection))) - (ensure-non-blocking-store-connection store) + (let ((store (open-connection #:non-blocking? #t + #:built-in-builders '("download")))) (set-build-options store #:fallback? #t) store)) (prevent-inlining-for-tests open-store-connection) -(define (with-store-connection f) - (with-store store - (ensure-non-blocking-store-connection store) - (set-build-options store #:fallback? #t) +(define* (with-store-connection proc) + (let ((store (open-store-connection))) + (define (thunk) + (parameterize ((current-store-protocol-version + (store-connection-version store))) + (call-with-values (lambda () (proc store)) + (lambda results + (close-connection store) + (apply values results))))) + + (with-exception-handler (lambda (exception) + (close-connection store) + (raise-exception exception)) + thunk))) - (f store))) (prevent-inlining-for-tests with-store-connection) (define* (process-load-new-guix-revision-job id #:key skip-system-tests? + extra-inferior-environment-variables + ignore-systems + ignore-targets parallelism) - (with-postgresql-connection - (simple-format #f "load-new-guix-revision ~A" id) - (lambda (conn) - ;; Fix the hash encoding of derivation_output_details. This'll only run - ;; once on any given database, but is kept here just to make sure any - ;; instances have the data updated. - (fix-derivation-output-details-hash-encoding conn) - - (exec-query conn "BEGIN") - - (match (select-job-for-update conn id) - (((id commit source git-repository-id)) - - ;; With a separate connection, outside of the transaction so the event - ;; gets persisted regardless. - (with-postgresql-connection - (simple-format #f "load-new-guix-revision ~A start-event" id) - (lambda (start-event-conn) - (record-job-event start-event-conn id "start"))) - - (simple-format #t "Processing job ~A (commit: ~A, source: ~A)\n\n" - id commit source) - - (if (eq? - (with-time-logging (string-append "processing revision " commit) - (with-exception-handler - (const #f) - (lambda () - (with-throw-handler #t - (lambda () - (load-new-guix-revision conn - git-repository-id - commit - #:skip-system-tests? #t - #:parallelism parallelism)) - (lambda (key . args) - (simple-format (current-error-port) - "error: load-new-guix-revision: ~A ~A\n" - key args) - (backtrace)))) - #:unwind? #t)) - #t) - (begin - (record-job-succeeded conn id) - (record-job-event conn id "success") - (exec-query conn "COMMIT") + (define finished-channel + (make-channel)) + + (define result + (with-postgresql-connection + (simple-format #f "load-new-guix-revision ~A" id) + (lambda (conn) + ;; Fix the hash encoding of derivation_output_details. This'll only run + ;; once on any given database, but is kept here just to make sure any + ;; instances have the data updated. + (fix-derivation-output-details-hash-encoding conn) + + (add-hook! after-gc-hook + (lambda () + (simple-format (current-error-port) + "after gc\n"))) - (with-time-logging - "vacuuming package derivations by guix revision range table" - (vacuum-package-derivations-table conn)) + (exec-query conn "BEGIN") - (with-time-logging - "vacuum-derivation-inputs-table" - (vacuum-derivation-inputs-table conn)) + ;; (spawn-fiber + ;; (lambda () + ;; (while #t + ;; (sleep (* 60 5)) + ;; (profile-heap)))) - (match (exec-query - conn - "SELECT reltuples::bigint FROM pg_class WHERE relname = 'derivation_inputs'") - (((rows)) - ;; Don't attempt counting distinct values if there are too - ;; many rows, as that is far to slow and could use up all the - ;; disk space. - (when (< (string->number rows) - 1000000000) - (with-time-logging - "update-derivation-inputs-statistics" - (update-derivation-inputs-statistics conn))))) - - (with-time-logging - "vacuum-derivation-outputs-table" - (vacuum-derivation-outputs-table conn)) - - (with-time-logging - "update-derivation-outputs-statistics" - (update-derivation-outputs-statistics conn)) - - #t) - (begin - (exec-query conn "ROLLBACK") - (record-job-event conn id "failure") - - #f))) - (() - (exec-query conn "ROLLBACK") - (simple-format #t "job ~A not found to be processed\n" - id)))))) + (spawn-fiber + (lambda () + (while (perform-operation + (choice-operation + (wrap-operation (get-operation finished-channel) + (const #f)) + (wrap-operation (sleep-operation 20) + (const #t)))) + + (let ((stats (gc-stats))) + (simple-format + (current-error-port) + "process-job heap: ~a MiB used (~a MiB heap)~%" + (round + (/ (- (assoc-ref stats 'heap-size) + (assoc-ref stats 'heap-free-size)) + (expt 2. 20))) + (round + (/ (assoc-ref stats 'heap-size) + (expt 2. 20)))))))) + + (match (select-job-for-update conn id) + (((id commit source git-repository-id)) + + ;; With a separate connection, outside of the transaction so the event + ;; gets persisted regardless. + (with-postgresql-connection + (simple-format #f "load-new-guix-revision ~A start-event" id) + (lambda (start-event-conn) + (record-job-event start-event-conn id "start"))) + + (simple-format #t "Processing job ~A (commit: ~A, source: ~A)\n\n" + id commit source) + + (if (eq? + (with-time-logging (string-append "processing revision " commit) + (with-exception-handler + (const #f) + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format (current-error-port) + "error: load-new-guix-revision: ~A\n" + exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (load-new-guix-revision + conn + git-repository-id + commit + #:skip-system-tests? #t + #:extra-inferior-environment-variables + extra-inferior-environment-variables + #:ignore-systems ignore-systems + #:ignore-targets ignore-targets + #:parallelism parallelism)))) + #:unwind? #t)) + #t) + (begin + (record-job-succeeded conn id) + (record-job-event conn id "success") + (exec-query conn "COMMIT") + + #t) + (begin + (exec-query conn "ROLLBACK") + (record-job-event conn id "failure") + + #f))) + (() + (exec-query conn "ROLLBACK") + (simple-format #t "job ~A not found to be processed\n" + id)))))) + + (when result + (fibers-parallel + (let ((revision-id + system-ids-and-targets + (with-postgresql-connection + (simple-format #f "post load-new-guix-revision ~A counts" id) + (lambda (conn) + (let ((revision-id + (guix-revision-id-for-job conn id))) + (values + revision-id + (exec-query + conn + " +SELECT DISTINCT system_id, target +FROM package_derivations +INNER JOIN guix_revision_package_derivations + ON package_derivations.id = guix_revision_package_derivations.package_derivation_id +WHERE revision_id = $1" + (list revision-id)))))))) + + (with-time-logging + (simple-format + #f "inserting guix_revision_package_derivation_distribution_counts for revision ~A" + revision-id) + (fibers-batch-for-each + (match-lambda + ((system-id target) + (with-postgresql-connection + (simple-format #f "post load-new-guix-revision ~A counts" id) + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (insert-guix-revision-package-derivation-distribution-counts + conn + revision-id + system-id + target))))))) + parallelism + system-ids-and-targets))) + + (with-postgresql-connection + (simple-format #f "post load-new-guix-revision ~A" id) + (lambda (conn) + (with-time-logging + "vacuuming package derivations by guix revision range table" + (vacuum-package-derivations-table conn)))) + + (with-postgresql-connection + (simple-format #f "post load-new-guix-revision ~A" id) + (lambda (conn) + (with-time-logging + "vacuum-derivation-inputs-table" + (vacuum-derivation-inputs-table conn)) + + (match (exec-query + conn + "SELECT reltuples::bigint FROM pg_class WHERE relname = 'derivation_inputs'") + (((rows)) + ;; Don't attempt counting distinct values if there are too + ;; many rows, as that is far to slow and could use up all the + ;; disk space. + (when (< (string->number rows) + 1000000000) + (with-time-logging + "update-derivation-inputs-statistics" + (update-derivation-inputs-statistics conn))))))) + + (with-postgresql-connection + (simple-format #f "post load-new-guix-revision ~A" id) + (lambda (conn) + (with-time-logging + "vacuum-derivation-outputs-table" + (vacuum-derivation-outputs-table conn)) + + (with-time-logging + "update-derivation-outputs-statistics" + (update-derivation-outputs-statistics conn)))))) + + (put-message finished-channel #t) + result) diff --git a/guix-data-service/model/blocked-builds.scm b/guix-data-service/model/blocked-builds.scm index 888e842..2dcbee1 100644 --- a/guix-data-service/model/blocked-builds.scm +++ b/guix-data-service/model/blocked-builds.scm @@ -353,7 +353,7 @@ WHERE status IN ('failed', 'failed-dependency', 'failed-other', 'canceled') (get-sql-to-select-package-and-related-derivations-for-revision conn (commit->revision-id conn revision-commit) - #:system-id (system->system-id conn system) + #:system-id (lookup-system-id conn system) #:target target) (string-append " @@ -369,7 +369,7 @@ WITH RECURSIVE all_derivations AS ( (simple-format #f " AND system_id = ~A\n" - (system->system-id conn system)) + (lookup-system-id conn system)) "") (if target (simple-format diff --git a/guix-data-service/model/build-server.scm b/guix-data-service/model/build-server.scm index d73dddd..ee25538 100644 --- a/guix-data-service/model/build-server.scm +++ b/guix-data-service/model/build-server.scm @@ -16,11 +16,15 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (guix-data-service model build-server) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (squee) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model utils) #:export (select-build-servers select-build-server - select-build-server-urls-by-id)) + select-build-server-urls-by-id + specify-build-servers)) (define (select-build-servers conn) (define query @@ -58,3 +62,173 @@ WHERE id = $1") ((id url lookup-all-derivations? lookup-builds?) (cons id url))) (select-build-servers conn))) + +(define (specify-build-servers build-servers) + (define (specify-token-seeds conn + build-server-id + token-seeds) + (define string-build-server-id + (number->string build-server-id)) + + (let* ((db-token-seeds + (map + car + (exec-query + conn + " +SELECT token_seed +FROM build_server_token_seeds +WHERE build_server_id = $1" + (list string-build-server-id)))) + (token-seeds-to-delete + (lset-difference string=? + db-token-seeds + token-seeds)) + (token-seeds-to-insert + (lset-difference string=? + token-seeds + db-token-seeds))) + + (for-each + (lambda (seed) + (exec-query + conn + " +DELETE FROM build_server_token_seeds +WHERE build_server_id = $1 + AND token_seed = $2" + (list string-build-server-id + seed))) + token-seeds-to-delete) + + (for-each + (lambda (seed) + (exec-query + conn + " +INSERT INTO build_server_token_seeds +VALUES ($1, $2)" + (list string-build-server-id + seed))) + token-seeds-to-insert))) + + (define (specify-build-config conn + build-server-id + systems-and-targets) + (define string-build-server-id + (number->string build-server-id)) + + (define pair-equal? + (match-lambda* + (((s1 . t1) (s2 . t2)) + (and (string=? s1 s2) + (string=? t1 t2))))) + + (let* ((db-systems-and-targets + (map + (match-lambda + ((system target) + (cons system target))) + (exec-query + conn + " +SELECT system, target +FROM build_servers_build_config +WHERE build_server_id = $1" + (list string-build-server-id)))) + (systems-and-targets-to-delete + (lset-difference pair-equal? + db-systems-and-targets + systems-and-targets)) + (systems-and-targets-to-insert + (lset-difference pair-equal? + systems-and-targets + db-systems-and-targets))) + + (for-each + (match-lambda + ((system . target) + (exec-query + conn + " +DELETE FROM build_servers_build_config +WHERE build_server_id = $1 + AND system = $2 + AND target = $3" + (list string-build-server-id + system + target)))) + systems-and-targets-to-delete) + + (for-each + (match-lambda + ((system . target) + (exec-query + conn + " +INSERT INTO build_servers_build_config +VALUES ($1, $2, $3)" + (list string-build-server-id + system + target)))) + systems-and-targets-to-insert))) + + (with-postgresql-connection + "specify-build-servers" + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (let* ((existing-ids + (map first (select-build-servers conn))) + (target-ids + (map (lambda (repo) + (or (assq-ref repo 'id) + (error "build server missing id"))) + build-servers)) + (build-servers-to-delete + (lset-difference equal? + existing-ids + target-ids))) + (for-each + (lambda (id-to-remove) + (simple-format (current-error-port) + "deleting build server ~A\n" + id-to-remove) + (exec-query + conn + "DELETE FROM build_servers WHERE id = $1" + (list (number->string id-to-remove)))) + build-servers-to-delete) + + (for-each + (lambda (build-server) + (let* ((related-table-keys '(systems-and-targets + token-seeds)) + (build-servers-without-related-data + (filter-map + (lambda (pair) + (if (memq (car pair) related-table-keys) + #f + pair)) + build-server)) + (fields (map car build-servers-without-related-data)) + (field-vals (map cdr build-servers-without-related-data))) + (update-or-insert + conn + "build_servers" + fields + field-vals) + + (specify-token-seeds + conn + (assq-ref build-server 'id) + (or (assq-ref build-server 'token-seeds) + '())) + + (specify-build-config + conn + (assq-ref build-server 'id) + (or (assq-ref build-server 'systems-and-targets) + '())))) + build-servers))))))) diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm index 1240453..acf745a 100644 --- a/guix-data-service/model/build.scm +++ b/guix-data-service/model/build.scm @@ -136,12 +136,14 @@ WHERE builds.id = $1" (exec-query conn " +WITH derivation_output_details_ids (id) AS ( + SELECT unnest(derivation_output_details_ids) AS id + FROM derivation_output_details_sets + WHERE derivation_output_details_sets.id = $1 +) SELECT derivation_output_details.path FROM derivation_output_details -INNER JOIN derivation_output_details_sets - ON ARRAY[derivation_output_details.id] && - derivation_output_details_sets.derivation_output_details_ids -WHERE derivation_output_details_sets.id = $1" +WHERE derivation_output_details.id IN (SELECT id FROM derivation_output_details_ids)" (list output-details-set-id)) (exec-query conn @@ -281,13 +283,14 @@ FROM builds INNER JOIN build_servers ON build_servers.id = builds.build_server_id INNER JOIN latest_build_status ON latest_build_status.build_id = builds.id -INNER JOIN derivation_output_details_sets - ON builds.derivation_output_details_set_id = - derivation_output_details_sets.id -INNER JOIN derivation_output_details - ON ARRAY[derivation_output_details.id] <@ - derivation_output_details_sets.derivation_output_details_ids -WHERE derivation_output_details.path = $1 +WHERE builds.derivation_output_details_set_id = ( + SELECT derivation_output_details_sets.id + FROM derivation_output_details_sets + INNER JOIN derivation_output_details + ON ARRAY[derivation_output_details.id] <@ + derivation_output_details_sets.derivation_output_details_ids + WHERE derivation_output_details.path = $1 +) ORDER BY latest_build_status.timestamp DESC") (exec-query-with-null-handling conn query (list output))) @@ -507,19 +510,20 @@ WHERE derivations.file_name = $1" derivation-output-details-lists build-server-build-ids) (let ((build-ids - (insert-missing-data-and-return-all-ids - conn - "builds" - '(build_server_id derivation_file_name build_server_build_id) - (map (lambda (derivation-file-name build-server-build-id) - (list build-server-id - derivation-file-name - (if (string? build-server-build-id) - build-server-build-id - '()))) - derivation-file-names - build-server-build-ids) - #:delete-duplicates? #t))) + (vector->list + (insert-missing-data-and-return-all-ids + conn + "builds" + '(build_server_id derivation_file_name build_server_build_id) + (list->vector + (map (lambda (derivation-file-name build-server-build-id) + (list build-server-id + derivation-file-name + (if (string? build-server-build-id) + build-server-build-id + '()))) + derivation-file-names + build-server-build-ids)))))) (for-each (lambda (build-id derivation-output-details) diff --git a/guix-data-service/model/channel-instance.scm b/guix-data-service/model/channel-instance.scm index 84fc901..2cce2da 100644 --- a/guix-data-service/model/channel-instance.scm +++ b/guix-data-service/model/channel-instance.scm @@ -22,36 +22,28 @@ #:use-module (json) #:use-module (guix utils) #:use-module (guix-data-service model utils) - #:use-module (guix-data-service model derivation) #:export (insert-channel-instances channel-instances-exist-for-guix-revision? select-channel-instances-for-guix-revision)) (define (insert-channel-instances conn guix-revision-id - derivations-by-system) - (let ((derivation-ids - (derivation-file-names->derivation-ids - conn - (list->vector - (map cdr derivations-by-system))))) - - (exec-query - conn - (string-append - " + derivation-ids-by-system) + (exec-query + conn + (string-append + " INSERT INTO channel_instances (guix_revision_id, system, derivation_id) VALUES " - (string-join - (map (lambda (system derivation-id) - (simple-format #f "(~A, '~A', ~A)" - guix-revision-id - system - derivation-id)) - (map car derivations-by-system) - (vector->list derivation-ids)) - ", ")))) + (string-join + (map (lambda (derivation-id-and-system) + (simple-format #f "(~A, '~A', ~A)" + guix-revision-id + (car derivation-id-and-system) + (cdr derivation-id-and-system))) + derivation-ids-by-system) + ", "))) #t) (define (channel-instances-exist-for-guix-revision? conn commit-hash) diff --git a/guix-data-service/model/channel-news.scm b/guix-data-service/model/channel-news.scm index 6bc6842..4bb5625 100644 --- a/guix-data-service/model/channel-news.scm +++ b/guix-data-service/model/channel-news.scm @@ -76,62 +76,21 @@ SELECT channel_news_entries.commit, conn "channel_news_entry_text" '(lang text) - (map (match-lambda - ((lang . text) - (list lang text))) - text))) + (list->vector + (map (match-lambda + ((lang . text) + (list lang text))) + text)))) (define (insert-channel-news-entry conn commit tag) - (match (exec-query - conn - (string-append - "INSERT INTO channel_news_entries (commit, tag) VALUES (" - (value->quoted-string-or-null commit) - "," - (value->quoted-string-or-null tag) - ") RETURNING id")) - (((id)) - (string->number id)))) + (insert-and-return-id + conn + "channel_news_entries" + '(commit tag) + (list (or commit NULL) + (or tag NULL)))) (define (insert-channel-news-entries conn channel-news-entries) - (define select-channel-news-entries - " -SELECT channel_news_entries.id, - channel_news_entries.commit, - channel_news_entries.tag, - ( - SELECT ARRAY_AGG( - channel_news_entry_titles.channel_news_entry_text_id - ORDER BY channel_news_entry_titles.channel_news_entry_text_id - ) - FROM channel_news_entry_titles - WHERE channel_news_entry_id = channel_news_entries.id - ) AS title_text, - ( - SELECT ARRAY_AGG( - channel_news_entry_bodies.channel_news_entry_text_id - ORDER BY channel_news_entry_bodies.channel_news_entry_text_id - ) - FROM channel_news_entry_bodies - WHERE channel_news_entry_id = channel_news_entries.id - ) AS body_text -FROM channel_news_entries -ORDER BY id") - - (define existing - (exec-query->vhash conn - select-channel-news-entries - (match-lambda - ((_ commit tag title-ids body-ids) - (list commit - tag - (map string->number - (parse-postgresql-array-string title-ids)) - (map string->number - (parse-postgresql-array-string body-ids))))) - (lambda (result) - (string->number (first result))))) - (map (lambda (entry) (let ((commit (channel-news-entry-commit entry)) @@ -145,36 +104,29 @@ ORDER BY id") conn (channel-news-entry-body entry)) <))) - (or (and=> (vhash-assoc (list (or commit '()) - (or tag '()) - title-ids - body-ids) - existing) - (match-lambda - ((value . key) - key))) - (let ((channel-news-entry-id - (insert-channel-news-entry conn commit tag))) - (for-each - (lambda (table ids) - (exec-query - conn - (string-append - "INSERT INTO " table - " VALUES " - (string-join - (map (lambda (id) - (simple-format #f "(~A, ~A)" - channel-news-entry-id - id)) - ids) - ", ")))) - '("channel_news_entry_titles" - "channel_news_entry_bodies") - (list title-ids - body-ids)) + (let ((channel-news-entry-id + (insert-channel-news-entry conn commit tag))) + (for-each + (lambda (table ids) + (exec-query + conn + (string-append + "INSERT INTO " table + " VALUES " + (string-join + (map (lambda (id) + (simple-format #f "(~A, ~A)" + channel-news-entry-id + id)) + (vector->list ids)) + ", ") + " ON CONFLICT DO NOTHING"))) + '("channel_news_entry_titles" + "channel_news_entry_bodies") + (list title-ids + body-ids)) - channel-news-entry-id)))) + channel-news-entry-id))) channel-news-entries)) (define (insert-channel-news-entries-for-guix-revision @@ -194,5 +146,6 @@ ORDER BY id") (simple-format #f "(~A,~A,~A)" guix-revision-id id index)) channel-news-entry-ids (iota (length channel-news-entries))) - ", "))))) + ", ") + " ON CONFLICT DO NOTHING")))) #t) diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index 170be49..a19bfca 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -21,15 +21,13 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 exceptions) #:use-module (ice-9 binary-ports) #:use-module (rnrs bytevectors) - #:use-module (gcrypt hash) #:use-module (squee) #:use-module (json) #:use-module (guix base16) #:use-module (guix base32) - #:use-module (guix serialization) - #:use-module (lzlib) #:use-module (guix inferior) #:use-module (guix memoization) #:use-module (guix derivations) @@ -58,6 +56,13 @@ select-fixed-output-package-derivations-in-revision select-derivation-outputs-in-revision fix-derivation-output-details-hash-encoding + fix-derivation-inputs + insert-derivation-sources + insert-derivation-source-file-nar + insert-placeholder-derivation-source-file-nar + update-derivation-source-file-nar + insert-derivation-outputs + insert-derivation-inputs derivation-output-details->derivation-output-details-ids derivation-output-details-ids->derivation-output-details-set-id select-derivations-by-revision-name-and-version @@ -66,11 +71,15 @@ select-existing-derivations select-derivations-by-id select-derivations-and-build-status - derivation-file-names->derivation-ids update-derivation-inputs-statistics vacuum-derivation-inputs-table update-derivation-outputs-statistics - vacuum-derivation-outputs-table)) + vacuum-derivation-outputs-table + + &missing-derivation-output-error + missing-derivation-output-error? + missing-derivation-output-error-name + missing-derivation-output-error-path)) (define (valid-targets conn) '("arm-linux-gnueabihf" @@ -198,7 +207,7 @@ ORDER BY systems.system DESC, (define* (select-package-derivations-in-revision conn commit-hash #:key - systems + system targets minimum-builds maximum-builds @@ -214,19 +223,25 @@ ORDER BY systems.system DESC, (string-join `(,@(filter-map (lambda (field values) - (if values - (string-append - field " IN (" - (string-join (map (lambda (value) - (simple-format #f "'~A'" value)) - values) - ",") - ")") - #f)) - '("systems.system" - "target") - (list systems - targets)) + (cond + ((list? values) + (string-append + field " IN (" + (string-join (map (lambda (value) + (simple-format #f "'~A'" value)) + values) + ",") + ")")) + ((number? values) + (string-append + field " = " (number->string values))) + (else + #f))) + '("package_derivations.system_id" "target") + (list + (and=> system (lambda (system) + (system->system-id conn system))) + targets)) ,@(if minimum-builds (list (string-append @@ -346,7 +361,6 @@ EXISTS ( (string-append " SELECT derivations.file_name, - systems.system, package_derivations.target" (if include-builds? ", @@ -371,8 +385,6 @@ SELECT derivations.file_name, "") " FROM derivations -INNER JOIN systems - ON derivations.system_id = systems.id INNER JOIN derivations_by_output_details_set ON derivations.id = derivations_by_output_details_set.derivation_id INNER JOIN package_derivations @@ -400,7 +412,7 @@ ORDER BY derivations.file_name ""))) (map (match-lambda - ((file_name system target builds) + ((file_name target builds) (list file_name system target @@ -408,7 +420,7 @@ ORDER BY derivations.file_name (eq? #f builds)) #() (json-string->scm builds)))) - ((file_name system target) + ((file_name target) (list file_name system target))) (exec-query conn query @@ -711,7 +723,7 @@ LIMIT $1")) (map (match-lambda ((derivation_file_name latest_build) `((derivation_file_name . ,derivation_file_name) - (latest_build . ,(if (null? latest_build) + (latest_build . ,(if (NULL? latest_build) 'null (map (match-lambda ((key . value) @@ -897,7 +909,7 @@ ORDER BY derivation_output_details.path hash hash_algorithm (string=? recursive "t") - (if (null? nars_json) + (if (NULL? nars_json) #() (json-string->scm nars_json)))) ((package_name package_version @@ -969,6 +981,28 @@ LOCK TABLE ONLY derivation_output_details ;; Recurse in case there are more to fix (loop (find-old-derivations-and-hashes conn)))))))) +(define (fix-derivation-inputs conn drv) + (define (derivation-missing-inputs? conn drv-id) + (let ((inputs (select-derivation-inputs-by-derivation-id + conn + drv-id))) + ;; TODO Detect missing inputs, as well as them all missing + (null? inputs))) + + (with-postgresql-transaction + conn + (lambda (conn) + (match (select-derivation-by-file-name conn (derivation-file-name drv)) + ((drv-id rest ...) + (if (derivation-missing-inputs? conn drv-id) + (begin + (insert-derivation-inputs + conn + (vector drv-id) + (vector drv)) + #t) + #f)))))) + (define (derivation-output-details->derivation-output-details-ids conn derivation-output-details) @@ -977,76 +1011,30 @@ LOCK TABLE ONLY derivation_output_details conn "derivation_output_details" '(path hash_algorithm hash recursive) - (map (lambda (details) - (list (assq-ref details 'path) - (or (non-empty-string-or-false - (assq-ref details 'hash_algorithm)) - NULL) - (or (non-empty-string-or-false - (assq-ref details 'hash)) - NULL) - (assq-ref details 'recursive))) - derivation-output-details))) + (list->vector + (map (lambda (details) + (list (assq-ref details 'path) + (or (non-empty-string-or-false + (assq-ref details 'hash_algorithm)) + NULL) + (or (non-empty-string-or-false + (assq-ref details 'hash)) + NULL) + (assq-ref details 'recursive))) + derivation-output-details)))) (define (derivation-output-details-ids->derivation-output-details-set-id conn derivation-output-details-ids) - (define sorted-derivation-output-details-ids - (sort derivation-output-details-ids <)) - - (define (select-derivation-output-details-sets-id) - (match (exec-query - conn - (string-append - " -SELECT id -FROM derivation_output_details_sets -WHERE derivation_output_details_ids = ARRAY[" - (string-join (map number->string - sorted-derivation-output-details-ids) - ",") - "]")) - (((id)) - (string->number id)) - (_ #f))) - - (define (insert-into-derivation-output-details-sets) - (match (exec-query - conn - (string-append - " -INSERT INTO derivation_output_details_sets (derivation_output_details_ids) -VALUES (ARRAY[" - (string-join (map number->string - sorted-derivation-output-details-ids) - ",") - "]) -RETURNING id")) - (((id)) - (string->number id)))) - - (or (select-derivation-output-details-sets-id) - (insert-into-derivation-output-details-sets))) + (insert-and-return-id + conn + "derivation_output_details_sets" + '(derivation_output_details_ids) + (list (sort derivation-output-details-ids <)))) (define (insert-derivation-outputs conn derivation-id names-and-derivation-outputs) - (define (insert-into-derivation-outputs output-names - derivation-output-details-ids) - (string-append "INSERT INTO derivation_outputs " - "(derivation_id, name, derivation_output_details_id) VALUES " - (string-join - (map (lambda (output-name derivation-output-details-id) - (simple-format - #f "(~A, '~A', ~A)" - derivation-id - output-name - derivation-output-details-id)) - output-names - derivation-output-details-ids) - ",") - ";")) - (define (insert-into-derivations-by-output-details-set derivation_output_details_set_id) (exec-query @@ -1054,42 +1042,53 @@ RETURNING id")) " INSERT INTO derivations_by_output_details_set (derivation_id, derivation_output_details_set_id) -VALUES ($1, $2)" +VALUES ($1, $2) +ON CONFLICT DO NOTHING" (list (number->string derivation-id) (number->string derivation_output_details_set_id)))) - (let* ((derivation-outputs (map cdr names-and-derivation-outputs)) - (derivation-output-paths (map derivation-output-path - derivation-outputs)) - (derivation-output-names - (map car names-and-derivation-outputs)) - - (derivation-output-details-ids - (derivation-output-details->derivation-output-details-ids - conn - (map - (match-lambda - (($ <derivation-output> path hash-algo hash recursive?) - `((path . ,path) - (hash_algorithm . ,(or (and=> hash-algo symbol->string) - NULL)) - (hash . ,(or (and=> hash bytevector->base16-string) - NULL)) - (recursive . ,recursive?)))) - derivation-outputs)))) - - (exec-query conn - (insert-into-derivation-outputs - derivation-output-names - derivation-output-details-ids)) - - (insert-into-derivations-by-output-details-set - (derivation-output-details-ids->derivation-output-details-set-id - conn - derivation-output-details-ids)) - +(let* ((derivation-outputs + (map cdr names-and-derivation-outputs)) + (derivation-output-paths + (map derivation-output-path + derivation-outputs)) + (derivation-output-details-ids + (derivation-output-details->derivation-output-details-ids + conn + (map + (match-lambda + (($ <derivation-output> path hash-algo hash recursive?) + `((path . ,path) + (hash_algorithm . ,(or (and=> hash-algo symbol->string) + NULL)) + (hash . ,(or (and=> hash bytevector->base16-string) + NULL)) + (recursive . ,recursive?)))) + derivation-outputs)))) + + (insert-missing-data + conn + "derivation_outputs" + '(derivation_id name derivation_output_details_id) + (let ((vec + (list->vector + (map car names-and-derivation-outputs)))) + (vector-map! + (lambda (_ output-name derivation-output-details-id) + (list derivation-id + output-name + derivation-output-details-id)) + vec + derivation-output-details-ids) + vec)) + + (insert-into-derivations-by-output-details-set + (derivation-output-details-ids->derivation-output-details-set-id + conn derivation-output-details-ids)) + derivation-output-details-ids)) + (define (select-derivation-by-file-name-hash conn file-name-hash) (define query (string-append @@ -1136,6 +1135,12 @@ VALUES ($1, $2)" (vector->list (json-string->scm env_vars))) system)))) +(define-exception-type &missing-derivation-output-error &error + make-derivation-output-error + missing-derivation-output-error? + (name missing-derivation-output-error-name) + (path missing-derivation-output-error-path)) + (define (select-derivation-outputs-by-derivation-id conn id) (define query (string-append @@ -1409,26 +1414,24 @@ WHERE derivation_source_files.store_path = $1" (define (insert-derivation-inputs conn derivation-ids derivations) (let ((query-parts - (append-map! - (lambda (derivation-id derivation) - (append-map! - (match-lambda - (($ <derivation-input> derivation-or-path sub-derivations) - (let ((path - (match derivation-or-path - ((? derivation? d) - ;; The first field changed to a derivation (from the file - ;; name) in 5cf4b26d52bcea382d98fb4becce89be9ee37b55 - (derivation-file-name d)) - ((? string? s) - s)))) - (map (lambda (sub-derivation) - (string-append "(" - (number->string derivation-id) - ", '" path - "', '" sub-derivation "')")) - sub-derivations)))) + (vector-fold + (lambda (_ result derivation-id derivation) + (fold + (lambda (drv-input result) + (match drv-input + (($ <derivation-input> (? derivation? d) sub-derivations) + (fold (lambda (sub-derivation result) + (cons + (string-append + "(" (number->string derivation-id) + ", '" (derivation-file-name d) + "', '" sub-derivation "')") + result)) + result + sub-derivations)))) + result (derivation-inputs derivation))) + '() derivation-ids derivations))) @@ -1443,22 +1446,15 @@ SELECT vals.derivation_id, derivation_outputs.id FROM (VALUES " (string-join query-parts-chunk ", ") ") AS vals (derivation_id, file_name, output_name) -INNER JOIN derivations +LEFT JOIN derivations ON derivations.file_name = vals.file_name -INNER JOIN derivation_outputs +LEFT JOIN derivation_outputs ON derivation_outputs.derivation_id = derivations.id - AND vals.output_name = derivation_outputs.name"))) + AND derivation_outputs.name = vals.output_name +ON CONFLICT DO NOTHING"))) 1000 query-parts))) -(define (select-from-derivation-source-files store-paths) - (string-append - "SELECT id, store_path FROM derivation_source_files " - "WHERE store_path IN (" - (string-join (map quote-string store-paths) - ",") - ");")) - (define (insert-derivation-sources conn derivation-id sources) (define (insert-into-derivation-sources derivation-source-file-ids) (string-append @@ -1468,54 +1464,28 @@ INNER JOIN derivation_outputs (map (lambda (derivation-source-file-id) (simple-format #f "(~A, ~A)" derivation-id derivation-source-file-id)) - derivation-source-file-ids) + (vector->list derivation-source-file-ids)) ",") - ";")) + "ON CONFLICT DO NOTHING;")) (let ((sources-ids (insert-missing-data-and-return-all-ids conn "derivation_source_files" '(store_path) - (map list sources)))) + (list->vector + (map list sources))))) (exec-query conn (insert-into-derivation-sources sources-ids)) sources-ids)) -(define (insert-derivation-source-file-nar conn id source-file) - (define missing? - (match (exec-query - conn - "SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" - (list (number->string id))) - (() #t) - (_ #f))) - - (when missing? - (let* ((nar-bytevector (call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (write-file source-file port) - (get-bytevector)))) - (data-string (bytevector->base16-string - (call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (call-with-lzip-output-port port - (lambda (port) - (put-bytevector port nar-bytevector)) - #:level 9) - (get-bytevector))))) - (hash (bytevector->nix-base32-string - (sha256 nar-bytevector))) - (uncompressed-size (bytevector-length nar-bytevector))) - (exec-query - conn - " +(define (insert-derivation-source-file-nar conn id + hash bytevector uncompressed-size) + (exec-query + conn + " INSERT INTO derivation_source_file_nars ( derivation_source_file_id, compression, @@ -1523,13 +1493,47 @@ INSERT INTO derivation_source_file_nars ( hash, uncompressed_size, data -) VALUES ($1, $2, $3, $4, $5, $6)" - (list (number->string id) - "lzip" - "sha256" - hash - (number->string uncompressed-size) - (string-append "\\x" data-string)))))) +) VALUES ($1, $2, $3, $4, $5, $6) +ON CONFLICT DO NOTHING" + (list (number->string id) + "lzip" + "sha256" + hash + (number->string uncompressed-size) + (string-append "\\x" (bytevector->base16-string bytevector))))) + +(define (insert-placeholder-derivation-source-file-nar conn id) + (exec-query + conn + " +INSERT INTO derivation_source_file_nars ( + derivation_source_file_id, + compression, + hash_algorithm, + hash, + uncompressed_size, + data +) VALUES ($1, $2, $3, $4, $5, $6) +ON CONFLICT DO NOTHING" + (list (number->string id) + "lzip" + "sha256" + "placeholder" + "0" + ""))) + +(define (update-derivation-source-file-nar conn id + hash bytevector uncompressed-size) + (exec-query + conn + " +UPDATE derivation_source_file_nars +SET hash = $1, uncompressed_size = $2, data = $3 +WHERE derivation_source_file_id = $4" + (list hash + (number->string uncompressed-size) + (string-append "\\x" (bytevector->base16-string bytevector)) + (number->string id)))) (define* (backfill-derivation-source-file-nars conn #:key (batch-size 10000) @@ -1561,130 +1565,6 @@ LIMIT $1" batch) (when loop? (loop (missing-batch)))))) -(define (insert-missing-derivations conn - derivation-ids-hash-table - derivations) - (define (ensure-input-derivations-exist input-derivation-file-names) - (unless (null? input-derivation-file-names) - (simple-format - #t "debug: ensure-input-derivations-exist: processing ~A derivations\n" - (length input-derivation-file-names)) - - (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - (list->vector - input-derivation-file-names)) - (simple-format - #t - "debug: ensure-input-derivations-exist: checking for missing input derivations\n") - (let ((missing-derivations-filenames - (filter (lambda (derivation-file-name) - (not (hash-ref derivation-ids-hash-table - derivation-file-name))) - input-derivation-file-names))) - - (unless (null? missing-derivations-filenames) - (simple-format - #f - "debug: ensure-input-derivations-exist: inserting missing input derivations\n") - ;; Ensure all the input derivations exist - (insert-missing-derivations - conn - derivation-ids-hash-table - (map read-derivation-from-file - missing-derivations-filenames)))))) - - (define (insert-into-derivations dervs) - (string-append - "INSERT INTO derivations " - "(file_name, builder, args, env_vars, system_id) VALUES " - (string-join - (map (match-lambda - (($ <derivation> outputs inputs sources - system builder args env-vars file-name) - (simple-format - #f "('~A', '~A', ARRAY[~A]::varchar[], ARRAY[~A], '~A')" - file-name - builder - (string-join (map quote-string args) ",") - (string-join (map (match-lambda - ((key . value) - (string-append - "['" key '"', $$" - value "$$ ]"))) - env-vars) - ",") - (system->system-id conn system)))) - dervs) - ",") - " RETURNING id" - ";")) - - (simple-format - #t "debug: insert-missing-derivations: inserting ~A derivations\n" - (length derivations)) - (let ((derivation-ids - (append-map - (lambda (chunk) - (map (lambda (result) - (string->number (car result))) - (exec-query conn (insert-into-derivations chunk)))) - (chunk derivations 500)))) - - (simple-format - #t "debug: insert-missing-derivations: updating hash table\n") - (for-each (lambda (derivation derivation-id) - (hash-set! derivation-ids-hash-table - (derivation-file-name derivation) - derivation-id)) - derivations - derivation-ids) - - (simple-format - #t "debug: insert-missing-derivations: inserting outputs\n") - (for-each (lambda (derivation-id derivation) - (insert-derivation-outputs conn - derivation-id - (derivation-outputs derivation))) - derivation-ids - derivations) - - (simple-format - #t "debug: insert-missing-derivations: inserting sources\n") - (for-each (lambda (derivation-id derivation) - (let ((sources (derivation-sources derivation))) - (unless (null? sources) - (let ((sources-ids - (insert-derivation-sources conn - derivation-id - sources))) - (map (lambda (id source-file) - (insert-derivation-source-file-nar conn - id - source-file)) - sources-ids - sources))))) - derivation-ids - derivations) - - (simple-format - #t "debug: insert-missing-derivations: ensure-input-derivations-exist\n") - - (ensure-input-derivations-exist (deduplicate-strings - (map derivation-input-path - (append-map derivation-inputs - derivations)))) - - (with-time-logging - (simple-format - #f "insert-missing-derivations: inserting inputs for ~A derivations" - (length derivations)) - (insert-derivation-inputs conn - derivation-ids - derivations)) - - derivation-ids)) - (define (select-derivations-by-id conn ids) (define query (string-append "SELECT id, file_name " @@ -1769,80 +1649,42 @@ WHERE " criteria ";")) '() sorted-derivations)) -(define (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - 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 - (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" - file-names-count (length missing-file-names)) - - (unless (null? missing-file-names) - (for-each - (lambda (chunk) - (for-each - (match-lambda - ((id file-name) - (hash-set! derivation-ids-hash-table - file-name - (string->number id)))) - (exec-query conn (select-existing-derivations chunk)))) - (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! - (append-map! - (lambda (ids-chunk) - (let ((query - (string-append - " +(define (insert-source-files-missing-nars conn derivation-ids) + (define (derivation-ids->next-related-derivation-ids! ids seen-ids) + (delete-duplicates/sort! + (append-map! + (lambda (ids-chunk) + (let ((query + (string-append + " SELECT derivation_outputs.derivation_id FROM derivation_inputs INNER JOIN derivation_outputs ON derivation_outputs.id = derivation_inputs.derivation_output_id WHERE derivation_inputs.derivation_id IN (" - (string-join (map number->string ids) ",") - ")"))) - - (filter-map - (lambda (row) - (let ((number - (string->number - (car row)))) - (if (hash-ref seen-ids number) - #f - (begin - (hash-set! seen-ids number #t) - - number)))) - (exec-query conn query)))) - (chunk! ids 500)) - < - =)) - - (define (derivation-ids->missing-sources ids) - (define query - (string-append - " + (string-join (map number->string ids) ",") + ")"))) + + (filter-map + (lambda (row) + (let ((number + (string->number + (car row)))) + (if (hash-ref seen-ids number) + #f + (begin + (hash-set! seen-ids number #t) + + number)))) + (exec-query conn query)))) + (chunk! ids 500)) + < + =)) + + (define (derivation-ids->missing-sources ids) + (define query + (string-append + " SELECT derivation_sources.derivation_source_file_id, derivation_source_files.store_path FROM derivation_sources LEFT JOIN derivation_source_file_nars @@ -1852,114 +1694,42 @@ INNER JOIN derivation_source_files ON derivation_sources.derivation_source_file_id = derivation_source_files.id WHERE derivation_sources.derivation_id IN (" - (string-join (map number->string ids) ", ") - ") + (string-join (map number->string ids) ", ") + ") AND derivation_source_file_nars.derivation_source_file_id IS NULL")) - (map (lambda (row) - (list (string->number (first row)) - (second row))) - (exec-query conn query))) - - (let ((seen-ids (make-hash-table))) - (let loop ((next-related-derivation-ids - (derivation-ids->next-related-derivation-ids! - (list-copy derivation-ids) - seen-ids))) - (unless (null? next-related-derivation-ids) - (let ((missing-sources - (append-map! derivation-ids->missing-sources - (chunk next-related-derivation-ids - 10000)))) - - (unless (null? missing-sources) - (with-time-logging - (simple-format #f "inserting ~A missing source files" - (length missing-sources)) - (for-each (match-lambda - ((derivation-source-file-id store-path) - (insert-derivation-source-file-nar - conn - derivation-source-file-id - store-path))) - missing-sources)))) - - (loop - (derivation-ids->next-related-derivation-ids! - next-related-derivation-ids - seen-ids)))))) - - (if (= 0 derivations-count) - #() - (let* ((derivation-ids-hash-table (make-hash-table - ;; Account for more derivations in - ;; the graph - (* 2 derivations-count)))) - (simple-format - #t "debug: derivation-file-names->derivation-ids: processing ~A derivations\n" - derivations-count) - - (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - derivation-file-names) - - (let ((missing-derivation-filenames - (deduplicate-strings - (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) - (let ((missing-derivations-chunk - (with-time-logging - (simple-format #f "reading ~A missing derivations" - (length missing-derivation-filenames-chunk)) - (map read-derivation-from-file - ;; Do the filter again, since processing the last - ;; chunk might have inserted some of the - ;; derivations in this chunk - (filter (lambda (derivation-file-name) - (not (hash-ref derivation-ids-hash-table - derivation-file-name))) - missing-derivation-filenames-chunk))))) - - (unless (null? missing-derivations-chunk) - (insert-missing-derivations conn - derivation-ids-hash-table - missing-derivations-chunk)))) - 1000 - missing-derivation-filenames) - - (let ((all-ids - (vector-map - (lambda (_ derivation-file-name) - (if derivation-file-name - (or (hash-ref derivation-ids-hash-table - derivation-file-name) - (error "missing derivation id")) - #f)) - derivation-file-names))) - - (with-time-logging "insert-source-files-missing-nars" - (insert-source-files-missing-nars - ;; TODO Avoid this conversion - (vector-fold - (lambda (_ result x) - (if x - (cons x result) - result)) - '() - all-ids))) - - all-ids))))) + (map (lambda (row) + (list (string->number (first row)) + (second row))) + (exec-query conn query))) + + (let ((seen-ids (make-hash-table))) + (let loop ((next-related-derivation-ids + (derivation-ids->next-related-derivation-ids! + (list-copy derivation-ids) + seen-ids))) + (unless (null? next-related-derivation-ids) + (let ((missing-sources + (append-map! derivation-ids->missing-sources + (chunk next-related-derivation-ids + 10000)))) + + (unless (null? missing-sources) + (with-time-logging + (simple-format #f "inserting ~A missing source files" + (length missing-sources)) + (for-each (match-lambda + ((derivation-source-file-id store-path) + (insert-derivation-source-file-nar + conn + derivation-source-file-id + store-path))) + missing-sources)))) + + (loop + (derivation-ids->next-related-derivation-ids! + next-related-derivation-ids + seen-ids)))))) (define (update-derivation-inputs-statistics conn) (let ((query diff --git a/guix-data-service/model/git-branch.scm b/guix-data-service/model/git-branch.scm index a800e8f..c4b56c0 100644 --- a/guix-data-service/model/git-branch.scm +++ b/guix-data-service/model/git-branch.scm @@ -47,16 +47,12 @@ WHERE git_repository_id = $1 (define (insert-git-branch-entry conn git-repository-id name) - (match (exec-query - conn - " -INSERT INTO git_branches (git_repository_id, name) -VALUES ($1, $2) -RETURNING id" - (list (number->string git-repository-id) - name)) - (((id)) - (string->number id)))) + (insert-and-return-id + conn + "git_branches" + '(git_repository_id name) + (list git-repository-id + name))) (define (git-branches-for-commit conn commit) (define query diff --git a/guix-data-service/model/git-commit.scm b/guix-data-service/model/git-commit.scm index 0e8f773..e8b00ff 100644 --- a/guix-data-service/model/git-commit.scm +++ b/guix-data-service/model/git-commit.scm @@ -43,5 +43,5 @@ ON CONFLICT DO NOTHING" conn "SELECT 1 FROM git_commits WHERE commit = $1" (list commit)) - (#f #f) + (() #f) (_ #t))) diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm index 5c605f8..b5f9fbe 100644 --- a/guix-data-service/model/git-repository.scm +++ b/guix-data-service/model/git-repository.scm @@ -20,9 +20,11 @@ #:use-module (ice-9 match) #:use-module (json) #:use-module (squee) + #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) #:export (all-git-repositories select-git-repository + specify-git-repositories git-repository-query-substitutes? git-repository-id->url select-includes-and-excluded-branches-for-git-repository @@ -68,6 +70,46 @@ WHERE id = $1" (string=? fetch_with_authentication "t") (and=> poll-interval string->number))))) +(define (specify-git-repositories repositories) + (with-postgresql-connection + "specify-git-repositories" + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (let* ((existing-ids + (map first (all-git-repositories conn))) + (target-ids + (map (lambda (repo) + (or (assq-ref repo 'id) + (error "repository missing id"))) + repositories)) + (repositories-to-delete + (lset-difference equal? + existing-ids + target-ids))) + (for-each + (lambda (id-to-remove) + (simple-format (current-error-port) + "deleting repository ~A\n" + id-to-remove) + (exec-query + conn + "DELETE FROM git_repositories WHERE id = $1" + (list (number->string id-to-remove)))) + repositories-to-delete) + + (for-each + (lambda (repo) + (let ((fields (map car repo)) + (field-vals (map cdr repo))) + (update-or-insert + conn + "git_repositories" + fields + field-vals))) + repositories))))))) + (define (git-repository-query-substitutes? conn id) (match (exec-query conn @@ -97,7 +139,7 @@ WHERE id = $1" item)) lst)) - (match (exec-query + (match (exec-query-with-null-handling conn " SELECT included_branches, excluded_branches @@ -105,13 +147,11 @@ FROM git_repositories WHERE id = $1" (list (number->string id))) (((included_branches excluded_branches)) (values - (if (or (eq? #f included_branches) - (string-null? included_branches)) - '() + (if (NULL? included_branches) + included_branches (make-regexes (parse-postgresql-array-string included_branches))) - (if (or (eq? excluded_branches #f) - (string-null? excluded_branches)) + (if (NULL? excluded_branches) '() (make-regexes (parse-postgresql-array-string excluded_branches))))))) diff --git a/guix-data-service/model/guix-revision-package-derivation.scm b/guix-data-service/model/guix-revision-package-derivation.scm index 63c23e5..6a1f7c4 100644 --- a/guix-data-service/model/guix-revision-package-derivation.scm +++ b/guix-data-service/model/guix-revision-package-derivation.scm @@ -20,6 +20,8 @@ #:use-module (ice-9 threads) #:use-module (squee) #:use-module (guix-data-service database) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service model system) #:export (insert-guix-revision-package-derivations insert-guix-revision-package-derivation-distribution-counts @@ -46,17 +48,9 @@ (define (insert-guix-revision-package-derivation-distribution-counts conn - guix-revision-id) - (define system-ids-and-targets - (exec-query - conn - " -SELECT DISTINCT system_id, target -FROM package_derivations -INNER JOIN guix_revision_package_derivations - ON package_derivations.id = guix_revision_package_derivations.package_derivation_id -WHERE revision_id = $1" - (list guix-revision-id))) + guix-revision-id + system-id + target) (define (get-count-for-next-level system-id target level-counts) (define next-level @@ -154,17 +148,12 @@ VALUES ($1, $2, $3, $4, $5)" (number->string level) (number->string count)))) - (for-each - (match-lambda - ((system-id target) - - (let loop ((level-counts '())) - (let ((level (length level-counts)) - (count (get-count-for-next-level system-id target level-counts))) - (unless (= count 0) - (insert-level-count system-id target level count) - (loop (append level-counts (list count)))))))) - system-ids-and-targets)) + (let loop ((level-counts '())) + (let ((level (length level-counts)) + (count (get-count-for-next-level system-id target level-counts))) + (unless (= count 0) + (insert-level-count system-id target level count) + (loop (append level-counts (list count))))))) (define (backfill-guix-revision-package-derivation-distribution-counts conn) (define revision-ids @@ -182,13 +171,40 @@ ORDER BY id DESC"))) (for-each (lambda (revision-id) - (simple-format #t "backfilling guix_revision_package_derivation_distribution_counts for revision ~A\n" revision-id) - (with-postgresql-transaction - conn - (lambda (conn) - (insert-guix-revision-package-derivation-distribution-counts - conn - revision-id)))) + (with-exception-handler + (lambda (exn) + (simple-format + #t "exception backfilling guix_revision_package_derivation_distribution_counts for revision ~A: ~A\n" + revision-id exn)) + (lambda () + (with-time-logging + (simple-format + #f "backfilling guix_revision_package_derivation_distribution_counts for revision ~A" + revision-id) + (let ((system-ids-and-targets + (exec-query + conn + " +SELECT DISTINCT system_id, target +FROM package_derivations +INNER JOIN guix_revision_package_derivations + ON package_derivations.id = guix_revision_package_derivations.package_derivation_id +WHERE revision_id = $1" + (list revision-id)))) + + (with-postgresql-transaction + conn + (lambda (conn) + (for-each + (match-lambda + ((system-id target) + (insert-guix-revision-package-derivation-distribution-counts + conn + revision-id + system-id + target))) + system-ids-and-targets)))))) + #:unwind? #t)) revision-ids)) (define* (get-sql-to-select-package-and-related-derivations-for-revision diff --git a/guix-data-service/model/guix-revision.scm b/guix-data-service/model/guix-revision.scm index 8bb20da..21e20a5 100644 --- a/guix-data-service/model/guix-revision.scm +++ b/guix-data-service/model/guix-revision.scm @@ -56,8 +56,7 @@ FROM guix_revisions WHERE commit = $1 AND git_repository_id = $2" (list commit git-repository-id)) - (((id)) - id) + (((id)) (string->number id)) (() #f))) (define (insert-guix-revision conn git-repository-id commit) @@ -67,7 +66,7 @@ INSERT INTO guix_revisions (git_repository_id, commit) VALUES ($1, $2) RETURNING id") (match (exec-query conn insert (list git-repository-id commit)) - (((id)) id))) + (((id)) (string->number id)))) (define (guix-commit-exists? conn commit) (define query diff --git a/guix-data-service/model/license-set.scm b/guix-data-service/model/license-set.scm index cff68b7..fe4272b 100644 --- a/guix-data-service/model/license-set.scm +++ b/guix-data-service/model/license-set.scm @@ -17,6 +17,7 @@ (define-module (guix-data-service model license-set) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (squee) #:use-module (guix-data-service utils) @@ -24,78 +25,12 @@ #:use-module (guix-data-service model license) #:export (inferior-packages->license-set-ids)) -(define select-license-sets - " -SELECT id, license_ids -FROM license_sets") - -(define (insert-license-sets license-id-lists) - (string-append - "INSERT INTO license_sets (license_ids) VALUES " - (string-join - (map (lambda (license-ids) - (string-append - "('{" - (string-join - (map number->string - (sort license-ids <)) - ", ") - "}')")) - license-id-lists) - ", ") - " RETURNING id")) - (define (inferior-packages->license-set-ids conn license-id-lists) - (let* ((existing-license-sets - (exec-query->vhash conn - select-license-sets - (lambda (results) - (if (string=? (second results) "{}") - '() - (map - string->number - (string-split - (string-drop-right - (string-drop (second results) 1) - 1) - #\,)))) - (lambda (result) - (string->number (first result))))) ;; id - (missing-license-sets - (delete-duplicates/sort! - ;; Use filter! with list-copy, as filter may return a list that - ;; shares a portion of the input list, and therefore could be at - ;; risk of being modified when deleting duplicates - (filter! (lambda (license-set-license-ids) - (not (vhash-assoc license-set-license-ids - existing-license-sets))) - (list-copy license-id-lists)) - (lambda (full-a full-b) - (let loop ((a full-a) - (b full-b)) - (cond - ((null? a) #f) - ((null? b) #t) - (else - (< (car a) (car b)))))))) - (new-license-set-entries - (if (null? missing-license-sets) - '() - (map (lambda (result) - (string->number (first result))) - (exec-query conn - (insert-license-sets missing-license-sets))))) - (new-entries-id-lookup-vhash - (two-lists->vhash missing-license-sets - new-license-set-entries))) - - (map (lambda (license-id-list) - (cdr - (or (vhash-assoc license-id-list - existing-license-sets) - (vhash-assoc license-id-list - new-entries-id-lookup-vhash) - (begin - (error "missing license set entry" - license-id-list))))) - license-id-lists))) + (insert-missing-data-and-return-all-ids + conn + "license_sets" + '(license_ids) + (vector-map + (lambda (_ license-ids) + (list (sort license-ids <))) + license-id-lists))) diff --git a/guix-data-service/model/license.scm b/guix-data-service/model/license.scm index ebca0eb..f16634d 100644 --- a/guix-data-service/model/license.scm +++ b/guix-data-service/model/license.scm @@ -17,10 +17,12 @@ (define-module (guix-data-service model license) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix inferior) + #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) #:export (inferior-packages->license-id-lists inferior-packages->license-data)) @@ -49,7 +51,7 @@ (current-error-port) "error: unknown license value ~A for package ~A" x package) - '())) + #f)) values)) (x (simple-format @@ -69,17 +71,21 @@ ;; save non string values as NULL NULL)) - (insert-missing-data-and-return-all-ids - conn - "licenses" - `(name uri comment) - (map (lambda (license-tuples) - (map - (match-lambda - ((name uri comment) - (list name - (string-or-null uri) - (string-or-null comment)))) - license-tuples)) - license-data) - #:sets-of-data? #t)) + (vector-map + (lambda (_ license-tuples) + (if (null? license-tuples) + #() + (insert-missing-data-and-return-all-ids + conn + "licenses" + `(name uri comment) + (list->vector + (filter-map + (match-lambda + ((name uri comment) + (list name + (string-or-null uri) + (string-or-null comment))) + (#f #f)) + license-tuples))))) + license-data)) diff --git a/guix-data-service/model/lint-checker.scm b/guix-data-service/model/lint-checker.scm index be3cfc6..4ee6521 100644 --- a/guix-data-service/model/lint-checker.scm +++ b/guix-data-service/model/lint-checker.scm @@ -17,6 +17,7 @@ (define-module (guix-data-service model lint-checker) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix-data-service model utils) @@ -24,8 +25,7 @@ lint-warning-count-by-lint-checker-for-revision insert-guix-revision-lint-checkers lint-checkers-for-revision - lint-checker-description-data->lint-checker-description-set-id - insert-lint-checker-description-set)) + lint-checker-description-data->lint-checker-description-set-id)) (define (lint-checkers->lint-checker-ids conn lint-checkers-data) (insert-missing-data-and-return-all-ids @@ -40,48 +40,23 @@ conn "lint_checker_descriptions" '(locale description) - (map (match-lambda - ((locale . description) - (list locale description))) - descriptions-by-locale))) - -(define (insert-lint-checker-description-set conn lint-description-ids) - (let ((query - (string-append - "INSERT INTO lint_checker_description_sets (description_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort lint-description-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) + (list->vector + (map (match-lambda + ((locale . description) + (list locale description))) + descriptions-by-locale)))) (define (lint-checker-description-data->lint-checker-description-set-id conn descriptions-by-locale) - (let* ((lint-checker-description-ids - (lint-checker-description-data->lint-checker-description-ids - conn - descriptions-by-locale)) - (lint-checker-description-set-id - (exec-query - conn - (string-append - "SELECT id FROM lint_checker_description_sets" - " WHERE description_ids = ARRAY[" - (string-join (map number->string - (sort lint-checker-description-ids <)) ", ") - "]")))) - (string->number - (match lint-checker-description-set-id - (((id)) id) - (() - (insert-lint-checker-description-set conn lint-checker-description-ids)))))) - + (insert-and-return-id + conn + "lint_checker_description_sets" + '(description_ids) + (list + (lint-checker-description-data->lint-checker-description-ids + conn + descriptions-by-locale)))) (define (lint-warning-count-by-lint-checker-for-revision conn commit-hash) (define query @@ -125,7 +100,7 @@ ORDER BY count DESC") "(~A, ~A)" lint-checker-id guix-revision-id)) - lint-checker-ids) + (vector->list lint-checker-ids)) ", ")))) (define (lint-checkers-for-revision conn commit-hash) diff --git a/guix-data-service/model/lint-warning-message.scm b/guix-data-service/model/lint-warning-message.scm index 72a8617..c44ba8a 100644 --- a/guix-data-service/model/lint-warning-message.scm +++ b/guix-data-service/model/lint-warning-message.scm @@ -16,6 +16,7 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (guix-data-service model lint-warning-message) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix-data-service database) @@ -30,49 +31,24 @@ conn "lint_warning_messages" '(locale message) - (map (match-lambda - ((locale . message) - (list locale message))) - messages-by-locale))) - -(define (insert-lint-warning-message-set conn lint-message-ids) - (let ((query - (string-append - "INSERT INTO lint_warning_message_sets (message_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort lint-message-ids <)) - ", ") - "}')") - " RETURNING id"))) - - (match (exec-query conn query) - (((id)) id)))) + (let ((v (list->vector messages-by-locale))) + (vector-map! (lambda (_ data) + (match data + ((locale . message) + (list locale message)))) + v) + v))) (define (lint-warning-message-data->lint-warning-message-set-id conn messages-by-locale) - - (let* ((lint-warning-message-ids - (lint-warning-message-data->lint-warning-message-ids - conn messages-by-locale)) - (lint-message-set-id - (exec-query - conn - (string-append - "SELECT id FROM lint_warning_message_sets " - "WHERE message_ids = ARRAY[" - (string-join (map number->string - (sort lint-warning-message-ids <)) ", ") - "]")))) - - (string->number - (match lint-message-set-id - (((id)) id) - (() - (insert-lint-warning-message-set conn lint-warning-message-ids)))))) + (insert-and-return-id + conn + "lint_warning_message_sets" + '(message_ids) + (list (lint-warning-message-data->lint-warning-message-ids + conn + messages-by-locale)))) (define (lint-warning-message-locales-for-revision conn commit-hash) (exec-query diff --git a/guix-data-service/model/lint-warning.scm b/guix-data-service/model/lint-warning.scm index eff332f..69241f3 100644 --- a/guix-data-service/model/lint-warning.scm +++ b/guix-data-service/model/lint-warning.scm @@ -40,22 +40,22 @@ (define (insert-guix-revision-lint-warnings conn guix-revision-id lint-warning-ids) - (if (null? lint-warning-ids) - '() - (exec-query - conn - (string-append - "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " - "VALUES " - (string-join - (map (lambda (lint-warning-id) - (simple-format - #f - "(~A, ~A)" - lint-warning-id - guix-revision-id)) - lint-warning-ids) - ", "))))) + (unless (= 0 (vector-length lint-warning-ids)) + (exec-query + conn + (string-append + "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " + "VALUES " + (string-join + (map (lambda (lint-warning-id) + (simple-format + #f + "(~A, ~A)" + lint-warning-id + guix-revision-id)) + (vector->list lint-warning-ids)) + ", ") + " ON CONFLICT DO NOTHING")))) (define* (lint-warnings-for-guix-revision conn commit-hash #:key diff --git a/guix-data-service/model/location.scm b/guix-data-service/model/location.scm index 6e010da..123354f 100644 --- a/guix-data-service/model/location.scm +++ b/guix-data-service/model/location.scm @@ -19,35 +19,14 @@ #:use-module (ice-9 match) #:use-module (guix utils) #:use-module (squee) + #:use-module (guix-data-service model utils) #:export (location->location-id)) -(define select-existing-location - (string-append - "SELECT id " - "FROM locations " - "WHERE file = $1 AND line = $2 AND column_number = $3")) - -(define insert-location - (string-append - "INSERT INTO locations " - "(file, line, column_number) VALUES " - "($1, $2, $3) " - "RETURNING id")) - (define (location->location-id conn location) - (match location - (($ <location> file line column) - (string->number - (match (exec-query conn - select-existing-location - (list file - (number->string line) - (number->string column))) - (((id)) id) - (() - (caar - (exec-query conn - insert-location - (list file - (number->string line) - (number->string column)))))))))) + (insert-and-return-id + conn + "locations" + '(file line column_number) + (match location + (($ <location> file line column) + (list file line column))))) diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm index 0e3b3e6..c66e6d2 100644 --- a/guix-data-service/model/nar.scm +++ b/guix-data-service/model/nar.scm @@ -57,11 +57,12 @@ narinfos)) (let ((nar-ids - (insert-missing-data-and-return-all-ids - conn - "nars" - '(store_path hash_algorithm hash size system deriver) - data))) + (vector->list + (insert-missing-data-and-return-all-ids + conn + "nars" + '(store_path hash_algorithm hash size system deriver) + (list->vector data))))) (let ((reference-data (concatenate @@ -176,49 +177,45 @@ VALUES ($1, $2)") #\;) ((version host-name signature-data) - (first - (insert-missing-data-and-return-all-ids - conn - "narinfo_signature_data" - '(version host_name data_hash data_hash_algorithm - data_json sig_val_json narinfo_signature_public_key_id - narinfo_body narinfo_signature_line) - (list - (append (list (string->number version) - host-name) - (let* ((data-sexp - (find (match-lambda - ((component data ...) - (if (eq? component 'data) - data - #f)) - (_ #f)) - signature-sexp)) - (hash-sexp - (third data-sexp)) - (hash-algorithm - (second hash-sexp)) - (hash - (third hash-sexp))) - (list - (bytevector->base16-string hash) - hash-algorithm - (cons "jsonb" - (sexp->json-string data-sexp)))) - (let ((sig-val-sexp - (find (match-lambda - ((component data ...) - (if (eq? component 'sig-val) - data - #f)) - (_ #f)) - signature-sexp))) - (list - (cons "jsonb" - (sexp->json-string sig-val-sexp)))) - (list public-key-id - body - signature-line)))))))))))) + (insert-and-return-id + conn + "narinfo_signature_data" + '(version host_name data_hash data_hash_algorithm + data_json sig_val_json narinfo_signature_public_key_id + narinfo_body narinfo_signature_line) + (append (list (string->number version) + host-name) + (let* ((data-sexp + (find (match-lambda + ((component data ...) + (if (eq? component 'data) + data + #f)) + (_ #f)) + signature-sexp)) + (hash-sexp + (third data-sexp)) + (hash-algorithm + (second hash-sexp)) + (hash + (third hash-sexp))) + (list + (bytevector->base16-string hash) + hash-algorithm + (sexp->json-string data-sexp))) + (let ((sig-val-sexp + (find (match-lambda + ((component data ...) + (if (eq? component 'sig-val) + data + #f)) + (_ #f)) + signature-sexp))) + (list + (sexp->json-string sig-val-sexp))) + (list public-key-id + body + signature-line)))))))))) (define (narinfo-signature->public-key-id conn signature) (let* ((public-key-sexp @@ -232,13 +229,11 @@ VALUES ($1, $2)") (public-key-json-string (sexp->json-string public-key-sexp))) - (first - (insert-missing-data-and-return-all-ids - conn - "narinfo_signature_public_keys" - '(sexp_json) - (list (list (cons "jsonb" - public-key-json-string))))))) + (insert-and-return-id + conn + "narinfo_signature_public_keys" + '(sexp_json) + (list public-key-json-string)))) (define (select-package-output-availability-for-revision conn revision-commit) (define query @@ -380,7 +375,7 @@ ORDER BY COUNT(*) DESC") (match status ("t" 'matching) ("f" 'not-matching) - (() 'unknown)) + ((? NULL? x) 'unknown)) (string->number count)))) (exec-query-with-null-handling conn query (list revision-commit))))) diff --git a/guix-data-service/model/package-derivation-by-guix-revision-range.scm b/guix-data-service/model/package-derivation-by-guix-revision-range.scm index 9ce527e..cc9f864 100644 --- a/guix-data-service/model/package-derivation-by-guix-revision-range.scm +++ b/guix-data-service/model/package-derivation-by-guix-revision-range.scm @@ -48,7 +48,7 @@ WHERE git_branch_id = $1 AND WHERE revision_id = $2 )" (list (number->string git-branch-id) - guix-revision-id))))) + (number->string guix-revision-id)))))) (define (insert-guix-revision-package-derivation-entries conn git-repository-id @@ -185,7 +185,7 @@ PARTITION OF package_derivations_by_guix_revision_range FOR VALUES IN (" query (list git-repository-id (number->string git-branch-id) - guix-revision-id)))) + (number->string guix-revision-id))))) (define (update-package-derivations-table conn git-repository-id diff --git a/guix-data-service/model/package-derivation.scm b/guix-data-service/model/package-derivation.scm index 2008409..fc7dca7 100644 --- a/guix-data-service/model/package-derivation.scm +++ b/guix-data-service/model/package-derivation.scm @@ -49,12 +49,13 @@ derivation-ids)) (if (null? data-4-tuples) - '() + #() (insert-missing-data-and-return-all-ids conn "package_derivations" '(package_id derivation_id system_id target) - data-4-tuples))) + (list->vector + data-4-tuples)))) (define (count-packages-derivations-in-revision conn commit-hash) (define query diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm index 6eca089..f1ffdbf 100644 --- a/guix-data-service/model/package-metadata.scm +++ b/guix-data-service/model/package-metadata.scm @@ -18,6 +18,7 @@ (define-module (guix-data-service model package-metadata) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (squee) @@ -29,6 +30,7 @@ #:use-module (guix i18n) #:use-module (guix inferior) #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service model location) #:use-module (guix-data-service model utils) #:export (select-package-metadata-by-revision-name-and-version @@ -204,27 +206,6 @@ WHERE packages.id IN ( (json-string->scm license-json))))) (exec-query conn query (list revision-commit-hash name version locale)))) -(define (insert-package-metadata metadata-rows) - (string-append "INSERT INTO package_metadata " - "(synopsis, description, home_page, location_id, license_set_id) " - "VALUES " - (string-join - (map (match-lambda - ((synopsis description home_page - location-id license-set-id) - (string-append - "(" - (value->quoted-string-or-null synopsis) "," - (value->quoted-string-or-null description) "," - (value->quoted-string-or-null home_page) "," - location-id "," - license-set-id - ")"))) - metadata-rows) - ",") - " RETURNING id" - ";")) - (define (inferior-packages->translated-package-descriptions-and-synopsis inferior inferior-package) @@ -292,73 +273,17 @@ WHERE packages.id IN ( (prevent-inlining-for-tests inferior-packages->translated-package-descriptions-and-synopsis) -(define (insert-package-synopsis-set conn package-synopsis-ids) - (let ((query - (string-append - "INSERT INTO package_synopsis_sets (synopsis_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort package-synopsis-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) - -(define (package-synopsis-data->package-synopsis-set-id - conn package-synopsis-ids) - (let ((package-synopsis-set-id - (exec-query - conn - (string-append - "SELECT id FROM package_synopsis_sets" - " WHERE synopsis_ids = ARRAY[" - (string-join (map number->string - (sort package-synopsis-ids <)) ", ") - "]")))) - (string->number - (match package-synopsis-set-id - (((id)) id) - (() - (insert-package-synopsis-set conn package-synopsis-ids)))))) - -(define (insert-package-description-set conn package-description-ids) - (let ((query - (string-append - "INSERT INTO package_description_sets (description_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort package-description-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) - -(define (package-description-data->package-description-set-id - conn package-description-ids) - (let* ((package-description-set-id - (exec-query - conn - (string-append - "SELECT id FROM package_description_sets" - " WHERE description_ids = ARRAY[" - (string-join (map number->string - (sort package-description-ids <)) ", ") - "]")))) - (string->number - (match package-description-set-id - (((id)) id) - (() - (insert-package-description-set conn package-description-ids)))))) - (define (inferior-packages->package-metadata-ids conn package-metadata license-set-ids) + (define (vector-zip . vecs) + (let ((result (make-vector (vector-length (first vecs))))) + (apply vector-map! + (lambda (i . vals) + (cdr vals)) + (cons result vecs)) + result)) + (insert-missing-data-and-return-all-ids conn "package_metadata" @@ -368,105 +293,82 @@ WHERE packages.id IN ( package_description_set_id package_synopsis_set_id) - (zip - (map (match-lambda - ((home-page rest ...) - (if (string? home-page) - home-page - NULL))) - package-metadata) + (vector-zip + (vector-map (match-lambda* + ((_ (home-page rest ...)) + (if (string? home-page) + home-page + NULL))) + package-metadata) (with-time-logging "preparing location ids" - (map (match-lambda - ((_ location rest ...) - (if location - (location->location-id - conn - location) - NULL))) - package-metadata)) + (vector-map (match-lambda* + ((_ (_ location rest ...)) + (if location + (location->location-id + conn + location) + NULL))) + package-metadata)) license-set-ids (with-time-logging "preparing package description set ids" - (map (lambda (package-description-ids) - (package-description-data->package-description-set-id - conn - package-description-ids)) - (with-time-logging "preparing package description ids" - (insert-missing-data-and-return-all-ids - conn - "package_descriptions" - '(locale description) - (map (match-lambda - ((_ _ package-description-data _) - (map (match-lambda - ((locale . description) - (list locale description))) - package-description-data))) - package-metadata) - #:delete-duplicates? #t - #:sets-of-data? #t)))) + (vector-map (match-lambda* + ((_ (_ _ package-description-data _)) + (let ((package-description-ids + (insert-missing-data-and-return-all-ids + conn + "package_descriptions" + '(locale description) + (let ((vec (list->vector package-description-data))) + (vector-map! + (match-lambda* + ((_ (locale . description)) + (list locale + ;; \u0000 has appeared in package + ;; descriptions (#71968), so strip it + ;; out here to avoid PostgreSQL throwing + ;; an error + (string-delete-null description)))) + vec) + vec)))) + (insert-and-return-id + conn + "package_description_sets" + '(description_ids) + (list (sort! package-description-ids <)))))) + package-metadata)) (with-time-logging "preparing package synopsis set ids" - (map (lambda (package-synopsis-ids) - (package-synopsis-data->package-synopsis-set-id - conn - package-synopsis-ids)) - (insert-missing-data-and-return-all-ids - conn - "package_synopsis" - '(locale synopsis) - (map (match-lambda - ((_ _ _ package-synopsis-data) - (map (match-lambda - ((locale . synopsis) - (list locale synopsis))) - package-synopsis-data))) - package-metadata) - #:delete-duplicates? #t - #:sets-of-data? #t)))) - ;; There can be duplicated entires in package-metadata, for example where - ;; you have one package definition which interits from another, and just - ;; overrides the version and the source, the package_metadata entries for - ;; both definitions will be the same. - #:delete-duplicates? #t - ;; There is so much package metadata that it's worth creating a temporary - ;; table - #:use-temporary-table? #t)) + (vector-map (match-lambda* + ((_ (_ _ _ package-synopsis-data)) + (let ((package-synopsis-ids + (insert-missing-data-and-return-all-ids + conn + "package_synopsis" + '(locale synopsis) + (let ((vec + (list->vector package-synopsis-data))) + (vector-map! + (match-lambda* + ((_ (locale . synopsis)) + (list locale synopsis))) + vec) + vec)))) + (insert-and-return-id + conn + "package_synopsis_sets" + '(synopsis_ids) + (list (sort! package-synopsis-ids <)))))) + package-metadata))))) (define (package-description-and-synopsis-locale-options-guix-revision conn revision-id) + ;; TODO This no longer uses the revision-id, as that's too expensive. Maybe + ;; some caching is needed. (exec-query conn " -WITH package_metadata_ids AS ( - SELECT packages.package_metadata_id AS id - FROM packages - WHERE packages.id IN ( - SELECT package_derivations.package_id - FROM package_derivations - INNER JOIN guix_revision_package_derivations - ON package_derivations.id = guix_revision_package_derivations.package_derivation_id - WHERE guix_revision_package_derivations.revision_id = $1 - ) -), synopsis_locales AS ( - SELECT package_synopsis.locale - FROM package_metadata - INNER JOIN package_synopsis_sets - ON package_synopsis_sets.id = package_metadata.package_synopsis_set_id - INNER JOIN package_synopsis - ON package_synopsis.id = ANY (package_synopsis_sets.synopsis_ids) - WHERE package_metadata.id IN (SELECT id FROM package_metadata_ids) -), description_locales AS ( - SELECT package_descriptions.locale - FROM package_metadata - INNER JOIN package_description_sets - ON package_description_sets.id = package_metadata.package_description_set_id - INNER JOIN package_descriptions - ON package_descriptions.id = ANY (package_description_sets.description_ids) - WHERE package_metadata.id IN (SELECT id FROM package_metadata_ids) -) -SELECT locale FROM synopsis_locales +SELECT locale FROM package_synopsis UNION -SELECT locale FROM description_locales" - (list revision-id))) +SELECT locale FROM package_descriptions")) (define (synopsis-counts-by-locale conn revision-id) (define synopsis-counts @@ -576,8 +478,8 @@ INNER JOIN ( OR translated_package_descriptions.locale = 'en_US.UTF-8') WHERE package_metadata.id IN (" (string-join - (map number->string - package-metadata-ids) ", ") ")" + (map number->string (vector->list package-metadata-ids)) + ", ") ")" " ORDER BY package_metadata.id, locale, CASE WHEN translated_package_synopsis.locale = diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm index 8d62ef3..395cbd4 100644 --- a/guix-data-service/model/package.scm +++ b/guix-data-service/model/package.scm @@ -250,23 +250,6 @@ WHERE packages.id IN ( (exec-query conn query (list commit-hash))) -(define (insert-into-package-entries package-entries) - (string-append - " -INSERT INTO packages (name, version, package_metadata_id) VALUES " - (string-join - (map - (match-lambda - ((name version package_metadata_id) - (simple-format #f "('~A', '~A', ~A)" - name - version - package_metadata_id))) - package-entries) - ",") - " -RETURNING id")) - (define (inferior-packages->package-ids conn package-entries) (insert-missing-data-and-return-all-ids conn diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm index fe2fb83..ab438b7 100644 --- a/guix-data-service/model/system-test.scm +++ b/guix-data-service/model/system-test.scm @@ -23,7 +23,6 @@ #:use-module (guix utils) #:use-module (guix-data-service model utils) #:use-module (guix-data-service model location) - #:use-module (guix-data-service model derivation) #:export (insert-system-tests-for-guix-revision select-system-tests-for-guix-revision @@ -39,7 +38,7 @@ "system_tests" '(name description location_id) (map (match-lambda - ((name description derivation-file-names-by-system location-data) + ((name description derivation-ids-by-system location-data) (list name description (location->location-id @@ -48,20 +47,13 @@ system-test-data))) (data (append-map - (lambda (system-test-id derivation-file-names-by-system) - (let ((systems - (map car derivation-file-names-by-system)) - (derivation-ids - (derivation-file-names->derivation-ids - conn - (map cdr derivation-file-names-by-system)))) - (map (lambda (system derivation-id) - (list guix-revision-id - system-test-id - derivation-id - system)) - systems - derivation-ids))) + (lambda (system-test-id derivation-ids-by-system) + (map (lambda (system-and-derivation-id) + (list guix-revision-id + system-test-id + (cdr system-and-derivation-id) + (car system-and-derivation-id))) + derivation-ids-by-system)) system-test-ids (map third system-test-data)))) diff --git a/guix-data-service/model/system.scm b/guix-data-service/model/system.scm index e64e7f5..d6efa46 100644 --- a/guix-data-service/model/system.scm +++ b/guix-data-service/model/system.scm @@ -22,6 +22,7 @@ #:use-module (squee) #:use-module (guix-data-service model utils) #:export (system->system-id + lookup-system-id list-systems)) (define system->system-id-cache @@ -33,17 +34,32 @@ (let ((cached-value (hash-ref system->system-id-cache system))) (or cached-value - (match (insert-missing-data-and-return-all-ids + (let ((id (insert-and-return-id + conn + "systems" + '(system) + (list system)))) + (hash-set! system->system-id-cache + system + id) + (set! systems-cache #f) + id)))) + +(define (lookup-system-id conn system) + (let ((cached-value (hash-ref system->system-id-cache + system))) + (or cached-value + (match (exec-query conn - "systems" - '(system) - `((,system))) - ((id) - (hash-set! system->system-id-cache - system - id) - (set! systems-cache #f) - id))))) + "SELECT id FROM systems WHERE system = $1" + (list system)) + (((id-string)) + (let ((id (string->number id-string))) + (hash-set! system->system-id-cache + system + id) + id)) + (() #f))))) (define (list-systems conn) (if systems-cache diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm index c05f20d..707c697 100644 --- a/guix-data-service/model/utils.scm +++ b/guix-data-service/model/utils.scm @@ -17,26 +17,34 @@ (define-module (guix-data-service model utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 receive) #:use-module (squee) #:use-module (guix-data-service database) #:use-module (guix-data-service utils) - #:export (NULL + #:export (string-delete-null quote-string value->quoted-string-or-null non-empty-string-or-false - exec-query->vhash - two-lists->vhash parse-postgresql-array-string deduplicate-strings group-list-by-first-n-fields group-to-alist group-to-alist/vector - insert-missing-data-and-return-all-ids)) + insert-missing-data-and-return-all-ids + insert-missing-data + update-or-insert + bulk-select + insert-and-return-id + prepare-insert-and-return-id)) -(define NULL '()) +(define (char-null? c) + (char=? c #\null)) + +(define (string-delete-null s) + (string-delete char-null? s)) (define (quote-string s) (string-append "$STR$" s "$STR$")) @@ -44,7 +52,7 @@ (define (value->quoted-string-or-null value) (if (string? value) (string-append "$STR$" value "$STR$") - "NULL")) + NULL)) (define (non-empty-string-or-false s) (if (string? s) @@ -53,22 +61,6 @@ s) #f)) -(define* (exec-query->vhash conn query field-function value-function - #:key (vhash vlist-null)) - (fold (lambda (row result) - (vhash-cons (field-function row) - (value-function row) - result)) - vhash - (exec-query-with-null-handling conn query))) - -(define (two-lists->vhash l1 l2) - (fold (lambda (key value result) - (vhash-cons key value result)) - vlist-null - l1 - l2)) - (define (parse-postgresql-array-string s) (if (string=? s "{}") '() @@ -145,322 +137,504 @@ WHERE table_name = $1" (string=? is_nullable "YES")))) results)))) +(define %field-can-be-null-cache + (make-hash-table)) + +(define (field-can-be-null? conn table-name field) + (let ((cache-key (cons table-name field))) + (match (hash-get-handle %field-can-be-null-cache + cache-key) + ((_ . res) res) + (#f + (let ((schema-details + (table-schema conn table-name))) + (match (find (lambda (column-data) + (string=? field + (car column-data))) + schema-details) + ((column-name data-type is-nullable?) + (hash-set! %field-can-be-null-cache + cache-key + is-nullable?) + is-nullable?) + (#f + (simple-format + (current-error-port) + "error: couldn't find data for ~A in ~A\n" + field + schema-details) + (error "error: field-can-be-null?")))))))) + +(define value->sql + (match-lambda + ((? string? s) + (string-append "$STR$" s "$STR$")) + ((? NULL?) + "NULL") + ((? symbol? s) + (value->sql (symbol->string s))) + ((? number? n) + (number->string n)) + ((? boolean? b) + (if b "TRUE" "FALSE")) + ((? vector? v) + (string-append + "ARRAY[" (string-join (map value->sql (vector->list v)) ",") "]")) + ((cast . value) + (string-append + (value->sql value) "::" cast)) + (v + (error + (simple-format #f "error: unknown type for value: ~A" v))))) + +(define value->sql-literal + (match-lambda + ((? string? s) s) + ((? NULL?) + "NULL") + ((? symbol? s) (symbol->string s)) + ((? number? n) + (number->string n)) + ((? boolean? b) + (if b "t" "f")) + ((? vector? v) + (string-append + "{" (string-join (map value->sql-literal (vector->list v)) ",") "}")) + ((cast . value) + (string-append + (value->sql-literal value) "::" cast)) + (v + (error + (simple-format #f "error: unknown type for value: ~A" v))))) + +(define* (bulk-select conn + table-name + fields + data + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define query + (string-append + " +SELECT vals.bulk_select_index, id +FROM " table-name " +JOIN (VALUES " +(string-join + (if (vector? data) + (vector-fold + (lambda (index result field-values) + (cons + (string-append + "(" + (number->string index) ", " + (string-join (map value->sql field-values) ",") + ")") + result)) + '() + data) + (map + (lambda (index field-values) + (string-append + "(" + (number->string index) ", " + (string-join (map value->sql field-values) ",") + ")")) + (iota (length data)) + data)) + ", ") +")\n AS vals (bulk_select_index, " (string-join field-strings ", ") ") " +"ON " +(string-join + (map (lambda (field) + (string-concatenate + `("(" + ,table-name "." ,field " = vals." ,field + ,@(if (field-can-be-null? conn table-name field) + `(" OR (" ,table-name "." ,field " IS NULL AND" + " vals." ,field " IS NULL" + ")") + '()) + ")"))) + field-strings) + " AND\n "))) + + (let ((result (make-vector (if (vector? data) + (vector-length data) + (length data)) + #f))) + (for-each + (match-lambda + ((index id) + (vector-set! result (string->number index) + (id-proc id)))) + (exec-query conn query)) + + result)) + +(define* (bulk-insert + conn + table-name + fields + data + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define query + (string-append + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") VALUES +" (string-join + (map (lambda (field-values) + (string-append + "(" + (string-join + (map (lambda (value) + (value->sql value)) + field-values) + ", ") + ")")) + data) + ", ") " +ON CONFLICT DO NOTHING +RETURNING id")) + + (if (null? data) + #() + (let* ((query-result (exec-query conn query)) + (expected-ids (length data)) + (returned-ids (length query-result))) + (if (= expected-ids returned-ids) + (let ((result + (make-vector returned-ids))) + (fold + (lambda (row index) + (match row + ((id) + (vector-set! result index + (id-proc id)))) + (1+ index)) + 0 + query-result) + result) + ;; Can't match up the ids to the data, so just query for them + (bulk-select conn + table-name + fields + data + #:id-proc id-proc))))) + +(define* (insert-missing-data + conn + table-name + fields + data) + (define field-strings + (map symbol->string fields)) + + (let* ((result + (bulk-select + conn + table-name + fields + data)) + (missing-data-indexes + (vector-fold + (lambda (i missing-data-indexes id-or-f) + (if id-or-f + missing-data-indexes + (cons i missing-data-indexes))) + '() + result))) + + (bulk-insert + conn + table-name + fields + (map (lambda (index) + (vector-ref data index)) + missing-data-indexes)) + + *unspecified*)) + (define* (insert-missing-data-and-return-all-ids conn table-name fields data - #:key - sets-of-data? - delete-duplicates? - use-temporary-table?) + #:key (id-proc string->number)) (define field-strings (map symbol->string fields)) - (define value->sql - (match-lambda - ((? string? s) - (string-append "$STR$" s "$STR$")) - ((? symbol? s) - (string-append "$STR$" - (symbol->string s) - "$STR$")) - ((? number? n) - (number->string n)) - ((? boolean? b) - (if b "TRUE" "FALSE")) - ((? null?) - "NULL") - ((cast . value) - (string-append - (value->sql value) "::" cast)) - (v - (error - (simple-format #f "error: unknown type for value: ~A" v))))) - - (define (delete-duplicates* data) - (delete-duplicates/sort! - (list-copy data) - (lambda (full-a full-b) - (let loop ((a full-a) - (b full-b)) - (if (null? a) - #f - (let ((a-val (match (car a) - ((_ . val) val) - ((? symbol? val) (symbol->string val)) - (val val))) - (b-val (match (car b) - ((_ . val) val) - ((? symbol? val) (symbol->string val)) - (val val)))) - (cond - ((null? a-val) - (if (null? b-val) - (loop (cdr a) (cdr b)) - #t)) - ((null? b-val) - #f) - (else - (match a-val - ((? string? v) - (if (string=? a-val b-val) - (loop (cdr a) (cdr b)) - (string<? a-val b-val))) - ((? number? v) - (if (= a-val b-val) - (loop (cdr a) (cdr b)) - (< a-val b-val))) - ((? boolean? v) - (if (eq? a-val b-val) - (loop (cdr a) (cdr b)) - a-val))))))))))) - - (define schema-details - (table-schema conn table-name)) - - (define (field-can-be-null? field) - (match (find (lambda (column-data) - (string=? field - (car column-data))) - schema-details) - ((column-name data-type is-nullable?) is-nullable?) - (#f - (simple-format - (current-error-port) - "error: couldn't find data for ~A in ~A\n" - field - schema-details) - (error "error: field-can-be-null?")))) - - (define (select-query data) + (let* ((result + (bulk-select + conn + table-name + fields + data + #:id-proc id-proc)) + (missing-data-indexes + (vector-fold + (lambda (i missing-data-indexes id-or-f) + (if id-or-f + missing-data-indexes + (cons i missing-data-indexes))) + '() + result)) + (new-ids + (bulk-insert + conn + table-name + fields + (map (lambda (index) + (vector-ref data index)) + missing-data-indexes) + #:id-proc id-proc))) + + (fold + (lambda (missing-data-index index) + (let ((new-id (vector-ref new-ids index))) + (vector-set! result missing-data-index new-id)) + (1+ index)) + 0 + missing-data-indexes) + + (values result new-ids))) + +(define* (update-or-insert conn + table-name + fields + field-vals + #:key (id-fields '(id))) + (define id-field-strings + (map symbol->string id-fields)) + + (define id-field-values + (map (lambda (id-field) + (any (lambda (field val) + (if (eq? field id-field) + (value->sql-literal val) + #f)) + fields + field-vals)) + id-fields)) + + (define field-strings + (map symbol->string fields)) + + (define select (string-append - "SELECT id,\n" - (string-join (map (lambda (field) - (string-append table-name "." field)) - field-strings) - ",\n") - " FROM " table-name - " JOIN (VALUES " - (string-join - (map - (lambda (field-values) - (string-append - "(" - (string-join (map value->sql field-values) ",") - ")")) - data) - ", ") - ")\n AS vals (" (string-join field-strings ", ") ") " - "ON " - (string-join - (map (lambda (field) - (string-concatenate - `("(" - ,table-name "." ,field " = vals." ,field - ,@(if (field-can-be-null? field) - `(" OR (" ,table-name "." ,field " IS NULL AND" - " vals." ,field " IS NULL" - ")") - '()) - ")"))) - field-strings) - " AND\n "))) - - (define (temp-table-select-query temp-table-name) + " +SELECT " (string-join field-strings ", ") " FROM " table-name " +WHERE " +(string-join + (filter-map + (lambda (i field) + (simple-format #f "(~A = $~A)" field i)) + (iota (length id-fields) 1) + id-field-strings) + " AND\n ") +";")) + + (define insert (string-append - "SELECT " table-name ".id, " - (string-join (map (lambda (field) - (string-append table-name "." field)) - field-strings) - ", ") - " FROM " table-name - " INNER JOIN " temp-table-name - " ON " - (string-join - (map (lambda (field) - (string-concatenate - `("(" - ,table-name "." ,field " = " ,temp-table-name "." ,field - ,@(if (field-can-be-null? field) - `(" OR (" - ,table-name "." ,field " IS NULL" - " AND " - ,temp-table-name "." ,field " IS NULL" - ")") - '()) - ")"))) - field-strings) - " AND "))) - - (define* (insert-sql missing-data - #:key - (table-name table-name)) + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING " (string-join id-field-strings ", ") ";")) + + (define (update fields-to-update) + (define update-field-strings + (map symbol->string fields-to-update)) + (string-append - "INSERT INTO " table-name " (\n" - (string-join field-strings ",\n") - ") VALUES " - (string-join - (map (lambda (field-values) + " +UPDATE " table-name " +SET " (string-join + (map (lambda (field i) + (simple-format #f "~A = $~A" field i)) + update-field-strings + (iota (length update-field-strings) 1)) + ", ") " +WHERE " +(string-join + (filter-map + (lambda (i field) + (simple-format #f "(~A = $~A)" field i)) + (iota (length id-fields) (+ 1 (length fields-to-update))) + id-field-strings) + " AND\n "))) + + (let ((sql-field-values + (map value->sql-literal field-vals))) + (match (exec-query + conn + select + id-field-values) + ((db-field-values) + (let* ((normalised-field-values + (map value->sql-literal + db-field-values)) + (fields-to-update + (filter-map + (lambda (field db-val target-val) + ;; TODO This might incorrectly detect differences + (if (equal? db-val target-val) + #f + field)) + fields + normalised-field-values + sql-field-values)) + (update-field-values + (filter-map + (lambda (field val) + (if (memq field fields-to-update) + val + #f)) + fields + sql-field-values))) + (unless (null? fields-to-update) + (exec-query + conn + (update fields-to-update) + (append update-field-values + id-field-values))))) + (() + (exec-query + conn + insert + sql-field-values)))) + *unspecified*) + +(define* (insert-and-return-id conn + table-name + fields + field-vals + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define select + (string-append + " +SELECT id FROM " table-name " +WHERE " +(string-join + (map (lambda (i field) + (string-append + "(" field " = $" i + (if (field-can-be-null? conn table-name field) (string-append - "(" - (string-join - (map (lambda (value) - (value->sql value)) - field-values) - ", ") - ")")) - missing-data) - ", ") - " RETURNING id")) - - (define (format-json json) - ;; PostgreSQL formats JSON strings differently to guile-json, so use - ;; PostgreSQL to do the formatting - (caar - (exec-query - conn - (string-append - "SELECT $STR$" json "$STR$::jsonb")))) - - (define (normalise-values data) - (map (match-lambda - ((? boolean? b) - (if b "t" "f")) - ((? number? n) - (number->string n)) - ((? symbol? s) - (symbol->string s)) - ((? string? s) - s) - ((? null? n) - ;; exec-query-with-null-handling specifies NULL values as '() - n) - ((cast . value) - (if (string=? cast "jsonb") - (format-json value) - value)) - (unknown - (error (simple-format #f "normalise-values: error: ~A\n" unknown)))) - data)) - - (let* ((existing-entries - (if use-temporary-table? - (let ((temp-table-name - (string-append "temp_" table-name)) - (data - (if sets-of-data? - (delete-duplicates* (concatenate data)) - (if delete-duplicates? - (delete-duplicates* data) - data)))) - ;; Create a temporary table to store the data - (exec-query - conn - (string-append "CREATE TEMPORARY TABLE " - temp-table-name - " (LIKE " - table-name - " INCLUDING ALL)")) - (exec-query - conn - (string-append - "ANALYZE " temp-table-name)) - - ;; Populate the temporary table - (if (null? data) - '() - (with-time-logging (string-append "populating " temp-table-name) - (exec-query conn - (insert-sql data - #:table-name temp-table-name)))) - ;; Use the temporary table to find the existing values - (let ((result - (with-time-logging - (string-append "querying the " temp-table-name) - (exec-query->vhash - conn - (temp-table-select-query temp-table-name) - cdr - (lambda (result) - (string->number (first result))))))) - - (exec-query conn (string-append "DROP TABLE " temp-table-name)) - result)) - - ;; If not using a temporary table, just do a single SELECT query - (if (null? data) - '() - (fold - (lambda (data-chunk result) - (exec-query->vhash conn - (select-query data-chunk) - cdr - (lambda (result) - (string->number (first result))) - #:vhash result)) - vlist-null - (chunk (if sets-of-data? - (delete-duplicates* - (concatenate data)) - data) - 3000))))) - (missing-entries - (let loop ((lst (if sets-of-data? - (concatenate data) - data)) - (result '())) - (if (null? lst) - (if delete-duplicates? - (delete-duplicates* result) - result) - (let ((field-values (car lst))) - (if (vhash-assoc - ;; Normalise at this point, so that the proper value - ;; to insert is carried forward - (normalise-values field-values) - existing-entries) - (loop (cdr lst) - result) - (loop (cdr lst) - (cons field-values result))))))) - (new-entries - (if (null? missing-entries) - '() - (append-map! - (lambda (missing-entries-chunk) - (map (lambda (result) - (string->number (first result))) - (exec-query conn - (insert-sql missing-entries-chunk)))) - (chunk missing-entries 3000)))) - - (new-entries-lookup-vhash - (two-lists->vhash missing-entries - new-entries)) - (all-ids - (if sets-of-data? - (map (lambda (field-value-lists) - ;; Normalise the result at this point, ensuring that the id's - ;; in the set are sorted - (sort - (map (lambda (field-values) - (cdr - (or (vhash-assoc (normalise-values field-values) - existing-entries) - (vhash-assoc field-values - new-entries-lookup-vhash) - (error "missing entry" field-values)))) - field-value-lists) - <)) - data) - (map (lambda (field-values) - (cdr - (or (vhash-assoc (normalise-values field-values) - existing-entries) - (vhash-assoc field-values - new-entries-lookup-vhash) - (error "missing entry" field-values)))) - data)))) - (values all-ids - new-entries))) + " OR (" field " IS NULL AND $" i " IS NULL)") + "") + ")")) + (map number->string + (iota (length fields) 1)) + field-strings) + " AND\n ") +";")) + + (define insert + (string-append + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING id;")) + + (let ((sql-field-values + (map value->sql-literal field-vals))) + (id-proc + (match (exec-query + conn + select + sql-field-values) + (((id)) id) + (() + (match (exec-query + conn + insert + sql-field-values) + (((id)) id) + (() + (match (exec-query + conn + select + sql-field-values) + (((id)) id))))))))) + +(define (prepare-insert-and-return-id conn + table-name + fields + types) + (define field-strings + (map symbol->string fields)) + + (define prepared-insert-select + (string-append + " +PREPARE " table-name "PreparedInsertSelect + (" (string-join (map symbol->string types) ",") ") AS +SELECT id FROM " table-name " +WHERE " +(string-join + (map (lambda (i field) + (string-append + "(" field " = $" i + (if (field-can-be-null? conn table-name field) + (string-append + " OR (" field " IS NULL AND $" i " IS NULL)") + "") + ")")) + (map number->string + (iota (length fields) 1)) + field-strings) + " AND\n ") +";")) + + (define prepared-insert + (string-append + " +PREPARE " table-name "PreparedInsert + (" (string-join (map symbol->string types) ",") ") AS +INSERT INTO " table-name " (\n" (string-join field-strings ",\n") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING id;")) + + (exec-query conn prepared-insert) + (exec-query conn prepared-insert-select) + + (lambda (conn field-vals) + (match (exec-query + conn + (string-append + " +EXECUTE " table-name "PreparedInsert(" + (string-join (map value->sql field-vals) ", ") + ");")) + (((id)) id) + (() + (match (exec-query + conn + (string-append + " +EXECUTE " table-name "PreparedInsertSelect(" +(string-join (map value->sql field-vals) ", ") +");")) + (((id)) id)))))) diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index 2ed5644..97154ec 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -22,11 +22,11 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 threads) #:use-module (squee) + #:use-module (knots) + #:use-module ((knots thread-pool) #:select (set-thread-name)) #:use-module (git) #:use-module (guix git) #:use-module (guix channels) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) #:use-module (guix-data-service database) #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service model git-branch) @@ -57,11 +57,12 @@ (simple-format #t "exception when polling git repository (~A): ~A\n" git-repository-id exn)) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () - (poll-git-repository conn git-repository-id)) - (lambda _ - (backtrace)))) + (poll-git-repository conn git-repository-id)))) #:unwind? #t) (and=> @@ -99,6 +100,9 @@ conn 'latest-channel-instances (lambda () + (simple-format (current-error-port) + "polling git repository ~A\n" + git-repository-id) ;; This was using update-cached-checkout, but it wants to checkout ;; refs/remotes/origin/HEAD by default, and that can fail for some reason ;; on some repositories: @@ -158,6 +162,15 @@ oid->string))))) (branch-list repository BRANCH-REMOTE))))) + (simple-format (current-error-port) + "git repository ~A: excluded branches: ~A\n" + git-repository-id + excluded-branches) + (simple-format (current-error-port) + "git repository ~A: included branches: ~A\n" + git-repository-id + included-branches) + (with-postgresql-transaction conn (lambda (conn) @@ -170,12 +183,10 @@ (filter (lambda (branch-name) (let ((excluded-branch? - (branch-in-list? excluded-branches branch-name)) - (included-branch? - (branch-in-list? included-branches branch-name))) + (branch-in-list? excluded-branches branch-name))) (and (not excluded-branch?) - (or (null? included-branches) - included-branch?)))) + (or (NULL? included-branches) + (branch-in-list? included-branches branch-name))))) (delete-duplicates! (append! (map car repository-branches) diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm index c7a45dc..3ac09eb 100644 --- a/guix-data-service/substitutes.scm +++ b/guix-data-service/substitutes.scm @@ -19,13 +19,14 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (ice-9 match) + #:use-module (ice-9 atomic) #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers channels) #:use-module (guix substitutes) #:use-module (guix narinfo) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) + #:use-module (knots) + #:use-module (knots thread-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service model build) @@ -55,17 +56,18 @@ (member id build-server-ids)) (when lookup-all-derivations? (simple-format #t "\nQuerying ~A\n" url) - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in query-build-server ~A ~A\n" + id url) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (fetch-narinfo-files conn id url revision-commits #:specific-outputs - outputs)) - (lambda (key . args) - (simple-format - (current-error-port) - "exception in query-build-server: ~A ~A\n" - key args) - (backtrace))))))) + outputs))))))) build-servers)))) (define %narinfo-max-size @@ -149,7 +151,7 @@ (lambda (channel) (put-message channel (cons build-server-id build-ids))))))) -(define (start-substitute-query-threads) +(define (start-substitute-query-threads startup-completed?) (define channel (make-channel)) @@ -162,15 +164,21 @@ (set-thread-name "request substitute query")) (const #t)) + (while (not (atomic-box-ref startup-completed?)) + (sleep 1)) + (while #t (with-exception-handler (lambda (exn) - (simple-format - (current-error-port) - "exception in request substitute query thread: ~A\n" - exn)) + #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in request substitute query thread:\n") + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (with-postgresql-connection "request-substitute-query-thread" @@ -196,9 +204,7 @@ conn (list build-server-id) #f - outputs)))))))) - (lambda _ - (backtrace)))) + outputs)))))))))) #:unwind? #t)))) (call-with-new-thread @@ -208,6 +214,9 @@ (set-thread-name "bulk substitute query")) (const #t)) + (while (not (atomic-box-ref startup-completed?)) + (sleep 1)) + (while #t (with-exception-handler (lambda (exn) diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index a9e8f39..7cd7342 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -17,7 +17,10 @@ (define-module (guix-data-service utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-71) + #:use-module (ice-9 q) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 atomic) @@ -33,23 +36,12 @@ #:use-module (fibers timers) #:use-module (fibers conditions) #:use-module (fibers scheduler) + #:use-module (knots timeout) #:use-module (prometheus) #:export (call-with-time-logging with-time-logging prevent-inlining-for-tests - resource-pool-default-timeout - %resource-pool-timeout-handler - make-resource-pool - destroy-resource-pool - call-with-resource-from-pool - with-resource-from-pool - resource-pool-stats - - parallel-via-fibers - par-map& - letpar& - chunk chunk! chunk-for-each! @@ -58,10 +50,9 @@ get-guix-metrics-updater - call-with-sigint - run-server/patched + spawn-port-monitoring-fiber - spawn-port-monitoring-fiber)) + make-queueing-channel)) (define (call-with-time-logging action thunk) (simple-format #t "debug: Starting ~A\n" action) @@ -80,466 +71,31 @@ (define-syntax-rule (prevent-inlining-for-tests var) (set! var var)) -(define* (make-resource-pool initializer max-size - #:key (min-size max-size) - (idle-seconds #f) - (delay-logger (const #f)) - (duration-logger (const #f)) - destructor - lifetime - (name "unnamed")) - (define (initializer/safe) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception running ~A resource pool initializer: ~A:\n ~A\n" - name - initializer - exn) - #f) - (lambda () - (with-throw-handler #t - initializer - (lambda args - (backtrace)))) - #:unwind? #t)) - - (define (destructor/safe args) - (let ((success? - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception running resource pool destructor (~A): ~A:\n ~A\n" - name - destructor - exn) - #f) - (lambda () - (with-throw-handler #t - (lambda () - (destructor args) - #t) - (lambda _ - (backtrace)))) - #:unwind? #t))) - - (or success? - #t - (begin - (sleep 5) - (destructor/safe args))))) - - (let ((channel (make-channel)) - (checkout-failure-count 0)) - (spawn-fiber - (lambda () - (while #t - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in the ~A pool fiber: ~A\n" - name - exn)) - (lambda () - (let loop ((resources '()) - (available '()) - (waiters '()) - (resources-last-used '())) - - (match (if idle-seconds - (perform-operation - (choice-operation - (get-operation channel) - (wrap-operation - ;; TODO Do something smarter - (sleep-operation 10) - (const '(check-for-idle-resources))))) - (get-message channel)) - (('checkout reply) - (if (null? available) - (if (= (length resources) max-size) - (loop resources - available - (cons reply waiters) - resources-last-used) - (let ((new-resource (initializer/safe))) - (if new-resource - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply new-resource) - (const #t)) - (wrap-operation (sleep-operation 1) - (const #f)))))) - (unless checkout-success? - (set! checkout-failure-count - (+ 1 checkout-failure-count))) - - (loop (cons new-resource resources) - (if checkout-success? - available - (cons new-resource available)) - waiters - (cons (get-internal-real-time) - resources-last-used))) - (loop resources - available - (cons reply waiters) - resources-last-used)))) - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply (car available)) - (const #t)) - (wrap-operation (sleep-operation 1) - (const #f)))))) - (unless checkout-success? - (set! checkout-failure-count - (+ 1 checkout-failure-count))) - - (if checkout-success? - (loop resources - (cdr available) - waiters - resources-last-used) - (loop resources - available - waiters - resources-last-used))))) - (('return resource) - ;; When a resource is returned, prompt all the waiters to request - ;; again. This is to avoid the pool waiting on channels that may - ;; be dead. - (for-each - (lambda (waiter) - (spawn-fiber - (lambda () - (perform-operation - (choice-operation - (put-operation waiter 'resource-pool-retry-checkout) - (sleep-operation 0.2)))))) - waiters) - - (loop resources - (cons resource available) - ;; clear waiters, as they've been notified - '() - (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - (get-internal-real-time)) - resources-last-used))) - (('stats reply) - (let ((stats - `((resources . ,(length resources)) - (available . ,(length available)) - (waiters . ,(length waiters)) - (checkout-failure-count . ,checkout-failure-count)))) - - (spawn-fiber - (lambda () - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply stats) - (const #t)) - (wrap-operation (sleep-operation 1) - (const #f))))))) - - (loop resources - available - waiters - resources-last-used)) - (('check-for-idle-resources) - (let* ((resources-last-used-seconds - (map - (lambda (internal-time) - (/ (- (get-internal-real-time) internal-time) - internal-time-units-per-second)) - resources-last-used)) - (resources-to-destroy - (filter-map - (lambda (resource last-used-seconds) - (if (and (member resource available) - (> last-used-seconds idle-seconds)) - resource - #f)) - resources - resources-last-used-seconds))) - - (for-each - (lambda (resource) - (destructor/safe resource)) - resources-to-destroy) - - (loop (lset-difference eq? resources resources-to-destroy) - (lset-difference eq? available resources-to-destroy) - waiters - (filter-map - (lambda (resource last-used) - (if (memq resource resources-to-destroy) - #f - last-used)) - resources - resources-last-used)))) - (('destroy reply) - (if (= (length resources) (length available)) - (begin - (for-each - (lambda (resource) - (destructor/safe resource)) - resources) - (put-message reply 'destroy-success)) - (begin - (spawn-fiber - (lambda () - (perform-operation - (choice-operation - (put-operation reply 'resource-pool-destroy-failed) - (sleep-operation 10))))) - (loop resources - available - waiters - resources-last-used)))) - (unknown - (simple-format - (current-error-port) - "unrecognised message to ~A resource pool channel: ~A\n" - name - unknown) - (loop resources - available - waiters - resources-last-used))))) - #:unwind? #t)))) - - channel)) - -(define (destroy-resource-pool pool) - (let ((reply (make-channel))) - (put-message pool (list 'destroy reply)) - (let ((msg (get-message reply))) - (unless (eq? msg 'destroy-success) - (error msg))))) - -(define resource-pool-default-timeout - (make-parameter #f)) - -(define &resource-pool-timeout - (make-exception-type '&recource-pool-timeout - &error - '())) - -(define make-resource-pool-timeout-error - (record-constructor &resource-pool-timeout)) - -(define resource-pool-timeout-error? - (record-predicate &resource-pool-timeout)) - -(define %resource-pool-timeout-handler - (make-parameter #f)) - -(define* (call-with-resource-from-pool pool proc #:key (timeout 'default) - (timeout-handler (%resource-pool-timeout-handler))) - "Call PROC with a resource from POOL, blocking until a resource becomes -available. Return the resource once PROC has returned." - - (define timeout-or-default - (if (eq? timeout 'default) - (resource-pool-default-timeout) - timeout)) - - (let ((resource - (let ((reply (make-channel))) - (if timeout-or-default - (let loop ((start-time (get-internal-real-time))) - (perform-operation - (choice-operation - (wrap-operation - (put-operation pool `(checkout ,reply)) - (const #t)) - (wrap-operation (sleep-operation timeout-or-default) - (const #f)))) - - (let ((time-remaining - (- timeout-or-default - (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second)))) - (if (> time-remaining 0) - (let ((response - (perform-operation - (choice-operation - (get-operation reply) - (wrap-operation (sleep-operation time-remaining) - (const #f)))))) - (if (or (not response) - (eq? response 'resource-pool-retry-checkout)) - (if (> (- timeout-or-default - (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second)) - 0) - (loop start-time) - #f) - response)) - #f))) - (let loop () - (put-message pool `(checkout ,reply)) - (let ((response (get-message reply))) - (if (eq? response 'resource-pool-retry-checkout) - (loop) - response))))))) - - (when (or (not resource) - (eq? resource 'resource-pool-retry-checkout)) - (when timeout-handler - (timeout-handler pool proc timeout)) - - (raise-exception - (make-resource-pool-timeout-error))) - - (with-exception-handler - (lambda (exception) - (put-message pool `(return ,resource)) - (raise-exception exception)) - (lambda () - (call-with-values - (lambda () - (with-throw-handler #t - (lambda () - (proc resource)) - (lambda _ - (backtrace)))) - (lambda vals - (put-message pool `(return ,resource)) - (apply values vals)))) - #:unwind? #t))) - -(define-syntax-rule (with-resource-from-pool pool resource exp ...) - (call-with-resource-from-pool - pool - (lambda (resource) exp ...))) - -(define* (resource-pool-stats pool #:key (timeout 5)) - (let ((reply (make-channel)) - (start-time (get-internal-real-time))) - (perform-operation - (choice-operation - (wrap-operation - (put-operation pool `(stats ,reply)) - (const #t)) - (wrap-operation (sleep-operation timeout) - (const #f)))) - - (let ((time-remaining - (- timeout - (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second)))) - (if (> time-remaining 0) - (let ((response - (perform-operation - (choice-operation - (get-operation reply) - (wrap-operation (sleep-operation time-remaining) - (const #f)))))) - response) - (raise-exception - (make-resource-pool-timeout-error)))))) - -(define (defer-to-parallel-fiber thunk) - (let ((reply (make-channel))) - (spawn-fiber - (lambda () - (with-exception-handler - (lambda (exn) - (put-message reply (cons 'exception exn))) - (lambda () - (call-with-values - (lambda () - (with-throw-handler #t - thunk - (lambda _ - (backtrace)))) - (lambda vals - (put-message reply vals)))) - #:unwind? #t)) - #:parallel? #t) - reply)) - -(define (fetch-result-of-defered-thunks . reply-channels) - (let ((responses (map get-message - reply-channels))) - (map - (match-lambda - (('exception . exn) - (raise-exception exn)) - (result - (apply values result))) - responses))) - -(define-syntax parallel-via-fibers - (lambda (x) - (syntax-case x () - ((_ e0 ...) - (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) - #'(let ((tmp0 (defer-to-parallel-fiber - (lambda () - e0))) - ...) - (apply values (fetch-result-of-defered-thunks tmp0 ...)))))))) - -(define-syntax-rule (letpar& ((v e) ...) b0 b1 ...) - (call-with-values - (lambda () (parallel-via-fibers e ...)) - (lambda (v ...) - b0 b1 ...))) - -(define (par-mapper' mapper cons) - (lambda (proc . lists) - (apply - fetch-result-of-defered-thunks - (let loop ((lists lists)) - (match lists - (((heads tails ...) ...) - (let ((tail (loop tails)) - (head (defer-to-parallel-fiber - (lambda () - (apply proc heads))))) - (cons head tail))) - (_ - '())))))) - -(define par-map& (par-mapper' map cons)) - (define (chunk lst max-length) - (if (> (length lst) - max-length) + (let ((len (length lst))) + (cond + ((= 0 len) '()) + ((> (length lst) max-length) (call-with-values (lambda () (split-at lst max-length)) (lambda (first-lst rest) (cons first-lst - (chunk rest max-length)))) - (list lst))) + (chunk rest max-length))))) + (else + (list lst))))) (define (chunk! lst max-length) - (if (> (length lst) - max-length) + (let ((len (length lst))) + (cond + ((= 0 len) '()) + ((> (length lst) max-length) (call-with-values (lambda () (split-at! lst max-length)) (lambda (first-lst rest) (cons first-lst - (chunk! rest max-length)))) - (list lst))) + (chunk! rest max-length))))) + (else + (list lst))))) (define* (chunk-for-each! proc chunk-size #:rest lsts) (define (do-one-iteration lsts) @@ -560,10 +116,10 @@ available. Return the resource once PROC has returned." (apply proc lsts))) (let ((list-lengths (map length lsts))) - (unless (eq? 1 (length (delete-duplicates list-lengths))) + (unless (= 1 (length (delete-duplicates list-lengths))) (error "lists not equal length")) - (unless (eq? 0 (first list-lengths)) + (unless (= 0 (first list-lengths)) (do-one-iteration lsts))) #t) @@ -608,173 +164,6 @@ available. Return the resource once PROC has returned." 0))) #:unwind? #t)))) -;; This variant of run-server from the fibers library supports running -;; multiple servers within one process. -(define run-server/patched - (let ((fibers-web-server-module - (resolve-module '(fibers web server)))) - - (define set-nonblocking! - (module-ref fibers-web-server-module 'set-nonblocking!)) - - (define make-default-socket - (module-ref fibers-web-server-module 'make-default-socket)) - - (define socket-loop - (module-ref fibers-web-server-module 'socket-loop)) - - (lambda* (handler - #:key - (host #f) - (family AF_INET) - (addr (if host - (inet-pton family host) - INADDR_LOOPBACK)) - (port 8080) - (socket (make-default-socket family addr port))) - ;; We use a large backlog by default. If the server is suddenly hit - ;; with a number of connections on a small backlog, clients won't - ;; receive confirmation for their SYN, leading them to retry -- - ;; probably successfully, but with a large latency. - (listen socket 1024) - (set-nonblocking! socket) - (sigaction SIGPIPE SIG_IGN) - (spawn-fiber (lambda () (socket-loop socket handler)))))) - -(define &port-timeout - (make-exception-type '&port-timeout - &external-error - '(port))) - -(define make-port-timeout-error - (record-constructor &port-timeout)) - -(define port-timeout-error? - (record-predicate &port-timeout)) - -(define &port-read-timeout - (make-exception-type '&port-read-timeout - &port-timeout - '())) - -(define make-port-read-timeout-error - (record-constructor &port-read-timeout)) - -(define port-read-timeout-error? - (record-predicate &port-read-timeout)) - -(define &port-write-timeout - (make-exception-type '&port-write-timeout - &port-timeout - '())) - -(define make-port-write-timeout-error - (record-constructor &port-write-timeout)) - -(define port-write-timeout-error? - (record-predicate &port-write-timeout)) - -;; These procedure are subject to spurious wakeups. - -(define (readable? port) - "Test if PORT is writable." - (match (select (vector port) #() #() 0) - ((#() #() #()) #f) - ((#(_) #() #()) #t))) - -(define (writable? port) - "Test if PORT is writable." - (match (select #() (vector port) #() 0) - ((#() #() #()) #f) - ((#() #(_) #()) #t))) - -(define (make-wait-operation ready? schedule-when-ready port - port-ready-fd this-procedure) - (make-base-operation - #f - (lambda _ - (and (ready? (port-ready-fd port)) values)) - (lambda (flag sched resume) - (define (commit) - (match (atomic-box-compare-and-swap! flag 'W 'S) - ('W (resume values)) - ('C (commit)) - ('S #f))) - (schedule-when-ready - sched (port-ready-fd port) commit)))) - -(define (wait-until-port-readable-operation port) - "Make an operation that will succeed when PORT is readable." - (unless (input-port? port) - (error "refusing to wait forever for input on non-input port")) - (make-wait-operation readable? schedule-task-when-fd-readable port - port-read-wait-fd - wait-until-port-readable-operation)) - -(define (wait-until-port-writable-operation port) - "Make an operation that will succeed when PORT is writable." - (unless (output-port? port) - (error "refusing to wait forever for output on non-output port")) - (make-wait-operation writable? schedule-task-when-fd-writable port - port-write-wait-fd - wait-until-port-writable-operation)) - -(define* (with-fibers-port-timeouts thunk - #:key timeout - (read-timeout timeout) - (write-timeout timeout)) - (define (no-fibers-wait port mode timeout) - (define poll-timeout-ms 200) - - ;; When the GC runs, it restarts the poll syscall, but the timeout - ;; remains unchanged! When the timeout is longer than the time - ;; between the syscall restarting, I think this renders the - ;; timeout useless. Therefore, this code uses a short timeout, and - ;; repeatedly calls poll while watching the clock to see if it has - ;; timed out overall. - (let ((timeout-internal - (+ (get-internal-real-time) - (* internal-time-units-per-second - (/ timeout 1000))))) - (let loop ((poll-value - (port-poll port mode poll-timeout-ms))) - (if (= poll-value 0) - (if (> (get-internal-real-time) - timeout-internal) - (raise-exception - (if (string=? mode "r") - (make-port-read-timeout-error port) - (make-port-write-timeout-error port))) - (loop (port-poll port mode poll-timeout-ms))) - poll-value)))) - - (parameterize - ((current-read-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-readable-operation port) - (wrap-operation - (sleep-operation read-timeout) - (lambda () - (raise-exception - (make-port-read-timeout-error thunk port)))))) - (no-fibers-wait port "r" read-timeout)))) - (current-write-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-writable-operation port) - (wrap-operation - (sleep-operation write-timeout) - (lambda () - (raise-exception - (make-port-write-timeout-error thunk port)))))) - (no-fibers-wait port "w" write-timeout))))) - (thunk))) - (define (spawn-port-monitoring-fiber port error-condition) (spawn-fiber (lambda () @@ -787,25 +176,10 @@ available. Return the resource once PROC has returned." port exn) (signal-condition! error-condition)) (lambda () - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (let ((sock (socket PF_INET SOCK_STREAM 0))) (connect sock AF_INET INADDR_LOOPBACK port) (close-port sock))) #:timeout 20)) #:unwind? #t))))) - -;; Copied from (fibers web server) -(define (call-with-sigint thunk cvar) - (let ((handler #f)) - (dynamic-wind - (lambda () - (set! handler - (sigaction SIGINT (lambda (sig) (signal-condition! cvar))))) - thunk - (lambda () - (if handler - ;; restore Scheme handler, SIG_IGN or SIG_DFL. - (sigaction SIGINT (car handler) (cdr handler)) - ;; restore original C handler. - (sigaction SIGINT #f)))))) diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm index e759fc8..473cc61 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -20,7 +20,10 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (json) + #:use-module (squee) #:use-module (fibers) + #:use-module (knots) + #:use-module (knots resource-pool) #:use-module (prometheus) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) @@ -123,21 +126,23 @@ (define (spawn-fiber-for-handler handler) (spawn-fiber (lambda () - (with-resource-from-pool (connection-pool) conn - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in build event handler: ~A\n" - exn)) - (lambda () - (with-throw-handler #t - (lambda () - (handler conn)) - (lambda _ - (display (backtrace) (current-error-port)) - (display "\n" (current-error-port))))) - #:unwind? #t))))) + (call-with-resource-from-pool (background-connection-pool) + (lambda (conn) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in build event handler: ~A\n" + exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (handler conn)))) + #:unwind? #t)) + #:timeout #f)))) (define (with-build-ids-for-status data build-ids @@ -218,6 +223,8 @@ (with-postgresql-transaction conn (lambda (conn) + (exec-query conn "SET LOCAL lock_timeout = '5s';") + (handle-derivation-events conn filtered-items)))))) @@ -270,8 +277,15 @@ (if (member provided-token (map cdr permitted-tokens) string=?) - (catch - 'json-invalid + (with-exception-handler + (lambda (exn) + (if (eq? (exception-kind exn) 'json-invalid) + (render-json + '((error . "could not parse body as JSON")) + #:code 400) + (render-json + '((error . "error")) + #:code 403))) (lambda () (let ((body-string (utf8->string body))) (let* ((body-json (json-string->scm body-string)) @@ -287,30 +301,27 @@ '((error . "no items to process")) #:code 400)) (else - (catch - #t + (with-exception-handler + (lambda (exn) + (render-json + '((error . "could not process events")) + #:code 500)) (lambda () - (process-items items) + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (simple-format (current-error-port) + "error processing events: ~A\n" + exn) + (for-each (lambda (item) + (simple-format (current-error-port) + " ~A\n" item)) + items)) + (lambda () + (process-items items))) (no-content)) - (lambda (key . args) - (simple-format (current-error-port) - "error processing events: ~A: ~A\n" - key - args) - (for-each (lambda (item) - (simple-format (current-error-port) - " ~A\n" item)) - items) - (render-json - '((error . "could not process events")) - #:code 500)))))))) - (lambda (key . args) - (render-json - '((error . "could not parse body as JSON")) - #:code 400))) - (render-json - '((error . "error")) - #:code 403))))))) + #:unwind? #t)))))) + #:unwind? #t))))))) (define (handle-signing-key-request id) (render-html diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm index bf77e03..7924dbb 100644 --- a/guix-data-service/web/build/controller.scm +++ b/guix-data-service/web/build/controller.scm @@ -18,6 +18,8 @@ (define-module (guix-data-service web build controller) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -41,7 +43,7 @@ (define parse-build-server (lambda (v) - (letpar& ((build-servers + (fibers-let ((build-servers (call-with-resource-from-pool (connection-pool) select-build-servers))) (or (any (match-lambda @@ -88,7 +90,7 @@ '())) (let ((system (assq-ref parsed-query-parameters 'system)) (target (assq-ref parsed-query-parameters 'target))) - (letpar& ((build-server-options + (fibers-let ((build-server-options (with-resource-from-pool (connection-pool) conn (map (match-lambda ((id url lookup-all-derivations diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index ebbf6df..dbb4975 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -24,6 +24,8 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (texinfo plain-text) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web sxml) @@ -229,7 +231,7 @@ (define (render-compare mime-types query-parameters) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((base-job + (fibers-let ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (with-resource-from-pool (connection-pool) conn @@ -275,7 +277,7 @@ #f #f #f))))) - (letpar& ((base-revision-id + (fibers-let ((base-revision-id (with-resource-from-pool (connection-pool) conn (commit->revision-id conn @@ -303,7 +305,7 @@ (version-changes (package-data-version-changes base-packages-vhash target-packages-vhash))) - (letpar& ((lint-warnings-data + (fibers-let ((lint-warnings-data (with-resource-from-pool (connection-pool) conn (group-list-by-first-n-fields 2 @@ -396,7 +398,7 @@ lint-warnings-data)))) #:extra-headers http-headers-for-unchanging-content)) (else - (letpar& ((lint-warnings-locale-options + (fibers-let ((lint-warnings-locale-options (map (match-lambda ((locale) @@ -449,7 +451,7 @@ (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) (locale (assq-ref query-parameters 'locale))) - (letpar& ((base-revision-details + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -624,7 +626,7 @@ '(application/json text/html) mime-types) ((application/json) - (letpar& ((base-job + (fibers-let ((base-job (and=> (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (and (string? value) value)) @@ -663,7 +665,7 @@ (base_job . ,base-job) (target_job . ,target-job))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -684,27 +686,33 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit)) - (systems (assq-ref query-parameters 'system)) + (systems (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems))) (targets (assq-ref query-parameters 'target)) (build-change (and=> (assq-ref query-parameters 'build_change) string->symbol)) (after-name (assq-ref query-parameters 'after_name)) (limit-results (assq-ref query-parameters 'limit_results))) - (letpar& ((data + (let ((data + (concatenate! + (fibers-map + (lambda (system) (with-resource-from-pool (connection-pool) conn (package-derivation-differences-data conn (commit->revision-id conn base-commit) (commit->revision-id conn target-commit) - #:systems systems + #:system system #:targets targets #:build-change build-change #:after-name after-name #:limit-results limit-results))) - (build-server-urls - (call-with-resource-from-pool (connection-pool) - select-build-server-urls-by-id))) + systems))) + (build-server-urls + (call-with-resource-from-pool (connection-pool) + select-build-server-urls-by-id))) (let ((names-and-versions (package-derivation-data->names-and-versions data))) (let-values @@ -725,9 +733,10 @@ (target . ((commit . ,target-commit))))) (derivation_changes - . ,derivation-changes)))) + . ,derivation-changes)) + #:stream? #t)) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -741,7 +750,8 @@ (valid-targets->options targets) build-status-strings build-server-urls - derivation-changes)))))))))))) + derivation-changes) + #:stream? #t))))))))))) (define (render-compare-by-datetime/package-derivations mime-types query-parameters) @@ -771,14 +781,16 @@ (base-datetime (assq-ref query-parameters 'base_datetime)) (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) - (systems (assq-ref query-parameters 'system)) + (systems (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems))) (targets (assq-ref query-parameters 'target)) (build-change (and=> (assq-ref query-parameters 'build_change) string->symbol)) (after-name (assq-ref query-parameters 'after_name)) (limit-results (assq-ref query-parameters 'limit_results))) - (letpar& + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -789,18 +801,20 @@ (select-guix-revision-for-branch-and-datetime conn target-branch target-datetime)))) - (letpar& - ((data - (with-resource-from-pool (connection-pool) conn - (package-derivation-differences-data - conn - (first base-revision-details) - (first target-revision-details) - #:systems systems - #:targets targets - #:build-change build-change - #:after-name after-name - #:limit-results limit-results)))) + (let ((data + (fibers-map + (lambda (system) + (with-resource-from-pool (connection-pool) conn + (package-derivation-differences-data + conn + (first base-revision-details) + (first target-revision-details) + #:system system + #:targets targets + #:build-change build-change + #:after-name after-name + #:limit-results limit-results))) + systems))) (let ((names-and-versions (package-derivation-data->names-and-versions data))) (let-values @@ -863,7 +877,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((base-job + (fibers-let ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (with-resource-from-pool (connection-pool) conn @@ -883,7 +897,7 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit))) - (letpar& ((base-revision-id + (fibers-let ((base-revision-id (with-resource-from-pool (connection-pool) conn (commit->revision-id conn @@ -932,7 +946,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls @@ -951,7 +965,7 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit)) (system (assq-ref query-parameters 'system))) - (letpar& ((data + (fibers-let ((data (with-resource-from-pool (connection-pool) conn (system-test-derivations-differences-data conn @@ -1002,7 +1016,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls @@ -1023,7 +1037,7 @@ (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) (system (assq-ref query-parameters 'system))) - (letpar& + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -1034,7 +1048,7 @@ (select-guix-revision-for-branch-and-datetime conn target-branch target-datetime)))) - (letpar& ((data + (fibers-let ((data (with-resource-from-pool (connection-pool) conn (system-test-derivations-differences-data conn diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm index 5b624d1..9f89b78 100644 --- a/guix-data-service/web/compare/html.scm +++ b/guix-data-service/web/compare/html.scm @@ -250,7 +250,7 @@ string<?))) (map (lambda (lang index) `(tr - ,@(if (eq? index 0) + ,@(if (= index 0) `((td (@ (rowspan ,(length languages))) ,(case change ((new) "New") diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index d503052..1c2c589 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -35,6 +35,9 @@ #:use-module (texinfo html) #:use-module (squee) #:use-module (json) + #:use-module (fibers) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (prometheus) #:use-module (guix-data-service utils) #:use-module (guix-data-service config) @@ -75,9 +78,13 @@ make-render-metrics controller + background-connection-pool connection-pool reserved-connection-pool)) +(define background-connection-pool + (make-parameter #f)) + (define connection-pool (make-parameter #f)) @@ -176,7 +183,8 @@ (resource-pools `(("normal" . ,(connection-pool)) - ("reserved" . ,(reserved-connection-pool)))) + ("reserved" . ,(reserved-connection-pool)) + ("background" . ,(background-connection-pool)))) (resource-pool-metrics `((resources . ,(make-gauge-metric @@ -229,7 +237,7 @@ #:always-rollback? #t)) (lambda () - (letpar& ((metric-values + (fibers-let ((metric-values (with-exception-handler (lambda (exn) (simple-format @@ -451,23 +459,23 @@ (write-metrics registry port)))))))) (define (render-derivation derivation-file-name) - (letpar& ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation + (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation-inputs + (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn (first derivation)))) (derivation-outputs - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-by-derivation-id conn (first derivation)))) (builds - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-builds-with-context-by-derivation-file-name conn (second derivation))))) @@ -486,11 +494,11 @@ (define (render-json-derivation derivation-file-name) (let ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs + (fibers-let ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn @@ -546,7 +554,7 @@ (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs + (fibers-let ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn @@ -591,12 +599,12 @@ #:sxml (view-narinfos narinfos))))) (define (render-store-item filename) - (letpar& ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation + (with-resource-from-pool (connection-pool) conn (select-derivation-by-output-filename conn filename)))) (match derivation (() - (match (with-resource-from-pool (reserved-connection-pool) conn + (match (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-by-store-path conn filename)) (() (render-html @@ -608,17 +616,17 @@ (render-html #:sxml (view-derivation-source-file filename - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-nar-details-by-file-name conn filename))) #:extra-headers http-headers-for-unchanging-content)))) (derivations - (letpar& ((nars - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((nars + (with-resource-from-pool (connection-pool) conn (select-nars-for-output conn filename))) (builds - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-builds-with-context-by-derivation-output conn filename)))) @@ -651,7 +659,7 @@ conn filename)))))))))) (derivations - (letpar& ((nars + (fibers-let ((nars (with-resource-from-pool (connection-pool) conn (select-nars-for-output conn filename)))) (render-json @@ -712,17 +720,9 @@ #:sxml (server-starting-up-page) #:code 503))) - (call-with-error-handling - (if startup-completed? - running-controller-thunk - startup-controller-thunk) - #:on-error 'backtrace - #:post-error (lambda args - (render-html #:sxml (error-page - (if (%show-error-details) - args - #f)) - #:code 500)))) + (if startup-completed? + (running-controller-thunk) + (startup-controller-thunk))) (define* (base-controller request method-and-path-components startup-completed?) @@ -803,7 +803,7 @@ (('GET) (render-html #:sxml (index - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (map (lambda (git-repository-details) (cons @@ -813,19 +813,8 @@ (all-git-repositories conn)))))) (('GET "builds") (delegate-to build-controller)) - (('GET "statistics") - (letpar& ((guix-revisions-count - (with-resource-from-pool (connection-pool) conn count-guix-revisions)) - (count-derivations - (with-resource-from-pool (connection-pool) conn count-derivations))) - - (render-html - #:sxml (view-statistics guix-revisions-count - count-derivations)))) (('GET "metrics") - (parameterize - ((resource-pool-default-timeout 6)) - (render-metrics))) + (render-metrics)) (('GET "revision" args ...) (delegate-to revision-controller)) (('GET "repositories") diff --git a/guix-data-service/web/jobs/controller.scm b/guix-data-service/web/jobs/controller.scm index 7e5084f..96621f9 100644 --- a/guix-data-service/web/jobs/controller.scm +++ b/guix-data-service/web/jobs/controller.scm @@ -17,6 +17,8 @@ (define-module (guix-data-service web jobs controller) #:use-module (ice-9 match) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -74,7 +76,7 @@ (define (render-jobs mime-types query-parameters) (define limit-results (assq-ref query-parameters 'limit_results)) - (letpar& ((jobs + (fibers-let ((jobs (with-resource-from-pool (connection-pool) conn (select-jobs-and-events conn diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm index e2ace7a..f7edac6 100644 --- a/guix-data-service/web/nar/controller.scm +++ b/guix-data-service/web/nar/controller.scm @@ -27,6 +27,8 @@ #:use-module (web uri) #:use-module (web request) #:use-module (web response) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix pki) #:use-module (guix base32) #:use-module (guix base64) @@ -155,7 +157,7 @@ #:code 200 #:headers '((content-type . (application/x-narinfo)))) (let ((derivation-file-name (second derivation))) - (letpar& + (fibers-let ((derivation-text (with-resource-from-pool (reserved-connection-pool) conn (select-serialized-derivation-by-file-name diff --git a/guix-data-service/web/package/controller.scm b/guix-data-service/web/package/controller.scm index 8dc6b0f..792394c 100644 --- a/guix-data-service/web/package/controller.scm +++ b/guix-data-service/web/package/controller.scm @@ -19,6 +19,8 @@ #:use-module (ice-9 match) #:use-module (web uri) #:use-module (web request) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -40,7 +42,7 @@ request `((system ,parse-system #:default "x86_64-linux") (target ,parse-target #:default ""))))) - (letpar& ((package-versions-with-branches + (fibers-let ((package-versions-with-branches (with-resource-from-pool (connection-pool) conn (branches-by-package-version conn name (assq-ref parsed-query-parameters diff --git a/guix-data-service/web/render.scm b/guix-data-service/web/render.scm index 744c66c..fee5daf 100644 --- a/guix-data-service/web/render.scm +++ b/guix-data-service/web/render.scm @@ -139,30 +139,41 @@ #f))) (define* (render-html #:key sxml (extra-headers '()) - (code 200)) + (code 200) + stream?) (list (build-response #:code code #:headers (append extra-headers '((content-type . (text/html (charset . "utf-8"))) (vary . (accept))))) - (call-with-encoded-output-string - "utf-8" - (lambda (port) - (sxml->html sxml port))))) + (if stream? + (lambda (port) + (set-port-encoding! port "utf-8") + (setvbuf port 'block (expt 2 20)) + (sxml->html sxml port)) + (call-with-encoded-output-string + "utf-8" + (lambda (port) + (sxml->html sxml port)))))) (define* (render-json json #:key (extra-headers '()) - (code 200)) + (code 200) + stream?) (list (build-response #:code code #:headers (append extra-headers '((content-type . (application/json (charset . "utf-8"))) (vary . (accept))))) - (call-with-encoded-output-string - "utf-8" - (lambda (port) - (scm->json json port))))) + (if stream? + (lambda (port) + (setvbuf port 'block (expt 2 16)) + (scm->json json port)) + (call-with-encoded-output-string + "utf-8" + (lambda (port) + (scm->json json port)))))) (define* (render-text text #:key (extra-headers '()) (code 200)) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index b77ca1f..ceb7b0c 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -19,6 +19,8 @@ #:use-module (ice-9 match) #:use-module (web uri) #:use-module (web request) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -47,7 +49,7 @@ (match method-and-path-components (('GET "repositories") - (letpar& ((git-repositories + (fibers-let ((git-repositories (call-with-resource-from-pool (connection-pool) all-git-repositories))) (case (most-appropriate-mime-type @@ -71,7 +73,7 @@ (match (with-resource-from-pool (connection-pool) conn (select-git-repository conn id)) ((label url cgit-url-base fetch-with-authentication? poll-interval) - (letpar& ((branches + (fibers-let ((branches (with-resource-from-pool (connection-pool) conn (all-branches-with-most-recent-commit conn @@ -119,7 +121,7 @@ `((after_date ,parse-datetime) (before_date ,parse-datetime) (limit_results ,parse-result-limit #:default 100))))) - (letpar& ((revisions + (fibers-let ((revisions (with-resource-from-pool (connection-pool) conn (most-recent-commits-for-branch conn @@ -160,7 +162,7 @@ parsed-query-parameters revisions))))))))) (('GET "repository" repository-id "branch" branch-name "package" package-name) - (letpar& ((package-versions + (fibers-let ((package-versions (with-resource-from-pool (connection-pool) conn (package-versions-for-branch conn (string->number repository-id) @@ -186,12 +188,18 @@ (datetime . ,last-datetime)))))) package-versions)))))) (else - (render-html - #:sxml (view-branch-package - repository-id - branch-name - package-name - package-versions)))))) + (if (null? package-versions) + (render-html + #:sxml (general-not-found + "Package or branch not found" + "") + #:code 404) + (render-html + #:sxml (view-branch-package + repository-id + branch-name + package-name + package-versions))))))) (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history") (render-branch-package-derivation-history request mime-types @@ -211,7 +219,7 @@ (parse-query-parameters request `((system ,parse-system #:default "x86_64-linux"))))) - (letpar& ((system-test-history + (fibers-let ((system-test-history (with-resource-from-pool (connection-pool) conn (system-test-derivations-for-branch conn @@ -256,7 +264,7 @@ valid-systems system-test-history))))))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -267,12 +275,13 @@ #:path-base path #:header-text `("Latest processed revision for branch " - (samp ,branch-name))) + (samp ,branch-name)) + #:max-age 60) (render-no-latest-revision mime-types repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -312,7 +321,7 @@ repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -421,7 +430,7 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "system-tests") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -439,7 +448,7 @@ repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -461,7 +470,7 @@ repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -475,7 +484,7 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "lint-warnings") - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -509,7 +518,7 @@ repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) - (letpar& ((commit-hash + (fibers-let ((commit-hash (with-resource-from-pool (connection-pool) conn (latest-processed-commit-for-branch conn repository-id @@ -582,7 +591,7 @@ (assq-ref parsed-query-parameters 'system)) (target (assq-ref parsed-query-parameters 'target))) - (letpar& + (fibers-let ((package-derivations (with-resource-from-pool (connection-pool) conn (package-derivations-for-branch conn @@ -619,7 +628,7 @@ . ,(list->vector builds))))) package-derivations)))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -656,7 +665,7 @@ (assq-ref parsed-query-parameters 'target)) (output-name (assq-ref parsed-query-parameters 'output))) - (letpar& + (fibers-let ((package-outputs (with-resource-from-pool (connection-pool) conn (package-outputs-for-branch conn @@ -694,7 +703,7 @@ . ,(list->vector builds))))) package-outputs)))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 114e9f4..b22fbed 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -24,6 +24,8 @@ #:use-module (texinfo html) #:use-module (texinfo plain-text) #:use-module (json) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -84,7 +86,7 @@ status)))) (define (parse-build-server v) - (letpar& ((build-servers + (fibers-let ((build-servers (call-with-resource-from-pool (connection-pool) select-build-servers))) (or (any (match-lambda @@ -395,7 +397,7 @@ `((unknown_commit . ,commit-hash)) #:code 404)) (else - (letpar& ((job + (fibers-let ((job (with-resource-from-pool (connection-pool) conn (select-job-for-commit conn commit-hash))) (git-repositories-and-branches @@ -423,7 +425,7 @@ `((unknown_commit . ,commit-hash)) #:code 404)) (else - (letpar& ((job + (fibers-let ((job (with-resource-from-pool (connection-pool) conn (select-job-for-commit conn commit-hash))) (git-repositories-and-branches @@ -446,8 +448,9 @@ commit-hash #:key path-base (header-text - `("Revision " (samp ,commit-hash)))) - (letpar& ((packages-count + `("Revision " (samp ,commit-hash))) + (max-age cache-control-default-max-age)) + (fibers-let ((packages-count (with-resource-from-pool (connection-pool) conn (count-packages-in-revision conn commit-hash))) (git-repositories-and-branches @@ -484,7 +487,10 @@ (network_dependent . ,(string=? network-dependent "t")) (count . ,(string->number count)))))) lint-warning-counts))) - #:extra-headers http-headers-for-unchanging-content)) + #:extra-headers + `((cache-control + . (public + (max-age . ,max-age)))))) (else (render-html #:sxml (view-revision @@ -496,7 +502,10 @@ lint-warning-counts #:path-base path-base #:header-text header-text) - #:extra-headers http-headers-for-unchanging-content))))) + #:extra-headers + `((cache-control + . (public + (max-age . ,max-age))))))))) (define* (render-revision-system-tests mime-types commit-hash @@ -507,7 +516,7 @@ `("Revision " (samp ,commit-hash))) (header-link (string-append "/revision/" commit-hash))) - (letpar& ((system-tests + (fibers-let ((system-tests (with-resource-from-pool (connection-pool) conn (select-system-tests-for-guix-revision conn @@ -535,7 +544,7 @@ (builds . ,(list->vector builds))))) system-tests)))))) (else - (letpar& ((git-repositories + (fibers-let ((git-repositories (with-resource-from-pool (connection-pool) conn (git-repositories-containing-commit conn commit-hash))) @@ -561,7 +570,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((channel-instances + (fibers-let ((channel-instances (with-resource-from-pool (connection-pool) conn (select-channel-instances-for-guix-revision conn commit-hash)))) (case (most-appropriate-mime-type @@ -589,7 +598,7 @@ (define* (render-revision-package-substitute-availability mime-types commit-hash #:key path-base) - (letpar& ((substitute-availability + (fibers-let ((substitute-availability (with-resource-from-pool (connection-pool) conn (select-package-output-availability-for-revision conn commit-hash))) @@ -635,7 +644,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((output-consistency + (fibers-let ((output-consistency (with-resource-from-pool (connection-pool) conn (select-output-consistency-for-revision conn commit-hash)))) (case (most-appropriate-mime-type @@ -669,7 +678,7 @@ #:sxml (view-revision-news commit-hash query-parameters '())))) - (letpar& ((news-entries + (fibers-let ((news-entries (with-resource-from-pool (connection-pool) conn (select-channel-news-entries-contained-in-guix-revision conn @@ -728,7 +737,7 @@ 99999)) ; TODO There shouldn't be a limit (fields (assq-ref query-parameters 'field)) (locale (assq-ref query-parameters 'locale))) - (letpar& + (fibers-let ((packages (with-resource-from-pool (connection-pool) conn (if search-query @@ -825,7 +834,7 @@ "/revision/" commit-hash)) (header-text `("Revision " (samp ,commit-hash)))) - (letpar& ((package-synopsis-counts + (fibers-let ((package-synopsis-counts (with-resource-from-pool (connection-pool) conn (synopsis-counts-by-locale conn (commit->revision-id @@ -865,7 +874,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((package-versions + (fibers-let ((package-versions (with-resource-from-pool (connection-pool) conn (select-package-versions-for-revision conn commit-hash @@ -922,7 +931,7 @@ (define has-replacement? (assq-ref query-parameters 'has_replacement)) - (letpar& ((metadata + (fibers-let ((metadata (with-resource-from-pool (connection-pool) conn (select-package-metadata-by-revision-name-and-version conn @@ -1034,7 +1043,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1060,10 +1069,10 @@ (assq-ref query-parameters 'search_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivations - (with-resource-from-pool (connection-pool) conn - (if search-query + (if search-query + (with-resource-from-pool (connection-pool) conn (search-package-derivations-in-revision conn commit-hash @@ -1081,24 +1090,31 @@ string->symbol) #:limit-results limit-results #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields)) - (select-package-derivations-in-revision - conn - commit-hash - #:systems (assq-ref query-parameters 'system) - #:targets (assq-ref query-parameters 'target) - #:maximum-builds (assq-ref query-parameters 'maximum_builds) - #:minimum-builds (assq-ref query-parameters 'minimum_builds) - #:build-from-build-servers (assq-ref query-parameters - 'build_from_build_server) - #:no-build-from-build-servers (assq-ref query-parameters - 'no_build_from_build_server) - #:build-status (and=> (assq-ref query-parameters - 'build_status) - string->symbol) - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields))))) + #:include-builds? (member "builds" fields))) + (concatenate! + (fibers-map + (lambda (system) + (with-resource-from-pool (connection-pool) conn + (select-package-derivations-in-revision + conn + commit-hash + #:system system + #:targets (assq-ref query-parameters 'target) + #:maximum-builds (assq-ref query-parameters 'maximum_builds) + #:minimum-builds (assq-ref query-parameters 'minimum_builds) + #:build-from-build-servers (assq-ref query-parameters + 'build_from_build_server) + #:no-build-from-build-servers (assq-ref query-parameters + 'no_build_from_build_server) + #:build-status (and=> (assq-ref query-parameters + 'build_status) + string->symbol) + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:include-builds? (member "builds" fields)))) + (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems)))))) (build-server-urls (call-with-resource-from-pool (connection-pool) select-build-server-urls-by-id))) @@ -1132,9 +1148,10 @@ `((target . ,target)) '()) (builds . ,builds)))) - derivations)))))) + derivations)))) + #:stream? #t)) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1172,7 +1189,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1198,7 +1215,7 @@ (assq-ref query-parameters 'search_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivations (with-resource-from-pool (connection-pool) conn (select-fixed-output-package-derivations-in-revision @@ -1227,7 +1244,7 @@ (render-json `((derivations . ,(list->vector derivations))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1269,7 +1286,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1293,7 +1310,7 @@ (assq-ref query-parameters 'all_results)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivation-outputs (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-in-revision @@ -1366,16 +1383,16 @@ (build-server-count (length build-servers))) (cond - ((or (eq? hash-count 0) - (eq? build-server-count 1)) + ((or (= hash-count 0) + (= build-server-count 1)) "unknown") - ((eq? hash-count 1) + ((= hash-count 1) "matching") ((> hash-count 1) "not-matching"))))))) derivation-outputs)))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1404,7 +1421,7 @@ (header-link (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1422,7 +1439,7 @@ '()))) (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1477,7 +1494,7 @@ (header-link (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1494,7 +1511,7 @@ '()))) (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1577,7 +1594,7 @@ (linters (assq-ref query-parameters 'linter)) (message-query (assq-ref query-parameters 'message_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((git-repositories (with-resource-from-pool (connection-pool) conn (git-repositories-containing-commit conn diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 0b9d4f5..412eb6e 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -22,6 +22,7 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (json) + #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) #:use-module (guix-data-service web util) #:use-module (guix-data-service web html-utils) @@ -271,7 +272,7 @@ git-repositories))) '()) ,@(if (> (vector-length licenses) 0) - `((dt ,(if (eq? (vector-length licenses) 1) + `((dt ,(if (= (vector-length licenses) 1) "License" "Licenses")) (dd (ul @@ -2042,7 +2043,7 @@ figure { (td (dl ,@(if - (null? hash-algorithm) + (NULL? hash-algorithm) (append-map (match-lambda ((hash . nars) @@ -2081,10 +2082,10 @@ figure { (build-server-count (length build-servers))) (cond - ((or (eq? hash-count 0) - (eq? build-server-count 1)) + ((or (= hash-count 0) + (= build-server-count 1)) "Unknown") - ((eq? hash-count 1) + ((= hash-count 1) '(span (@ (class "text-success")) "Matching")) ((> hash-count 1) diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index 6e91809..2fd26f5 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -19,22 +19,29 @@ (define-module (guix-data-service web server) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (web http) #:use-module (web request) #:use-module (web uri) #:use-module (system repl error-handling) #:use-module (ice-9 atomic) #:use-module (fibers) + #:use-module (fibers channels) #:use-module (fibers scheduler) #:use-module (fibers conditions) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) + #:use-module (knots) + #:use-module (knots web-server) + #:use-module (knots thread-pool) + #:use-module (knots resource-pool) #:use-module (prometheus) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web controller) #:use-module (guix-data-service web util) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web view html) #:use-module (guix-data-service model guix-revision-package-derivation) #:export (%guix-data-service-metrics-registry @@ -94,9 +101,38 @@ (%guix-data-service-metrics-registry registry) - (let ((finished? (make-condition))) + (let ((finished? (make-condition)) + (priority-scheduler #f) + (request-scheduler #f)) (call-with-sigint (lambda () + (call-with-new-thread + (lambda () + (run-fibers + (lambda () + (let* ((current (current-scheduler)) + (schedulers + (cons current (scheduler-remote-peers current)))) + + (set! priority-scheduler current) + + (for-each + (lambda (i sched) + (spawn-fiber + (lambda () + (catch 'system-error + (lambda () + (set-thread-name + (string-append "priority " (number->string i)))) + (const #t))) + sched)) + (iota (length schedulers)) + schedulers)) + + (wait finished?)) + #:hz 0 + #:parallelism 1))) + (run-fibers (lambda () (let* ((current (current-scheduler)) @@ -109,88 +145,166 @@ (catch 'system-error (lambda () (set-thread-name - (string-append "fibers " (number->string i)))) + (string-append "server " (number->string i)))) (const #t))) sched)) (iota (length schedulers)) schedulers)) - (parameterize - ((connection-pool - (make-resource-pool - (lambda () - (open-postgresql-connection - "web" - postgresql-statement-timeout)) - (floor (/ postgresql-connections 2)) - #:idle-seconds 30 - #:destructor - (lambda (conn) - (close-postgresql-connection conn "web")))) - - (reserved-connection-pool - (make-resource-pool - (lambda () - (open-postgresql-connection - "web-reserved" - postgresql-statement-timeout)) - (floor (/ postgresql-connections 2)) - #:idle-seconds 600 - #:destructor - (lambda (conn) - (close-postgresql-connection conn "web-reserved")))) - - (resource-pool-default-timeout 5)) - - (let ((resource-pool-checkout-failures-metric - (make-counter-metric registry - "resource_pool_checkout_timeouts_total" - #:labels '(pool_name)))) - (%resource-pool-timeout-handler - (lambda (pool proc timeout) - (let ((pool-name - (cond - ((eq? pool (connection-pool)) "normal") - ((eq? pool (reserved-connection-pool)) "reserved") - (else #f)))) - (when pool-name - (metric-increment - resource-pool-checkout-failures-metric - #:label-values `((pool_name . ,pool-name)))))))) - - (spawn-fiber - (lambda () - (with-resource-from-pool (connection-pool) conn - (backfill-guix-revision-package-derivation-distribution-counts - conn)))) - - (let ((render-metrics - (make-render-metrics registry)) - (requests-metric - (make-counter-metric registry "requests_total"))) - - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "\n + (while (not priority-scheduler) + (sleep 0.1)) + + (let ((requests-metric + (make-counter-metric registry "requests_total"))) + + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "\n error: guix-data-service could not start: ~A Check if it's already running, or whether another process is using that port. Also, the port used can be changed by passing the --port option.\n" - exn) - (primitive-exit 1)) - (lambda () - (run-server/patched - (lambda (request body) - (metric-increment requests-metric) - - (handler request finished? body controller - secret-key-base - startup-completed - render-metrics)) - #:host host - #:port port)) + exn) + (primitive-exit 1)) + (lambda () + (parameterize + ((background-connection-pool + (make-resource-pool + (lambda () + (open-postgresql-connection + "background" + postgresql-statement-timeout)) + 4 + #:name "background" + #:idle-seconds 5 + #:destructor + (lambda (conn) + (close-postgresql-connection conn "background")) + #:scheduler priority-scheduler)) + + (connection-pool + (make-resource-pool + (lambda () + (open-postgresql-connection + "web" + postgresql-statement-timeout)) + (floor (/ postgresql-connections 2)) + #:name "web" + #:idle-seconds 30 + #:destructor + (lambda (conn) + (close-postgresql-connection conn "web")) + #:scheduler priority-scheduler)) + + (reserved-connection-pool + (make-resource-pool + (lambda () + (open-postgresql-connection + "web-reserved" + postgresql-statement-timeout)) + (floor (/ postgresql-connections 2)) + #:name "web-reserved" + #:idle-seconds 600 + #:destructor + (lambda (conn) + (close-postgresql-connection conn "web-reserved")) + #:default-checkout-timeout 6 + #:scheduler priority-scheduler))) + + (let ((resource-pool-checkout-failures-metric + (make-counter-metric registry + "resource_pool_checkout_timeouts_total" + #:labels '(pool_name)))) + (resource-pool-default-timeout-handler + (lambda (pool proc timeout) + (let ((pool-name + (cond + ((eq? pool (connection-pool)) "normal") + ((eq? pool (reserved-connection-pool)) "reserved") + (else #f)))) + (when pool-name + (metric-increment + resource-pool-checkout-failures-metric + #:label-values `((pool_name . ,pool-name)))))))) + + (spawn-fiber + (lambda () + (while (not (check-startup-completed startup-completed)) + (sleep 1)) + + (with-resource-from-pool (background-connection-pool) conn + (backfill-guix-revision-package-derivation-distribution-counts + conn))) + #:parallel? #t) + + (let ((render-metrics (make-render-metrics registry))) + (run-knots-web-server + (lambda (request) + (with-exception-handler + (lambda (exn) + (when (resource-pool-timeout-error? exn) + (spawn-fiber + (lambda () + (let* ((pool (resource-pool-timeout-error-pool exn)) + (stats (resource-pool-stats pool))) + (simple-format (current-error-port) + "resource pool timeout error: ~A, ~A\n" + pool + stats))))) + + (let ((path-components + mime-types + (request->path-components-and-mime-type request))) + (case (most-appropriate-mime-type + mime-types + '(text/html application/json)) + ((application/json) + (apply + values + (render-json `((error . ,(if (%show-error-details) + (simple-format #f "~A" exn) + #f))) + #:code 500))) + (else + (apply + values + (render-html #:sxml (error-page + (if (%show-error-details) + exn + #f)) + #:code 500)))))) + (lambda () + (with-exception-handler + (lambda (exn) + (let* ((error-string + (call-with-output-string + (lambda (port) + (simple-format + port + "exception when processing: ~A ~A\n" + (request-method request) + (uri-path (request-uri request))) + (print-backtrace-and-exception/knots + exn + #:port port))))) + (display error-string + (current-error-port))) + + (raise-exception exn)) + (lambda () + (metric-increment requests-metric) + + (let ((body (read-request-body request))) + (handler request finished? body controller + secret-key-base + startup-completed + render-metrics))))) + #:unwind? #t)) + #:connection-buffer-size (expt 2 16) + #:host host + #:port port))) #:unwind? #t))) ;; Guile sometimes just seems to stop listening on the port, so try @@ -198,5 +312,6 @@ port. Also, the port used can be changed by passing the --port option.\n" (spawn-port-monitoring-fiber port finished?) (wait finished?)) + #:hz 0 #:parallelism 4)) finished?))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index ab09644..480b066 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -43,7 +43,6 @@ index readme general-not-found - view-statistics view-builds view-derivation view-formatted-derivation @@ -305,10 +304,6 @@ (style "margin-top: 1.3rem;") (role "group")) (a (@ (class "btn btn-lg btn-default") - (href "/statistics") - (role "button")) - "Statistics") - (a (@ (class "btn btn-lg btn-default") (href "/jobs") (role "button")) "Jobs")))) @@ -335,30 +330,6 @@ branches-with-most-recent-commits))))))) git-repositories-and-revisions))))) -(define (view-statistics guix-revisions-count derivations-count) - (define page-header "Statistics") - (layout - #:title - page-header - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-md-6")) - (h3 "Guix revisions") - (strong (@ (class "text-center") - (style "font-size: 2em; display: block;")) - ,guix-revisions-count)) - (div - (@ (class "col-md-6")) - (h3 "Derivations") - (strong (@ (class "text-center") - (style "font-size: 2em; display: block;")) - ,derivations-count))))))) - (define (table/branches-with-most-recent-commits git-repository-id branches-with-most-recent-commits) `(table @@ -752,9 +723,9 @@ (or hash-algorithm "")) "\"" "," - "\"" ,hash "\"" + "\"" ,(or hash "") "\"" ")" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(","))))) derivation-outputs @@ -792,7 +763,7 @@ ",") "]" ")" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(","))))) derivation-inputs @@ -818,7 +789,7 @@ (a (@ (href ,source)) ,(display-store-item source)) "\"" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(",")))) derivation-sources @@ -879,7 +850,7 @@ `(div "\"" ,(display-possible-store-item arg) "\"" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(",")))) args @@ -998,10 +969,7 @@ (h1 "An error occurred") (p "Sorry about that!") ,@(if error - (match error - ((key . args) - `((b ,key) - (pre ,args)))) + `((pre ,error)) '()))))) (define* (server-starting-up-page) diff --git a/guix-dev.scm b/guix-dev.scm index 8d33657..7226227 100644 --- a/guix-dev.scm +++ b/guix-dev.scm @@ -41,6 +41,39 @@ (gnu packages ruby) (srfi srfi-1)) +(define guile-knots + (let ((commit "c641c19ce42876b16186ea82f3803a56a43a5f91") + (revision "1")) + (package + (name "guile-knots") + (version (git-version "0" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://git.cbaines.net/git/guile/knots") + (commit commit))) + (sha256 + (base32 + "1lnijs8cdifajy7n63v5cvhj5pd0abfxb0rj07mr67ihd4829d3d")) + (file-name (string-append name "-" version "-checkout")))) + (build-system gnu-build-system) + (native-inputs + (list pkg-config + autoconf + automake + guile-3.0 + guile-lib + guile-fibers)) + (inputs + (list guile-3.0)) + (propagated-inputs + (list guile-fibers)) + (home-page "https://git.cbaines.net/guile/knots") + (synopsis "Patterns and functionality to use with Guile Fibers") + (description + "") + (license license:gpl3+)))) + (package (name "guix-data-service") (version "0.0.0") @@ -52,6 +85,7 @@ guile-json-4 guile-squee guile-fibers + guile-knots guile-gcrypt guile-lzlib guile-readline diff --git a/scripts/guix-data-service-process-branch-updated-email.in b/scripts/guix-data-service-process-branch-updated-email.in index d8f6196..a0e97ae 100644 --- a/scripts/guix-data-service-process-branch-updated-email.in +++ b/scripts/guix-data-service-process-branch-updated-email.in @@ -27,6 +27,7 @@ (rnrs bytevectors) (squee) (email email) + (knots) (guix-data-service database) (guix-data-service branch-updated-emails)) @@ -35,20 +36,17 @@ (lambda (conn) (let* ((email-bytevector (get-bytevector-all (current-input-port)))) - (catch - #t + (with-exception-handler + (lambda _ #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (display "\nerror: while parsing email\n" + (current-error-port)) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (enqueue-job-for-email conn - (parse-email email-bytevector))) - (lambda (key . args) - (display "\nerror: while parsing email\n" - (current-error-port)) - (simple-format (current-error-port) - "~A: ~A\n\n" - key - args) - (display-backtrace (make-stack #t) (current-error-port))))) - (lambda (key . args) #f))))) + (parse-email email-bytevector))))) + #:unwind? #t)))) diff --git a/scripts/guix-data-service-process-branch-updated-mbox.in b/scripts/guix-data-service-process-branch-updated-mbox.in index 0a79f40..5773341 100644 --- a/scripts/guix-data-service-process-branch-updated-mbox.in +++ b/scripts/guix-data-service-process-branch-updated-mbox.in @@ -27,6 +27,7 @@ (rnrs bytevectors) (squee) (email email) + (knots) (guix-data-service database) (guix-data-service model git-repository) (guix-data-service branch-updated-emails)) @@ -36,7 +37,7 @@ (lambda (conn) (let ((count (count-git-repositories-with-x-git-repo-header-values conn))) - (when (eq? count 0) + (when (= count 0) (display "\nerror: no git_repositories exist with a value for x_git_repo_header error: to match emails to repositories, the git_repositories entry must have @@ -52,23 +53,21 @@ a x_git_repo_header value\n" (for-each (lambda (email-bytevector) (display "." (current-error-port)) - (catch - #t + (with-exception-handler + (lambda (exn) + #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (display "\nerror: while parsing email\n" + (current-error-port)) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (enqueue-job-for-email conn - (parse-email email-bytevector))) - (lambda (key . args) - (display "\nerror: while parsing email\n" - (current-error-port)) - (simple-format (current-error-port) - "~A: ~A\n\n" - key - args) - (display-backtrace (make-stack #t) (current-error-port))))) - (lambda (key . args) #f))) + (parse-email email-bytevector))))) + #:unwind? #t)) (call-with-input-file file mbox->emails)) diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in index df6142e..5643246 100644 --- a/scripts/guix-data-service-process-job.in +++ b/scripts/guix-data-service-process-job.in @@ -51,10 +51,27 @@ (alist-cons 'parallelism (string->number arg) (alist-delete 'parallelism - result)))))) + result)))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) + result))) + (option '("ignore-systems") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-systems + (string-split arg #\,) + result))) + (option '("ignore-targets") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-targets + (string-split arg #\,) + result))))) (define %default-options - '((parallelism . 1))) + '((parallelism . 1) + (ignore-systems . ()) + (ignore-targets . ()))) (define (parse-options args) (args-fold @@ -79,6 +96,15 @@ (process-load-new-guix-revision-job job #:skip-system-tests? (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) + #:ignore-systems (assq-ref opts 'ignore-systems) + #:ignore-targets (assq-ref opts 'ignore-targets) #:parallelism (assq-ref opts 'parallelism))) #:hz 0 #:parallelism 1))))) diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in index ae1542c..ede8581 100644 --- a/scripts/guix-data-service-process-jobs.in +++ b/scripts/guix-data-service-process-jobs.in @@ -24,6 +24,8 @@ (use-modules (srfi srfi-1) (srfi srfi-37) + (ice-9 match) + (knots) (guix-data-service database) (guix-data-service jobs)) @@ -49,12 +51,42 @@ (lambda (opt name arg result) (alist-cons 'per-job-parallelism (string->number arg) + result))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) + result))) + (option '("free-space-requirement") #t #f + (lambda (opt name arg result) + (alist-cons 'free-space-requirement + (string->number arg) + result))) + (option '("ignore-systems") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-systems + (string-split arg #\,) + result))) + (option '("ignore-targets") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-targets + (string-split arg #\,) + result))) + (option '("timeout") #t #f + (lambda (opt name arg result) + (alist-cons 'timeout + (string->number arg) result))))) + (define %default-options ;; Alist of default option values `((max-processes . ,default-max-processes) - (per-job-parallelism . 1))) + (per-job-parallelism . 1) + (ignore-systems . ()) + (ignore-targets . ()) + (timeout . ,(* (* 60 60) ;; 1 hour in seconds + 72)))) (define (parse-options args) (args-fold @@ -79,24 +111,34 @@ (simple-format #t "Ready to process jobs...\n") (with-exception-handler (lambda (exn) - (simple-format - (current-error-port) - "exception: ~A\n" - exn) (exit 1)) (lambda () - (with-throw-handler #t - (lambda () - (process-jobs - conn - #:max-processes (assq-ref opts 'max-processes) - #:latest-branch-revision-max-processes - (or (assq-ref opts 'latest-branch-revision-max-processes) - (* 2 (assq-ref opts 'max-processes))) - #:skip-system-tests? - (assq-ref opts 'skip-system-tests) - #:per-job-parallelism - (assq-ref opts 'per-job-parallelism))) - (lambda _ - (backtrace)))) + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (process-jobs + conn + #:max-processes (assq-ref opts 'max-processes) + #:latest-branch-revision-max-processes + (or (assq-ref opts 'latest-branch-revision-max-processes) + (* 2 (assq-ref opts 'max-processes))) + #:skip-system-tests? + (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) + #:per-job-parallelism + (assq-ref opts 'per-job-parallelism) + #:ignore-systems (assq-ref opts 'ignore-systems) + #:ignore-targets (assq-ref opts 'ignore-targets) + #:free-space-requirement + (assq-ref opts 'free-space-requirement) + #:timeout + (assq-ref opts 'timeout))))) #:unwind? #t)))) diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 8a124ee..238483d 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -137,13 +137,13 @@ (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) +(unless (getenv "COLUMNS") + (setenv "COLUMNS" "128")) + (let ((opts (parse-options (cdr (program-arguments))))) (when (assq-ref opts 'repl) ((@@ (ice-9 top-repl) call-with-sigint) - (lambda () - (with-postgresql-connection-per-thread - "repl" - start-repl))) + start-repl) (exit 0)) (let ((repl-port (assoc-ref opts 'listen-repl))) @@ -197,7 +197,7 @@ (lambda (port) (simple-format port "~A\n" (getpid))))) - (start-substitute-query-threads) + (start-substitute-query-threads startup-completed) (call-with-new-thread (lambda () diff --git a/sqitch/deploy/alter_build_servers_id_default.sql b/sqitch/deploy/alter_build_servers_id_default.sql new file mode 100644 index 0000000..7d4b8c6 --- /dev/null +++ b/sqitch/deploy/alter_build_servers_id_default.sql @@ -0,0 +1,13 @@ +-- Deploy guix-data-service:alter_build_servers_id_default to pg + +BEGIN; + +ALTER TABLE build_servers + ALTER COLUMN id + DROP identity; + +ALTER TABLE build_servers + ALTER COLUMN id + ADD generated by default as identity; + +COMMIT; diff --git a/sqitch/deploy/build_server_build_id_index.sql b/sqitch/deploy/build_server_build_id_index.sql new file mode 100644 index 0000000..7bd32c6 --- /dev/null +++ b/sqitch/deploy/build_server_build_id_index.sql @@ -0,0 +1,7 @@ +-- Deploy guix-data-service:build_server_build_id_index to pg + +BEGIN; + +CREATE INDEX builds_build_server_build_id ON builds (build_server_build_id); + +COMMIT; diff --git a/sqitch/revert/alter_build_servers_id_default.sql b/sqitch/revert/alter_build_servers_id_default.sql new file mode 100644 index 0000000..eddb3d1 --- /dev/null +++ b/sqitch/revert/alter_build_servers_id_default.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:alter_build_servers_id_default from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/revert/build_server_build_id_index.sql b/sqitch/revert/build_server_build_id_index.sql new file mode 100644 index 0000000..2d30c11 --- /dev/null +++ b/sqitch/revert/build_server_build_id_index.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:build_server_build_id_index from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index 14232e3..666f6de 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -98,3 +98,5 @@ cascade_nar_foreign_keys 2023-08-01T09:42:33Z Chris <chris@felis> # Make it easi nar_indexes 2023-08-01T11:37:35Z Chris <chris@felis> # Add nar related indexes git_repositories_poll_interval 2023-10-08T20:36:09Z Chris <chris@felis> # Add git_repositories.poll_interval git_repositories_job_priority 2024-03-07T09:39:27Z Chris <chris@felis> # Add git_repositories.job_priority +build_server_build_id_index 2024-09-07T17:42:28Z Chris <chris@felis> # Add index on builds.build_server_build_id +alter_build_servers_id_default 2024-12-15T20:48:51Z Chris <chris@fang> # Alter build_servers id default diff --git a/sqitch/verify/alter_build_servers_id_default.sql b/sqitch/verify/alter_build_servers_id_default.sql new file mode 100644 index 0000000..55a83ed --- /dev/null +++ b/sqitch/verify/alter_build_servers_id_default.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:alter_build_servers_id_default on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; diff --git a/sqitch/verify/build_server_build_id_index.sql b/sqitch/verify/build_server_build_id_index.sql new file mode 100644 index 0000000..28eceb2 --- /dev/null +++ b/sqitch/verify/build_server_build_id_index.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:build_server_build_id_index on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm index 1a64ce3..64f2464 100644 --- a/tests/jobs-load-new-guix-revision.scm +++ b/tests/jobs-load-new-guix-revision.scm @@ -2,6 +2,7 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match) #:use-module (squee) + #:use-module (fibers) #:use-module (guix utils) #:use-module (guix store) #:use-module (guix tests) @@ -44,9 +45,9 @@ (mock ((guix-data-service jobs load-new-guix-revision) channel->source-and-derivations-by-system - (lambda* (conn store channel fetch-with-authentication? - #:key parallelism) - (cons + (lambda* (conn channel fetch-with-authentication? + #:key parallelism ignore-systems) + (values "/gnu/store/guix" '(("x86_64-linux" . @@ -56,16 +57,14 @@ (mock ((guix-data-service jobs load-new-guix-revision) channel-derivations-by-system->guix-store-item - (lambda (store channel-derivations-by-system) - "/gnu/store/test")) + (lambda (channel-derivations-by-system) + (values "/gnu/store/test" + "/gnu/store/test.drv"))) (mock ((guix-data-service jobs load-new-guix-revision) extract-information-from - (lambda* (conn store guix-revision-id commit - guix-source store-path - #:key skip-system-tests? - parallelism) + (lambda _ #t)) (mock @@ -80,6 +79,12 @@ (lambda (channel commit) '())) + (mock + ((guix-data-service jobs load-new-guix-revision) + derivation-file-names->derivation-ids + (lambda _ + #(1))) + (mock ((guix store) add-temp-root @@ -92,125 +97,20 @@ (match (enqueue-load-new-guix-revision-job conn - (git-repository-url->git-repository-id conn "test-url") + (git-repository-url->git-repository-id conn "test-url3") "test-commit" "test-source") ((id) - (process-load-new-guix-revision-job id))))))))))))) + (run-fibers + (lambda () + (process-load-new-guix-revision-job + id #:parallelism 1)) + #:hz 0 + #:parallelism 1)))))))))))))) (exec-query conn "TRUNCATE guix_revisions CASCADE") (exec-query conn "TRUNCATE load_new_guix_revision_jobs CASCADE") - (test-equal "test build store item failure" - #f - (mock - ((guix-data-service jobs load-new-guix-revision) - with-store-connection - (lambda (f) - (f 'fake-store-connection))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - channel->source-and-derivations-by-system - (lambda (conn store channel fetch-with-authentication?) - (cons - "/gnu/store/guix" - '(("x86_64-linux" - . - ((manifest-entry-item . "/gnu/store/foo.drv") - (profile . "/gnu/store/bar.drv"))))))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - load-channel-instances - (lambda (git-repository-id commit - channel-derivations-by-system) - 0)) - - (mock - ((guix-data-service jobs load-new-guix-revision) - setup-logging - (lambda (conn thunk) - (thunk))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - channel-derivations-by-system->guix-store-item - (lambda (store channel-derivations-by-system) - #f)) - - (match (enqueue-load-new-guix-revision-job - conn - (git-repository-url->git-repository-id conn "test-url") - "test-commit" - "test-source") - ((id) - (process-load-new-guix-revision-job id))))))))) - - (exec-query conn "TRUNCATE load_new_guix_revision_jobs CASCADE") - - (test-equal "test extract information failure" - #f - (mock - ((guix-data-service jobs load-new-guix-revision) - with-store-connection - (lambda (f) - (f 'fake-store-connection))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - channel->source-and-derivations-by-system - (lambda (conn store channel fetch-with-authentication?) - (cons - "/gnu/store/guix" - '(("x86_64-linux" - . - ((manifest-entry-item . "/gnu/store/foo.drv") - (profile . "/gnu/store/bar.drv"))))))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - load-channel-instances - (lambda (git-repository-id commit - channel-derivations-by-system) - 0)) - - (mock - ((guix-data-service jobs load-new-guix-revision) - setup-logging - (lambda (conn thunk) - (thunk))) - - (mock - ((guix-data-service jobs load-new-guix-revision) - channel-derivations-by-system->guix-store-item - (lambda (store channel-derivations-by-system) - "/gnu/store/test")) - - (mock - ((guix-data-service jobs load-new-guix-revision) - extract-information-from - (lambda* (conn store git-repository-id commit - guix-source store-path - #:key skip-system-tests?) - #f)) - - (mock - ((guix channels) - channel-news-for-commit - (lambda (channel commit) - '())) - - (match (enqueue-load-new-guix-revision-job - conn - (git-repository-url->git-repository-id conn "test-url") - "test-commit" - "test-source") - ((id) - (process-load-new-guix-revision-job id))))))))))) - - (exec-query conn "TRUNCATE load_new_guix_revision_jobs CASCADE") - (test-assert "test duplicate job handling" (with-postgresql-transaction conn diff --git a/tests/model-git-branch.scm b/tests/model-git-branch.scm index 1bcc1c3..5c2dfe8 100644 --- a/tests/model-git-branch.scm +++ b/tests/model-git-branch.scm @@ -16,7 +16,7 @@ (with-postgresql-transaction conn (lambda (conn) - (let* ((url "test-url") + (let* ((url "test-url4") (git-repository-id (git-repository-url->git-repository-id conn url))) (insert-git-branch-entry conn git-repository-id "master") diff --git a/tests/model-git-commit.scm b/tests/model-git-commit.scm index b8bc3d8..ef4f535 100644 --- a/tests/model-git-commit.scm +++ b/tests/model-git-commit.scm @@ -17,7 +17,7 @@ (with-postgresql-transaction conn (lambda (conn) - (let* ((url "test-url") + (let* ((url "test-url5") (git-repository-id (git-repository-url->git-repository-id conn url)) (git-branch-id @@ -33,7 +33,7 @@ (with-postgresql-transaction conn (lambda (conn) - (let* ((url "test-url") + (let* ((url "test-url2") (git-repository-id (git-repository-url->git-repository-id conn url)) (git-branch-id diff --git a/tests/model-git-repository.scm b/tests/model-git-repository.scm index ca43c59..8f40778 100644 --- a/tests/model-git-repository.scm +++ b/tests/model-git-repository.scm @@ -22,7 +22,7 @@ #t))) #:always-rollback? #t)) - (let* ((url "test-url") + (let* ((url "test-url6") (id (git-repository-url->git-repository-id conn url))) (with-postgresql-transaction conn diff --git a/tests/model-license-set.scm b/tests/model-license-set.scm index 1b377b7..38a86de 100644 --- a/tests/model-license-set.scm +++ b/tests/model-license-set.scm @@ -9,15 +9,15 @@ (test-begin "test-model-license-set") (define license-data - '((("License 1" - "https://gnu.org/licenses/test-1.html" - "https://example.com/why-license-1")) - (("License 1" - "https://gnu.org/licenses/test-1.html" - #f) - ("License 2" - #f - #f)))) + '#((("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" + #f) + ("License 2" + #f + #f)))) (with-postgresql-connection "test-model-license-set" diff --git a/tests/model-license.scm b/tests/model-license.scm index 32b5623..e34b4f8 100644 --- a/tests/model-license.scm +++ b/tests/model-license.scm @@ -8,18 +8,18 @@ (test-begin "test-model-license") (define license-data - '((("License 1" - "https://gnu.org/licenses/test-1.html" - "https://example.com/why-license-1")) - (("License 1" - "https://gnu.org/licenses/test-1.html" - #f) - ("License 2" - "https://gnu.org/licenses/test-2.html" - #f) - ("License 3" - #f - #f)))) + '#((("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" + #f) + ("License 2" + "https://gnu.org/licenses/test-2.html" + #f) + ("License 3" + #f + #f)))) (with-postgresql-connection "test-model-license" diff --git a/tests/model-lint-checker.scm b/tests/model-lint-checker.scm index e6740b1..73ac405 100644 --- a/tests/model-lint-checker.scm +++ b/tests/model-lint-checker.scm @@ -16,32 +16,23 @@ conn (lambda (conn) (define data - `((name-1 #t ,(string->number (insert-lint-checker-description-set - conn '(37)))) - (name-2 #f ,(string->number (insert-lint-checker-description-set - conn '(38)))))) + `#((name-1 + #t + ,(lint-checker-description-data->lint-checker-description-set-id + conn + '(("en_US" . "foo")))) + (name-2 + #f + ,(lint-checker-description-data->lint-checker-description-set-id + conn + '(("en_US" . "bar")))))) (match (lint-checkers->lint-checker-ids conn data) - (((? number? id1) (? number? id2)) - #t))) - #:always-rollback? #t)) - - (test-assert "double insert" - (with-postgresql-transaction - conn - (lambda (conn) - (define data - `((name-1 #t ,(string->number (insert-lint-checker-description-set - conn '(37)))) - (name-2 #f ,(string->number (insert-lint-checker-description-set - conn '(38)))))) - - (match (lint-checkers->lint-checker-ids conn data) - (((? number? id1) (? number? id2)) + (#((? number? id1) (? number? id2)) (match (lint-checkers->lint-checker-ids conn data) - (((? number? second-id1) (? number? second-id2)) - (and (eq? id1 second-id1) - (eq? id2 second-id2))))))) + (#((? number? second-id1) (? number? second-id2)) + (and (= id1 second-id1) + (= id2 second-id2))))))) #:always-rollback? #t)))) (test-end) diff --git a/tests/model-lint-warning-message.scm b/tests/model-lint-warning-message.scm index 7231a34..88cedd1 100644 --- a/tests/model-lint-warning-message.scm +++ b/tests/model-lint-warning-message.scm @@ -20,7 +20,7 @@ conn (lambda (conn) (match (lint-warning-message-data->lint-warning-message-ids conn data) - (((? number? id1) (? number? id2)) + (#((? number? id1) (? number? id2)) #t))) #:always-rollback? #t)) @@ -29,11 +29,11 @@ conn (lambda (conn) (match (lint-warning-message-data->lint-warning-message-ids conn data) - (((? number? id1) (? number? id2)) + (#((? number? id1) (? number? id2)) (match (lint-warning-message-data->lint-warning-message-ids conn data) - (((? number? second-id1) (? number? second-id2)) - (and (eq? id1 second-id1) - (eq? id2 second-id2))))))) + (#((? number? second-id1) (? number? second-id2)) + (and (= id1 second-id1) + (= id2 second-id2))))))) #:always-rollback? #t)) (test-assert "single set insert" @@ -53,7 +53,7 @@ ((? number? id) (match (lint-warning-message-data->lint-warning-message-set-id conn data) ((? number? second-id) - (eq? id second-id)))))) + (= id second-id)))))) #:always-rollback? #t)))) (test-end) diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm index 407b7d2..5e9c897 100644 --- a/tests/model-package-metadata.scm +++ b/tests/model-package-metadata.scm @@ -34,21 +34,25 @@ mock-inferior-package-foo-2)) (define mock-package-metadata - (map (lambda (mock-inf-pkg) - (list - (mock-inferior-package-home-page mock-inf-pkg) - (mock-inferior-package-location mock-inf-pkg) - `(("en_US.UTF-8" . "Fake synopsis")) - `(("en_US.UTF-8" . "Fake description")))) - mock-inferior-packages)) + (list->vector + (map (lambda (mock-inf-pkg) + (list + (mock-inferior-package-home-page mock-inf-pkg) + (mock-inferior-package-location mock-inf-pkg) + `(("en_US.UTF-8" . "Fake synopsis")) + `(("en_US.UTF-8" . "Fake description")))) + mock-inferior-packages))) (define (test-license-set-ids conn) (let ((license-id-lists (inferior-packages->license-id-lists conn - '((("License 1" - "https://gnu.org/licenses/test-1.html" - "https://example.com/why-license-1")))))) + '#((("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")))))) (inferior-packages->license-set-ids conn license-id-lists))) @@ -73,7 +77,8 @@ conn mock-package-metadata (test-license-set-ids conn)) - ((x) (number? x)))) + (#(x y) (and (number? x) + (number? y))))) #:always-rollback? #t)) (with-postgresql-transaction diff --git a/tests/model-package.scm b/tests/model-package.scm index bf2cf71..f58b887 100644 --- a/tests/model-package.scm +++ b/tests/model-package.scm @@ -36,9 +36,12 @@ (let ((license-id-lists (inferior-packages->license-id-lists conn - '((("License 1" - "https://gnu.org/licenses/test-1.html" - "https://example.com/why-license-1")))))) + '#((("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")))))) (inferior-packages->license-set-ids conn license-id-lists))) @@ -47,13 +50,14 @@ mock-inferior-package-foo-2)) (define mock-package-metadata - (map (lambda (mock-inf-pkg) - (list - (mock-inferior-package-home-page mock-inf-pkg) - (mock-inferior-package-location mock-inf-pkg) - `(("en_US.UTF-8" . "Fake synopsis")) - `(("en_US.UTF-8" . "Fake description")))) - mock-inferior-packages)) + (list->vector + (map (lambda (mock-inf-pkg) + (list + (mock-inferior-package-home-page mock-inf-pkg) + (mock-inferior-package-location mock-inf-pkg) + `(("en_US.UTF-8" . "Fake synopsis")) + `(("en_US.UTF-8" . "Fake description")))) + mock-inferior-packages))) (with-mock-inferior-packages (lambda () @@ -81,11 +85,13 @@ (cons "integer" NULL)))) (match (inferior-packages->package-ids conn - (zip (map mock-inferior-package-name mock-inferior-packages) - (map mock-inferior-package-version mock-inferior-packages) - package-metadata-ids - package-replacement-package-ids)) - ((x) (number? x)))))) + (list->vector + (zip (map mock-inferior-package-name mock-inferior-packages) + (map mock-inferior-package-version mock-inferior-packages) + (vector->list package-metadata-ids) + package-replacement-package-ids))) + (#(x y) (and (number? x) + (number? y))))))) #:always-rollback? #t) (with-postgresql-transaction @@ -102,16 +108,18 @@ (test-equal "inferior-packages->package-ids is idempotent" (inferior-packages->package-ids conn - (zip (map mock-inferior-package-name mock-inferior-packages) - (map mock-inferior-package-version mock-inferior-packages) - package-metadata-ids - package-replacement-package-ids)) + (list->vector + (zip (map mock-inferior-package-name mock-inferior-packages) + (map mock-inferior-package-version mock-inferior-packages) + (vector->list package-metadata-ids) + package-replacement-package-ids))) (inferior-packages->package-ids conn - (zip (map mock-inferior-package-name mock-inferior-packages) - (map mock-inferior-package-version mock-inferior-packages) - package-metadata-ids - package-replacement-package-ids))))) + (list->vector + (zip (map mock-inferior-package-name mock-inferior-packages) + (map mock-inferior-package-version mock-inferior-packages) + (vector->list package-metadata-ids) + package-replacement-package-ids)))))) #:always-rollback? #t))))) (test-end) |