Add %package-cachedir parameter.

4 files changed, 52 insertions, 38 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index ae201d1..84e3f18 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -30,10 +30,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (ice-9 getopt-long))
 
 (define* (show-help)
-  (simple-format #t "Usage: ~a [OPTIONS] [CACHEDIR]" (%program-name))
-  (display "
-Run Guix job from a git repository cloned in CACHEDIR.
+  (simple-format #t "Usage: ~a [OPTIONS] ~%" (%program-name))
+  (display "Run build jobs.
 
+      --cache-directory=DIR Use DIR for storing repository data
   -f  --use-file=FILE       Use FILE which defines the job to evaluate
   -D  --database=DB         Use DB to store build results.
   -I, --interval=N          Wait N seconds between each evaluation
@@ -43,7 +43,8 @@ Run Guix job from a git repository cloned in CACHEDIR.
   (show-package-information))
 
 (define %options
-  `((file     (single-char #\f) (value #t))
+  `((cache-directory            (value #t))
+    (file     (single-char #\f) (value #t))
     (database (single-char #\f) (value #t))
     (interval (single-char #\I) (value #t))
     (version  (single-char #\V) (value #f))
@@ -55,39 +56,41 @@ Run Guix job from a git repository cloned in CACHEDIR.
     (beautify-user-module! m)
     m))
 
-(define (fetch-repository cachedir spec)
-  "Get the latest version of Guix repository.  Clone repository in directory
-DIR if required."
-  (or (file-exists? cachedir) (mkdir cachedir))
-  (with-directory-excursion cachedir
-    (let ((name   (job-spec-name spec))
-          (url    (job-spec-url spec))
-          (branch (job-spec-branch spec))
-          (commit (job-spec-commit spec))
-          (tag    (job-spec-tag spec)))
-      (or (file-exists? name) (system* "git" "clone" url name))
-      (with-directory-excursion name
-        (and (zero? (system* "git" "fetch"))
-             (zero? (system* "git" "reset" "--hard"
-                             (or tag
-                                 commit
-                                 (string-append "origin/" branch)))))))))
+(define (fetch-repository spec)
+  "Get the latest version of repository specified in SPEC.  Clone repository
+if required."
+  (let ((cachedir (%package-cachedir)))
+    (or (file-exists? cachedir) (mkdir cachedir))
+    (with-directory-excursion cachedir
+      (let ((name   (job-spec-name spec))
+            (url    (job-spec-url spec))
+            (branch (job-spec-branch spec))
+            (commit (job-spec-commit spec))
+            (tag    (job-spec-tag spec)))
+        (or (file-exists? name) (system* "git" "clone" url name))
+        (with-directory-excursion name
+          (and (zero? (system* "git" "fetch"))
+               (zero? (system* "git" "reset" "--hard"
+                               (or tag
+                                   commit
+                                   (string-append "origin/" branch))))))))))
 
-(define (set-load-path! cachedir spec)
+(define (set-load-path! spec)
   "Set %LOAD-PATH to match what is specified in SPEC."
   (let* ((name (job-spec-name spec))
          (path (job-spec-load-path spec))
-         (dir  (string-join (list cachedir name path) "/")))
+         (dir  (string-join (list (%package-cachedir) name path) "/")))
     (format #t "prepending ~s to the load path~%" dir)
     (set! %load-path (cons dir %load-path))))
 
-(define (evaluate store db cachedir spec)
+(define (evaluate store db spec)
   "Evaluate and build package derivations.  Return a list a jobs."
   (save-module-excursion
    (lambda ()
      (set-current-module %user-module)
      ;; Handle both relative and absolute file names for SPEC-FILE.
-     (with-directory-excursion cachedir
+     (with-directory-excursion
+         (string-append (%package-cachedir) "/" (job-spec-name spec))
        (primitive-load (job-spec-file spec)))))
   (let* ((proc (module-ref %user-module (job-spec-proc spec)))
          (jobs (proc store (job-spec-arguments spec))))
@@ -127,7 +130,9 @@ DIR if required."
   (let ((opts (getopt-long args %options)))
     (parameterize
         ((%program-name     (car args))
-         (%package-database (option-ref opts 'database (%package-database))))
+         (%package-database (option-ref opts 'database (%package-database)))
+         (%package-cachedir
+          (option-ref opts 'cache-directory (%package-cachedir))))
       (cond
        ((option-ref opts 'help #f)
         (show-help)
@@ -138,24 +143,20 @@ DIR if required."
        (else
         (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
                (interval (option-ref opts 'interval "60"))
-               (specs    (primitive-load specfile))
-               (args     (option-ref opts '() #f))
-               (cachedir (if (null? args)
-                             (getenv "CUIRASS_CACHEDIR")
-                             (car args))))
+               (specs    (primitive-load specfile)))
           (with-database db
             (while #t
               (for-each
                (λ (spec)
-                 (fetch-repository cachedir spec)
+                 (fetch-repository spec)
                  (let ((old-path %load-path))
                    (and (job-spec-load-path spec)
-                        (set-load-path! cachedir spec))
+                        (set-load-path! spec))
                    (let ((store ((guix-variable 'store 'open-connection))))
                      (dynamic-wind
                        (const #t)
                        (lambda ()
-                         (let ((jobs (evaluate store db cachedir spec))
+                         (let ((jobs (evaluate store db spec))
                                (set-build-options
                                 (guix-variable 'store 'set-build-options)))
                            (set-build-options store #:use-substitutes? #f)
diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in
index 5b61cb2..b92a1a1 100644
--- a/build-aux/pre-inst-env.in
+++ b/build-aux/pre-inst-env.in
@@ -27,7 +27,4 @@ export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
 PATH="$abs_top_builddir/bin:$PATH"
 export PATH
 
-CUIRASS_CACHEDIR="$abs_top_builddir/cache"
-export CUIRASS_CACHEDIR
-
 exec "$@"
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 8e6ea36..c3fe733 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -25,7 +25,8 @@
             guix-variable
             call-with-time-display
             ;; Parameters.
-            %program-name))
+            %program-name
+            %package-cachedir))
 
 (define %program-name
   ;; Similar in spirit to Gnulib 'progname' module.
@@ -37,6 +38,17 @@
             ((string-rindex val #\/) => (λ (idx) (substring val (1+ idx))))
             (else val)))))
 
+(define %package-cachedir
+  ;; Define to location of cache directory of this package.
+  (make-parameter (or (getenv "CUIRASS_CACHEDIR")
+                      (string-append (or (getenv "HOME") ".")
+                                     "/.cache/cuirass"))
+    (λ (val)
+      (if (string? val)
+          val
+          (scm-error 'wrong-type-arg
+                     "%package-cachedir" "Not a string: ~S" (list #f) #f)))))
+
 (define (guix-variable module name)
   "Dynamically link variable NAME under Guix module MODULE and return it.
 Note: this is used instead of `@', because when using `@' in an uncompiled
diff --git a/tests/base.scm b/tests/base.scm
index 4557bb8..fb3bfd1 100644
--- a/tests/base.scm
+++ b/tests/base.scm
@@ -23,3 +23,7 @@
 (test-error "invalid program name"
   'wrong-type-arg
   (%program-name #f))
+
+(test-error "invalid cache directory"
+  'wrong-type-arg
+  (%package-cachedir #f))