mirror of https://notabug.org/mthl/cuirass.git
Use stamps to poll repositories.
parent
e51a755f10
commit
c83d5d4da8
|
@ -28,7 +28,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
||||||
(guix derivations)
|
(guix derivations)
|
||||||
(guix store)
|
(guix store)
|
||||||
(ice-9 getopt-long)
|
(ice-9 getopt-long)
|
||||||
(ice-9 popen))
|
(ice-9 popen)
|
||||||
|
(ice-9 rdelim))
|
||||||
|
|
||||||
(define (show-help)
|
(define (show-help)
|
||||||
(format #t "Usage: ~a [OPTIONS] SPECFILE~%" (%program-name))
|
(format #t "Usage: ~a [OPTIONS] SPECFILE~%" (%program-name))
|
||||||
|
@ -54,6 +55,13 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
||||||
(define (fetch-repository spec)
|
(define (fetch-repository spec)
|
||||||
"Get the latest version of repository specified in SPEC. Clone repository
|
"Get the latest version of repository specified in SPEC. Clone repository
|
||||||
if required."
|
if required."
|
||||||
|
(define (current-commit)
|
||||||
|
(let* ((pipe (open-input-pipe "git log -n1"))
|
||||||
|
(log (read-string pipe))
|
||||||
|
(commit (cadr (string-split log char-set:whitespace))))
|
||||||
|
(close-pipe pipe)
|
||||||
|
commit))
|
||||||
|
|
||||||
(let ((cachedir (%package-cachedir)))
|
(let ((cachedir (%package-cachedir)))
|
||||||
(or (file-exists? cachedir) (mkdir cachedir))
|
(or (file-exists? cachedir) (mkdir cachedir))
|
||||||
(with-directory-excursion cachedir
|
(with-directory-excursion cachedir
|
||||||
|
@ -68,7 +76,8 @@ if required."
|
||||||
(zero? (system* "git" "reset" "--hard"
|
(zero? (system* "git" "reset" "--hard"
|
||||||
(or tag
|
(or tag
|
||||||
commit
|
commit
|
||||||
(string-append "origin/" branch))))))))))
|
(string-append "origin/" branch))))
|
||||||
|
(current-commit)))))))
|
||||||
|
|
||||||
(define (compile dir)
|
(define (compile dir)
|
||||||
;; Required for fetching Guix bootstrap tarballs.
|
;; Required for fetching Guix bootstrap tarballs.
|
||||||
|
@ -116,13 +125,16 @@ if required."
|
||||||
(define (process-specs db jobspecs)
|
(define (process-specs db jobspecs)
|
||||||
"Evaluate and build JOBSPECS and store results in DB."
|
"Evaluate and build JOBSPECS and store results in DB."
|
||||||
(for-each (λ (spec)
|
(for-each (λ (spec)
|
||||||
(fetch-repository spec)
|
(let ((commit (fetch-repository spec))
|
||||||
(compile (string-append (%package-cachedir) "/"
|
(stamp (db-get-stamp db spec)))
|
||||||
(assq-ref spec #:name)))
|
(unless (string=? commit stamp)
|
||||||
(with-store store
|
(compile (string-append (%package-cachedir) "/"
|
||||||
(let ((jobs (evaluate store db spec)))
|
(assq-ref spec #:name)))
|
||||||
(set-build-options store #:use-substitutes? #f)
|
(with-store store
|
||||||
(build-packages store db jobs))))
|
(let ((jobs (evaluate store db spec)))
|
||||||
|
(set-build-options store #:use-substitutes? #f)
|
||||||
|
(build-packages store db jobs))))
|
||||||
|
(db-add-stamp db spec commit)))
|
||||||
jobspecs))
|
jobspecs))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -29,6 +29,8 @@
|
||||||
db-close
|
db-close
|
||||||
db-add-specification
|
db-add-specification
|
||||||
db-get-specifications
|
db-get-specifications
|
||||||
|
db-add-stamp
|
||||||
|
db-get-stamp
|
||||||
evaluation-exists?
|
evaluation-exists?
|
||||||
db-add-evaluation
|
db-add-evaluation
|
||||||
db-get-evaluation
|
db-get-evaluation
|
||||||
|
@ -188,3 +190,23 @@ INSERT INTO Builds (derivation, log, output) VALUES ('~A', '~A', '~A');"
|
||||||
(assq-ref build #:log)
|
(assq-ref build #:log)
|
||||||
(assq-ref build #:output))
|
(assq-ref build #:output))
|
||||||
(last-insert-rowid db))
|
(last-insert-rowid db))
|
||||||
|
|
||||||
|
(define (db-get-stamp db spec)
|
||||||
|
"Return a stamp corresponding to specification SPEC in database DB."
|
||||||
|
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification='~A';"
|
||||||
|
(assq-ref spec #:id))))
|
||||||
|
(match res
|
||||||
|
(() "")
|
||||||
|
((#(spec commit)) commit))))
|
||||||
|
|
||||||
|
(define (db-add-stamp db spec commit)
|
||||||
|
"Associate stamp COMMIT to specification SPEC in database DB."
|
||||||
|
(if (string-null? (db-get-stamp db spec))
|
||||||
|
(sqlite-exec db "\
|
||||||
|
INSERT INTO Stamps (specification, stamp) VALUES ('~A', '~A');"
|
||||||
|
(assq-ref spec #:id)
|
||||||
|
commit)
|
||||||
|
(sqlite-exec db "\
|
||||||
|
UPDATE Stamps SET stamp='~A' WHERE specification='~A';"
|
||||||
|
commit
|
||||||
|
(assq-ref spec #:id))))
|
||||||
|
|
|
@ -14,6 +14,12 @@ CREATE TABLE Specifications (
|
||||||
revision TEXT
|
revision TEXT
|
||||||
);
|
);
|
||||||
|
|
||||||
|
CREATE TABLE Stamps (
|
||||||
|
specification INTEGER NOT NULL PRIMARY KEY,
|
||||||
|
stamp TEXT NOT NULL,
|
||||||
|
FOREIGN KEY (specification) REFERENCES Specifications (id)
|
||||||
|
);
|
||||||
|
|
||||||
CREATE TABLE Evaluations (
|
CREATE TABLE Evaluations (
|
||||||
derivation TEXT NOT NULL PRIMARY KEY,
|
derivation TEXT NOT NULL PRIMARY KEY,
|
||||||
job_name TEXT NOT NULL,
|
job_name TEXT NOT NULL,
|
||||||
|
|
Loading…
Reference in New Issue