;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2019 Christopher Baines ;;; ;;; This program is free software: you can redistribute it and/or ;;; modify it under the terms of the GNU Affero General Public License ;;; as published by the Free Software Foundation, either version 3 of ;;; the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Affero General Public License for more details. ;;; ;;; You should have received a copy of the GNU Affero General Public ;;; License along with this program. If not, see ;;; . (define-module (guix-data-service jobs load-new-guix-revision) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 textual-ports) #:use-module (ice-9 hash-table) #:use-module (rnrs exceptions) #:use-module (json) #:use-module (squee) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix channels) #:use-module (guix inferior) #:use-module (guix profiles) #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix progress) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix build utils) #: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 channel-instance) #:use-module (guix-data-service model channel-news) #:use-module (guix-data-service model package) #:use-module (guix-data-service model package-derivation-by-guix-revision-range) #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model package-derivation) #:use-module (guix-data-service model guix-revision-package-derivation) #:use-module (guix-data-service model license) #:use-module (guix-data-service model license-set) #:use-module (guix-data-service model lint-checker) #:use-module (guix-data-service model lint-warning) #:use-module (guix-data-service model lint-warning-message) #:use-module (guix-data-service model location) #:use-module (guix-data-service model package-metadata) #:use-module (guix-data-service model derivation) #:use-module (guix-data-service model system-test) #:export (log-for-job count-log-parts combine-log-parts! fetch-unlocked-jobs process-load-new-guix-revision-job select-load-new-guix-revision-job-metrics select-job-for-commit select-jobs-and-events select-recent-job-events select-unprocessed-jobs-and-events select-jobs-and-events-for-commit guix-revision-loaded-successfully? record-job-event enqueue-load-new-guix-revision-job most-recent-n-load-new-guix-revision-jobs)) (define (log-part-sequence-name job-id) (simple-format #f "load_new_guix_revision_job_log_parts_id_seq_~A" job-id)) (define* (log-port job-id conn #:key delete-existing-log-parts? real-output-port) (define output-port (or real-output-port (current-output-port))) (define buffer "") (define (insert job_id s) (exec-query conn (string-append " INSERT INTO load_new_guix_revision_job_log_parts (id, job_id, contents) VALUES (nextval('" (log-part-sequence-name job_id) "'), $1, $2)") (list job_id s))) (define (log-string s) (if (string-contains s "\n") (let ((output (string-append buffer s))) (set! buffer "") ; clear the buffer (catch #t (lambda () (insert job-id output) (display output output-port)) (lambda (key . args) (display (simple-format #f " error: ~A: ~A error: could not insert log part: '~A'\n\n" key args output) output-port) (catch #t (lambda () (insert job-id (simple-format #f " guix-data-service: error: missing log line: ~A \n" key))) (lambda () #t))))) (set! buffer (string-append buffer s)))) (exec-query conn (simple-format #f "CREATE SEQUENCE IF NOT EXISTS ~A" (log-part-sequence-name job-id))) (when delete-existing-log-parts? ;; TODO, this is useful when re-running jobs, but I'm not sure that should ;; be a thing, jobs should probably be only attempted once. (exec-query conn "DELETE FROM load_new_guix_revision_job_log_parts WHERE job_id = $1" (list job-id))) (let ((port (make-soft-port (vector (lambda (c) (set! buffer (string-append buffer (string c)))) log-string (lambda () (force-output output-port)) #f ; fetch one character (lambda () ;; close port #f) #f) ; number of characters that can be read "w"))) (setvbuf port 'line) port)) (define (setup-port-for-inferior-error-output job-id real-output-port) (define (insert conn job_id s) (exec-query conn (string-append " INSERT INTO load_new_guix_revision_job_log_parts (id, job_id, contents) VALUES (nextval('" (log-part-sequence-name job_id) "'), $1, $2)") (list job_id s))) (match (pipe) ((port-to-read-from . port-to-write-to) (setvbuf port-to-read-from 'line) (setvbuf port-to-write-to 'line) (call-with-new-thread (lambda () (with-postgresql-connection (simple-format #f "~A inferior error logging" job-id) (lambda (logging-conn) (let loop ((line (get-line port-to-read-from))) (let ((line-with-newline (string-append line "\n"))) (catch #t (lambda () (insert logging-conn job-id line-with-newline) (display line-with-newline real-output-port)) (lambda (key . args) (display (simple-format #f " error: ~A: ~A error: could not insert log part: '~A'\n\n" key args line) real-output-port) (catch #t (lambda () (insert logging-conn job-id (simple-format #f " guix-data-service: error: missing log line: ~A \n" key))) (lambda () #t))))) (loop (get-line port-to-read-from))))))) port-to-write-to))) (define real-error-port (make-parameter (current-error-port))) (define inferior-error-port (make-parameter (current-error-port))) (define* (log-for-job conn job-id #:key character-limit start-character) (define (sql-html-escape s) (string-append "replace(" (string-append "replace(" (string-append "replace(" s ",'&','&')") ",'<','<')") ",'>','>')")) (define (get-characters s) (if start-character (simple-format #f "substr(~A, ~A, ~A)" s start-character character-limit) (simple-format #f "right(~A, ~A)" s character-limit))) (define log-query (string-append "SELECT " (sql-html-escape (get-characters "contents")) " FROM load_new_guix_revision_job_logs" " WHERE job_id = $1 AND contents IS NOT NULL")) (define parts-query (string-append "SELECT " (sql-html-escape (get-characters "STRING_AGG(contents, '' ORDER BY id ASC)")) " FROM load_new_guix_revision_job_log_parts WHERE job_id = $1")) (match (exec-query conn log-query (list job-id)) (((contents)) contents) (() (match (exec-query conn parts-query (list job-id)) (((contents)) contents))))) (define (insert-empty-log-entry conn job-id) (exec-query conn "DELETE FROM load_new_guix_revision_job_logs WHERE job_id = $1" (list job-id)) (exec-query conn "INSERT INTO load_new_guix_revision_job_logs (job_id, contents) VALUES ($1, NULL)" (list job-id))) (define (count-log-parts conn job-id) (match (exec-query conn " SELECT COUNT(*) FROM load_new_guix_revision_job_log_parts WHERE job_id = $1" (list job-id)) (((id)) (string->number id)))) (define (combine-log-parts! conn job-id) (with-postgresql-transaction conn (lambda (conn) (exec-query conn (string-append " UPDATE load_new_guix_revision_job_logs SET contents = ( SELECT STRING_AGG(contents, '' ORDER BY id ASC) FROM load_new_guix_revision_job_log_parts WHERE job_id = $1 GROUP BY job_id ) WHERE job_id = $1") (list job-id)) (exec-query conn "DELETE FROM load_new_guix_revision_job_log_parts WHERE job_id = $1" (list job-id))))) (define (drop-log-parts-sequence conn job-id) (with-postgresql-transaction conn (lambda (conn) (exec-query conn "SET LOCAL lock_timeout = '10s'") (with-exception-handler (lambda (exn) (simple-format (current-error-port) "error when dropping sequence: ~A" exn)) (lambda () (exec-query conn (string-append "DROP SEQUENCE IF EXISTS " (log-part-sequence-name job-id)))) #:unwind? #t)))) (define (vacuum-log-parts-table conn) (exec-query conn "VACUUM load_new_guix_revision_job_log_parts")) (define inferior-package-id (@@ (guix inferior) inferior-package-id)) (define (record-start-time action) (simple-format #t "debug: Starting ~A\n" action) (cons action (current-time))) (define record-end-time (match-lambda ((action . start-time) (let ((time-taken (- (current-time) start-time))) (simple-format #t "debug: Finished ~A, took ~A seconds\n" action time-taken))))) (define (with-advisory-session-lock/log-time conn lock f) (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock) (let ((start-time (current-time))) (with-advisory-session-lock conn lock (lambda () (let ((time-taken (- (current-time) start-time))) (simple-format #t "debug: Finished aquiring lock ~A, took ~A seconds\n" lock time-taken)) (let ((result (f))) (let ((time-spent (- (current-time) start-time))) (simple-format #t "debug: Releasing lock ~A, spent ~A seconds\n" lock time-spent)) result))))) (define (inferior-guix-systems inf) (cond ((inferior-eval '(defined? 'systems (resolve-module '(guix platform))) inf) (remove (lambda (system) ;; There aren't currently bootstrap binaries for s390x-linux, so this ;; just leads to lots of errors (string=? system "s390x-linux")) (inferior-eval '((@ (guix platform) systems)) inf))) (else (inferior-eval '(@ (guix packages) %supported-systems) inf)))) (define (all-inferior-system-tests inf store) (define inf-systems (inferior-guix-systems inf)) (define extract `(lambda (store) (map (lambda (system-test) (simple-format (current-error-port) "guix-data-service: computing derivation for ~A system test\n" (system-test-name system-test)) (list (system-test-name system-test) (system-test-description system-test) (filter-map (lambda (system) (catch #t (lambda () (cons system (parameterize ((%current-system system)) (derivation-file-name (run-with-store store (mbegin %store-monad (system-test-value system-test))))))) (lambda (key . args) (simple-format (current-error-port) "guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n" (system-test-name system-test) system key args) #f))) (list ,@inf-systems)) (match (system-test-location system-test) (($ file line column) (list file line column))))) (all-system-tests)))) (catch #t (lambda () (let ((system-test-data (with-time-logging "getting system tests" (inferior-eval-with-store inf store extract)))) (for-each (lambda (derivation-file-names-by-system) (for-each (lambda (derivation-file-name) (add-temp-root 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)) (display "\n" (current-error-port)) (simple-format (current-error-port) "error: all-inferior-system-tests: ~A: ~A\n" key args) #f))) (define (all-inferior-lint-warnings inf store packages) (define locales '("cs_CZ.UTF-8" "da_DK.UTF-8" "de_DE.UTF-8" "eo_EO.UTF-8" "es_ES.UTF-8" "fr_FR.UTF-8" "hu_HU.UTF-8" "nl_NL.UTF-8" "pl_PL.UTF-8" "pt_BR.UTF-8" ;;"sr_SR.UTF-8" "sv_SE.UTF-8" "vi_VN.UTF-8" "zh_CN.UTF-8")) (define (cleanup-inferior inf) (format (current-error-port) "inferior heap before cleanup: ~a MiB used (~a MiB heap)~%" (round (/ (inferior-eval '(let ((stats (gc-stats))) (- (assoc-ref stats 'heap-size) (assoc-ref stats 'heap-free-size))) inf) (expt 2. 20))) (round (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf) (expt 2. 20)))) ;; Clean the cached store connections, as there are caches associated with ;; these that take up lots of memory (inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf) (catch 'match-error (lambda () (inferior-eval '(invalidate-derivation-caches!) inf)) (lambda (key . args) (simple-format (current-error-port) "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) (inferior-eval '(gc) inf) (format (current-error-port) "inferior heap after cleanup: ~a MiB used (~a MiB heap)~%" (round (/ (inferior-eval '(let ((stats (gc-stats))) (- (assoc-ref stats 'heap-size) (assoc-ref stats 'heap-free-size))) inf) (expt 2. 20))) (round (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf) (expt 2. 20))))) (define (lint-warnings-for-checker packages checker-name) `(lambda (store) (let* ((checker (find (lambda (checker) (eq? (lint-checker-name checker) ',checker-name)) %local-checkers)) (check (lint-checker-check checker))) (define lint-checker-requires-store?-defined? (defined? 'lint-checker-requires-store? (resolve-module '(guix lint)))) (define (process-lint-warning lint-warning) (list (match (lint-warning-location lint-warning) (($ file line column) (list (if (string-prefix? "/gnu/store/" file) ;; Convert a string like ;; /gnu/store/53xh0mpigin2rffg31s52x5dc08y0qmr-guix-module-union/share/guile/site/2.2/gnu/packages/xdisorg.scm ;; ;; This happens when the checker uses ;; package-field-location. (string-join (drop (string-split file #\/) 8) "/") file) line column))) (let* ((source-locale "en_US.UTF-8") (source-message (begin (setlocale LC_MESSAGES source-locale) (lint-warning-message lint-warning))) (messages-by-locale (filter-map (lambda (locale) (catch 'system-error (lambda () (setlocale LC_MESSAGES locale)) (lambda (key . args) (error (simple-format #f "error changing locale to ~A: ~A ~A" locale key args)))) (let ((message (lint-warning-message lint-warning))) (setlocale LC_MESSAGES source-locale) (if (string=? message source-message) #f (cons locale message)))) (list ,@locales)))) (cons (cons source-locale source-message) messages-by-locale)))) (filter-map (lambda (package-id) (let* ((package (hashv-ref %package-table package-id)) (warnings (map process-lint-warning (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception checking ~A with ~A checker: ~A\n" package ',checker-name exn) (raise-exception exn)) (lambda () (if (and lint-checker-requires-store?-defined? (lint-checker-requires-store? checker)) (check package #:store store) (check package))) #:unwind? #t)))) (if (null? warnings) #f (cons package-id warnings)))) (list ,@(map inferior-package-id packages)))))) (and (or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f) (use-modules (guix lint)) #t) inf) (begin (simple-format (current-error-port) "warning: no (guix lint) module found\n") #f)) (let ((checkers (inferior-eval `(begin (define (lint-descriptions-by-locale checker) (let* ((source-locale "en_US.UTF-8") (source-description (begin (setlocale LC_MESSAGES source-locale) (G_ (lint-checker-description checker)))) (descriptions-by-locale (filter-map (lambda (locale) (catch 'system-error (lambda () (setlocale LC_MESSAGES locale)) (lambda (key . args) (error (simple-format #f "error changing locale to ~A: ~A ~A" locale key args)))) (let ((description (G_ (lint-checker-description checker)))) (setlocale LC_MESSAGES source-locale) (if (string=? description source-description) #f (cons locale description)))) (list ,@locales)))) (cons (cons source-locale source-description) descriptions-by-locale))) (map (lambda (checker) (list (lint-checker-name checker) (lint-descriptions-by-locale checker) (if (memq checker %network-dependent-checkers) #t #f))) %all-checkers)) inf))) (map (match-lambda ((name description network-dependent?) (cons (list name description network-dependent?) (if network-dependent? '() (with-time-logging (simple-format #f "getting ~A lint warnings" name) (let loop ((packages-chunks (chunk packages 4000)) (warnings '())) (if (null? packages-chunks) warnings (let ((new-warnings (inferior-eval-with-store inf store (lint-warnings-for-checker (car packages-chunks) name)))) (cleanup-inferior inf) (loop (cdr packages-chunks) (append! warnings new-warnings)))))))))) checkers)))) (define (all-inferior-package-derivations store inf packages) (define inf-systems (inferior-guix-systems inf)) (define inf-targets (cond ((inferior-eval '(defined? 'targets (resolve-module '(guix platform))) inf) (inferior-eval '((@ (guix platform) targets)) inf)) (else '("arm-linux-gnueabihf" "aarch64-linux-gnu" "mips64el-linux-gnu" "powerpc-linux-gnu" "powerpc64le-linux-gnu" "riscv64-linux-gnu" "i586-pc-gnu" "i686-w64-mingw32" "x86_64-w64-mingw32")))) (define cross-derivations `(("x86_64-linux" . ,(remove (lambda (target) ;; Remove targets that don't make much sense (member target '("x86_64-linux-gnu" "i686-linux-gnu"))) inf-targets)))) (define supported-system-pairs (map (lambda (system) (cons system #f)) inf-systems)) (define supported-system-cross-build-pairs (append-map (match-lambda ((system . targets) (map (lambda (target) (cons system target)) targets))) cross-derivations)) (define (proc packages system-target-pairs) `(lambda (store) (define target-system-alist (if (defined? 'platforms (resolve-module '(guix platform))) (filter-map (lambda (platform) (and (platform-target platform) (cons (platform-target platform) (platform-system platform)))) (platforms)) '(("arm-linux-gnueabihf" . "armhf-linux") ("aarch64-linux-gnu" . "aarch64-linux") ("mips64el-linux-gnu" . "mips64el-linux") ("powerpc-linux-gnu" . "powerpc-linux") ("powerpc64le-linux-gnu" . "powerpc64le-linux") ("riscv64-linux-gnu" . "riscv64-linux") ("i586-pc-gnu" . "i586-gnu")))) (define package-transitive-supported-systems-supports-multiple-arguments? #t) (define (get-supported-systems package system) (or (and package-transitive-supported-systems-supports-multiple-arguments? (catch 'wrong-number-of-args (lambda () (package-transitive-supported-systems package system)) (lambda (key . args) ;; Older Guix revisions don't support two ;; arguments to ;; package-transitive-supported-systems (simple-format (current-error-port) "info: package-transitive-supported-systems doesn't support two arguments, falling back to package-supported-systems\n") (set! package-transitive-supported-systems-supports-multiple-arguments? #f) #f))) (catch #t (lambda () (package-supported-systems package)) (lambda (key . args) (simple-format (current-error-port) "error: while processing ~A, unable to compute supported systems\n" (package-name package)) (simple-format (current-error-port) "error ~A: ~A\n" key args) #f)))) (define (derivations-for-system-and-target inferior-package-id package system target) (catch 'misc-error (lambda () (guard (c ((package-cross-build-system-error? c) #f)) (let ((derivation (if target (package-cross-derivation store package target system) (package-derivation store package system)))) ;; You don't always get what you ask for, so check (if (string=? system (derivation-system derivation)) (list inferior-package-id system target (let ((file-name (derivation-file-name derivation))) (add-temp-root store file-name) file-name)) (begin (simple-format (current-error-port) "warning: request for ~A derivation for ~A produced a derivation for system ~A\n" system (package-name package) (derivation-system derivation)) #f))))) (lambda args ;; misc-error #f ~A ~S (No ;; cross-compilation for ;; clojure-build-system yet: #f))) (append-map (lambda (inferior-package-id) (let ((package (hashv-ref %package-table inferior-package-id))) (catch #t (lambda () (append-map (lambda (system) (let ((supported-systems (get-supported-systems package system))) (if (and supported-systems (member system supported-systems)) (filter-map (lambda (target) (derivations-for-system-and-target inferior-package-id package system target)) (filter (match-lambda (#f #t) ; No target (target (let ((system-for-target (assoc-ref target-system-alist target))) (or (not system-for-target) (member system-for-target (package-supported-systems package) string=?))))) (list ,@(map cdr system-target-pairs)))) '()))) (delete-duplicates (list ,@(map car system-target-pairs)) string=?))) (lambda (key . args) (if (and (eq? key 'system-error) (eq? (car args) 'fport_write)) (begin (simple-format (current-error-port) "error: while processing ~A, exiting: ~A: ~A\n" (package-name package) key args) (exit 1)) (begin (simple-format (current-error-port) "error: while processing ~A ignoring error: ~A: ~A\n" (package-name package) key args) '())))))) (list ,@(map inferior-package-id packages))))) (inferior-eval '(when (defined? 'systems (resolve-module '(guix platform))) (use-modules (guix platform))) inf) (append-map (lambda (system-target-pair) (format (current-error-port) "heap size: ~a MiB~%" (round (/ (assoc-ref (gc-stats) 'heap-size) (expt 2. 20)))) (format (current-error-port) "inferior heap: ~a MiB used (~a MiB heap)~%" (round (/ (inferior-eval '(let ((stats (gc-stats))) (- (assoc-ref stats 'heap-size) (assoc-ref stats 'heap-free-size))) inf) (expt 2. 20))) (round (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf) (expt 2. 20)))) (let ((derivations (with-time-logging (simple-format #f "getting derivations for ~A" system-target-pair) (catch 'match-error (lambda () (inferior-eval '(invalidate-derivation-caches!) inf)) (lambda (key . args) (simple-format (current-error-port) "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) (inferior-eval-with-store inf store (proc packages (list system-target-pair)))))) ;; 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) derivations)) (append supported-system-pairs supported-system-cross-build-pairs))) (define (deduplicate-inferior-packages 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))) (if (and (string=? a-name b-name) (string=? a-version b-version)) (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))) (stringlicense-data inf packages))) (package-metadata (with-time-logging "fetching inferior package metadata" (map (lambda (package) (let ((translated-package-descriptions-and-synopsis (inferior-packages->translated-package-descriptions-and-synopsis inf package))) (list (non-empty-string-or-false (inferior-package-home-page package)) (inferior-package-location package) (car translated-package-descriptions-and-synopsis) (cdr translated-package-descriptions-and-synopsis)))) packages))) (package-replacement-data (if process-replacements? (map (lambda (package) (let ((replacement (inferior-package-replacement package))) (if replacement ;; I'm not sure if replacements can themselves be ;; replaced, but I do know for sure that there are ;; infinite chains of replacements (python(2)-urllib3 ;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for ;; example). ;; ;; This code currently just capures the first level ;; of replacements (first (all-inferior-packages-data inf (list replacement) #:process-replacements? #f)) #f))) packages) #f))) `((names . ,(map inferior-package-name packages)) (versions . ,(map inferior-package-version packages)) (license-data . ,package-license-data) (metadata . ,package-metadata) (replacemnets . ,package-replacement-data)))) (define (insert-packages conn inferior-packages-data) (let*-values (((package-license-set-ids) (inferior-packages->license-set-ids conn (inferior-packages->license-id-lists conn (assq-ref inferior-packages-data 'license-data)))) ((all-package-metadata-ids new-package-metadata-ids) (with-time-logging "inserting package metadata entries" (inferior-packages->package-metadata-ids conn (assq-ref inferior-packages-data 'metadata) package-license-set-ids))) ((replacement-ids) (or (and=> (assq-ref inferior-packages-data 'replacements) (lambda (all-replacement-data) (with-time-logging "inserting package replacements" (map (lambda (replacement-data) (if replacement-data (first (insert-packages conn (list replacement-data))) (cons "integer" NULL))) all-replacement-data)))) (make-list (length package-license-set-ids) (cons "integer" NULL))))) (unless (null? new-package-metadata-ids) (with-time-logging "fetching package metadata tsvector entries" (insert-package-metadata-tsvector-entries conn new-package-metadata-ids))) (with-time-logging "getting package-ids" (inferior-packages->package-ids conn (zip (assq-ref inferior-packages-data 'names) (assq-ref inferior-packages-data 'versions) all-package-metadata-ids replacement-ids))))) (define (insert-lint-warnings conn inferior-package-id->package-database-id lint-checker-ids lint-warnings-data) (lint-warnings-data->lint-warning-ids conn (append-map (lambda (lint-checker-id warnings-by-package-id) (append-map (match-lambda ((package-id . warnings) (map (match-lambda ((location-data messages-by-locale) (let ((location-id (location->location-id conn (apply location location-data))) (lint-warning-message-set-id (lint-warning-message-data->lint-warning-message-set-id conn messages-by-locale))) (list lint-checker-id (inferior-package-id->package-database-id package-id) location-id lint-warning-message-set-id)))) (fold (lambda (location-and-messages result) (if (member location-and-messages result) (begin (apply simple-format (current-error-port) "warning: skipping duplicate lint warning ~A ~A\n" location-and-messages) result) (append result (list location-and-messages)))) '() warnings)))) warnings-by-package-id)) lint-checker-ids (map cdr lint-warnings-data)))) (define (inferior-data->package-derivation-ids conn inf inferior-package-id->package-database-id inferior-data-4-tuples) (let ((derivation-ids (derivation-file-names->derivation-ids conn (map fourth inferior-data-4-tuples))) (flat-package-ids-systems-and-targets (map (match-lambda ((inferior-package-id system target derivation-file-name) (list (inferior-package-id->package-database-id inferior-package-id) system (or target "")))) inferior-data-4-tuples))) (insert-package-derivations conn flat-package-ids-systems-and-targets derivation-ids))) (define guix-store-path (let ((store-path #f)) (lambda (store) (if (and store-path (file-exists? store-path)) store-path (let ((config-guix (%config 'guix))) (if (and (file-exists? config-guix) (string-prefix? "/gnu/store/" config-guix)) (begin (set! store-path (dirname (dirname (%config 'guix)))) store-path) (begin (invalidate-derivation-caches!) (hash-clear! (@@ (guix packages) %derivation-cache)) (let* ((guix-package (@ (gnu packages package-management) guix)) (derivation (package-derivation store guix-package))) (with-time-logging "building the guix derivation" (build-derivations store (list derivation))) (let ((new-store-path (derivation->output-path derivation))) (set! store-path new-store-path) (simple-format (current-error-port) "debug: guix-store-path: ~A\n" new-store-path) new-store-path))))))))) (define (nss-certs-store-path store) (let* ((nss-certs-package (@ (gnu packages certs) nss-certs)) (derivation (package-derivation store nss-certs-package))) (with-time-logging "building the nss-certs derivation" (build-derivations store (list derivation))) (derivation->output-path derivation))) (define (channel->derivation-file-names-by-system conn store channel fetch-with-authentication?) (define use-container? (defined? 'open-inferior/container (resolve-module '(guix inferior)))) (define (inferior-code channel-instance systems) `(lambda (store) (let* ((instances (list (channel-instance (channel (name ',(channel-name channel)) (url ,(channel-url channel)) (branch ,(channel-branch channel)) (commit ,(channel-commit channel))) ,(channel-instance-commit channel-instance) ,(channel-instance-checkout channel-instance))))) (map (lambda (system) (simple-format (current-error-port) "guix-data-service: computing the derivation-file-name for ~A\n" system) (let ((manifest (catch #t (lambda () ((channel-instances->manifest instances #:system system) store)) (lambda (key . args) (simple-format (current-error-port) "error: while computing manifest entry derivation for ~A\n" system) (simple-format (current-error-port) "error ~A: ~A\n" key args) #f)))) (define (add-tmp-root-and-return-drv drv) (add-temp-root store drv) drv) `(,system . ((manifest-entry-item . ,(and manifest (add-tmp-root-and-return-drv (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))))))) (list ,@systems))))) (let ((inferior (if use-container? (open-inferior/container store (guix-store-path store) #:extra-shared-directories '("/gnu/store") #:extra-environment-variables (list (string-append "SSL_CERT_DIR=" (nss-certs-store-path store)))) (begin (simple-format #t "debug: using open-inferior\n") (open-inferior (guix-store-path store) #:error-port (inferior-error-port)))))) (define (start-inferior-and-return-derivation-file-names) ;; /etc is only missing if open-inferior/container has been used (when use-container? (inferior-eval '(begin ;; Create /etc/pass, as %known-shorthand-profiles in (guix ;; profiles) tries to read from this file. Because the environment ;; is cleaned in build-self.scm, xdg-directory in (guix utils) ;; falls back to accessing /etc/passwd. (mkdir "/etc") (call-with-output-file "/etc/passwd" (lambda (port) (display "root:x:0:0::/root:/bin/bash" port)))) inferior)) (let ((channel-instance ;; Obtain a session level lock here, to avoid conflicts with ;; other jobs over the Git repository. (with-advisory-session-lock/log-time conn 'latest-channel-instances (lambda () (first (latest-channel-instances store (list channel) #:authenticate? fetch-with-authentication?)))))) (inferior-eval '(use-modules (srfi srfi-1) (ice-9 history) (guix channels) (guix grafts) (guix profiles)) inferior) (inferior-eval '(%graft? #f) inferior) (inferior-eval '(disable-value-history!) inferior) (inferior-eval '(define channel-instance (@@ (guix channels) channel-instance)) inferior) (let* ((systems (inferior-eval '(@ (guix packages) %supported-systems) inferior)) (result (inferior-eval-with-store inferior store (inferior-code channel-instance systems)))) (close-inferior inferior) result))) (catch #t (lambda () (with-throw-handler #t start-inferior-and-return-derivation-file-names (lambda (key . parameters) (display (backtrace) (current-error-port)) (display "\n" (current-error-port)) (simple-format (current-error-port) "error: channel->derivation-file-names-by-system: ~A: ~A\n" key parameters)))) (lambda args (close-inferior inferior) #f)))) (define (channel->derivations-by-system conn store channel fetch-with-authentication?) (let ((derivation-file-names-by-system (with-time-logging "computing the channel derivation" (channel->derivation-file-names-by-system conn store channel fetch-with-authentication?)))) (for-each (match-lambda ((system . derivation-file-name) (simple-format (current-error-port) "debug: ~A: channel dervation: ~A\n" system derivation-file-name))) derivation-file-names-by-system) derivation-file-names-by-system)) (prevent-inlining-for-tests channel->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))) (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))) (store-item->guix-store-item (derivation->output-path derivation-for-current-system))) #f))) (prevent-inlining-for-tests channel-derivations-by-system->guix-store-item) (define (glibc-locales-for-guix-store-path store store-path) (let ((inf (if (defined? 'open-inferior/container (resolve-module '(guix inferior))) (open-inferior/container store store-path #:extra-shared-directories '("/gnu/store")) (begin (simple-format #t "debug: using open-inferior\n") (open-inferior store-path #:error-port (inferior-error-port)))))) (inferior-eval '(use-modules (srfi srfi-1) (srfi srfi-34) (guix grafts) (guix derivations)) inf) (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf) (let* ((inferior-glibc-locales (first (lookup-inferior-packages inf "glibc-locales"))) (derivation (inferior-package-derivation store inferior-glibc-locales)) (output (derivation->output-path derivation))) (close-inferior inf) (with-time-logging "building the glibc-locales derivation" (build-derivations store (list derivation))) output))) (define (start-inferior-for-data-extration store store-path) (let* ((guix-locpath (getenv "GUIX_LOCPATH")) (inf (let ((guix-locpath ;; Augment the GUIX_LOCPATH to include glibc-locales from ;; the Guix at store-path, this should mean that the ;; inferior Guix works, even if it's build using a different ;; glibc version (string-append (glibc-locales-for-guix-store-path store store-path) "/lib/locale" ":" guix-locpath))) ;; 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 (inferior-error-port))))))) (setenv "GUIX_LOCPATH" 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) (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) inf)) (define (extract-information-from conn store guix-revision-id commit store-path) (simple-format #t "debug: extract-information-from: ~A\n" store-path) (let ((inf (start-inferior-for-data-extration store store-path))) (catch #t (lambda () (let* ((packages (with-time-logging "fetching inferior packages" (inferior-packages-plus-replacements inf))) (inferior-lint-warnings (with-time-logging "fetching inferior lint warnings" (all-inferior-lint-warnings inf store packages))) (inferior-data-4-tuples (with-time-logging "getting inferior derivations" (all-inferior-package-derivations store inf packages))) (inferior-system-tests (with-time-logging "getting inferior system tests" (all-inferior-system-tests inf store))) (packages-data (with-time-logging "getting all inferior package data" (all-inferior-packages-data inf packages)))) (simple-format #t "debug: finished loading information from inferior\n") (close-inferior inf) (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)) (let* ((package-ids (insert-packages conn packages-data)) (inferior-package-id->package-database-id (let ((lookup-table (alist->hashq-table (map (lambda (package package-id) (cons (inferior-package-id package) package-id)) packages package-ids)))) (lambda (inferior-id) (or (hashq-ref lookup-table inferior-id) (error (simple-format #f "error: inferior-package-id->package-database-id: ~A missing\n" inferior-id))))))) (when inferior-lint-warnings (let* ((lint-checker-ids (lint-checkers->lint-checker-ids conn (map (match-lambda ((name descriptions-by-locale network-dependent) (list name network-dependent (lint-checker-description-data->lint-checker-description-set-id conn descriptions-by-locale)))) (map car inferior-lint-warnings)))) (lint-warning-ids (insert-lint-warnings conn inferior-package-id->package-database-id lint-checker-ids inferior-lint-warnings))) (insert-guix-revision-lint-checkers conn guix-revision-id lint-checker-ids) (insert-guix-revision-lint-warnings conn guix-revision-id lint-warning-ids))) (when inferior-system-tests (insert-system-tests-for-guix-revision conn guix-revision-id inferior-system-tests)) (let ((package-derivation-ids (with-time-logging "inferior-data->package-derivation-ids" (inferior-data->package-derivation-ids conn inf inferior-package-id->package-database-id inferior-data-4-tuples)))) (insert-guix-revision-package-derivations conn guix-revision-id package-derivation-ids) (simple-format #t "Successfully loaded ~A package/derivation pairs\n" (length package-derivation-ids))))) #t) (lambda (key . args) (simple-format (current-error-port) "Failed extracting information from commit: ~A\n\n" commit) (simple-format (current-error-port) " ~A ~A\n\n" key args) #f) (lambda (key . args) (display-backtrace (make-stack #t) (current-error-port)))))) (prevent-inlining-for-tests extract-information-from) (define (load-channel-instances 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 (with-postgresql-connection "load-new-guix-revision insert channel instances" (lambda (channel-instances-conn) (with-postgresql-transaction channel-instances-conn (lambda (channel-instances-conn) (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 channel-instances-conn 'load-new-guix-revision-inserts)) (let* ((existing-guix-revision-id (git-repository-id-and-commit->revision-id channel-instances-conn git-repository-id commit)) (guix-revision-id (or existing-guix-revision-id (insert-guix-revision channel-instances-conn git-repository-id commit)))) (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)) (simple-format (current-error-port) "guix-data-service: saved the channel instance derivations to the database\n")) guix-revision-id)))))) (prevent-inlining-for-tests load-channel-instances) (define (load-new-guix-revision conn store git-repository-id commit) (let* ((git-repository-fields (select-git-repository conn git-repository-id)) (git-repository-url (second git-repository-fields)) (fetch-with-authentication? (fourth git-repository-fields)) (channel-for-commit (channel (name 'guix) (url git-repository-url) (commit commit))) (channel-derivations-by-system (channel->derivations-by-system conn store channel-for-commit fetch-with-authentication?)) (guix-revision-id (load-channel-instances git-repository-id commit channel-derivations-by-system))) (let ((store-item (channel-derivations-by-system->guix-store-item store channel-derivations-by-system))) (if store-item (and (extract-information-from conn store guix-revision-id commit store-item) (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)))) (begin (simple-format #t "Failed to generate store item for ~A\n" commit) #f))))) (define (enqueue-load-new-guix-revision-job conn git-repository-id commit source) (define query " INSERT INTO load_new_guix_revision_jobs (git_repository_id, commit, source) VALUES ($1, $2, $3) ON CONFLICT DO NOTHING RETURNING id;") (match (exec-query conn query (list (number->string git-repository-id) commit source)) ((result) result) (() #f))) (define (select-load-new-guix-revision-job-metrics conn) (define query " SELECT COALESCE(git_repositories.label, git_repositories.url) AS repository_label, CASE WHEN succeeded_at IS NOT NULL THEN 'succeeded' WHEN ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry' ) >= ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure' ) THEN 'queued' ELSE 'failed' END AS state, COUNT(*) FROM load_new_guix_revision_jobs INNER JOIN git_repositories ON load_new_guix_revision_jobs.git_repository_id = git_repositories.id GROUP BY 1, 2") (map (match-lambda ((label state count) (list label state (string->number count)))) (exec-query conn query))) (define (select-job-for-commit conn commit) (let ((result (exec-query conn " SELECT id, commit, source, git_repository_id, CASE WHEN succeeded_at IS NOT NULL THEN 'succeeded' WHEN ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry' ) >= ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure' ) THEN 'queued' ELSE 'failed' END AS state FROM load_new_guix_revision_jobs WHERE commit = $1" (list commit)))) (match result (() #f) (((id commit source git_repository_id state)) `((id . ,(string->number id)) (commit . ,commit) (source . ,source) (git_repository_id . ,(string->number git_repository_id)) (state . ,state)))))) (define* (select-recent-job-events conn #:key (limit 8)) (define query (string-append " SELECT load_new_guix_revision_jobs.id, load_new_guix_revision_jobs.commit, load_new_guix_revision_jobs.source, load_new_guix_revision_jobs.git_repository_id, load_new_guix_revision_job_events.event, load_new_guix_revision_job_events.occurred_at FROM load_new_guix_revision_jobs INNER JOIN load_new_guix_revision_job_events ON load_new_guix_revision_job_events.job_id = load_new_guix_revision_jobs.id ORDER BY load_new_guix_revision_job_events.occurred_at DESC LIMIT " (number->string limit))) (exec-query conn query)) (define (select-jobs-and-events conn before-id limit) (define query (string-append " SELECT load_new_guix_revision_jobs.id, load_new_guix_revision_jobs.commit, load_new_guix_revision_jobs.source, load_new_guix_revision_jobs.git_repository_id, load_new_guix_revision_jobs.created_at, load_new_guix_revision_jobs.succeeded_at, ( SELECT JSON_AGG( json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC ) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id ), EXISTS ( SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id ) AS log_exists FROM load_new_guix_revision_jobs " (if before-id (string-append "WHERE load_new_guix_revision_jobs.id < " (number->string before-id)) "") " ORDER BY load_new_guix_revision_jobs.id DESC " (if limit (string-append "LIMIT " (number->string limit)) ""))) (map (match-lambda ((id commit source git-repository-id created-at succeeded-at events-json log-exists?) (list id commit source git-repository-id created-at succeeded-at (if (or (eq? #f events-json) (string-null? events-json)) #() (json-string->scm events-json)) (string=? log-exists? "t")))) (exec-query conn query))) (define (select-unprocessed-jobs-and-events conn) (define query " SELECT load_new_guix_revision_jobs.id, load_new_guix_revision_jobs.commit, load_new_guix_revision_jobs.source, load_new_guix_revision_jobs.git_repository_id, load_new_guix_revision_jobs.created_at, ( SELECT JSON_AGG( json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC ) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id ), EXISTS ( SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id ) AS log_exists, commit IN ( SELECT commit FROM ( SELECT DISTINCT ON (name) name, git_commits.commit FROM git_branches INNER JOIN git_commits ON git_commits.git_branch_id = git_branches.id WHERE git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id ORDER BY name, datetime DESC ) branches_and_latest_commits ) AS latest_branch_commit FROM load_new_guix_revision_jobs WHERE succeeded_at IS NULL AND ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry' ) >= ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure' ) ORDER BY latest_branch_commit DESC, id DESC") (map (match-lambda ((id commit source git-repository-id created-at events-json log-exists? latest-branch-commit) (list id commit source git-repository-id created-at (if (or (eq? #f events-json) (string-null? events-json)) #() (json-string->scm events-json)) (string=? log-exists? "t") (string=? latest-branch-commit "t")))) (exec-query conn query))) (define (select-jobs-and-events-for-commit conn commit) (define query " SELECT load_new_guix_revision_jobs.id, load_new_guix_revision_jobs.source, load_new_guix_revision_jobs.git_repository_id, load_new_guix_revision_jobs.created_at, load_new_guix_revision_jobs.succeeded_at, ( SELECT JSON_AGG( json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC ) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id ), EXISTS ( SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id ) AS log_exists FROM load_new_guix_revision_jobs WHERE commit = $1 ORDER BY load_new_guix_revision_jobs.id DESC") (map (match-lambda ((id source git-repository-id created-at succeeded-at events-json log-exists?) (list id commit source git-repository-id created-at succeeded-at (if (or (eq? #f events-json) (string-null? events-json)) #() (json-string->scm events-json)) (string=? log-exists? "t")))) (exec-query conn query (list commit)))) (define (guix-revision-loaded-successfully? conn commit) (define query " SELECT EXISTS( SELECT 1 FROM load_new_guix_revision_jobs INNER JOIN load_new_guix_revision_job_events ON job_id = load_new_guix_revision_jobs.id WHERE commit = $1 AND event = 'success' )") (let ((result (caar (exec-query conn query (list commit))))) (string=? result "t"))) (define (most-recent-n-load-new-guix-revision-jobs conn n) (let ((result (exec-query conn " SELECT id, commit, source, git_repository_id FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT $1" (list (number->string n))))) result)) (define (select-job-for-update conn id) (exec-query conn " SELECT id, commit, source, git_repository_id FROM load_new_guix_revision_jobs WHERE id = $1 AND succeeded_at IS NULL FOR NO KEY UPDATE SKIP LOCKED" (list id))) (define (record-job-event conn job-id event) (exec-query conn (string-append " INSERT INTO load_new_guix_revision_job_events (job_id, event) VALUES ($1, $2)") (list job-id event))) (define (record-job-succeeded conn id) (exec-query conn (string-append " UPDATE load_new_guix_revision_jobs SET succeeded_at = clock_timestamp() WHERE id = $1 ") (list id))) (define (fetch-unlocked-jobs conn) (define query " SELECT id, commit IN ( SELECT commit FROM ( SELECT DISTINCT ON (name) name, git_commits.commit FROM git_branches INNER JOIN git_commits ON git_commits.git_branch_id = git_branches.id WHERE git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id ORDER BY name, datetime DESC ) branches_and_latest_commits ) AS latest_branch_commit FROM load_new_guix_revision_jobs WHERE succeeded_at IS NULL AND ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry' ) >= ( SELECT COUNT(*) FROM load_new_guix_revision_job_events WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure' ) ORDER BY latest_branch_commit DESC, id DESC FOR NO KEY UPDATE OF load_new_guix_revision_jobs SKIP LOCKED") (map (match-lambda ((id priority) (list id (string=? priority "t")))) (exec-query conn query))) (define (with-store-connection f) (with-store store (set-build-options store #:fallback? #t) (f store))) (prevent-inlining-for-tests with-store-connection) (define (setup-logging id thunk) (let* ((previous-output-port (current-output-port)) (previous-error-port (current-error-port)) (result (with-postgresql-connection (simple-format #f "load-new-guix-revision ~A logging" id) (lambda (logging-conn) (insert-empty-log-entry logging-conn id) (let ((logging-port (log-port id logging-conn #:delete-existing-log-parts? #t))) (set-current-output-port logging-port) (set-current-error-port logging-port) (let ((result (parameterize ((current-build-output-port logging-port) (real-error-port previous-error-port) (inferior-error-port (setup-port-for-inferior-error-output id previous-error-port))) (thunk)))) (set-current-output-port previous-output-port) (set-current-error-port previous-error-port) ;; This can happen with GC, so do it explicitly (close-port logging-port) (combine-log-parts! logging-conn id) result)))))) result)) (define (cleanup-logging id conn) (drop-log-parts-sequence conn id) (with-time-logging "vacuuming log parts" (vacuum-log-parts-table conn))) (prevent-inlining-for-tests setup-logging) (define (process-load-new-guix-revision-job id) (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) (setup-logging id (lambda () (with-exception-handler (const #f) (lambda () (with-throw-handler #t (lambda () (with-store-connection (lambda (store) (load-new-guix-revision conn store git-repository-id commit)))) (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") (with-time-logging "cleanup logging" (cleanup-logging id conn)) (with-time-logging "vacuuming package derivations by guix revision range table" (vacuum-package-derivations-table conn)) #t) (begin (exec-query conn "ROLLBACK") (record-job-event conn id "failure") (with-time-logging "cleanup logging" (cleanup-logging id conn)) #f))) (() (exec-query conn "ROLLBACK") (simple-format #t "job ~A not found to be processed\n" id))))))