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

Refactor how channel derivations are handled

Browse source 
Yet again...

This makes the channel-derivations for each system accessible within the
load-new-guix-revision procedure, in preparation for storing them in the
database.
This commit is contained in:
Christopher Baines 2020-02-09 21:40:56 +00:00
parent 60d53f898f
commit e0ee3d224b
1 changed files with 152 additions and 142 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -714,7 +714,7 @@ WHERE job_id = $1"
(build-derivations store (list derivation)))) (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 channel)
(define use-container? (defined? (define use-container? (defined?
'open-inferior/container 'open-inferior/container
(resolve-module '(guix inferior)))) (resolve-module '(guix inferior))))
@ -732,128 +732,130 @@ WHERE job_id = $1"
,(channel-instance-checkout channel-instance))))) ,(channel-instance-checkout channel-instance)))))
(map (map
(lambda (system) (lambda (system)
(log-time (simple-format
(simple-format (current-error-port)
#f "computing the derivation-file-name for ~A" "guix-data-service: computing the derivation-file-name for ~A\n"
system) system)
(lambda ()
(with-store store ((set-current-system system) store)
((set-current-system system) store) (let ((manifest
(let ((manifest (catch #t
(catch #t (lambda ()
(lambda () ((channel-instances->manifest instances) store))
((channel-instances->manifest instances) store)) (lambda (key . args)
(lambda (key . args) (simple-format
(simple-format (current-error-port)
(current-error-port) "error: while computing manifest entry derivation for ~A\n"
"error: while computing manifest entry derivation for ~A\n" system)
system) (simple-format
(simple-format (current-error-port)
(current-error-port) "error ~A: ~A\n" key args)
"error ~A: ~A\n" key args) #f))))
#f)))) `(,system
`(,system .
. ((manifest-entry-item
((manifest-entry-item . ,(and manifest
. ,(and manifest (derivation-file-name
(derivation-file-name (manifest-entry-item
(manifest-entry-item (first
(first (manifest-entries manifest))))))
(manifest-entries manifest)))))) (profile
(profile . ,(catch #t
. ,(catch #t (lambda ()
(lambda () (and manifest
(and manifest (derivation-file-name
(derivation-file-name (run-with-store store
(run-with-store store (profile-derivation
(profile-derivation manifest
manifest #:hooks %channel-profile-hooks)))))
#:hooks %channel-profile-hooks))))) (lambda (key . args)
(lambda (key . args) (simple-format
(simple-format (current-error-port)
(current-error-port) "error: while computing profile derivation for ~A\n"
"error: while computing profile derivation for ~A\n" system)
system) (simple-format
(simple-format (current-error-port)
(current-error-port) "error ~A: ~A\n" key args)
"error ~A: ~A\n" key args) #f)))))))
#f))))))))))
(list ,@systems))))) (list ,@systems)))))
(let ((inferior (with-store store
(if use-container? (set-build-options store #:fallback? #t)
(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 (real-error-port))))))
(define (start-inferior-and-return-derivation-file-names) (let ((inferior
;; /etc is only missing if open-inferior/container has been used (if use-container?
(when use-container? (open-inferior/container
(inferior-eval store
'(begin (guix-store-path store)
;; Create /etc/pass, as %known-shorthand-profiles in (guix #:extra-shared-directories
;; profiles) tries to read from this file. Because the environment '("/gnu/store")
;; is cleaned in build-self.scm, xdg-directory in (guix utils) #:extra-environment-variables
;; falls back to accessing /etc/passwd. (list (string-append
(mkdir "/etc") "SSL_CERT_DIR=" (nss-certs-store-path store))))
(call-with-output-file "/etc/passwd" (begin
(lambda (port) (simple-format #t "debug: using open-inferior\n")
(display "root:x:0:0::/root:/bin/bash" port)))) (open-inferior (guix-store-path store)
inferior)) #:error-port (real-error-port))))))
(let ((channel-instance (define (start-inferior-and-return-derivation-file-names)
(first ;; /etc is only missing if open-inferior/container has been used
(latest-channel-instances store (when use-container?
(list channel))))) (inferior-eval
(inferior-eval '(use-modules (srfi srfi-1) '(begin
(guix channels) ;; Create /etc/pass, as %known-shorthand-profiles in (guix
(guix grafts) ;; profiles) tries to read from this file. Because the environment
(guix profiles)) ;; is cleaned in build-self.scm, xdg-directory in (guix utils)
inferior) ;; falls back to accessing /etc/passwd.
(inferior-eval '(when (defined? '%graft?) (%graft? #f)) (mkdir "/etc")
inferior) (call-with-output-file "/etc/passwd"
(inferior-eval '(define channel-instance (lambda (port)
(@@ (guix channels) channel-instance)) (display "root:x:0:0::/root:/bin/bash" port))))
inferior) inferior))
(let* ((systems (let ((channel-instance
(inferior-eval '(@ (guix packages) %supported-systems) (first
inferior)) (latest-channel-instances store
(result (list channel)))))
(inferior-eval-with-store (inferior-eval '(use-modules (srfi srfi-1)
inferior (guix channels)
store (guix grafts)
(inferior-code channel-instance systems)))) (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) (close-inferior inferior)
#f)))))
result))) (define (channel->derivations-by-system conn channel)
(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->manifest-store-item conn store channel)
(let* ((derivation-file-names-by-system (let* ((derivation-file-names-by-system
(log-time (log-time
"computing the channel derivation" "computing the channel derivation"
@ -864,12 +866,7 @@ WHERE job_id = $1"
conn conn
'channel->manifest-store-item 'channel->manifest-store-item
(lambda () (lambda ()
(channel->derivation-file-names-by-system store channel)))))) (channel->derivation-file-names-by-system channel)))))))
(derivation
(read-derivation-from-file (assoc-ref
(assoc-ref derivation-file-names-by-system
(%current-system))
'profile))))
(for-each (for-each
(match-lambda (match-lambda
((system . derivation-file-name) ((system . derivation-file-name)
@ -878,27 +875,36 @@ WHERE job_id = $1"
system system
derivation-file-name))) derivation-file-name)))
derivation-file-names-by-system) derivation-file-names-by-system)
(log-time
"building the channel derivation"
(lambda ()
(build-derivations store (list derivation))))
(derivation->output-path derivation)))
(define (channel->guix-store-item conn channel) derivation-file-names-by-system))
(catch
#t (define (channel-derivations-by-system->guix-store-item
(lambda () channel-derivations-by-system)
(with-store store
(set-build-options store #:fallback? #t) (define (store-item->guix-store-item filename)
(dirname (dirname
(readlink (readlink
(string-append (channel->manifest-store-item conn (string-append filename "/bin"))))
store
channel) (let ((derivation-file-name-for-current-system
"/bin"))))) (assoc-ref
(lambda args (assoc-ref channel-derivations-by-system
(simple-format #t "guix-data-service: load-new-guix-revision: error: ~A\n" args) (%current-system))
#f))) 'profile)))
(if derivation-file-name-for-current-system
(let ((derivation-for-current-system
(read-derivation-from-file derivation-file-name-for-current-system)))
(with-store store
(set-build-options store #:fallback? #t)
(log-time
"building the channel derivation"
(lambda ()
(build-derivations store (list derivation-for-current-system)))))
(store-item->guix-store-item
(derivation->output-path derivation-for-current-system)))
#f)))
(define (glibc-locales-for-guix-store-path store store-path) (define (glibc-locales-for-guix-store-path store store-path)
(let ((inf (if (defined? (let ((inf (if (defined?
@ -1186,8 +1192,12 @@ ORDER BY packages.name, packages.version"
conn conn
git-repository-id)) git-repository-id))
(commit commit))) (commit commit)))
(channel-derivations-by-system
(channel->derivations-by-system conn
channel-for-commit))
(store-item (store-item
(channel->guix-store-item conn channel-for-commit))) (channel-derivations-by-system->guix-store-item
channel-derivations-by-system)))
(if store-item (if store-item
(let ((guix-revision-id (let ((guix-revision-id
(insert-guix-revision conn git-repository-id (insert-guix-revision conn git-repository-id