mirror of https://notabug.org/mthl/cuirass.git
117 lines
4.0 KiB
Scheme
117 lines
4.0 KiB
Scheme
;;;; 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))))
|