[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

Hi,

Here are two patches to remove useless/duplicated stuff from cuirass
and prepare (guix git) integration.

Thanks,

Mathieu

Mathieu Othacehe (2):
  repo: remove git-repo.
  utils: Remove useless procedures.

 bin/cuirass.in        |  4 +--
 bin/evaluate.in       |  2 +-
 src/cuirass/base.scm  |  2 +-
 src/cuirass/repo.scm  | 38 +---------------------------
 src/cuirass/utils.scm | 69 +--------------------------------------------------
 tests/repo.scm        | 32 ------------------------
 tests/utils.scm       | 15 -----------
 7 files changed, 6 insertions(+), 156 deletions(-)

-- 
2.13.1

[bug#27550] [PATCH 1/2] repo: remove git-repo.

[Mathieu Othacehe]

* src/cuirass/repo.scm (git-repo): Remove it.
* tests/repo.scm: Remove related tests.

git-repo is not used and it's usecases will be covered by (guix git).
---
 src/cuirass/repo.scm | 38 +-------------------------------------
 tests/repo.scm       | 32 --------------------------------
 2 files changed, 1 insertion(+), 69 deletions(-)

diff --git a/src/cuirass/repo.scm b/src/cuirass/repo.scm
index be5ea5b..26ea328 100644
--- a/src/cuirass/repo.scm
+++ b/src/cuirass/repo.scm
@@ -30,8 +30,7 @@
             repo-snapshot
             repo-updater
             repo-update
-            file-repo
-            git-repo))
+            file-repo))
 
 (define-immutable-record-type <repo>
   ;; An Abstract repository.  Use "repo" as a shortname for "repository".
@@ -79,38 +78,3 @@
             #:location file-name
             #:snapshoter file-repo-snapshot
             #:updater file-repo-update))))
-
-(define git-repo
-  (let ((git       "git")
-        (hash-algo "sha256"))
-    (define (git-repo-snapshot this store)
-      "Add a snapshot of URL to STORE. "
-      (let ((dir (repo-location this))
-            (id  (repo-id this)))
-        (call-with-temporary-directory
-         (λ (tmpdir)
-           (let ((tmp-repo (string-append tmpdir "/" dir)))
-             (and (zero? (system* "cp" "-R" dir tmpdir))
-                  (with-directory-excursion tmp-repo
-                    (zero? (system* "rm" "-rf" ".git")))
-                  (add-to-store store id #t hash-algo tmp-repo)))))))
-
-    (define (git-repo-update this ref)
-      (let ((url (repo-url this))
-            (dir (repo-location this)))
-        (and
-         (or (file-exists? dir)
-             (zero? (system* git "clone" url dir))
-             (error "file not found"))
-         (with-directory-excursion dir
-           (and (zero? (system* git "pull"))
-                (zero? (system* git "reset" "--hard" ref)))))))
-
-    (λ* (#:key url dir)
-      "Create a Git repository.  URL is the location of the remote repository.
-REF is the identifier that is tracked."
-      (repo #:id dir
-            #:url url
-            #:location dir
-            #:snapshoter git-repo-snapshot
-            #:updater git-repo-update))))
diff --git a/tests/repo.scm b/tests/repo.scm
index fc73a64..8890c0a 100644
--- a/tests/repo.scm
+++ b/tests/repo.scm
@@ -76,38 +76,6 @@ name."
   ;; Cleanup.
   (delete-file file-name))
 
-;;;
-;;; Git repository.
-;;;
-
-(define (create-git-repository name)
-  (let ((git "git"))
-    (system* git "init" name)
-    (with-directory-excursion name
-      (create-file "foo")
-      (system* git "add" "foo")
-      (system* git "commit" "-m" "'foo'"))))
-
-(test-group-with-cleanup "git-repo"
-  (define rpt (git-repo #:url file-name
-                        #:dir "git-example"))
-
-  ;; Since repository doesn't exist yet, 'repo-update' should throw an error.
-  (test-error "git-repo-update: file not found"
-    'system-error
-    (repo-update rpt "master"))
-
-  (create-git-repository file-name)
-
-  (test-assert "git-repo-update"
-    (repo-update rpt "master"))
-
-  (test-assert "git-repo-snapshot"
-    (in-store? (repo-snapshot rpt store)))
-
-  ;; Cleanup.
-  (system* "rm" "-rf" file-name "git-example"))
-
 (close-connection store)
 
 (test-end)
-- 
2.13.1

[bug#27550] [PATCH 2/2] utils: Remove useless procedures.

[Mathieu Othacehe]

* src/cuirass/utils.scm (mkdir-p, make-user-module,
  call-with-temporary-directory, with-directory-excursion): Remove because
  already defined in guix.
* tests/utils (with-directory-excursion): Remove associated test.
* src/cuirass/base.scm: Use (guix build utils) to provide procedure removed
  from (cuirass utils).
* bin/evaluate.in: Ditto.
* bin/cuirass.in: Use "make-user-module" provided by (guix ui).
---
 bin/cuirass.in        |  4 +--
 bin/evaluate.in       |  2 +-
 src/cuirass/base.scm  |  2 +-
 src/cuirass/utils.scm | 69 +--------------------------------------------------
 tests/utils.scm       | 15 -----------
 5 files changed, 5 insertions(+), 87 deletions(-)

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 7df5ddb..27efaac 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -26,7 +26,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 
 (use-modules (cuirass)
              (cuirass ui)
-             (cuirass utils)
+             (guix ui)
              (ice-9 getopt-long))
 
 (define (show-help)
@@ -90,7 +90,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
             (and specfile
                  (let ((new-specs (save-module-excursion
                                    (λ ()
-                                     (set-current-module (make-user-module))
+                                     (set-current-module (make-user-module '()))
                                      (primitive-load specfile)))))
                    (for-each (λ (spec) (db-add-specification db spec))
                              new-specs)))
diff --git a/bin/evaluate.in b/bin/evaluate.in
index 8875238..09a785b 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -26,9 +26,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (use-modules (cuirass)
-             (cuirass utils)
              (ice-9 match)
              (ice-9 pretty-print)
+             (guix build utils)
              (guix store))
 
 (define* (main #:optional (args (command-line)))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index fc3cc1a..58f2be3 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -20,8 +20,8 @@
 
 (define-module (cuirass base)
   #:use-module (cuirass database)
-  #:use-module (cuirass utils)
   #:use-module (gnu packages)
+  #:use-module (guix build utils)
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (ice-9 format)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index bcd5e12..dbe00a0 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -23,12 +23,8 @@
   #:use-module (srfi srfi-1)
   #:export (;; Procedures
             alist?
-            mkdir-p
-            make-user-module
-            call-with-temporary-directory
             ;; Macros.
-            λ*
-            with-directory-excursion))
+            λ*))
 
 (define-syntax-rule (λ* formals body ...)
   (lambda* formals body ...))
@@ -37,66 +33,3 @@
   "Return #t if OBJ is an alist."
   (and (list? obj)
        (every pair? obj)))
-
-(define mkdir-p
-  (let ((not-slash (char-set-complement (char-set #\/))))
-    (λ* (dir #:optional mode)
-      "Create directory DIR and all its ancestors."
-      (let ((absolute? (string-prefix? "/" dir)))
-        (let loop ((components (string-tokenize dir not-slash))
-                   (root       (if absolute? "" ".")))
-          (match components
-            ((head tail ...)
-             (let ((dir-name (string-append root "/" head)))
-               (catch 'system-error
-                 (λ ()
-                   (if mode
-                       (mkdir dir-name mode)
-                       (mkdir dir-name))
-                   (loop tail dir-name))
-                 (λ args
-                   ;; On GNU/Hurd we can get EROFS instead of EEXIST here.
-                   ;; Thus, if we get something other than EEXIST, check
-                   ;; whether DIR-NAME exists.  See
-                   ;; <https://lists.gnu.org/archive/html/guix-devel/2016-02/msg00049.html>.
-                   (if (or (= EEXIST (system-error-errno args))
-                           (let ((st (stat dir-name #f)))
-                             (and st (eq? 'directory (stat:type st)))))
-                       (loop tail dir-name)
-                       (apply throw args))))))
-            (() #t)))))))
-
-(define-syntax-rule (with-directory-excursion dir body ...)
-  "Run BODY with DIR as the process's current directory."
-  (let ((init (getcwd)))
-    (dynamic-wind
-      (λ () (chdir dir))
-      (λ () body ...)
-      (λ () (chdir init)))))
-
-(define* (make-user-module #:optional (modules '()))
-  "Return a new user module with the additional MODULES loaded."
-  ;; Module in which the machine description file is loaded.
-  (let ((module (make-fresh-user-module)))
-    (for-each (lambda (iface)
-                (module-use! module (resolve-interface iface)))
-              modules)
-    module))
-
-\f
-;;;
-;;; Temporary files.
-;;;
-
-(define (call-with-temporary-directory proc)
-  "Call PROC with a name of a temporary directory; close the directory and
-delete it when leaving the dynamic extent of this call."
-  (let* ((parent  (or (getenv "TMPDIR") "/tmp"))
-         (tmp-dir (string-append parent "/" (basename (tmpnam)))))
-    (mkdir-p tmp-dir)
-    (dynamic-wind
-      (const #t)
-      (lambda ()
-        (proc tmp-dir))
-      (lambda ()
-        (false-if-exception (rmdir tmp-dir))))))
diff --git a/tests/utils.scm b/tests/utils.scm
index 6a14355..d5298c5 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -35,19 +35,4 @@
        (not (alist? 'foo))
        (not (alist? #:bar))))
 
-(test-assert "with-directory-excursion"
-  (let ((old (getcwd))
-        (tmp (tmpnam)))
-    (dynamic-wind
-      (λ ()
-        (mkdir tmp))
-      (λ ()
-        (with-directory-excursion tmp
-          (dir-1 (getcwd)))
-        (dir-2 (getcwd))
-        (and (string=? (dir-1) tmp)
-             (string=? (dir-2) old)))
-      (λ ()
-        (rmdir tmp)))))
-
 (test-end)
-- 
2.13.1

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> Here are two patches to remove useless/duplicated stuff from cuirass
> and prepare (guix git) integration.

Woohoo, glad to see progress on this front!

> Mathieu Othacehe (2):
>   repo: remove git-repo.
>   utils: Remove useless procedures.

FWIW, I prefer to bake patches in such a way that the repo is always
usable at any given commit; doing that allows for bug hunting for ‘git
bisect’, among other things.  If we applied these patches, we’d be left
with a dysfunctional Cuirass, IIUC.

What about instead coming up with a single patch that replaces
‘git-repo’ with its Guile-Git counterpart?  The removal of unused
procedures can come separately, or along with this patch.

Thanks,
Ludo’.

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

Hi Ludo,

> What about instead coming up with a single patch that replaces
> ‘git-repo’ with its Guile-Git counterpart?  The removal of unused
> procedures can come separately, or along with this patch.

I got your point but unless I'm wrong git-repo is not used in
cuirass. So removing it does not have any functional impact on Cuirass.

Anyway the (guix git) binding is almost ready, I'll send a patch soon.

Thanks,

Mathieu

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

[-- Attachment #1: Type: text/plain, Size: 97 bytes --]


> Anyway the (guix git) binding is almost ready, I'll send a patch soon.

Here it is !

Mathieu

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-base-Use-guix-git-module.patch --]
[-- Type: text/x-diff, Size: 6349 bytes --]

From 37d7b68c1e89a2873673613f4781efb6acda529b Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Sat, 1 Jul 2017 12:29:59 +0200
Subject: [PATCH] base: Use (guix git) module.

* src/cuirass/base.scm (copy-repository-cache) : New procedure.
(fetch-repository): Use latest-repository-commit to fetch git
repository instead of raw git system commands.
(process-specs): Use fetch-repository to get a store directory
containing the repository described in SPEC, add copy it to cache with
"copy-repository-cache".
---
 src/cuirass/base.scm | 99 ++++++++++++++++++++++++++++++----------------------
 1 file changed, 57 insertions(+), 42 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 58f2be3..24b4769 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -24,10 +24,12 @@
   #:use-module (guix build utils)
   #:use-module (guix derivations)
   #:use-module (guix store)
+  #:use-module (guix git)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
   #:export (;; Procedures.
@@ -77,33 +79,42 @@ values."
                 duration)
         (acons #:duration duration result)))))
 
-(define (fetch-repository spec)
-  "Get the latest version of repository specified in SPEC.  Clone repository
-if required.  Return the last commit ID on success, #f otherwise."
-  (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))
-
+(define (fetch-repository store spec)
+  "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."
+
+  (define (add-origin branch)
+    "Prefix branch name with origin if no remote is specified."
+    (if (string-index branch #\/)
+        branch
+        (string-append "origin/" branch)))
+
+  (let ((name   (assq-ref spec #:name))
+        (url    (assq-ref spec #:url))
+        (branch (and=> (assq-ref spec #:branch)
+                       (lambda (b)
+                         `(branch . ,(add-origin b)))))
+        (commit (and=> (assq-ref spec #:commit)
+                       (lambda (c)
+                         `(commit . ,c))))
+        (tag    (and=> (assq-ref spec #:tag)
+                       (lambda (t)
+                         `(tag . ,t)))))
+    (latest-repository-commit store url
+                              #:cache-directory (%package-cachedir)
+                              #:ref (pk (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))
-            (url    (assq-ref spec #:url))
-            (branch (assq-ref spec #:branch))
-            (commit (assq-ref spec #:commit))
-            (tag    (assq-ref spec #:tag)))
-        (and (or (file-exists? name)
-                 (zero? (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))))
-                    (current-commit))))))))
+      (let ((name (assq-ref spec #:name)))
+        ;; Flush any directory with the same name.
+        (false-if-exception (delete-file-recursively name))
+        (copy-recursively repo name)))))
 
 (define (compile dir)
   ;; Required for fetching Guix bootstrap tarballs.
@@ -127,6 +138,7 @@ if required.  Return the last commit ID on success, #f otherwise."
                            (%package-database)))
          (jobs (read port)))
     (close-pipe port)
+    ;; XXX: test if jobs is consistent.
     jobs))
 
 (define (build-packages store db jobs)
@@ -171,24 +183,27 @@ if required.  Return the last commit ID on success, #f otherwise."
 (define (process-specs db jobspecs)
   "Evaluate and build JOBSPECS and store results in DB."
   (define (process spec)
-    (let ((commit (fetch-repository spec))
-          (stamp  (db-get-stamp db spec)))
-      (when commit
-        (unless (string=? commit stamp)
-          (unless (assq-ref spec #:no-compile?)
-            (compile (string-append (%package-cachedir) "/"
-                                    (assq-ref spec #:name))))
-          (with-store store
-            ;; Always set #:keep-going? so we don't stop on the first build
-            ;; failure.
-            (set-build-options store
-                               #:use-substitutes? (%use-substitutes?)
-                               #:keep-going? #t)
-
-            (let* ((spec* (acons #:current-commit commit spec))
-                   (jobs  (evaluate store db spec*)))
-              (build-packages store db jobs))))
-        (db-add-stamp db spec commit))))
+    (with-store store
+      (let ((stamp (db-get-stamp db spec)))
+        (receive (store-dir commit)
+            (fetch-repository store spec)
+          (when commit
+            (unless (string=? commit stamp)
+              (copy-repository-cache store-dir spec)
+
+              (unless (assq-ref spec #:no-compile?)
+                (compile (string-append (%package-cachedir) "/"
+                                        (assq-ref spec #:name))))
+              ;; Always set #:keep-going? so we don't stop on the first build
+              ;; failure.
+              (set-build-options store
+                                 #:use-substitutes? (%use-substitutes?)
+                                 #:keep-going? #t)
+
+              (let* ((spec* (acons #:current-commit commit spec))
+                     (jobs  (evaluate store db spec*)))
+                (build-packages store db jobs)))
+            (db-add-stamp db spec commit))))))
 
   (for-each process jobspecs))
 
-- 
2.13.1

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> What about instead coming up with a single patch that replaces
>> ‘git-repo’ with its Guile-Git counterpart?  The removal of unused
>> procedures can come separately, or along with this patch.
>
> I got your point but unless I'm wrong git-repo is not used in
> cuirass. So removing it does not have any functional impact on Cuirass.

Oh sorry, I thought it was relied on.  In that case you can go ahead
with this patch; likewise for the second patch if all these procedures
are already unused.

Ludo’.

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

> Oh sorry, I thought it was relied on.  In that case you can go ahead
> with this patch; likewise for the second patch if all these procedures
> are already unused.

No problem, just pushed them both !

Thanks,

Mathieu

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> From 37d7b68c1e89a2873673613f4781efb6acda529b Mon Sep 17 00:00:00 2001
> From: Mathieu Othacehe <m.othacehe@gmail.com>
> Date: Sat, 1 Jul 2017 12:29:59 +0200
> Subject: [PATCH] base: Use (guix git) module.
>
> * src/cuirass/base.scm (copy-repository-cache) : New procedure.
> (fetch-repository): Use latest-repository-commit to fetch git
> repository instead of raw git system commands.
> (process-specs): Use fetch-repository to get a store directory
> containing the repository described in SPEC, add copy it to cache with
> "copy-repository-cache".

Looks nice!

> +(define (fetch-repository store spec)
> +  "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."
> +
> +  (define (add-origin branch)
> +    "Prefix branch name with origin if no remote is specified."
> +    (if (string-index branch #\/)
> +        branch
> +        (string-append "origin/" branch)))
> +
> +  (let ((name   (assq-ref spec #:name))
> +        (url    (assq-ref spec #:url))
> +        (branch (and=> (assq-ref spec #:branch)
> +                       (lambda (b)
> +                         `(branch . ,(add-origin b)))))
> +        (commit (and=> (assq-ref spec #:commit)
> +                       (lambda (c)
> +                         `(commit . ,c))))
> +        (tag    (and=> (assq-ref spec #:tag)
> +                       (lambda (t)
> +                         `(tag . ,t)))))
> +    (latest-repository-commit store url
> +                              #:cache-directory (%package-cachedir)
> +                              #:ref (pk (or branch commit tag)))))

Leftover ‘pk’.  :-)

> +    (with-store store
> +      (let ((stamp (db-get-stamp db spec)))
> +        (receive (store-dir commit)
> +            (fetch-repository store spec)

Maybe s/store-dir/checkout/ for clarity.

Please add a check for (guix git) in configure.ac.

Now there are ‘git-error’ exception that can be thrown from there.
Should the ‘cuirass’ program catch them, report them on stderr, and keep
going?  Maybe we can ignore that for now (throwing is better than
silently ignoring Git problems anyway.)

Thanks,
Ludo’.

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

Hi Ludo,

> Looks nice!

Thanks :)

> Leftover ‘pk’.  :-)

Oops !

>
> Maybe s/store-dir/checkout/ for clarity.
>
> Please add a check for (guix git) in configure.ac.

Ok.

>
> Now there are ‘git-error’ exception that can be thrown from there.
> Should the ‘cuirass’ program catch them, report them on stderr, and keep
> going?  Maybe we can ignore that for now (throwing is better than
> silently ignoring Git problems anyway.)

Maybe we can ignore them for now, and when guile-git will support
git-error integer error code -> string conversion, we can report them
and keep going as you suggested ?

Mathieu

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

[-- Attachment #1: Type: text/plain, Size: 34 bytes --]


Here's the v2.

Thanks,

Mathieu

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-base-Use-guix-git-module.patch --]
[-- Type: text/x-diff, Size: 6491 bytes --]

From 1b79b7bf6e3ce864582b9aa79877b591798852ef Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Sat, 1 Jul 2017 12:29:59 +0200
Subject: [PATCH] base: Use (guix git) module.

* src/cuirass/base.scm (copy-repository-cache) : New procedure.
(fetch-repository): Use latest-repository-commit to fetch git
repository instead of raw git system commands.
(process-specs): Use fetch-repository to get a store directory
containing the repository described in SPEC, add copy it to cache with
"copy-repository-cache".
* configure.ac: Check (guix git) module presence.
---
 configure.ac         |  1 +
 src/cuirass/base.scm | 98 ++++++++++++++++++++++++++++++----------------------
 2 files changed, 57 insertions(+), 42 deletions(-)

diff --git a/configure.ac b/configure.ac
index 640e0c3..d7f111c 100644
--- a/configure.ac
+++ b/configure.ac
@@ -47,6 +47,7 @@ AS_IF([test -z "$ac_cv_path_GUILD"],
   [AC_MSG_ERROR(['guild' program cannot be found.])])
 
 GUILE_MODULE_REQUIRED([guix])
+GUILE_MODULE_REQUIRED([guix git])
 GUILE_MODULE_REQUIRED([json])
 GUILE_MODULE_REQUIRED([sqlite3])
 
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 58f2be3..1d15747 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -24,10 +24,12 @@
   #:use-module (guix build utils)
   #:use-module (guix derivations)
   #:use-module (guix store)
+  #:use-module (guix git)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
   #:export (;; Procedures.
@@ -77,33 +79,42 @@ values."
                 duration)
         (acons #:duration duration result)))))
 
-(define (fetch-repository spec)
-  "Get the latest version of repository specified in SPEC.  Clone repository
-if required.  Return the last commit ID on success, #f otherwise."
-  (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))
-
+(define (fetch-repository store spec)
+  "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."
+
+  (define (add-origin branch)
+    "Prefix branch name with origin if no remote is specified."
+    (if (string-index branch #\/)
+        branch
+        (string-append "origin/" branch)))
+
+  (let ((name   (assq-ref spec #:name))
+        (url    (assq-ref spec #:url))
+        (branch (and=> (assq-ref spec #:branch)
+                       (lambda (b)
+                         `(branch . ,(add-origin b)))))
+        (commit (and=> (assq-ref spec #:commit)
+                       (lambda (c)
+                         `(commit . ,c))))
+        (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))
-            (url    (assq-ref spec #:url))
-            (branch (assq-ref spec #:branch))
-            (commit (assq-ref spec #:commit))
-            (tag    (assq-ref spec #:tag)))
-        (and (or (file-exists? name)
-                 (zero? (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))))
-                    (current-commit))))))))
+      (let ((name (assq-ref spec #:name)))
+        ;; Flush any directory with the same name.
+        (false-if-exception (delete-file-recursively name))
+        (copy-recursively repo name)))))
 
 (define (compile dir)
   ;; Required for fetching Guix bootstrap tarballs.
@@ -171,24 +182,27 @@ if required.  Return the last commit ID on success, #f otherwise."
 (define (process-specs db jobspecs)
   "Evaluate and build JOBSPECS and store results in DB."
   (define (process spec)
-    (let ((commit (fetch-repository spec))
-          (stamp  (db-get-stamp db spec)))
-      (when commit
-        (unless (string=? commit stamp)
-          (unless (assq-ref spec #:no-compile?)
-            (compile (string-append (%package-cachedir) "/"
-                                    (assq-ref spec #:name))))
-          (with-store store
-            ;; Always set #:keep-going? so we don't stop on the first build
-            ;; failure.
-            (set-build-options store
-                               #:use-substitutes? (%use-substitutes?)
-                               #:keep-going? #t)
-
-            (let* ((spec* (acons #:current-commit commit spec))
-                   (jobs  (evaluate store db spec*)))
-              (build-packages store db jobs))))
-        (db-add-stamp db spec commit))))
+    (with-store store
+      (let ((stamp (db-get-stamp db spec)))
+        (receive (checkout commit)
+            (fetch-repository store spec)
+          (when commit
+            (unless (string=? commit stamp)
+              (copy-repository-cache checkout spec)
+
+              (unless (assq-ref spec #:no-compile?)
+                (compile (string-append (%package-cachedir) "/"
+                                        (assq-ref spec #:name))))
+              ;; Always set #:keep-going? so we don't stop on the first build
+              ;; failure.
+              (set-build-options store
+                                 #:use-substitutes? (%use-substitutes?)
+                                 #:keep-going? #t)
+
+              (let* ((spec* (acons #:current-commit commit spec))
+                     (jobs  (evaluate store db spec*)))
+                (build-packages store db jobs)))
+            (db-add-stamp db spec commit))))))
 
   (for-each process jobspecs))
 
-- 
2.13.1

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Ludovic Courtès]

Hello,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> Looks nice!
>
> Thanks :)
>
>> Leftover ‘pk’.  :-)
>
> Oops !
>
>>
>> Maybe s/store-dir/checkout/ for clarity.
>>
>> Please add a check for (guix git) in configure.ac.
>
> Ok.
>
>>
>> Now there are ‘git-error’ exception that can be thrown from there.
>> Should the ‘cuirass’ program catch them, report them on stderr, and keep
>> going?  Maybe we can ignore that for now (throwing is better than
>> silently ignoring Git problems anyway.)
>
> Maybe we can ignore them for now, and when guile-git will support
> git-error integer error code -> string conversion, we can report them
> and keep going as you suggested ?

Sure, sounds good, let’s ignore this for now.

Thank you!

Ludo’.

[bug#27550] [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> From 1b79b7bf6e3ce864582b9aa79877b591798852ef Mon Sep 17 00:00:00 2001
> From: Mathieu Othacehe <m.othacehe@gmail.com>
> Date: Sat, 1 Jul 2017 12:29:59 +0200
> Subject: [PATCH] base: Use (guix git) module.
>
> * src/cuirass/base.scm (copy-repository-cache) : New procedure.
> (fetch-repository): Use latest-repository-commit to fetch git
> repository instead of raw git system commands.
> (process-specs): Use fetch-repository to get a store directory
> containing the repository described in SPEC, add copy it to cache with
> "copy-repository-cache".
> * configure.ac: Check (guix git) module presence.

OK!

Ludo'.

bug#27550: [PATCH 0/2] cuirass: Prepare (guix git) integration.

[Mathieu Othacehe]

Pushed as 1b79b7b,

Thanks,

Mathieu