mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
There's an issue where sometimes for i686-linux and armhf-linux, only a few package derivations are computed. This commit tries to simplify the code, and adds some conditional logging for the guix package, which might help reveal what's going on.
2246 lines
84 KiB
Scheme
2246 lines
84 KiB
Scheme
;;; 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 (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 build syscalls)
|
|
#:select (set-thread-name))
|
|
#: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 ()
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(set-thread-name "inferior logging"))
|
|
(const #t))
|
|
|
|
(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 guix-source guix-commit)
|
|
(define inf-systems
|
|
(inferior-guix-systems inf))
|
|
|
|
(define extract
|
|
`(lambda (store)
|
|
(parameterize ((current-guix-package
|
|
(channel-source->package ,guix-source
|
|
#:commit ,guix-commit)))
|
|
(map
|
|
(lambda (system-test)
|
|
(let ((stats (gc-stats)))
|
|
(simple-format
|
|
(current-error-port)
|
|
"inferior heap: ~a MiB used (~a MiB heap)~%"
|
|
(round
|
|
(/ (- (assoc-ref stats 'heap-size)
|
|
(assoc-ref stats 'heap-free-size))
|
|
(expt 2. 20)))
|
|
(round
|
|
(/ (assoc-ref (gc-stats) 'heap-size)
|
|
(expt 2. 20)))))
|
|
|
|
(list (system-test-name system-test)
|
|
(system-test-description system-test)
|
|
(filter-map
|
|
(lambda (system)
|
|
(simple-format
|
|
(current-error-port)
|
|
"guix-data-service: computing derivation for ~A system test (on ~A)\n"
|
|
(system-test-name system-test)
|
|
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)
|
|
(($ <location> file line column)
|
|
(list file
|
|
line
|
|
column)))))
|
|
(all-system-tests)))))
|
|
|
|
(catch
|
|
#t
|
|
(lambda ()
|
|
(inferior-eval
|
|
;; For channel-source->package
|
|
'(use-modules (gnu packages package-management))
|
|
inf)
|
|
|
|
(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)
|
|
(($ <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.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 (or network-dependent?
|
|
(eq? name 'derivation))
|
|
'()
|
|
(let ((warnings
|
|
(with-time-logging (simple-format #f "getting ~A lint warnings"
|
|
name)
|
|
(inferior-eval-with-store
|
|
inf
|
|
store
|
|
(lint-warnings-for-checker packages
|
|
name)))))
|
|
(cleanup-inferior inf)
|
|
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
|
|
'(lambda (store system-target-pair)
|
|
(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 (derivation-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
|
|
(simple-format
|
|
(current-error-port)
|
|
"warning: error when computing ~A derivation for system ~A (~A): ~A\n"
|
|
(package-name package)
|
|
system
|
|
(or target "no target")
|
|
args)
|
|
#f)))
|
|
|
|
(filter-map
|
|
(lambda (inferior-package-id)
|
|
(let ((package (hashv-ref %package-table inferior-package-id)))
|
|
(catch
|
|
#t
|
|
(lambda ()
|
|
(let* ((system (car system-target-pair))
|
|
(target (cdr system-target-pair))
|
|
(supported-systems (get-supported-systems package system))
|
|
(system-supported?
|
|
(and supported-systems
|
|
(->bool (member system supported-systems))))
|
|
(target-supported?
|
|
(or (not target)
|
|
(let ((system-for-target
|
|
(assoc-ref target-system-alist
|
|
target)))
|
|
(or (not system-for-target)
|
|
(->bool
|
|
(member system-for-target
|
|
(package-supported-systems package)
|
|
string=?)))))))
|
|
|
|
(when (string=? (package-name package) "guix")
|
|
(simple-format
|
|
(current-error-port)
|
|
"looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n"
|
|
supported-systems
|
|
system-supported?
|
|
target-supported?))
|
|
|
|
(if system-supported?
|
|
(if target-supported?
|
|
(derivation-for-system-and-target inferior-package-id
|
|
package
|
|
system
|
|
target)
|
|
#f)
|
|
#f)))
|
|
(lambda (key . args)
|
|
(if (and (eq? key 'system-error)
|
|
(eq? (car args) 'fport_write))
|
|
(begin
|
|
(simple-format
|
|
(current-error-port)
|
|
"error: while processing ~A, exiting: ~A: ~A\n"
|
|
(package-name package)
|
|
key
|
|
args)
|
|
(exit 1))
|
|
(begin
|
|
(simple-format
|
|
(current-error-port)
|
|
"error: while processing ~A ignoring error: ~A: ~A\n"
|
|
(package-name package)
|
|
key
|
|
args)
|
|
#f))))))
|
|
gds-inferior-package-ids)))
|
|
|
|
(inferior-eval
|
|
'(when (defined? 'systems (resolve-module '(guix platform)))
|
|
(use-modules (guix platform)))
|
|
inf)
|
|
|
|
(inferior-eval
|
|
`(define gds-inferior-package-ids
|
|
(list ,@(map inferior-package-id packages)))
|
|
inf)
|
|
|
|
(inferior-eval
|
|
`(define gds-packages-proc ,proc)
|
|
inf)
|
|
|
|
(append-map!
|
|
(lambda (system-target-pair)
|
|
(format (current-error-port)
|
|
"heap size: ~a MiB~%"
|
|
(round
|
|
(/ (assoc-ref (gc-stats) 'heap-size)
|
|
(expt 2. 20))))
|
|
|
|
(format (current-error-port)
|
|
"inferior heap before cleanup: ~a MiB used (~a MiB heap)~%"
|
|
(round
|
|
(/ (inferior-eval
|
|
'(let ((stats (gc-stats)))
|
|
(- (assoc-ref stats 'heap-size)
|
|
(assoc-ref stats 'heap-free-size)))
|
|
inf)
|
|
(expt 2. 20)))
|
|
(round
|
|
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
|
|
(expt 2. 20))))
|
|
(catch
|
|
'match-error
|
|
(lambda ()
|
|
(inferior-eval '(invalidate-derivation-caches!) inf))
|
|
(lambda (key . args)
|
|
(simple-format
|
|
(current-error-port)
|
|
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
|
|
|
|
;; Clean the cached store connections, as there are caches associated
|
|
;; with these that take up lots of memory
|
|
(inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf)
|
|
|
|
(inferior-eval '(gc) inf)
|
|
|
|
(format (current-error-port)
|
|
"inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
|
|
(round
|
|
(/ (inferior-eval
|
|
'(let ((stats (gc-stats)))
|
|
(- (assoc-ref stats 'heap-size)
|
|
(assoc-ref stats 'heap-free-size)))
|
|
inf)
|
|
(expt 2. 20)))
|
|
(round
|
|
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
|
|
(expt 2. 20))))
|
|
|
|
(with-time-logging
|
|
(simple-format #f "getting derivations for ~A" system-target-pair)
|
|
(inferior-eval-with-store
|
|
inf
|
|
store
|
|
`(lambda (store)
|
|
(gds-packages-proc store (cons ,(car system-target-pair)
|
|
,(cdr system-target-pair)))))))
|
|
(append supported-system-pairs
|
|
supported-system-cross-build-pairs)))
|
|
|
|
(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<? a-version
|
|
b-version)))
|
|
(string<? a-name
|
|
b-name)))))))
|
|
|
|
(define (inferior-packages-plus-replacements inf)
|
|
(let* ((packages (inferior-packages inf))
|
|
(replacements (filter-map inferior-package-replacement packages))
|
|
(non-exported-replacements
|
|
(let ((package-id-hash-table (make-hash-table)))
|
|
(for-each (lambda (pkg)
|
|
(hash-set! package-id-hash-table
|
|
(inferior-package-id pkg)
|
|
#t))
|
|
packages)
|
|
|
|
(filter (lambda (pkg)
|
|
(eq? #f
|
|
(hash-ref package-id-hash-table
|
|
(inferior-package-id pkg))))
|
|
replacements)))
|
|
|
|
(deduplicated-packages
|
|
;; This isn't perfect, sometimes there can be two packages with the
|
|
;; same name and version, but different derivations. Guix will warn
|
|
;; about this case though, generally this means only one of the
|
|
;; packages should be exported.
|
|
(deduplicate-inferior-packages
|
|
(append! packages non-exported-replacements))))
|
|
|
|
|
|
deduplicated-packages))
|
|
|
|
(define* (all-inferior-packages-data inf packages #:key (process-replacements? #t))
|
|
(let* ((package-license-data
|
|
(with-time-logging "fetching inferior package license metadata"
|
|
(inferior-packages->license-data inf packages)))
|
|
(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->source-and-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)
|
|
|
|
(cons
|
|
(channel-instance-checkout channel-instance)
|
|
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->source-and-derivations-by-system conn store channel
|
|
fetch-with-authentication?)
|
|
(match (with-time-logging "computing the channel derivation"
|
|
(channel->source-and-derivation-file-names-by-system
|
|
conn
|
|
store
|
|
channel
|
|
fetch-with-authentication?))
|
|
((source . derivation-file-names-by-system)
|
|
(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)
|
|
|
|
(cons source derivation-file-names-by-system))))
|
|
|
|
(prevent-inlining-for-tests channel->source-and-derivations-by-system)
|
|
|
|
(define (channel-derivations-by-system->guix-store-item
|
|
store
|
|
channel-derivations-by-system)
|
|
|
|
(define (store-item->guix-store-item filename)
|
|
(dirname
|
|
(readlink
|
|
(string-append filename "/bin"))))
|
|
|
|
(let ((derivation-file-name-for-current-system
|
|
(assoc-ref
|
|
(assoc-ref channel-derivations-by-system
|
|
(%current-system))
|
|
'profile)))
|
|
(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
|
|
guix-source store-path
|
|
#:key skip-system-tests?)
|
|
(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
|
|
(if skip-system-tests?
|
|
(begin
|
|
(simple-format #t "debug: skipping system tests\n")
|
|
'())
|
|
(with-time-logging "getting inferior system tests"
|
|
(all-inferior-system-tests inf store
|
|
guix-source commit))))
|
|
(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)
|
|
|
|
(chunk-for-each!
|
|
(lambda (lint-warning-ids-chunk)
|
|
(insert-guix-revision-lint-warnings conn
|
|
guix-revision-id
|
|
lint-warning-ids-chunk))
|
|
5000
|
|
lint-warning-ids)))
|
|
|
|
(when inferior-system-tests
|
|
(insert-system-tests-for-guix-revision conn
|
|
guix-revision-id
|
|
inferior-system-tests))
|
|
|
|
(let* ((package-derivation-ids
|
|
(with-time-logging "inferior-data->package-derivation-ids"
|
|
(inferior-data->package-derivation-ids
|
|
conn inf inferior-package-id->package-database-id
|
|
inferior-data-4-tuples)))
|
|
(ids-count
|
|
(length package-derivation-ids)))
|
|
(chunk-for-each! (lambda (package-derivation-ids-chunk)
|
|
(insert-guix-revision-package-derivations
|
|
conn
|
|
guix-revision-id
|
|
package-derivation-ids-chunk))
|
|
2000
|
|
package-derivation-ids)
|
|
(simple-format
|
|
#t "Successfully loaded ~A package/derivation pairs\n"
|
|
ids-count))
|
|
|
|
(with-time-logging
|
|
"insert-guix-revision-package-derivation-distribution-counts"
|
|
(insert-guix-revision-package-derivation-distribution-counts
|
|
conn
|
|
guix-revision-id))))
|
|
#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
|
|
#:key skip-system-tests?)
|
|
(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)))
|
|
(source-and-channel-derivations-by-system
|
|
(channel->source-and-derivations-by-system conn
|
|
store
|
|
channel-for-commit
|
|
fetch-with-authentication?))
|
|
(guix-source
|
|
(car source-and-channel-derivations-by-system))
|
|
(channel-derivations-by-system
|
|
(cdr source-and-channel-derivations-by-system))
|
|
(guix-revision-id
|
|
(load-channel-instances git-repository-id commit
|
|
channel-derivations-by-system)))
|
|
(let ((store-item
|
|
(channel-derivations-by-system->guix-store-item
|
|
store
|
|
channel-derivations-by-system)))
|
|
(if store-item
|
|
(and
|
|
(extract-information-from conn store
|
|
guix-revision-id
|
|
commit guix-source store-item
|
|
#:skip-system-tests?
|
|
skip-system-tests?)
|
|
|
|
(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 #:key skip-system-tests?)
|
|
(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
|
|
#:skip-system-tests?
|
|
skip-system-tests?))))
|
|
(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))
|
|
|
|
(with-time-logging
|
|
"vacuum-derivation-inputs-table"
|
|
(vacuum-derivation-inputs-table conn))
|
|
|
|
(match (exec-query
|
|
conn
|
|
"SELECT reltuples::bigint FROM pg_class WHERE relname = 'derivation_inputs'")
|
|
(((rows))
|
|
;; Don't attempt counting distinct values if there are too
|
|
;; many rows, as that is far to slow and could use up all the
|
|
;; disk space.
|
|
(when (< (string->number rows)
|
|
1000000000)
|
|
(with-time-logging
|
|
"update-derivation-inputs-statistics"
|
|
(update-derivation-inputs-statistics conn)))))
|
|
|
|
(with-time-logging
|
|
"vacuum-derivation-outputs-table"
|
|
(vacuum-derivation-outputs-table conn))
|
|
|
|
(with-time-logging
|
|
"update-derivation-outputs-statistics"
|
|
(update-derivation-outputs-statistics conn))
|
|
|
|
#t)
|
|
(begin
|
|
(exec-query conn "ROLLBACK")
|
|
(record-job-event conn id "failure")
|
|
|
|
(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))))))
|