mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2023-12-14 06:03:04 +01:00
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.
This commit is contained in:
parent
a6807cb29c
commit
16aec469d4
4 changed files with 250 additions and 0 deletions
|
@ -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
|
||||
|
||||
|
|
116
src/cuirass/repo.scm
Normal file
116
src/cuirass/repo.scm
Normal file
|
@ -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))))
|
|
@ -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))))))
|
||||
|
|
113
tests/repo.scm
Normal file
113
tests/repo.scm
Normal file
|
@ -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)
|
Loading…
Reference in a new issue