blob: be5ea5b33f6a6c4373aa8fde5e0981f9f7e15c34 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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))))
|