From 2fe7ff87e23b18d49bd33cffc4766b7eaa382054 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Apr 2018 22:57:05 +0200 Subject: 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. --- bin/evaluate.in | 5 ++-- src/cuirass/base.scm | 69 ++++++++++++++++++++++++++++++---------------------- 2 files changed, 42 insertions(+), 32 deletions(-) diff --git a/bin/evaluate.in b/bin/evaluate.in index 1439ea3..4c9efd5 100644 --- a/bin/evaluate.in +++ b/bin/evaluate.in @@ -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?) diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 7522a57..0ae06ee 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -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)))) - -(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))))) + (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 (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))))))) -- cgit v1.2.3