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.

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)))))))