diff options
22 files changed, 641 insertions, 450 deletions
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 727c515..51d35c2 100644 --- a/guix-data-service/comparison.scm +++ b/guix-data-service/comparison.scm @@ -61,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))))) diff --git a/guix-data-service/data-deletion.scm b/guix-data-service/data-deletion.scm index 1e0f7e4..d25c2ae 100644 --- a/guix-data-service/data-deletion.scm +++ b/guix-data-service/data-deletion.scm @@ -677,7 +677,7 @@ 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 (hash-clear! ignored-derivation-ids) (let ((batch-deleted-count (delete-batch conn))) diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm index cb9402e..86747e0 100644 --- a/guix-data-service/database.scm +++ b/guix-data-service/database.scm @@ -172,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") @@ -216,13 +216,15 @@ (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)))) + result)) + #:unwind? #t)) (define (check-test-database! conn) (match (exec-query conn "SELECT current_database()") @@ -318,7 +320,7 @@ (cond ((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)) diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index b045133..3ea1ebf 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -334,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" @@ -363,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) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index e0e0bc6..618ec25 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -59,7 +59,7 @@ #:use-module (guix serialization) #:use-module (guix build utils) #:use-module ((guix build syscalls) - #:select (set-thread-name free-disk-space)) + #:select (free-disk-space)) #:use-module (guix-data-service jobs) #:use-module (guix-data-service config) #:use-module (guix-data-service database) @@ -95,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)) @@ -120,19 +123,33 @@ (define* (retry-on-missing-store-item thunk #:key on-exception) (with-exception-handler (lambda (exn) - (if (missing-store-item-error? exn) - (begin - (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)) - (raise-exception 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? #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 @@ -610,8 +627,9 @@ (begin (simple-format (current-error-port) - "error: while processing ~A ignoring error: ~A: ~A\n" + "error: while processing ~A (~A) ignoring error: ~A: ~A\n" (package-name package) + system-target-pair key args) #f))))) @@ -639,8 +657,9 @@ store proc)) -(define (sort-and-deduplicate-inferior-packages packages - pkg-to-replacement-hash-table) +(define* (sort-and-deduplicate-inferior-packages packages + pkg-to-replacement-hash-table + #:key log-duplicates?) (let ((sorted-packages (sort packages (lambda (a b) @@ -707,21 +726,23 @@ (and (eq? #f a-replacement) (eq? #f b-replacement)))) (begin - (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) + (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) +(define* (inferior-packages-plus-replacements inf + #:key log-duplicates?) (let* ((packages ;; The use of force in (guix inferior) introduces a continuation ;; barrier @@ -780,7 +801,8 @@ ;; 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))) @@ -934,65 +956,70 @@ package-ids lint-checker-ids lint-warnings-data) - (concatenate! - (filter-map - (lambda (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))) - '() - package-ids - warnings-per-package) - #f)) - (vector->list lint-checker-ids) - lint-warnings-data))) + (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 - derivation-file-names) - (define derivations-count (vector-length derivation-file-names)) + derivations-or-file-names) + (define derivations-count (vector-length derivations-or-file-names)) (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))) + (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)) '() - derivation-file-names))) + 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) - (for-each + (chunk-for-each! (lambda (chunk) (for-each (match-lambda @@ -1001,7 +1028,97 @@ file-name (string->number id)))) (exec-query conn (select-existing-derivations chunk)))) - (chunk! missing-file-names 1000))))) + 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 + 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 @@ -1035,16 +1152,7 @@ (update-derivation-ids-hash-table! conn derivation-ids-hash-table - (let ((file-names-vector - (make-vector (length unfiltered-derivations)))) - (for-each - (lambda (i drv) - (vector-set! file-names-vector - i - (derivation-file-name drv))) - (iota (vector-length file-names-vector)) - unfiltered-derivations) - file-names-vector)) + (list->vector unfiltered-derivations)) (let ((derivations ;; Do this while holding the PostgreSQL connection to @@ -1089,90 +1197,43 @@ (values derivations derivation-ids))))))) - (define (insert-sources derivations derivation-ids) + (define (insert-input-derivations derivations) (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 - id) - #t) - (_ #f))) - ;; Use a utility thread to control concurrency here, to - ;; avoid using too much memory - (call-with-utility-thread - (lambda () - (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)))))))) - (vector->list sources-ids) - sources))))) - (vector->list derivation-ids) - (vector->list derivations)))) + (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 (null? derivations) + (unless (= 0 (vector-length derivations)) (fibers-parallel - (insert-sources derivations - derivation-ids) + (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 ")") @@ -1184,43 +1245,135 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (derivation-outputs derivation))) derivation-ids 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 - (for-each - (lambda (chunk) - (insert-missing-derivations - postgresql-connection-pool - call-with-utility-thread - derivation-ids-hash-table - chunk - #:log-tag log-tag)) - (chunk! input-derivations 1000)))))) + (insert-input-derivations derivations)) (simple-format (current-error-port) "debug: insert-missing-derivations: done parallel (~A)\n" log-tag) - (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)))))) + (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 @@ -1257,23 +1410,24 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (length missing-derivation-filenames) log-tag) - (let ((chunks (chunk! missing-derivation-filenames 1000))) - (for-each - (lambda (i missing-derivation-file-names-chunk) + (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" - i + 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))) - (iota (length chunks)) - chunks)) + 1000 + missing-derivation-filenames)) (let ((all-ids (vector-map @@ -1956,7 +2110,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (with-time-logging "getting all inferior package data" (let ((packages pkg-to-replacement-hash-table - (inferior-packages-plus-replacements inferior))) + (inferior-packages-plus-replacements + inferior + #:log-duplicates? #t))) (all-inferior-packages-data inferior packages @@ -2000,8 +2156,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (inferior-lint-warnings inferior inferior-store checker-name))))))) - (vector->list - inferior-lint-checkers-data)))) + inferior-lint-checkers-data))) (let ((package-ids (fibers-force package-ids-promise))) (with-resource-from-pool postgresql-connection-pool conn @@ -2095,7 +2250,13 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (round (/ (assoc-ref stats 'heap-size) (expt 2. 20))))) - inferior)) + inferior) + + ;; (inferior-eval + ;; '((@@ (guix memoization) show-memoization-tables)) + ;; inferior) + + *unspecified*) (define (get-derivations system target) (let ((derivations-vector (make-vector packages-count))) @@ -2443,38 +2604,37 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" #: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)) - (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 - (fibers-force guix-revision-id-promise) - (channel-news-for-commit channel-for-commit commit))) - (begin - (simple-format - #t "debug: importing channel news not supported\n") - #t)) - - (with-postgresql-transaction - conn - (lambda (conn) + (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 - (fibers-force guix-revision-id-promise) - commit))) - (with-time-logging "updating builds.derivation_output_details_set_id" - (update-builds-derivation-output-details-set-id - conn - (fibers-force guix-revision-id-promise))) - (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)) + 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) diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index 4cb8db4..a19bfca 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -21,6 +21,7 @@ #: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 (squee) @@ -55,6 +56,7 @@ 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 @@ -72,7 +74,12 @@ 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" @@ -974,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) @@ -1019,46 +1048,47 @@ ON CONFLICT DO NOTHING" (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)))) - - (insert-missing-data - conn - "derivation_outputs" - '(derivation_id name derivation_output_details_id) - (list->vector - (map (lambda (output-name derivation-output-details-id) - (list derivation-id - output-name - derivation-output-details-id)) - derivation-output-names - (vector->list 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)) - + (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 @@ -1105,24 +1135,11 @@ ON CONFLICT DO NOTHING" (vector->list (json-string->scm env_vars))) system)))) -(define select-derivation-output-id - (mlambda (conn name path) - (match (exec-query - conn - " -SELECT derivation_outputs.id FROM derivation_outputs -INNER JOIN derivations - ON derivation_outputs.derivation_id = derivations.id -WHERE derivations.file_name = $1 - AND derivation_outputs.name = $2" - (list path - name)) - (((id)) - id) - (() - (error (simple-format - #f "cannot find derivation-output with name ~A and path ~A" - name path)))))) +(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 @@ -1396,38 +1413,47 @@ WHERE derivation_source_files.store_path = $1" #f))) (define (insert-derivation-inputs conn derivation-ids derivations) - (define (insert-into-derivation-inputs derivation-id output-ids) - (for-each - (lambda (output-id) + (let ((query-parts + (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))) + + (chunk-for-each! + (lambda (query-parts-chunk) (exec-query conn - " + (string-append + " INSERT INTO derivation_inputs (derivation_id, derivation_output_id) -VALUES ($1, $2);" - (list (number->string derivation-id) output-id))) - output-ids)) - - (vector-for-each - (lambda (i derivation-id derivation) - (let ((inputs (derivation-inputs derivation))) - (unless (null? inputs) - (insert-into-derivation-inputs - derivation-id - (append-map! - (match-lambda - ;; The first field changed to a derivation (from the file name) - ;; in 5cf4b26d52bcea382d98fb4becce89be9ee37b55, so guard against - ;; that in the match - (($ <derivation-input> (? derivation? d) sub-derivations) - (let ((path (derivation-file-name d))) - (map (lambda (sub-derivation) - (select-derivation-output-id conn - sub-derivation - path)) - sub-derivations)))) - inputs))))) - derivation-ids - derivations)) +SELECT vals.derivation_id, derivation_outputs.id +FROM (VALUES " + (string-join query-parts-chunk ", ") + ") AS vals (derivation_id, file_name, output_name) +LEFT JOIN derivations + ON derivations.file_name = vals.file_name +LEFT JOIN derivation_outputs + ON derivation_outputs.derivation_id = derivations.id + AND derivation_outputs.name = vals.output_name +ON CONFLICT DO NOTHING"))) + 1000 + query-parts))) (define (insert-derivation-sources conn derivation-id sources) (define (insert-into-derivation-sources derivation-source-file-ids) diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index d242139..97154ec 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -23,11 +23,10 @@ #: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) diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm index ec9f346..3ac09eb 100644 --- a/guix-data-service/substitutes.scm +++ b/guix-data-service/substitutes.scm @@ -25,9 +25,8 @@ #: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) diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index c85bed3..7cd7342 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -30,8 +30,6 @@ #:use-module (ice-9 ports internal) #:use-module (ice-9 suspendable-ports) #:use-module (lzlib) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers operations) @@ -52,8 +50,6 @@ get-guix-metrics-updater - call-with-sigint - spawn-port-monitoring-fiber make-queueing-channel)) @@ -76,24 +72,30 @@ (set! var var)) (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) @@ -114,10 +116,10 @@ (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) @@ -181,18 +183,3 @@ (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 94c7e52..473cc61 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -277,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)) @@ -294,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/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/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 1f30c0b..b22fbed 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -1383,10 +1383,10 @@ (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"))))))) diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 8e46c54..412eb6e 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -272,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 @@ -2082,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 88f7b1a..2fd26f5 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -31,10 +31,10 @@ #:use-module (fibers channels) #:use-module (fibers scheduler) #:use-module (fibers conditions) + #:use-module (knots) #:use-module (knots web-server) + #:use-module (knots thread-pool) #:use-module (knots resource-pool) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) #:use-module (prometheus) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) @@ -242,49 +242,66 @@ port. Also, the port used can be changed by passing the --port option.\n" (let ((render-metrics (make-render-metrics registry))) (run-knots-web-server (lambda (request) - (metric-increment requests-metric) + (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 ((body (read-request-body request))) - (handler request finished? body controller - secret-key-base - startup-completed - render-metrics))) - #:exception-handler - (lambda (exn request) - (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))) - ;; Use the error output from the default exception handler - (default-exception-handler exn request) + (raise-exception exn)) + (lambda () + (metric-increment requests-metric) - (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)))))) + (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))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index dd3c07f..480b066 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -725,7 +725,7 @@ "," "\"" ,(or hash "") "\"" ")" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(","))))) derivation-outputs @@ -763,7 +763,7 @@ ",") "]" ")" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(","))))) derivation-inputs @@ -789,7 +789,7 @@ (a (@ (href ,source)) ,(display-store-item source)) "\"" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(",")))) derivation-sources @@ -850,7 +850,7 @@ `(div "\"" ,(display-possible-store-item arg) "\"" - ,@(if (eq? count-down 0) + ,@(if (= count-down 0) '() '(",")))) args diff --git a/scripts/guix-data-service-process-branch-updated-mbox.in b/scripts/guix-data-service-process-branch-updated-mbox.in index 7205b7a..5773341 100644 --- a/scripts/guix-data-service-process-branch-updated-mbox.in +++ b/scripts/guix-data-service-process-branch-updated-mbox.in @@ -37,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 diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 2244c0e..238483d 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -143,10 +143,7 @@ (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))) diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm index bcd9579..64f2464 100644 --- a/tests/jobs-load-new-guix-revision.scm +++ b/tests/jobs-load-new-guix-revision.scm @@ -97,7 +97,7 @@ (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) 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 a983401..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 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 |