guix/data-service
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/data-service.git synced 2023-12-14 03:23:03 +01:00
Code Issues Releases Wiki Activity
data-service/guix-data-service/jobs/load-new-guix-revision.scm
Christopher Baines a6a4a84b20 Avoid problems with lint warnings for duplicate packages 
Use the deduplicated list of packages when fetching lint warnings, to avoid
duplicates. This was first seen in the following Guix commit
843344273c6a587b8e6c84d8406500fd64d8908a.
2020-08-09 16:53:26 +01:00

1669 lines
63 KiB
Scheme
Raw Blame History

;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service jobs load-new-guix-revision)
#:use-module (srfi srfi-1)
#: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 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-job-for-commit
select-jobs-and-events
select-recent-job-events
select-unprocessed-jobs-and-events
select-jobs-and-events-for-commit
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")))
(insert logging-conn job-id line-with-newline)
(display line-with-newline real-output-port))
(loop (get-line port-to-read-from)))))))3
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
",'&','&amp;')")
",'<','&lt;')")
",'>','&gt;')"))
(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)
(exec-query
conn
(string-append
"DROP SEQUENCE "
(log-part-sequence-name job-id))))
(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 (all-inferior-system-tests inf store)
(define inferior-%supported-systems
(inferior-eval '(@ (guix packages) %supported-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)
(map (lambda (system)
(cons
system
(parameterize ((%current-system system))
(derivation-file-name
(run-with-store store
(mbegin %store-monad
(system-test-value system-test)))))))
(list ,@inferior-%supported-systems))
(match (system-test-location system-test)
(($ <location> 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.utf8"
"da_DK.utf8"
"de_DE.utf8"
"eo_EO.utf8"
"es_ES.utf8"
"fr_FR.utf8"
"hu_HU.utf8"
"pl_PL.utf8"
"pt_BR.utf8"
;;"sr_SR.utf8"
"sv_SE.utf8"
"vi_VN.utf8"
"zh_CN.utf8"))
(define (lint-warnings-for-checker 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)
(($ <location> 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.utf8")
(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
(match-lambda
((package-id . warnings)
(not (null? warnings))))
(map
(lambda (package-id)
(let ((package (hashv-ref %package-table package-id)))
(cons
package-id
(map process-lint-warning
(if (and lint-checker-requires-store?-defined?
(lint-checker-requires-store? checker))
(check package #:store store)
(check package))))))
(list ,@(map inferior-package-id packages)))))))
(and
(or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f)
(use-modules (guix lint)
(guix i18n))
#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.utf8")
(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)
(inferior-eval-with-store inf store (lint-warnings-for-checker
name)))))))
checkers))))
(define (all-inferior-package-derivations store inf packages)
(define inferior-%supported-systems
(inferior-eval '(@ (guix packages) %supported-systems) inf))
(define cross-derivations
`(("x86_64-linux" . ("arm-linux-gnueabihf"
"aarch64-linux-gnu"
"powerpc-linux-gnu"
"riscv64-linux-gnu"
"i586-pc-gnu"))))
(define supported-system-pairs
(map (lambda (system)
(cons system #f))
inferior-%supported-systems))
(define supported-system-cross-build-pairs
(append-map
(match-lambda
((system . targets)
(list
(map (lambda (target)
(cons system target))
targets))))
cross-derivations))
(define (proc packages system-target-pairs)
`(lambda (store)
(define target-system-alist
'(("arm-linux-gnueabihf" . "armhf-linux")
("aarch64-linux-gnu" . "aarch64-linux")
("powerpc-linux-gnu" . "") ; TODO I don't know?
("riscv64-linux-gnu" . "") ; TODO I don't know?
("i586-pc-gnu" . "i586-gnu")))
;; TODO Currently unused
(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 one\n")
(set! package-transitive-supported-systems-supports-multiple-arguments? #f)
#f)))
(catch
#t
(lambda ()
(package-transitive-supported-systems package))
(lambda (key . args)
(simple-format
(current-error-port)
"error: while processing ~A, unable to compute transitive 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 (package-supported-systems package)))
(if 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)))
(member system-for-target
supported-systems
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)))))
(append-map
(lambda (system-target-pairs)
(format (current-error-port)
"heap size: ~a MiB~%"
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pairs)
(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 system-target-pairs))))
(append (map list 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)))
(string<? (inferior-package-version a)
(inferior-package-version b))))
(string<? a-name
b-name)))))))
(define (insert-packages conn inf packages)
(let* ((package-license-set-ids
(with-time-logging "fetching inferior package license metadata"
(inferior-packages->license-set-ids
conn
(inferior-packages->license-id-lists
conn
(inferior-packages->license-data inf packages)))))
(packages-metadata-ids
(with-time-logging "fetching inferior package metadata"
(inferior-packages->package-metadata-ids
conn inf packages package-license-set-ids))))
(with-time-logging "getting package-ids"
(inferior-packages->package-ids
conn
(zip (map inferior-package-name packages)
(map inferior-package-version packages)
packages-metadata-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)
(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)
(parameterize ((%current-system system))
(let ((manifest
(catch #t
(lambda ()
((channel-instances->manifest instances) 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
(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)))))))
(inferior-eval '(use-modules (srfi srfi-1)
(guix channels)
(guix grafts)
(guix profiles))
inferior)
(inferior-eval '(when (defined? '%graft?) (%graft? #f))
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)
(let* ((derivation-file-names-by-system
(with-time-logging "computing the channel derivation"
(channel->derivation-file-names-by-system conn store channel))))
(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 (extract-information-from conn store guix-revision-id commit store-path)
(simple-format #t "debug: extract-information-from: ~A\n" 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
(catch
#t
(lambda ()
(inferior-eval '(setlocale LC_ALL "en_US.utf8") inf))
(lambda (key . args)
(simple-format (current-error-port)
"warning: failed to set locale to en_US.utf8: ~A ~A\n"
key args)
(display "trying to setlocale to en_US.UTF-8 instead\n"
(current-error-port))
(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)
(guix grafts)
(guix derivations)
(gnu tests))
inf)
(inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf)
(catch
#t
(lambda ()
(let* ((packages
(with-time-logging "fetching inferior packages"
(deduplicate-inferior-packages
(inferior-packages 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))))
(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 inf packages))
(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)))))))
(simple-format
#t "debug: finished loading information from inferior\n")
(close-inferior inf)
(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))))
(update-builds-derivation-output-details-set-id
conn
(map fourth 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-new-guix-revision conn store git-repository-id commit)
(let* ((channel-for-commit
(channel (name 'guix)
(url (git-repository-id->url
conn
git-repository-id))
(commit commit)))
(channel-derivations-by-system
(channel->derivations-by-system conn
store
channel-for-commit))
(store-item
(channel-derivations-by-system->guix-store-item
store
channel-derivations-by-system)))
(if store-item
(let ((guix-revision-id
(insert-guix-revision conn git-repository-id
commit store-item)))
(and
guix-revision-id
(extract-information-from conn store
guix-revision-id
commit store-item)
(insert-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))
(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)))
(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-job-for-commit conn commit)
(let ((result
(exec-query
conn
(string-append
"SELECT id, commit, source, git_repository_id "
"FROM load_new_guix_revision_jobs WHERE commit = $1")
(list commit))))
result))
(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 (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_branches.commit
FROM git_branches
WHERE
git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id AND
git_branches.commit IS NOT NULL
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 (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 (string-null? events-json)
#()
(json-string->scm events-json))
(string=? log-exists? "t"))))
(exec-query conn query (list commit))))
(define (most-recent-n-load-new-guix-revision-jobs conn n)
(let ((result
(exec-query
conn
(string-append
"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
(string-append
"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_branches.commit
FROM git_branches
WHERE
git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id AND
git_branches.commit IS NOT NULL
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))))
(combine-log-parts! logging-conn id)
(drop-log-parts-sequence logging-conn id)
;; This can happen with GC, so do it explicitly
(close-port logging-port)
result))))))
(set-current-output-port previous-output-port)
(set-current-error-port previous-error-port)
result))
(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 (or
(guix-revision-exists? conn git-repository-id commit)
(eq?
(with-time-logging (string-append "loading revision " commit)
(setup-logging
id
(lambda ()
(with-exception-handler
(const #f)
(lambda ()
(with-exception-handler
(lambda (exn)
(simple-format (current-error-port)
"error: load-new-guix-revision: ~A\n"
exn)
(backtrace)
#f)
(lambda ()
(with-store-connection
(lambda (store)
(load-new-guix-revision conn
store
git-repository-id
commit))))))
#:unwind? #t))))
#t))
(begin
(record-job-succeeded conn id)
(record-job-event conn id "success")
(exec-query conn "COMMIT")
#t)
(begin
(exec-query conn "ROLLBACK")
(record-job-event conn id "failure")
#f)))
(()
(exec-query conn "ROLLBACK")
(simple-format #t "job ~A not found to be processed\n"
id))))))
View git blame Copy permalink