diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | src/cuirass/repo.scm | 116 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 19 | ||||
| -rw-r--r-- | tests/repo.scm | 113 |
4 files changed, 250 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index cf6f21a..4c562ea 100644 --- a/Makefile.am +++ b/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 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)))))) diff --git a/tests/repo.scm b/tests/repo.scm new file mode 100644 index 0000000..fc73a64 --- /dev/null +++ b/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) |