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

[Mathieu Othacehe]

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

Here it is !

Mathieu

>From 37d7b68c1e89a2873673613f4781efb6acda529b Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <address@hidden>
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