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.

Makefile.am

@@ -34,6 +34,7 @@ dist_pkgmodule_DATA = \
   src/cuirass/base.scm \
   src/cuirass/database.scm \
   src/cuirass/http.scm \
+  src/cuirass/repo.scm \
   src/cuirass/ui.scm \
   src/cuirass/utils.scm
 
@@ -64,6 +65,7 @@ TESTS = \
 ## tests/basic.sh # takes too long to execute
   tests/database.scm \
   tests/http.scm \
+  tests/repo.scm \
   tests/ui.scm \
   tests/utils.scm
 

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

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

tests/repo.scm

@@ -0,0 +1,113 @@
+;;;; repo.scm -- tests for (cuirass repo) module
+;;; 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/>.
+
+(use-modules (cuirass repo)
+             (cuirass utils)
+             (guix store)
+             (srfi srfi-64))
+
+(test-begin "repo")
+
+(test-equal "<repo> datatype"
+  ;; Check that all the procedures for manipulating <repo> objects are
+  ;; exported and that the keywords of the constructor matches their slot.
+  '(1 2 3 4 5 6)
+  (let ((obj (repo #:id 1 #:url 2 #:location 3 #:ref 4
+                   #:snapshoter 5 #:updater 6)))
+    (and (repo? obj)
+         (list (repo-id obj)
+               (repo-url obj)
+               (repo-location obj)
+               (repo-reference obj)
+               (repo-snapshoter obj)
+               (repo-updater obj)))))
+
+(define file-name
+  (pk (simple-format #f "tmp-~S" (getpid))))
+
+(define store
+  (open-connection))
+
+(define (create-file name)
+  "Create a dummy file in current directory."
+  (with-output-to-file name
+    (λ () (display "test!\n"))))
+
+(define (in-store? file-name)
+  "Check if FILE-NAME is in the store.  FILE-NAME must be an absolute file
+name."
+  (string-prefix? "/gnu/store" file-name))
+
+;;;
+;;; File repository.
+;;;
+
+(test-group-with-cleanup "file-repo"
+  (define rpt (pk (file-repo file-name)))
+
+  ;; Since file doesn't exist yet, 'repo-update' should throw an error.
+  (test-error "file-repo-update: file not found"
+    'system-error
+    (repo-update rpt))
+
+  (create-file file-name)
+
+  (test-assert "file-repo-update"
+    (repo-update rpt))
+
+  (test-assert "file-repo-snapshot"
+    (in-store? (repo-snapshot rpt store)))
+
+  ;; 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)