2019-02-06 17:14:44 +01:00
|
|
|
(define-module (guix-data-service jobs load-new-guix-revision)
|
2019-02-24 10:05:17 +01:00
|
|
|
#:use-module (srfi srfi-1)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (ice-9 match)
|
|
|
|
#:use-module (squee)
|
|
|
|
#:use-module (guix monads)
|
|
|
|
#:use-module (guix store)
|
|
|
|
#:use-module (guix channels)
|
|
|
|
#:use-module (guix inferior)
|
|
|
|
#:use-module (guix profiles)
|
2019-02-24 10:05:17 +01:00
|
|
|
#:use-module (guix packages)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix derivations)
|
2019-02-23 21:15:35 +01:00
|
|
|
#:use-module (guix build utils)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service model package)
|
|
|
|
#:use-module (guix-data-service model guix-revision)
|
|
|
|
#:use-module (guix-data-service model guix-revision-package)
|
|
|
|
#:use-module (guix-data-service model package-metadata)
|
|
|
|
#:use-module (guix-data-service model derivation)
|
2019-02-24 17:47:29 +01:00
|
|
|
#:export (process-next-load-new-guix-revision-job
|
|
|
|
select-job-for-commit))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
|
|
|
(define (inferior-guix->package-ids store conn inf)
|
|
|
|
(let* ((packages (inferior-packages inf))
|
|
|
|
(packages-metadata-ids
|
|
|
|
(inferior-packages->package-metadata-ids conn packages))
|
|
|
|
(packages-derivation-ids
|
2019-02-10 10:42:22 +01:00
|
|
|
(derivations->derivation-ids conn
|
|
|
|
(map (lambda (package)
|
|
|
|
(inferior-package-derivation
|
|
|
|
store package))
|
|
|
|
packages))))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
|
|
|
(inferior-packages->package-ids
|
|
|
|
conn packages packages-metadata-ids packages-derivation-ids)))
|
|
|
|
|
2019-02-24 10:05:17 +01:00
|
|
|
(define (guix-store-path store)
|
|
|
|
(let* ((guix-package (@ (gnu packages package-management)
|
|
|
|
guix))
|
|
|
|
(derivation (package-derivation store guix-package)))
|
|
|
|
(build-derivations store (list derivation))
|
|
|
|
(derivation->output-path derivation)))
|
|
|
|
|
|
|
|
(define (nss-certs-store-path store)
|
|
|
|
(let* ((nss-certs-package (@ (gnu packages certs)
|
|
|
|
nss-certs))
|
|
|
|
(derivation (package-derivation store nss-certs-package)))
|
|
|
|
(build-derivations store (list derivation))
|
|
|
|
(derivation->output-path derivation)))
|
|
|
|
|
|
|
|
(define (channel->derivation-file-name store channel)
|
|
|
|
(let ((inferior
|
|
|
|
(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))))))
|
|
|
|
|
|
|
|
;; 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.
|
|
|
|
(inferior-eval
|
|
|
|
'(begin
|
|
|
|
(mkdir "/etc")
|
|
|
|
(call-with-output-file "/etc/passwd"
|
|
|
|
(lambda (port)
|
|
|
|
(display "root:x:0:0::/root:/bin/bash" port))))
|
|
|
|
inferior)
|
|
|
|
|
|
|
|
(let ((channel-instance
|
|
|
|
(first
|
|
|
|
(latest-channel-instances store
|
|
|
|
(list channel)))))
|
|
|
|
(inferior-eval '(use-modules (guix channels)
|
|
|
|
(guix profiles))
|
|
|
|
inferior)
|
|
|
|
(inferior-eval '(define channel-instance
|
|
|
|
(@@ (guix channels) channel-instance))
|
|
|
|
inferior)
|
|
|
|
|
|
|
|
(inferior-eval-with-store
|
|
|
|
inferior
|
|
|
|
store
|
|
|
|
`(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)))))
|
|
|
|
(run-with-store store
|
|
|
|
(mlet* %store-monad ((manifest (channel-instances->manifest instances))
|
|
|
|
(derv (profile-derivation manifest)))
|
|
|
|
(mbegin %store-monad
|
|
|
|
(return (derivation-file-name derv)))))))))))
|
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define (channel->manifest-store-item store channel)
|
2019-02-24 10:05:17 +01:00
|
|
|
(let* ((manifest-store-item-derivation-file-name
|
|
|
|
(channel->derivation-file-name store channel))
|
|
|
|
(derivation
|
|
|
|
(read-derivation-from-file manifest-store-item-derivation-file-name)))
|
|
|
|
(build-derivations store (list derivation))
|
|
|
|
(derivation->output-path derivation)))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
|
|
|
(define (channel->guix-store-item store channel)
|
|
|
|
(dirname
|
|
|
|
(readlink
|
2019-02-24 10:05:17 +01:00
|
|
|
(string-append (channel->manifest-store-item store
|
|
|
|
channel)
|
2019-02-06 17:14:44 +01:00
|
|
|
"/bin"))))
|
|
|
|
|
|
|
|
(define (extract-information-from store conn url commit store_path)
|
2019-02-24 10:05:17 +01:00
|
|
|
(let ((inf (open-inferior/container store store_path
|
|
|
|
#:extra-shared-directories
|
|
|
|
'("/gnu/store"))))
|
2019-02-06 17:14:44 +01:00
|
|
|
(inferior-eval '(use-modules (guix grafts)) inf)
|
|
|
|
(inferior-eval '(%graft? #f) inf)
|
|
|
|
|
|
|
|
(let ((package-ids (inferior-guix->package-ids store conn inf)))
|
|
|
|
(exec-query conn "BEGIN")
|
|
|
|
|
|
|
|
(let ((guix-revision-id
|
|
|
|
(insert-guix-revision conn url commit store_path)))
|
2019-02-24 10:05:17 +01:00
|
|
|
(insert-guix-revision-packages conn guix-revision-id package-ids))
|
|
|
|
|
|
|
|
(exec-query conn "COMMIT")
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-02-24 10:05:17 +01:00
|
|
|
(simple-format
|
|
|
|
#t "Successfully loaded ~A packages\n" (length package-ids)))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
|
|
|
(close-inferior inf)))
|
|
|
|
|
|
|
|
(define (load-new-guix-revision conn url commit)
|
|
|
|
(if (guix-revision-exists? conn url commit)
|
|
|
|
#t
|
|
|
|
(with-store store
|
|
|
|
(let ((store-item (channel->guix-store-item
|
|
|
|
store
|
|
|
|
(channel (name 'guix)
|
|
|
|
(url url)
|
|
|
|
(commit commit)))))
|
|
|
|
(extract-information-from store conn url commit store-item)))))
|
|
|
|
|
2019-02-24 17:47:29 +01:00
|
|
|
(define (select-job-for-commit conn commit)
|
|
|
|
(let ((result
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
"SELECT * FROM load_new_guix_revision_jobs WHERE commit = $1"
|
|
|
|
(list commit))))
|
|
|
|
result))
|
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define (process-next-load-new-guix-revision-job conn)
|
|
|
|
(let ((next
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
"SELECT * FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT 1")))
|
|
|
|
(match next
|
2019-02-28 19:32:51 +01:00
|
|
|
(((id url commit source))
|
2019-02-06 17:14:44 +01:00
|
|
|
(begin
|
2019-02-28 19:32:51 +01:00
|
|
|
(simple-format #t "Processing job ~A (url: ~A, commit: ~A, source: ~A)\n\n"
|
|
|
|
id url commit source)
|
2019-02-06 17:14:44 +01:00
|
|
|
(load-new-guix-revision conn url commit)
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append "DELETE FROM load_new_guix_revision_jobs WHERE id = '"
|
|
|
|
id
|
|
|
|
"'"))))
|
|
|
|
(_ #f))))
|
|
|
|
|