guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

base: Make a writable copy of the checkout only when #:no-compile? is false. 

This avoids copying things back and forth.

* src/cuirass/base.scm (fetch-repository): Add #:writable-copy?
parameter.  Call 'make-writable-copy' when it's true.
(copy-repository-cache): Remove.
(make-writable-copy): New procedure.
(evaluate): Add 'source' parameter and pass it to the 'evaluate' program.
(process-specs): Define 'compile?'.  Pass #:writable-copy? to
'fetch-repository'.  Remove call to 'copy-repository-cache'.  Remove
computation of the checkout directory name.  Pass CHECKOUT to 'evaluate'.
* bin/evaluate.in (main): Replace 'cachedir' with 'source'.  Remove
computation of the checkout directory name.
This commit is contained in:
Ludovic Courtès 2018-04-01 22:57:05 +02:00
parent 8eefd24672
commit 2fe7ff87e2
2 changed files with 41 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
bin/evaluate.in
View File

@ -35,7 +35,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(define* (main #:optional (args (command-line)))
(match args
((command load-path guix-package-path cachedir specstr)
((command load-path guix-package-path source specstr)
;; Load FILE, a Scheme file that defines Hydra jobs.
(let ((%user-module (make-fresh-user-module))
(spec (with-input-from-string specstr read))
@ -44,8 +44,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(with-directory-excursion
(string-append cachedir "/" (assq-ref spec #:name))
(with-directory-excursion source
(primitive-load (assq-ref spec #:file)))))
(with-store store
(unless (assoc-ref spec #:use-substitutes?)

67
src/cuirass/base.scm
View File

@ -138,10 +138,13 @@ values."
(lambda (key err)
(report-git-error err))))
(define (fetch-repository store spec)
(define* (fetch-repository store spec #:key writable-copy?)
"Get the latest version of repository specified in SPEC. Return two
values: the content of the git repository at URL copied into a store
directory and the sha1 of the top level commit in this directory."
directory and the sha1 of the top level commit in this directory.
When WRITABLE-COPY? is true, return a writable copy; otherwise, return a
read-only directory."
(define (add-origin branch)
"Prefix branch name with origin if no remote is specified."
@ -160,21 +163,29 @@ directory and the sha1 of the top level commit in this directory."
(tag (and=> (assq-ref spec #:tag)
(lambda (t)
`(tag . ,t)))))
(latest-repository-commit store url
#:cache-directory (%package-cachedir)
#:ref (or branch commit tag))))
(let-values (((directory commit)
(latest-repository-commit store url
#:cache-directory (%package-cachedir)
#:ref (or branch commit tag))))
;; TODO: When WRITABLE-COPY? is true, we could directly copy the
;; checkout directly in a writable location instead of copying it to the
;; store first.
(values (if writable-copy?
(make-writable-copy directory
(string-append (%package-cachedir)
"/" (assq-ref spec #:name)))
directory)
commit))))
(define (copy-repository-cache repo spec)
"Copy REPO directory in cache. The directory is named after NAME
field in SPEC."
(let ((cachedir (%package-cachedir)))
(mkdir-p cachedir)
(with-directory-excursion cachedir
(let ((name (assq-ref spec #:name)))
;; Flush any directory with the same name.
(false-if-exception (delete-file-recursively name))
(copy-recursively repo name)
(system* "chmod" "-R" "+w" name)))))
(define (make-writable-copy source target)
"Create TARGET and make it a writable copy of directory SOURCE; delete
TARGET beforehand if it exists. Return TARGET."
(mkdir-p (dirname target))
;; Remove any directory with the same name.
(false-if-exception (delete-file-recursively target))
(copy-recursively source target)
(system* "chmod" "-R" "+w" target)
target)
(define (compile dir)
;; Required for fetching Guix bootstrap tarballs.
@ -217,8 +228,9 @@ fibers."
(logior (@ (fibers epoll) EPOLLERR)
(@ (fibers epoll) EPOLLHUP)))))
(define (evaluate store db spec)
"Evaluate and build package derivations. Return a list of jobs."
(define (evaluate store db spec source)
"Evaluate and build package derivations defined in SPEC, using the checkout
in SOURCE directory. Return a list of jobs."
(define (augment-job job eval-id)
(let ((drv (read-derivation-from-file
(assq-ref job #:derivation))))
@ -234,8 +246,7 @@ fibers."
(assq-ref spec #:name) "/"
(assq-ref spec #:load-path))
(%guix-package-path)
(%package-cachedir)
(object->string spec))))
source (object->string spec))))
(result (match (read/non-blocking port)
;; If an error occured during evaluation report it,
;; otherwise, suppose that data read from port are
@ -602,13 +613,17 @@ procedure is meant to be called at startup."
(define (process-specs db jobspecs)
"Evaluate and build JOBSPECS and store results in DB."
(define (process spec)
(define compile?
(not (assq-ref spec #:no-compile?)))
(with-store store
(let ((stamp (db-get-stamp db spec))
(name (assoc-ref spec #:name)))
(log-message "considering spec '~a', URL '~a'"
name (assoc-ref spec #:url))
(receive (checkout commit)
(non-blocking (fetch-repository store spec))
(non-blocking (fetch-repository store spec
#:writable-copy? compile?))
(log-message "spec '~a': fetched commit ~s (stamp was ~s)"
name commit stamp)
(when commit
@ -617,12 +632,8 @@ procedure is meant to be called at startup."
;; a concurrent evaluation of that same commit.
(db-add-stamp db spec commit)
(copy-repository-cache checkout spec)
(unless (assq-ref spec #:no-compile?)
(non-blocking
(compile (string-append (%package-cachedir) "/"
(assq-ref spec #:name)))))
(when compile?
(non-blocking (compile checkout)))
(spawn-fiber
(lambda ()
@ -635,7 +646,7 @@ procedure is meant to be called at startup."
(with-store store
(with-database db
(let* ((spec* (acons #:current-commit commit spec))
(jobs (evaluate store db spec*)))
(jobs (evaluate store db spec* checkout)))
(log-message "building ~a jobs for '~a'"
(length jobs) name)
(build-packages store db jobs)))))))