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)
|
2019-03-13 10:24:47 +01:00
|
|
|
#:use-module (ice-9 hash-table)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (squee)
|
|
|
|
#:use-module (guix monads)
|
|
|
|
#:use-module (guix store)
|
|
|
|
#:use-module (guix channels)
|
|
|
|
#:use-module (guix inferior)
|
|
|
|
#:use-module (guix profiles)
|
2019-03-11 23:11:14 +01:00
|
|
|
#:use-module (guix progress)
|
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)
|
2019-05-05 14:35:48 +02:00
|
|
|
#:use-module (guix-data-service model git-repository)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service model guix-revision)
|
2019-03-11 23:11:14 +01:00
|
|
|
#:use-module (guix-data-service model package-derivation)
|
|
|
|
#:use-module (guix-data-service model guix-revision-package-derivation)
|
2019-05-15 09:05:14 +02:00
|
|
|
#:use-module (guix-data-service model license-set)
|
2019-02-06 17:14:44 +01:00
|
|
|
#: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
|
2019-03-03 19:15:29 +01:00
|
|
|
select-job-for-commit
|
2019-03-19 21:18:09 +01:00
|
|
|
enqueue-load-new-guix-revision-job
|
2019-03-03 19:15:29 +01:00
|
|
|
most-recent-n-load-new-guix-revision-jobs))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-03-13 10:24:47 +01:00
|
|
|
(define inferior-package-id
|
|
|
|
(@@ (guix inferior) inferior-package-id))
|
|
|
|
|
2019-03-15 10:31:52 +01:00
|
|
|
(define (log-time action f)
|
|
|
|
(simple-format #t "debug: Starting ~A\n" action)
|
|
|
|
(force-output)
|
|
|
|
(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)
|
|
|
|
(force-output)
|
|
|
|
result))
|
|
|
|
|
2019-03-13 10:24:47 +01:00
|
|
|
(define (all-inferior-package-derivations store inf packages)
|
2019-03-16 18:26:44 +01:00
|
|
|
(define inferior-%supported-systems
|
|
|
|
(inferior-eval '(@ (guix packages) %supported-systems) inf))
|
|
|
|
|
|
|
|
(define supported-system-pairs
|
|
|
|
(map (lambda (system)
|
|
|
|
(cons system system))
|
|
|
|
inferior-%supported-systems))
|
|
|
|
|
|
|
|
(define supported-system-cross-build-pairs
|
|
|
|
(map (lambda (system)
|
|
|
|
(filter-map (lambda (target)
|
|
|
|
(and (not (string=? system target))
|
|
|
|
(cons system target)))
|
|
|
|
inferior-%supported-systems))
|
|
|
|
inferior-%supported-systems))
|
|
|
|
|
|
|
|
(define (proc packages system-target-pairs)
|
2019-03-13 10:24:47 +01:00
|
|
|
`(lambda (store)
|
|
|
|
(append-map
|
|
|
|
(lambda (inferior-package-id)
|
2019-03-15 10:31:08 +01:00
|
|
|
(let ((package (hashv-ref %package-table inferior-package-id)))
|
|
|
|
(catch
|
|
|
|
#t
|
|
|
|
(lambda ()
|
|
|
|
(let ((supported-systems
|
2019-03-29 10:14:03 +01:00
|
|
|
(catch
|
|
|
|
#t
|
|
|
|
(lambda ()
|
|
|
|
(package-transitive-supported-systems package))
|
|
|
|
(lambda (key . args)
|
|
|
|
(simple-format
|
|
|
|
(current-error-port)
|
|
|
|
"error: while processing ~A, unable to compute transitive supported systems\n"
|
|
|
|
(package-name package))
|
|
|
|
(simple-format
|
|
|
|
(current-error-port)
|
|
|
|
"error ~A: ~A\n" key args)
|
|
|
|
#f))))
|
|
|
|
(if supported-systems
|
|
|
|
(append-map
|
|
|
|
(lambda (system)
|
|
|
|
(filter-map
|
|
|
|
(lambda (target)
|
|
|
|
(catch
|
|
|
|
'misc-error
|
|
|
|
(lambda ()
|
|
|
|
(guard (c ((package-cross-build-system-error? c)
|
|
|
|
#f))
|
|
|
|
(list inferior-package-id
|
|
|
|
system
|
|
|
|
target
|
|
|
|
(derivation-file-name
|
|
|
|
(if (string=? system target)
|
|
|
|
(package-derivation store package system)
|
|
|
|
(package-cross-derivation store package
|
|
|
|
target
|
|
|
|
system))))))
|
|
|
|
(lambda args
|
|
|
|
;; misc-error #f ~A ~S (No
|
|
|
|
;; cross-compilation for
|
|
|
|
;; clojure-build-system yet:
|
|
|
|
#f)))
|
|
|
|
(lset-intersection
|
|
|
|
string=?
|
|
|
|
supported-systems
|
|
|
|
(list ,@(map cdr system-target-pairs)))))
|
|
|
|
(lset-intersection
|
|
|
|
string=?
|
|
|
|
supported-systems
|
|
|
|
(list ,@(map car system-target-pairs))))
|
|
|
|
'())))
|
2019-05-01 10:24:38 +02:00
|
|
|
(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)
|
|
|
|
(force-output)
|
|
|
|
(exit 1))
|
|
|
|
(begin
|
|
|
|
(simple-format
|
|
|
|
(current-error-port)
|
|
|
|
"error: while processing ~A ignoring error: ~A: ~A\n"
|
|
|
|
(package-name package)
|
|
|
|
key
|
|
|
|
args)
|
|
|
|
(force-output)
|
|
|
|
'()))))))
|
2019-03-13 10:24:47 +01:00
|
|
|
(list ,@(map inferior-package-id packages)))))
|
|
|
|
|
2019-03-16 18:26:44 +01:00
|
|
|
(append-map
|
|
|
|
(lambda (system-target-pairs)
|
|
|
|
(format (current-error-port)
|
|
|
|
"heap size: ~a MiB~%"
|
|
|
|
(round
|
|
|
|
(/ (assoc-ref (gc-stats) 'heap-size)
|
|
|
|
(expt 2. 20))))
|
|
|
|
(log-time
|
|
|
|
(simple-format #f "getting derivations for ~A" system-target-pairs)
|
|
|
|
(lambda ()
|
|
|
|
(inferior-eval '(invalidate-derivation-caches!) inf)
|
|
|
|
(inferior-eval-with-store inf store (proc packages system-target-pairs)))))
|
|
|
|
(append (map list supported-system-pairs)
|
|
|
|
supported-system-cross-build-pairs)))
|
2019-03-11 23:11:14 +01:00
|
|
|
|
2019-03-29 10:13:29 +01:00
|
|
|
(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)
|
|
|
|
(string<? (inferior-package-version a)
|
|
|
|
(inferior-package-version b))
|
|
|
|
(string<? a-name
|
|
|
|
b-name)))))))
|
|
|
|
|
2019-03-13 10:24:47 +01:00
|
|
|
(define (inferior-guix->package-derivation-ids store conn inf)
|
2019-03-15 10:31:52 +01:00
|
|
|
(let* ((packages (log-time "fetching inferior packages"
|
|
|
|
(lambda ()
|
2019-03-29 10:13:29 +01:00
|
|
|
(deduplicate-inferior-packages
|
|
|
|
(inferior-packages inf)))))
|
2019-05-15 09:05:14 +02:00
|
|
|
(package-license-set-ids
|
|
|
|
(log-time "fetching inferior package license metadata"
|
|
|
|
(lambda ()
|
|
|
|
(inferior-packages->license-set-ids conn inf
|
|
|
|
packages))))
|
2019-02-06 17:14:44 +01:00
|
|
|
(packages-metadata-ids
|
2019-03-15 10:31:52 +01:00
|
|
|
(log-time "fetching inferior package metadata"
|
|
|
|
(lambda ()
|
2019-05-15 09:05:14 +02:00
|
|
|
(inferior-packages->package-metadata-ids
|
|
|
|
conn packages package-license-set-ids))))
|
2019-03-11 23:11:14 +01:00
|
|
|
(package-ids
|
2019-03-15 10:31:52 +01:00
|
|
|
(log-time "getting package-ids"
|
|
|
|
(lambda ()
|
|
|
|
(inferior-packages->package-ids
|
|
|
|
conn packages packages-metadata-ids))))
|
2019-03-13 10:24:47 +01:00
|
|
|
(inferior-package-id->package-id-hash-table
|
|
|
|
(alist->hashq-table
|
|
|
|
(map (lambda (package package-id)
|
|
|
|
(cons (inferior-package-id package)
|
|
|
|
package-id))
|
|
|
|
packages
|
|
|
|
package-ids)))
|
|
|
|
(inferior-data-4-tuples
|
2019-03-15 10:31:52 +01:00
|
|
|
(log-time "getting inferior derivations"
|
|
|
|
(lambda ()
|
|
|
|
(all-inferior-package-derivations store inf packages)))))
|
2019-03-13 10:24:47 +01:00
|
|
|
|
|
|
|
(simple-format
|
|
|
|
#t "debug: finished loading information from inferior\n")
|
|
|
|
(close-inferior inf)
|
|
|
|
|
|
|
|
(let ((derivation-ids
|
2019-03-14 09:18:01 +01:00
|
|
|
(derivation-file-names->derivation-ids
|
2019-03-13 10:24:47 +01:00
|
|
|
conn
|
2019-03-14 09:18:01 +01:00
|
|
|
(map fourth inferior-data-4-tuples)))
|
2019-03-13 10:24:47 +01:00
|
|
|
(flat-package-ids-systems-and-targets
|
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((inferior-package-id system target derivation-file-name)
|
|
|
|
(list (hashq-ref inferior-package-id->package-id-hash-table
|
|
|
|
inferior-package-id)
|
|
|
|
system
|
|
|
|
target)))
|
|
|
|
inferior-data-4-tuples)))
|
|
|
|
|
|
|
|
(insert-package-derivations conn
|
|
|
|
flat-package-ids-systems-and-targets
|
|
|
|
derivation-ids))))
|
2019-03-11 23:11:14 +01:00
|
|
|
|
|
|
|
(define (inferior-package-transitive-supported-systems package)
|
|
|
|
((@@ (guix inferior) inferior-package-field)
|
|
|
|
package
|
|
|
|
'package-transitive-supported-systems))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-03-28 21:41:05 +01:00
|
|
|
(define guix-store-path
|
|
|
|
(let ((store-path #f))
|
|
|
|
(lambda (store)
|
|
|
|
(if (and store-path
|
|
|
|
(file-exists? store-path))
|
|
|
|
store-path
|
|
|
|
(begin
|
|
|
|
(invalidate-derivation-caches!)
|
2019-04-10 21:20:42 +02:00
|
|
|
(hash-clear! (@@ (guix packages) %derivation-cache))
|
2019-03-28 21:41:05 +01:00
|
|
|
(let* ((guix-package (@ (gnu packages package-management)
|
|
|
|
guix))
|
|
|
|
(derivation (package-derivation store guix-package)))
|
|
|
|
(build-derivations store (list derivation))
|
|
|
|
|
|
|
|
(let ((new-store-path
|
|
|
|
(derivation->output-path derivation)))
|
|
|
|
(set! store-path new-store-path)
|
|
|
|
new-store-path)))))))
|
2019-02-24 10:05:17 +01:00
|
|
|
|
|
|
|
(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))))))
|
|
|
|
|
2019-03-16 18:26:44 +01:00
|
|
|
(catch
|
|
|
|
#t
|
|
|
|
(lambda ()
|
|
|
|
;; 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)
|
|
|
|
|
|
|
|
(let ((file-name
|
|
|
|
(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))))))))))
|
|
|
|
|
|
|
|
(close-inferior inferior)
|
|
|
|
|
|
|
|
file-name)))
|
|
|
|
(lambda args
|
|
|
|
(simple-format (current-error-port)
|
|
|
|
"error: channel->derivation-file-name: ~A\n"
|
|
|
|
args)
|
2019-03-13 10:24:47 +01:00
|
|
|
|
|
|
|
(close-inferior inferior)
|
|
|
|
|
2019-03-16 18:26:44 +01:00
|
|
|
#f))))
|
2019-02-24 10:05:17 +01:00
|
|
|
|
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)
|
2019-03-01 08:29:49 +01:00
|
|
|
(catch
|
|
|
|
#t
|
|
|
|
(lambda ()
|
|
|
|
(dirname
|
|
|
|
(readlink
|
|
|
|
(string-append (channel->manifest-store-item store
|
|
|
|
channel)
|
|
|
|
"/bin"))))
|
|
|
|
(lambda args
|
|
|
|
(simple-format #t "guix-data-service: load-new-guix-revision: error: ~A\n" args)
|
|
|
|
#f)))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define (extract-information-from store conn git-repository-id commit store-path)
|
2019-03-13 10:24:47 +01:00
|
|
|
(simple-format
|
|
|
|
#t "debug: extract-information-from: ~A\n" store-path)
|
|
|
|
(let ((inf (open-inferior/container store store-path
|
2019-02-24 10:05:17 +01:00
|
|
|
#:extra-shared-directories
|
|
|
|
'("/gnu/store"))))
|
2019-03-13 10:24:47 +01:00
|
|
|
(inferior-eval '(use-modules (srfi srfi-1)
|
|
|
|
(srfi srfi-34)
|
2019-03-16 18:26:44 +01:00
|
|
|
(guix grafts)
|
|
|
|
(guix derivations))
|
2019-03-13 10:24:47 +01:00
|
|
|
inf)
|
2019-02-06 17:14:44 +01:00
|
|
|
(inferior-eval '(%graft? #f) inf)
|
|
|
|
|
2019-03-11 23:11:14 +01:00
|
|
|
(exec-query conn "BEGIN")
|
2019-05-01 10:24:38 +02:00
|
|
|
(catch
|
|
|
|
#t
|
|
|
|
(lambda ()
|
2019-05-05 14:35:48 +02:00
|
|
|
(let* ((package-derivation-ids
|
|
|
|
(inferior-guix->package-derivation-ids store conn inf))
|
|
|
|
(guix-revision-id
|
|
|
|
(insert-guix-revision conn git-repository-id commit store-path)))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-01 10:24:38 +02:00
|
|
|
(insert-guix-revision-package-derivations conn
|
|
|
|
guix-revision-id
|
|
|
|
package-derivation-ids)
|
2019-02-24 10:05:17 +01:00
|
|
|
|
2019-05-01 10:24:38 +02:00
|
|
|
(exec-query conn "COMMIT")
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-01 10:24:38 +02:00
|
|
|
(simple-format
|
|
|
|
#t "Successfully loaded ~A package/derivation pairs\n"
|
2019-06-02 17:20:51 +02:00
|
|
|
(length package-derivation-ids)))
|
|
|
|
#t)
|
2019-05-01 10:24:38 +02:00
|
|
|
(lambda (key . args)
|
|
|
|
(simple-format (current-error-port)
|
|
|
|
"Failed extracting information: ~A ~A\n"
|
|
|
|
key args)
|
|
|
|
(force-output)
|
2019-06-02 17:20:51 +02:00
|
|
|
(exec-query conn "ROLLBACK")
|
|
|
|
#f))))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define (load-new-guix-revision conn git-repository-id commit)
|
|
|
|
(if (guix-revision-exists? conn git-repository-id commit)
|
2019-02-06 17:14:44 +01:00
|
|
|
#t
|
|
|
|
(with-store store
|
|
|
|
(let ((store-item (channel->guix-store-item
|
|
|
|
store
|
|
|
|
(channel (name 'guix)
|
2019-05-05 14:35:48 +02:00
|
|
|
(url (git-repository-id->url
|
|
|
|
conn
|
|
|
|
git-repository-id))
|
2019-02-06 17:14:44 +01:00
|
|
|
(commit commit)))))
|
2019-03-01 08:29:49 +01:00
|
|
|
(and store-item
|
2019-05-05 14:35:48 +02:00
|
|
|
(extract-information-from store conn git-repository-id
|
|
|
|
commit store-item))))))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define (enqueue-load-new-guix-revision-job conn git-repository-id commit source)
|
2019-03-19 21:18:09 +01:00
|
|
|
(define query
|
|
|
|
"
|
2019-05-05 14:35:48 +02:00
|
|
|
INSERT INTO load_new_guix_revision_jobs (git_repository_id, commit, source)
|
2019-03-19 21:18:09 +01:00
|
|
|
VALUES ($1, $2, $3)
|
|
|
|
RETURNING id;")
|
|
|
|
|
|
|
|
(first
|
|
|
|
(exec-query conn
|
|
|
|
query
|
2019-05-05 14:35:48 +02:00
|
|
|
(list git-repository-id commit source))))
|
2019-03-19 21:18:09 +01:00
|
|
|
|
2019-02-24 17:47:29 +01:00
|
|
|
(define (select-job-for-commit conn commit)
|
|
|
|
(let ((result
|
|
|
|
(exec-query
|
|
|
|
conn
|
2019-05-05 14:35:48 +02:00
|
|
|
(string-append
|
|
|
|
"SELECT id, commit, source, git_repository_id "
|
|
|
|
"FROM load_new_guix_revision_jobs WHERE commit = $1")
|
2019-02-24 17:47:29 +01:00
|
|
|
(list commit))))
|
|
|
|
result))
|
|
|
|
|
2019-03-03 19:15:29 +01:00
|
|
|
(define (most-recent-n-load-new-guix-revision-jobs conn n)
|
|
|
|
(let ((result
|
|
|
|
(exec-query
|
|
|
|
conn
|
2019-05-05 14:35:48 +02:00
|
|
|
(string-append
|
|
|
|
"SELECT id, commit, source, git_repository_id "
|
|
|
|
"FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT $1")
|
2019-03-03 19:15:29 +01:00
|
|
|
(list (number->string n)))))
|
|
|
|
result))
|
|
|
|
|
2019-06-02 17:20:51 +02:00
|
|
|
(define (record-job-succeeded conn id)
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append
|
|
|
|
"UPDATE load_new_guix_revision_jobs WHERE id = $1 "
|
|
|
|
"SET succeeded_at = current_time")
|
|
|
|
(list id)))
|
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define (process-next-load-new-guix-revision-job conn)
|
|
|
|
(let ((next
|
|
|
|
(exec-query
|
|
|
|
conn
|
2019-05-05 14:35:48 +02:00
|
|
|
(string-append
|
|
|
|
"SELECT id, commit, source, git_repository_id "
|
|
|
|
"FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT 1"))))
|
2019-02-06 17:14:44 +01:00
|
|
|
(match next
|
2019-05-05 14:35:48 +02:00
|
|
|
(((id commit source git-repository-id))
|
2019-02-06 17:14:44 +01:00
|
|
|
(begin
|
2019-05-05 14:35:48 +02:00
|
|
|
(simple-format #t "Processing job ~A (commit: ~A, source: ~A)\n\n"
|
|
|
|
id commit source)
|
2019-06-02 17:20:51 +02:00
|
|
|
(when (eq? (load-new-guix-revision conn git-repository-id commit)
|
|
|
|
#t)
|
|
|
|
(record-job-succeeded conn id))))
|
2019-02-06 17:14:44 +01:00
|
|
|
(_ #f))))
|