cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Switch to using some shorter syntax for logging time taken

Browse source 
In the load-new-guix-revision module.
This commit is contained in:
Christopher Baines 2020-02-24 21:31:04 +00:00
parent 49d10cfe14
commit ce10833459
1 changed files with 108 additions and 152 deletions
Download patch file Download diff file Expand all files Collapse all files

260
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -35,6 +35,7 @@
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix-data-service config) #:use-module (guix-data-service config)
#:use-module (guix-data-service database) #: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 build)
#:use-module (guix-data-service model channel-instance) #:use-module (guix-data-service model channel-instance)
#:use-module (guix-data-service model channel-news) #:use-module (guix-data-service model channel-news)
@ -254,15 +255,6 @@ WHERE job_id = $1"
(define inferior-package-id (define inferior-package-id
(@@ (guix inferior) inferior-package-id)) (@@ (guix inferior) inferior-package-id))
(define (log-time action f)
(simple-format #t "debug: Starting ~A\n" action)
(let* ((start-time (current-time))
(result (f))
(time-taken (- (current-time) start-time)))
(simple-format #t "debug: Finished ~A, took ~A seconds\n"
action time-taken)
result))
(define (record-start-time action) (define (record-start-time action)
(simple-format #t "debug: Starting ~A\n" action) (simple-format #t "debug: Starting ~A\n" action)
(cons action (cons action
@ -306,10 +298,8 @@ WHERE job_id = $1"
(all-system-tests)))) (all-system-tests))))
(let ((system-test-data (let ((system-test-data
(log-time (with-time-logging "getting system tests"
"getting system tests" (inferior-eval-with-store inf store extract))))
(lambda ()
(inferior-eval-with-store inf store extract)))))
(for-each (lambda (derivation-file-name) (for-each (lambda (derivation-file-name)
(add-temp-root store derivation-file-name)) (add-temp-root store derivation-file-name))
@ -423,11 +413,10 @@ WHERE job_id = $1"
(list name description network-dependent?) (list name description network-dependent?)
(if network-dependent? (if network-dependent?
'() '()
(log-time (with-time-logging (simple-format #f "getting ~A lint warnings"
(simple-format #f "getting ~A lint warnings" name) name)
(lambda () (inferior-eval-with-store inf store (lint-warnings-for-checker
(inferior-eval-with-store inf store (lint-warnings-for-checker name)))))))
name))))))))
checkers)))) checkers))))
(define (all-inferior-package-derivations store inf packages) (define (all-inferior-package-derivations store inf packages)
@ -579,18 +568,17 @@ WHERE job_id = $1"
(round (round
(/ (assoc-ref (gc-stats) 'heap-size) (/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20)))) (expt 2. 20))))
(log-time (with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pairs) (simple-format #f "getting derivations for ~A" system-target-pairs)
(lambda () (catch
(catch 'match-error
'match-error (lambda ()
(lambda () (inferior-eval '(invalidate-derivation-caches!) inf))
(inferior-eval '(invalidate-derivation-caches!) inf)) (lambda (key . args)
(lambda (key . args) (simple-format
(simple-format (current-error-port)
(current-error-port) "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n"))) (inferior-eval-with-store inf store (proc packages system-target-pairs))))
(inferior-eval-with-store inf store (proc packages system-target-pairs)))))
(append (map list supported-system-pairs) (append (map list supported-system-pairs)
supported-system-cross-build-pairs))) supported-system-cross-build-pairs)))
@ -637,23 +625,20 @@ WHERE job_id = $1"
(define (insert-packages conn inf packages) (define (insert-packages conn inf packages)
(let* ((package-license-set-ids (let* ((package-license-set-ids
(log-time "fetching inferior package license metadata" (with-time-logging "fetching inferior package license metadata"
(lambda () (inferior-packages->license-set-ids conn inf
(inferior-packages->license-set-ids conn inf packages)))
packages))))
(packages-metadata-ids (packages-metadata-ids
(log-time "fetching inferior package metadata" (with-time-logging "fetching inferior package metadata"
(lambda () (inferior-packages->package-metadata-ids
(inferior-packages->package-metadata-ids conn packages package-license-set-ids))))
conn packages package-license-set-ids)))))
(log-time "getting package-ids" (with-time-logging "getting package-ids"
(lambda () (inferior-packages->package-ids
(inferior-packages->package-ids conn
conn (zip (map inferior-package-name packages)
(zip (map inferior-package-name packages) (map inferior-package-version packages)
(map inferior-package-version packages) packages-metadata-ids)))))
packages-metadata-ids))))))
(define (insert-lint-warnings conn inferior-package-id->package-database-id (define (insert-lint-warnings conn inferior-package-id->package-database-id
lint-checker-ids lint-checker-ids
@ -741,10 +726,8 @@ WHERE job_id = $1"
(let* ((guix-package (@ (gnu packages package-management) (let* ((guix-package (@ (gnu packages package-management)
guix)) guix))
(derivation (package-derivation store guix-package))) (derivation (package-derivation store guix-package)))
(log-time (with-time-logging "building the guix derivation"
"building the guix derivation" (build-derivations store (list derivation)))
(lambda ()
(build-derivations store (list derivation))))
(let ((new-store-path (let ((new-store-path
(derivation->output-path derivation))) (derivation->output-path derivation)))
@ -758,10 +741,8 @@ WHERE job_id = $1"
(let* ((nss-certs-package (@ (gnu packages certs) (let* ((nss-certs-package (@ (gnu packages certs)
nss-certs)) nss-certs))
(derivation (package-derivation store nss-certs-package))) (derivation (package-derivation store nss-certs-package)))
(log-time (with-time-logging "building the nss-certs derivation"
"building the nss-certs derivation" (build-derivations store (list derivation)))
(lambda ()
(build-derivations store (list derivation))))
(derivation->output-path derivation))) (derivation->output-path derivation)))
(define (channel->derivation-file-names-by-system store channel) (define (channel->derivation-file-names-by-system store channel)
@ -910,16 +891,14 @@ WHERE job_id = $1"
(define (channel->derivations-by-system conn store channel) (define (channel->derivations-by-system conn store channel)
(let* ((derivation-file-names-by-system (let* ((derivation-file-names-by-system
(log-time (with-time-logging "computing the channel derivation"
"computing the channel derivation" ;; Obtain a session level lock here, to avoid conflicts with
(lambda () ;; other jobs over the Git repository.
;; Obtain a session level lock here, to avoid conflicts with (with-advisory-session-lock/log-time
;; other jobs over the Git repository. conn
(with-advisory-session-lock/log-time 'channel->manifest-store-item
conn (lambda ()
'channel->manifest-store-item (channel->derivation-file-names-by-system store channel))))))
(lambda ()
(channel->derivation-file-names-by-system store channel)))))))
(for-each (for-each
(match-lambda (match-lambda
((system . derivation-file-name) ((system . derivation-file-name)
@ -948,10 +927,8 @@ WHERE job_id = $1"
(if derivation-file-name-for-current-system (if derivation-file-name-for-current-system
(let ((derivation-for-current-system (let ((derivation-for-current-system
(read-derivation-from-file derivation-file-name-for-current-system))) (read-derivation-from-file derivation-file-name-for-current-system)))
(log-time (with-time-logging "building the channel derivation"
"building the channel derivation" (build-derivations store (list derivation-for-current-system)))
(lambda ()
(build-derivations store (list derivation-for-current-system))))
(store-item->guix-store-item (store-item->guix-store-item
(derivation->output-path derivation-for-current-system))) (derivation->output-path derivation-for-current-system)))
@ -982,10 +959,8 @@ WHERE job_id = $1"
inferior-glibc-locales)) inferior-glibc-locales))
(output (derivation->output-path derivation))) (output (derivation->output-path derivation)))
(close-inferior inf) (close-inferior inf)
(log-time (with-time-logging "building the glibc-locales derivation"
"building the glibc-locales derivation" (build-derivations store (list derivation)))
(lambda ()
(build-derivations store (list derivation))))
output))) output)))
@ -1064,34 +1039,25 @@ WHERE job_id = $1"
#t #t
(lambda () (lambda ()
(let* ((packages (let* ((packages
(log-time (with-time-logging "fetching inferior packages"
"fetching inferior packages" (deduplicate-inferior-packages
(lambda () (inferior-packages inf))))
(deduplicate-inferior-packages
(inferior-packages inf)))))
(inferior-lint-warnings (inferior-lint-warnings
(log-time (with-time-logging "fetching inferior lint warnings"
"fetching inferior lint warnings" (all-inferior-lint-warnings inf store)))
(lambda ()
(all-inferior-lint-warnings inf store))))
(inferior-data-4-tuples (inferior-data-4-tuples
(log-time (with-time-logging "getting inferior derivations"
"getting inferior derivations" (all-inferior-package-derivations store inf packages)))
(lambda ()
(all-inferior-package-derivations store inf packages))))
(inferior-system-tests (inferior-system-tests
(log-time (with-time-logging "getting inferior system tests"
"getting inferior system tests" (all-inferior-system-tests inf store))))
(lambda ()
(all-inferior-system-tests inf store)))))
(log-time (with-time-logging
"acquiring advisory transaction lock: load-new-guix-revision-inserts" "acquiring advisory transaction lock: load-new-guix-revision-inserts"
(lambda () ;; Wait until this is the only transaction inserting data, to
;; Wait until this is the only transaction inserting data, to ;; avoid any concurrency issues
;; avoid any concurrency issues (obtain-advisory-transaction-lock conn
(obtain-advisory-transaction-lock conn 'load-new-guix-revision-inserts))
'load-new-guix-revision-inserts)))
(let* ((package-ids (let* ((package-ids
(insert-packages conn inf packages)) (insert-packages conn inf packages))
(inferior-package-id->package-database-id (inferior-package-id->package-database-id
@ -1139,12 +1105,10 @@ WHERE job_id = $1"
inferior-system-tests) inferior-system-tests)
(let ((package-derivation-ids (let ((package-derivation-ids
(log-time (with-time-logging "inferior-data->package-derivation-ids"
"inferior-data->package-derivation-ids" (inferior-data->package-derivation-ids
(lambda () conn inf inferior-package-id->package-database-id
(inferior-data->package-derivation-ids inferior-data-4-tuples))))
conn inf inferior-package-id->package-database-id
inferior-data-4-tuples)))))
(update-builds-derivation-output-details-set-id (update-builds-derivation-output-details-set-id
conn conn
(map fourth inferior-data-4-tuples)) (map fourth inferior-data-4-tuples))
@ -1166,36 +1130,32 @@ WHERE job_id = $1"
(display-backtrace (make-stack #t) (current-error-port)))))) (display-backtrace (make-stack #t) (current-error-port))))))
(define (update-package-versions-table conn git-repository-id commit) (define (update-package-versions-table conn git-repository-id commit)
(log-time (with-time-logging "lock table: package_versions_by_guix_revision_range"
"lock table: package_versions_by_guix_revision_range" ;; Lock the table to wait for other transactions to commit before updating
(lambda () ;; the table
;; Lock the table to wait for other transactions to commit before updating (exec-query
;; the table conn
(exec-query "
conn
"
LOCK TABLE ONLY package_versions_by_guix_revision_range LOCK TABLE ONLY package_versions_by_guix_revision_range
IN SHARE ROW EXCLUSIVE MODE"))) IN SHARE ROW EXCLUSIVE MODE"))
(for-each (for-each
(match-lambda (match-lambda
((branch-name) ((branch-name)
(log-time (with-time-logging
(simple-format #f "deleting package version entries for ~A" branch-name) (simple-format #f "deleting package version entries for ~A" branch-name)
(lambda () (exec-query
(exec-query conn
conn "
"
DELETE FROM package_versions_by_guix_revision_range DELETE FROM package_versions_by_guix_revision_range
WHERE git_repository_id = $1 AND branch_name = $2" WHERE git_repository_id = $1 AND branch_name = $2"
(list git-repository-id (list git-repository-id
branch-name)))) branch-name)))
(log-time (with-time-logging
(simple-format #f "inserting package version entries for ~A" branch-name) (simple-format #f "inserting package version entries for ~A" branch-name)
(lambda () (exec-query
(exec-query conn
conn "
"
INSERT INTO package_versions_by_guix_revision_range INSERT INTO package_versions_by_guix_revision_range
SELECT DISTINCT SELECT DISTINCT
$1::integer AS git_repository_id, $1::integer AS git_repository_id,
@ -1223,7 +1183,7 @@ WINDOW package_version AS (
RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING
) )
ORDER BY packages.name, packages.version" ORDER BY packages.name, packages.version"
(list git-repository-id branch-name)))))) (list git-repository-id branch-name)))))
(exec-query (exec-query
conn conn
"SELECT name FROM git_branches WHERE commit = $1 AND git_repository_id = $2" "SELECT name FROM git_branches WHERE commit = $1 AND git_repository_id = $2"
@ -1268,13 +1228,11 @@ ORDER BY packages.name, packages.version"
channel-derivations-by-system)) channel-derivations-by-system))
(if (defined? 'channel-news-for-commit (if (defined? 'channel-news-for-commit
(resolve-module '(guix channels))) (resolve-module '(guix channels)))
(log-time (with-time-logging "inserting channel news entries"
"inserting channel news entries" (insert-channel-news-entries-for-guix-revision
(lambda () conn
(insert-channel-news-entries-for-guix-revision guix-revision-id
conn (channel-news-for-commit channel-for-commit commit)))
guix-revision-id
(channel-news-for-commit channel-for-commit commit))))
(begin (begin
(simple-format #t "debug: importing channel news not supported\n") (simple-format #t "debug: importing channel news not supported\n")
#t)) #t))
@ -1612,26 +1570,24 @@ SKIP LOCKED")
(if (or (if (or
(guix-revision-exists? conn git-repository-id commit) (guix-revision-exists? conn git-repository-id commit)
(eq? (eq?
(log-time (with-time-logging (string-append "loading revision " commit)
(string-append "loading revision " commit) (setup-logging
(lambda () id
(setup-logging (lambda ()
id (catch #t
(lambda () (lambda ()
(catch #t (with-store-connection
(lambda () (lambda (store)
(with-store-connection (load-new-guix-revision conn
(lambda (store) store
(load-new-guix-revision conn git-repository-id
store commit))))
git-repository-id (lambda (key . args)
commit)))) (simple-format
(lambda (key . args) (current-error-port)
(simple-format "error: load-new-guix-revision: ~A ~A\n"
(current-error-port) key args)
"error: load-new-guix-revision: ~A ~A\n" #f)))))
key args)
#f))))))
#t)) #t))
(begin (begin
(record-job-succeeded conn id) (record-job-succeeded conn id)