repo: Add <repo> record datatype.

* src/cuirass/utils.scm (call-with-temporary-directory): New procedure.
* src/cuirass/repo.scm: Use it.  New file.
* tests/repo.scm: New tests.
* Makefile.am (dist_pkgmodule_DATA, TESTS): Add them.

2 files changed, 135 insertions, 0 deletions

diff --git a/src/cuirass/repo.scm b/src/cuirass/repo.scm
new file mode 100644
index 0000000..be5ea5b
--- /dev/null
+++ b/src/cuirass/repo.scm
@@ -0,0 +1,116 @@
+;;;; repo.scm -- manage code repositories
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass repo)
+  #:use-module (cuirass utils)
+  #:use-module (guix store)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (repo
+            repo?
+            repo-id
+            repo-url
+            repo-location
+            repo-reference
+            repo-snapshoter
+            repo-snapshot
+            repo-updater
+            repo-update
+            file-repo
+            git-repo))
+
+(define-immutable-record-type <repo>
+  ;; An Abstract repository.  Use "repo" as a shortname for "repository".
+  (make-repo id url location ref snapshoter updater)
+  repo?
+  (id         repo-id)                  ;string
+  (url        repo-url)                 ;string
+  (location   repo-location)            ;string
+  (ref        repo-reference)           ;string
+  (snapshoter repo-snapshoter)          ;method
+  (updater    repo-updater))            ;method
+
+(define* (repo #:key id url location ref snapshoter updater)
+  ;; Convenient <repo> constructor using keyword arguments.
+  (make-repo id url location ref snapshoter updater))
+
+(define (repo-snapshot repo store)
+  "Send a snapshot of REPO to the STORE."
+  ((repo-snapshoter repo) repo store))
+
+(define* (repo-update repo #:optional ref)
+  "Pull changes from REPO according to reference REF."
+  ((repo-updater repo) repo ref))
+
+;;;
+;;; Concrete repositories.
+;;;
+
+(define file-repo
+  (let ((hash-algo "sha256"))
+    (define (file-repo-snapshot this store)
+      ;; Send file to the STORE.
+      (let* ((basename   (repo-id this))
+             (file       (repo-location this))
+             (directory? (eq? 'directory (stat:type (stat file)))))
+        (add-to-store store basename directory? hash-algo file)))
+
+    (define (file-repo-update this ref)
+      ;; Ensure that file still exists.
+      (stat (repo-location this)))
+
+    (λ* (file-name #:key id)
+      "Basic repository that handles a local file or directory."
+      (repo #:id (or id file-name)
+            #: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/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 56b9c6a..bcd5e12 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -25,6 +25,7 @@
             alist?
             mkdir-p
             make-user-module
+            call-with-temporary-directory
             ;; Macros.
             λ*
             with-directory-excursion))
@@ -81,3 +82,21 @@
                 (module-use! module (resolve-interface iface)))
               modules)
     module))
+
+
+;;;
+;;; 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))))))