Commit e8b64f06 authored by Eric Timmons's avatar Eric Timmons
Browse files

Implement local overrides for VCS reqs in bundle operations

parent 1a285bda
......@@ -9,6 +9,7 @@
#:anaphora
#:clpm/client
#:clpm/clpmfile
#:clpm/config
#:clpm/context
#:clpm/install
#:clpm/log
......@@ -28,6 +29,13 @@
:sources (clpmfile-sources clpmfile)
:requirements (clpmfile-all-requirements clpmfile)))
(defun make-vcs-override-fun (clpmfile-pathname)
(let ((clpmfile-directory (uiop:pathname-directory-pathname clpmfile-pathname)))
(lambda (project-name)
(let ((override (config-value :bundle :local project-name)))
(when override
(merge-pathnames override clpmfile-directory))))))
(defun build-lockfile (clpmfile &key localp)
"Given a clpmfile instance, make a lockfile context for it."
(let* ((lockfile (create-empty-lockfile clpmfile))
......@@ -57,6 +65,7 @@ the lock file if necessary."
(let* ((*fetch-repo-automatically* (not localp))
(clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile)))
(lockfile nil)
(changedp nil))
(if (probe-file lockfile-pathname)
......@@ -68,7 +77,8 @@ the lock file if necessary."
:context lockfile
:validate (lambda (diff)
(aprog1 (funcall validate diff)
(setf changedp it)))))
(setf changedp it)))
:update-projects (config-table-keys :bundle :local)))
(when changedp
(with-open-file (stream lockfile-pathname
:direction :output
......@@ -80,6 +90,7 @@ the lock file if necessary."
(let* ((*fetch-repo-automatically* nil)
(clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile)))
lockfile)
(unless (probe-file lockfile-pathname)
(error "Lockfile ~A does not exist" lockfile-pathname))
......@@ -96,6 +107,7 @@ the lock file if necessary."
(let* ((*fetch-repo-automatically* (not localp))
(clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile)))
(lockfile nil)
(changedp nil))
(unless (probe-file lockfile-pathname)
......
......@@ -95,6 +95,16 @@ directory in ~*clpm-config-directories*~."
:documentation
"The tar implementation to use.")
((:bundle)
:type hash-table)
((:bundle :local)
:type hash-table)
((:bundle :local :*)
:wildcard-types (string)
:type (or string pathname)
:documentation
"Path to a folder to use for a project's git repository instead of a CLPM managed one. Relative pathnames are resolved with respect to the location of the clpmfile.")
((:context)
:type string
:default "default"
......
......@@ -7,10 +7,12 @@
(:use #:cl
#:clpm/repos/defs
#:clpm/repos/git
#:clpm/repos/gitlab)
#:clpm/repos/gitlab
#:clpm/repos/local-git-override)
(:reexport #:clpm/repos/defs)
(:reexport #:clpm/repos/git)
(:reexport #:clpm/repos/gitlab)
(:reexport #:clpm/repos/local-git-override)
(:export #:make-repo-from-description))
(in-package #:clpm/repos)
......
......@@ -10,6 +10,8 @@
#:ensure-ref-present-locally!
#:ref-present-p
#:repo-archive-stream
#:repo-current-branch
#:repo-current-commit
#:repo-lib-base-pathname
#:repo-to-form
#:resolve-ref-to-commit))
......@@ -24,6 +26,10 @@
(defgeneric repo-archive-stream (repo ref))
(defgeneric repo-current-branch (repo))
(defgeneric repo-current-commit (repo))
(defgeneric repo-lib-base-pathname (repo))
(defgeneric repo-to-form (repo))
......
......@@ -149,11 +149,11 @@ optionally changing into the local dir for ~repo~."
:output '(:string :stripped t)
:ignore-error-status ignore-error-status)))
(defun git-rev-parse (rev &key repo ignore-error-status)
(defun git-rev-parse (rev &key repo abbrev-ref ignore-error-status)
"Calls ~git rev-parse~ with the provided revision and returns the result,
optionally changing into the local dir for ~repo~."
(with-git-dir (repo)
(uiop:run-program `("git" "rev-parse" ,rev)
(uiop:run-program `("git" "rev-parse" ,@(when abbrev-ref '("--abbrev-ref")) ,rev)
:output '(:string :stripped t)
:ignore-error-status ignore-error-status)))
......@@ -162,6 +162,7 @@ optionally changing into the local dir for ~repo~."
(let* ((local-dir (git-repo-local-dir repo))
(uri-string (git-repo-uri-string repo))
(credentials (git-repo-credentials repo)))
(log:debug "Fetching ~A" local-dir)
(multiple-value-bind (prefix env)
(authenticated-git-command-list credentials)
(uiop:with-current-directory (local-dir)
......@@ -248,3 +249,9 @@ ref is present locally, fetching or cloning the repo as necessary."
(defmethod resolve-ref-to-commit ((repo git-repo) ref)
(git-rev-parse (second ref) :repo repo))
(defmethod repo-current-branch ((repo git-repo))
(git-rev-parse "HEAD" :repo repo :abbrev-ref t))
(defmethod repo-current-commit ((repo git-repo))
(git-rev-parse "HEAD" :repo repo))
;;;; Git Repositories
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos/local-git-override
(:use #:cl
#:clpm/log
#:clpm/repos/git)
(:export #:local-git-override-repo))
(in-package #:clpm/repos/local-git-override)
(setup-logger)
(defclass local-git-override-repo (git-repo)
((directory-pathname
:initarg :pathname
:reader git-repo-local-dir)))
(defmethod initialize-instance :after ((repo local-git-override-repo) &rest initargs &key pathname)
(declare (ignore initargs))
(assert (uiop:absolute-pathname-p pathname))
(assert (uiop:directory-pathname-p pathname))
(assert (uiop:directory-exists-p pathname)))
......@@ -314,10 +314,7 @@ source.")
(branch `(:branch ,branch))
(tag `(:tag ,tag))))
(release (ensure-gethash ref (ff-project-vcs-releases-map project)
(make-instance 'vcs-release
:source (project-source project)
:project project
:ref ref))))
(make-vcs-release (project-source project) project ref))))
(unless commit
(setf release (ensure-gethash `(:commit ,(vcs-release-commit release)) (ff-project-vcs-releases-map project)
release)))
......
......@@ -18,10 +18,11 @@
#:clpm/requirement
#:clpm/sources/defs
#:clpm/sources/semantic-versioned-project)
(:export #:ensure-vcs-release-installed!
(:export #:*vcs-project-override-fun*
#:ensure-vcs-release-installed!
#:make-vcs-release
#:vcs-project/cache-directory
#:vcs-project/path
#:vcs-release
#:vcs-release-commit
#:vcs-source
#:vcs-source-register-project!))
......@@ -29,6 +30,7 @@
(in-package #:clpm/sources/vcs)
(setup-logger)
;; * sources
......@@ -118,6 +120,29 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
;; * projects
;; ** Overrides
(defvar *vcs-project-override-fun* (constantly nil)
"A function that, given a project name returns either NIL or a directory
pathname. If a directory pathname is returned, then that is assumed to be a
local override when requesting a VCS release.")
(defun make-vcs-release (source project ref)
(let ((override-pathname (funcall *vcs-project-override-fun* (project-name project))))
(if override-pathname
(make-instance 'vcs-local-release
:source source
:project project
:ref ref
:repo (make-instance 'local-git-override-repo
:pathname override-pathname))
(make-instance 'vcs-remote-release
:source source
:project project
:ref ref))))
;; ** Projects
(defclass vcs-project (clpm-project)
((source
:initarg :source
......@@ -152,10 +177,7 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
(branch `(:branch ,branch))
(tag `(:tag ,tag))))
(release (ensure-gethash ref (vcs-project-releases-by-spec project)
(make-instance 'vcs-release
:source (project-source project)
:project project
:ref ref))))
(make-vcs-release (project-source project) project ref))))
(unless commit
(setf release (ensure-gethash `(:commit ,(vcs-release-commit release)) (vcs-project-releases-by-spec project)
release)))
......@@ -186,10 +208,46 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
:initform (make-hash-table :test 'equal)
:accessor vcs-release-system-releases-by-name)))
(defmethod initialize-instance :after ((release vcs-release) &rest initargs &key ref)
(defclass vcs-remote-release (vcs-release)
()
(:documentation "Represents a release fetched from a remote repository."))
(defclass vcs-local-release (vcs-release)
((installed-p
:initform t)
(repo
:initarg :repo
:reader vcs-release-repo))
(:documentation "Represents a release that uses a user managed local repository."))
(defmethod initialize-instance :after ((release vcs-remote-release) &rest initargs &key ref)
(declare (ignore initargs))
(vcs-release-resolve! release ref))
(defmethod initialize-instance :after ((release vcs-local-release) &rest initargs &key ref)
(declare (ignore initargs))
(destructuring-bind (ref-type ref-name) ref
(ecase ref-type
(:branch
;; Error unless the target branch name matches the actual branch name.
(let ((current-branch-name (repo-current-branch (vcs-release-repo release))))
(unless (equal ref-name current-branch-name)
(log:error "In order to use local overrides, branch names must match. Expected: ~a, actual: ~a"
ref-name current-branch-name)
(error "In order to use local overrides, branch names must match. Expected: ~a, actual: ~a"
ref-name current-branch-name))))
(:commit
;; Warn if the desired commit is not present in the repo.
(unless (ref-present-p (vcs-release-repo release) ref)
(log:warn "Commit ~A is not present in the local override. Your local repo may not be up to date!"
ref-name)
(warn "Commit ~A is not present in the local override. Your local repo may not be up to date!"
ref-name)))))
(setf (vcs-release-commit release) (repo-current-commit (vcs-release-repo release))))
(defmethod vcs-release-repo ((release vcs-remote-release))
(project-repo (release-project release)))
(defun populate-release-system-files! (release)
(ensure-release-installed! release)
(let ((ht-by-namestring (make-hash-table :test 'equal))
......@@ -226,10 +284,9 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
already created."
(gethash system-file-namestring (vcs-release-system-files-by-namestring release)))
(defmethod release-lib-pathname ((release vcs-release))
(let* ((project (release-project release))
(repo (project-repo project))
(commit-string (vcs-release-commit release)))
(defmethod release-lib-pathname ((release vcs-remote-release))
(let ((repo (vcs-release-repo release))
(commit-string (vcs-release-commit release)))
(uiop:resolve-absolute-location
`(,(repo-lib-base-pathname repo)
,(subseq commit-string 0 2)
......@@ -237,6 +294,9 @@ already created."
,commit-string)
:ensure-directory t)))
(defmethod release-lib-pathname ((release vcs-local-release))
(git-repo-local-dir (vcs-release-repo release)))
(defmethod release-system-releases ((release vcs-release))
"Get all the system files and append together their systems."
(let* ((system-files (release-system-files release)))
......@@ -397,8 +457,7 @@ include it."
;; * Installing
(defun vcs-release-resolve! (release ref)
(let* ((project (release-project release))
(repo (project-repo project)))
(let ((repo (vcs-release-repo release)))
(ensure-ref-present-locally! repo ref)
......@@ -407,8 +466,8 @@ include it."
(defmethod ensure-release-installed! ((release vcs-release))
(unless (vcs-release-installed-p release)
(let* ((project (release-project release))
(repo (project-repo project)))
(let ((project (release-project release))
(repo (vcs-release-repo release)))
(let ((install-root (release-lib-pathname release)))
(unless (uiop:probe-file* install-root)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment