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

Refactor all VCS operations to outside of the source

parent 1d9f2707
...@@ -82,12 +82,12 @@ with zero configuration or helpers needed (other than ASDF, of course). ...@@ -82,12 +82,12 @@ with zero configuration or helpers needed (other than ASDF, of course).
bundle. bundle.
#+begin_src common-lisp #+begin_src common-lisp
(name &key (host "gitlab.com") repo branch commit tag systems) (name &key (host "gitlab.com") path branch commit tag systems)
#+end_src #+end_src
+ ~name~ :: must be a string, unique in the file. + ~name~ :: must be a string, unique in the file.
+ ~:host~ :: is the hostname of the gitlab server. Defaults to gitlab.com. + ~:host~ :: is the hostname of the gitlab server. Defaults to gitlab.com.
+ ~:repo~ :: is a string naming the path to the repository. + ~:path~ :: is a string naming the path to the repository.
+ ~:branch~ :: If specified, must be a string naming the branch to use. If + ~:branch~ :: If specified, must be a string naming the branch to use. If
none of branch, commit, or tag are specified, the branch defaults to the none of branch, commit, or tag are specified, the branch defaults to the
default branch from the server. default branch from the server.
......
...@@ -31,8 +31,8 @@ ...@@ -31,8 +31,8 @@
*bundle-arguments* *bundle-arguments*
*common-arguments*)) *common-arguments*))
(defun ensure-git-req-installed-and-rewrite-req (req) (defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a git requirement, install it and return a new requirement on the "Given a VCS requirement, install it and return a new requirement on the
correct commit." correct commit."
(let* ((project-name (requirement/name req)) (let* ((project-name (requirement/name req))
(branch (requirement/branch req)) (branch (requirement/branch req))
...@@ -49,8 +49,8 @@ correct commit." ...@@ -49,8 +49,8 @@ correct commit."
(tag (tag
`(:tag ,tag)))))) `(:tag ,tag))))))
(install-release vcs-release) (install-release vcs-release)
(make-instance 'git-project-requirement (make-instance 'vcs-project-requirement
:commit (git-release/commit vcs-release) :commit (vcs-release/commit vcs-release)
:repo (requirement/repo req) :repo (requirement/repo req)
:source (requirement/source req) :source (requirement/source req)
:name (requirement/name req) :name (requirement/name req)
...@@ -62,11 +62,11 @@ correct commit." ...@@ -62,11 +62,11 @@ correct commit."
(let* ((sources (clpmfile/sources clpmfile)) (let* ((sources (clpmfile/sources clpmfile))
(raw-reqs (clpmfile/all-requirements clpmfile)) (raw-reqs (clpmfile/all-requirements clpmfile))
reqs) reqs)
;; Make sure all git releases are installed and replace their requirements ;; Make sure all vcs releases are installed and replace their requirements
;; with a requirement on the commit. ;; with a requirement on the commit.
(dolist (r raw-reqs) (dolist (r raw-reqs)
(if (typep r 'git-requirement) (if (typep r 'vcs-requirement)
(push (ensure-git-req-installed-and-rewrite-req r) reqs) (push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs))) (push r reqs)))
;; Resolve the requirements! ;; Resolve the requirements!
......
...@@ -31,8 +31,8 @@ ...@@ -31,8 +31,8 @@
*bundle-arguments* *bundle-arguments*
*common-arguments*)) *common-arguments*))
(defun ensure-git-req-installed-and-rewrite-req (req) (defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a git requirement, install it and return a new requirement on the "Given a VCS requirement, install it and return a new requirement on the
correct commit." correct commit."
(let* ((project-name (requirement/name req)) (let* ((project-name (requirement/name req))
(branch (requirement/branch req)) (branch (requirement/branch req))
...@@ -49,8 +49,8 @@ correct commit." ...@@ -49,8 +49,8 @@ correct commit."
(tag (tag
`(:tag ,tag)))))) `(:tag ,tag))))))
(install-release vcs-release) (install-release vcs-release)
(make-instance 'git-project-requirement (make-instance 'vcs-project-requirement
:commit (git-release/commit vcs-release) :commit (vcs-release/commit vcs-release)
:repo (requirement/repo req) :repo (requirement/repo req)
:source (requirement/source req) :source (requirement/source req)
:name (requirement/name req) :name (requirement/name req)
...@@ -67,8 +67,8 @@ correct commit." ...@@ -67,8 +67,8 @@ correct commit."
;; Make sure all git releases are installed and replace their requirements ;; Make sure all git releases are installed and replace their requirements
;; with a requirement on the commit. ;; with a requirement on the commit.
(dolist (r raw-reqs) (dolist (r raw-reqs)
(if (typep r 'git-requirement) (if (typep r 'vcs-requirement)
(push (ensure-git-req-installed-and-rewrite-req r) reqs) (push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs))) (push r reqs)))
;; Resolve the requirements! ;; Resolve the requirements!
......
...@@ -10,6 +10,7 @@ ...@@ -10,6 +10,7 @@
#:iterate #:iterate
#:clpm/config #:clpm/config
#:clpm/deps #:clpm/deps
#:clpm/repos
#:clpm/requirement #:clpm/requirement
#:clpm/source) #:clpm/source)
(:export #:clpmfile/all-requirements (:export #:clpmfile/all-requirements
...@@ -49,6 +50,12 @@ ...@@ -49,6 +50,12 @@
:accessor clpmfile/fs-source :accessor clpmfile/fs-source
:documentation :documentation
"The filesystem source rooted at this clpmfile's directory.") "The filesystem source rooted at this clpmfile's directory.")
(vcs-source
:initform (make-instance 'vcs-source
:name "%clpmfile-vcs")
:accessor clpmfile/vcs-source
:documentation
"The VCS source for all orphaned VCS requirements in this clpmfile.")
(implicit-sources (implicit-sources
:initform nil :initform nil
:accessor clpmfile/implicit-sources :accessor clpmfile/implicit-sources
...@@ -132,6 +139,7 @@ clpmfile is located." ...@@ -132,6 +139,7 @@ clpmfile is located."
(defun clpmfile/sources (clpmfile) (defun clpmfile/sources (clpmfile)
"Return a list of all the sources associated with ~clpmfile~." "Return a list of all the sources associated with ~clpmfile~."
(list* (clpmfile/fs-source clpmfile) (list* (clpmfile/fs-source clpmfile)
(clpmfile/vcs-source clpmfile)
(append (clpmfile/implicit-sources clpmfile) (append (clpmfile/implicit-sources clpmfile)
(clpmfile/user-global-sources clpmfile)))) (clpmfile/user-global-sources clpmfile))))
...@@ -145,41 +153,21 @@ or raise an error if it does not exist." ...@@ -145,41 +153,21 @@ or raise an error if it does not exist."
(defun parse-req-statement (clpmfile name (defun parse-req-statement (clpmfile name
&key (type :project) version source &key (type :project) version source
git systems) systems)
"Parse a ~:req~ statement from a ~clpmfile~ into a ~requirement~ instance." "Parse a ~:req~ statement from a ~clpmfile~ into a ~requirement~ instance."
(assert (null systems))
(let ((req nil)) (let ((req nil))
(if git (setf req
(destructuring-bind (type (make-instance (ecase type
&key branch commit tag repo host (:project 'project-requirement)
&allow-other-keys) (:system 'system-requirement))
git :name (string-downcase (string name))
(let ((source (get-git-source type host))) :source (when source
;; This may be the first time this source is seen. Record it. (find-source-or-error (clpmfile/user-global-sources clpmfile)
(pushnew source (clpmfile/implicit-sources clpmfile)) source))
;; Register the git project. :version-spec (when version
(git-source-register-project! source repo name) (cons (first version)
(assert (xor branch commit tag)) (second version)))))
(setf req
(make-instance 'git-project-requirement
:systems systems
:name name
:source source
:repo git
:branch branch
:commit commit
:tag tag))))
(setf req
(make-instance (ecase type
(:project 'project-requirement)
(:system 'system-requirement))
:name (string-downcase (string name))
:source (when source
(find-source-or-error (clpmfile/user-global-sources clpmfile)
source))
:version-spec (when version
(cons (first version)
(second version))))))
(push req (clpmfile/user-requirements clpmfile)))) (push req (clpmfile/user-requirements clpmfile))))
(defun parse-system-statement (clpmfile name &key source) (defun parse-system-statement (clpmfile name &key source)
...@@ -192,37 +180,16 @@ instance." ...@@ -192,37 +180,16 @@ instance."
source))) source)))
(clpmfile/user-requirements clpmfile))) (clpmfile/user-requirements clpmfile)))
(defun parse-git-statement (clpmfile name
&key repo branch commit tag systems)
"Parse a ~:git~ statement from a ~clpmfile~ into a ~git-project-requirement~
instance."
(let ((source (get-git-source :git)))
;; This may be the first time this source is seen. Record it.
(pushnew source (clpmfile/implicit-sources clpmfile))
;; Register the git project.
(git-source-register-project! source repo name)
(assert (xor branch commit tag))
(push (make-instance 'git-project-requirement
:systems systems
:name name
:source source
:repo repo
:branch branch
:commit commit
:tag tag)
(clpmfile/user-requirements clpmfile))))
(defun parse-gitlab-statement (clpmfile name (defun parse-gitlab-statement (clpmfile name
&key (host "gitlab.com") repo branch commit tag systems) &key (host "gitlab.com") path branch commit tag systems)
"Parse a ~:gitlab~ statement from a ~clpmfile~ into a "Parse a ~:gitlab~ statement from a ~clpmfile~ into a
~git-project-requirement~ instance." ~vcs-project-requirement~ instance."
(let ((source (get-git-source :gitlab host))) (let ((source (clpmfile/vcs-source clpmfile))
;; This may be the first time this source is seen. Record it. (repo (make-repo-from-description (list :gitlab :host host :path path))))
(pushnew source (clpmfile/implicit-sources clpmfile))
;; Register the git project. ;; Register the git project.
(git-source-register-project! source repo name) (vcs-source-register-project! source repo name)
(assert (xor branch commit tag)) (assert (xor branch commit tag))
(push (make-instance 'git-project-requirement (push (make-instance 'vcs-project-requirement
:systems systems :systems systems
:name name :name name
:source source :source source
...@@ -284,8 +251,6 @@ sources." ...@@ -284,8 +251,6 @@ sources."
(ecase type (ecase type
(:source (:source
(apply #'parse-source-statement clpmfile args)) (apply #'parse-source-statement clpmfile args))
(:git
(apply #'parse-git-statement clpmfile args))
(:gitlab (:gitlab
(apply #'parse-gitlab-statement clpmfile args)) (apply #'parse-gitlab-statement clpmfile args))
(:system (:system
...@@ -323,28 +288,17 @@ sources." ...@@ -323,28 +288,17 @@ sources."
(push system-file (lockfile/system-files lockfile)) (push system-file (lockfile/system-files lockfile))
lockfile)) lockfile))
(defmethod parse-system-file-statement (lockfile (statement-type (eql :git)) (defmethod parse-system-file-statement (lockfile (statement-type (eql :gitlab))
&key type host repo commit system-files &key host path commit system-files
name) name)
;; First, look for a local override. ;; First, look for a local override.
(let ((local (config-value :bundle :local name :path))) (let ((local (config-value :bundle :local name :path)))
(if local (if local
;; A local override exists. ;; A local override exists.
(let* ((local-path (uiop:ensure-directory-pathname (error "local overrides currently broken.")
(merge-pathnames local (let* ((source (clpmfile/vcs-source (lockfile/clpmfile lockfile)))
(uiop:pathname-directory-pathname (repo (make-repo-from-description `(:gitlab :host ,host :path ,path)))
(lockfile/pathname lockfile))))) (project (vcs-source-register-project! source repo name))
(source (get-git-source :local))
(project (git-source-register-project! source local-path name))
(release (project/release project :current))
(system-files (mapcar (curry #'release/system-file release) system-files)))
(log:debug "Using override for ~S" name)
(unless (commit-in-repo-p release commit)
(error "Commit ~S is missing from local repo at ~S" commit local-path))
(setf (lockfile/system-files lockfile)
(append system-files (lockfile/system-files lockfile))))
(let* ((source (get-git-source type host))
(project (git-source-register-project! source repo name))
(release (project/release project `(:commit ,commit))) (release (project/release project `(:commit ,commit)))
(system-files (mapcar (curry #'release/system-file release) system-files))) (system-files (mapcar (curry #'release/system-file release) system-files)))
(setf (lockfile/system-files lockfile) (setf (lockfile/system-files lockfile)
...@@ -402,9 +356,25 @@ sources." ...@@ -402,9 +356,25 @@ sources."
,@(when-let ((source (requirement/source req))) ,@(when-let ((source (requirement/source req)))
(list :source (source/name source))))) (list :source (source/name source)))))
(defmethod req-to-sexp ((req git-project-requirement)) (defgeneric repo-to-sexp (repo req))
(defmethod repo-to-sexp ((repo gitlab-repo) req)
`(:gitlab
:host ,(gitlab-repo-host repo)
:path ,(gitlab-repo-path repo)
,@(awhen (requirement/branch req)
`(:branch ,it))
,@(awhen (requirement/commit req)
`(:commit ,it))
,@(awhen (requirement/tag req)
`(:tag ,it))
,@(awhen (requirement/systems req)
`(:systems ,it))))
(defmethod req-to-sexp ((req vcs-project-requirement))
`(:req ,(requirement/name req) `(:req ,(requirement/name req)
:git ,(requirement/repo req))) :type :vcs
:vcs-type ,@(repo-to-sexp (requirement/repo req) req)))
(defun lockfile-system-file-sexps (lockfile) (defun lockfile-system-file-sexps (lockfile)
"Return a list of system file statements from ~lockfile~ suitable for writing "Return a list of system file statements from ~lockfile~ suitable for writing
...@@ -428,18 +398,20 @@ to a file." ...@@ -428,18 +398,20 @@ to a file."
(collect `(:local-asd (collect `(:local-asd
:path ,(system-file/asd-enough-namestring file))))) :path ,(system-file/asd-enough-namestring file)))))
;; TODO: Make this handle local vs remote git repos ;; TODO: Make this handle local vs remote git repos
((typep release 'git-release) ((typep release 'vcs-release)
(let ((version (release/version release)) (let* ((version (release/version release))
(source (release/source release))) (project (release/project release))
(repo (project/repo project)))
(assert (listp version)) (assert (listp version))
(assert (eql :commit (first version))) (assert (eql :commit (first version)))
(assert (stringp (second version))) (assert (stringp (second version)))
(collect `(:git (collect `(,(etypecase repo
(gitlab-repo
:gitlab))
:name ,(project/name (release/project release)) :name ,(project/name (release/project release))
:type ,(git-source-type-keyword source) :host ,(gitlab-repo-host repo)
:host ,(git-source/host source) :path ,(gitlab-repo-path repo)
:repo ,(vcs-project/path (release/project release))
:commit ,(second version) :commit ,(second version)
:system-files ,(mapcar #'system-file/asd-enough-namestring system-files-in-release))))) :system-files ,(mapcar #'system-file/asd-enough-namestring system-files-in-release)))))
(t (t
......
...@@ -82,6 +82,6 @@ ...@@ -82,6 +82,6 @@
(defgeneric install-release (release &key activate-globally) (defgeneric install-release (release &key activate-globally)
(:documentation "Install a ~release~ and optinally activate it globally.")) (:documentation "Install a ~release~ and optinally activate it globally."))
(defmethod install-release ((release git-release) &key activate-globally) (defmethod install-release ((release vcs-release) &key activate-globally)
(assert (null activate-globally)) (assert (null activate-globally))
(ensure-git-release-installed! release)) (ensure-vcs-release-installed! release))
;;;; VCS Repositories
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos
(:use #:cl
#:clpm/repos/defs
#:clpm/repos/git
#:clpm/repos/gitlab)
(:reexport #:clpm/repos/defs)
(:reexport #:clpm/repos/git)
(:reexport #:clpm/repos/gitlab)
(:export #:make-repo-from-description))
(in-package #:clpm/repos)
(defun make-repo-from-description (desc)
(destructuring-bind (repo-type &rest args) desc
(ecase repo-type
(:gitlab
(apply #'make-instance 'gitlab-repo args)))))
;;;; Defs for VCS Repositories
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos/defs
(:use #:cl)
(:export #:ensure-ref-present-locally!
#:ref-present-p
#:repo-archive-stream
#:repo-lib-base-pathname
#:resolve-ref-to-commit))
(in-package #:clpm/repos/defs)
(defgeneric ensure-ref-present-locally! (repo &key commit branch tag))
(defgeneric ref-present-p (repo &key commit branch tag))
(defgeneric repo-archive-stream (repo &key branch tag commit))
(defgeneric repo-lib-base-pathname (repo))
(defgeneric resolve-ref-to-commit (repo &key branch tag commit))
;;;; Git Repositories
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos/git
(:use #:cl
#:alexandria
#:clpm/archives
#:clpm/cache
#:clpm/http-client
#:clpm/log
#:clpm/repos/defs
#:clpm/utils
#:split-sequence)
(:import-from #:bordeaux-threads)
(:import-from #:puri)
(:export #:git-repo
#:git-repo-credentials
#:git-repo-local-dir
#:git-repo-uri-string))
(in-package #:clpm/repos/git)
(setup-logger)
(defclass git-repo ()
())
(defgeneric git-repo-local-dir (repo))
(defgeneric git-repo-uri-string (repo))
(defgeneric git-repo-credentials (repo))
;; * URI parsing
(defclass git-uri (uri)
((user-name
:initform nil
:accessor git-uri/user-name)
(real-host
:initform nil
:accessor git-uri/real-host))
(:documentation "A URI class for git uris. holds on to the real host and username."))
(defmethod initialize-instance :after ((uri git-uri) &rest initargs
&key host)
(declare (ignore initargs))
(let ((@-pos (position #\@ host)))
(if @-pos
(setf (git-uri/real-host uri) (subseq host (1+ @-pos))
(git-uri/user-name uri) (subseq host 0 @-pos))
(setf (git-uri/real-host uri) host))))
(defun guess-git-protocol (uri-string)
(let* ((colon-pos (position #\: uri-string)))
(if colon-pos
;; Either the protocol is directly specified *or* the user is using
;; SCP-like syntax.
(let ((pre-colon (subseq uri-string 0 colon-pos)))
(switch (pre-colon :test #'string-equal)
("http"
:http)
("https"
:https)
("ssh"
:ssh)
("file"
:file)
(t
:scp)))
;; Implicit file protocol
:file-implicit)))
(defun convert-scp-to-ssh (uri-string)
(concatenate 'string "ssh://"
(substitute #\/ #\: uri-string :count 1)))
(defun parse-git-uri (uri-string)
;; First, guess at the protocol:
(let ((protocol (guess-git-protocol uri-string)))
(ecase protocol
(:file-implicit
(pathname uri-string))
(:scp
(puri:parse-uri (convert-scp-to-ssh uri-string)
:class 'git-uri))
((:http :https :ssh :file)
(puri:parse-uri uri-string
:class 'git-uri)))))
;; * Git utils
(defun authenticated-git-command-list (credential-alist)
"Given an alist of credentials (currently recognizes keys ~:username~ and
~:password~), returns two values: a list that can be used as a prefix when
assembling a command to run and an alist of environment variables to set when
running the command. This prefix starts with ~\"git\"~ and contains settings
to appropriately set the username and password.
If a password needs to be set, it attempts to pass the password through an
environment variable, so as to prevent the password from showing up on the
process list."
(let ((prefix (list "git"))
(env nil)
(username (assoc-value credential-alist :username))
(password (assoc-value credential-alist :password)))
(when username
(push "-c" prefix)
(push (concatenate 'string "credential.username=" username) prefix))
(when password
(push (cons "CLPM_GIT_PASS_HELPER_PASS" password) env)
(push "-c" prefix)
(push "credential.helper=!f() { echo \"password=${CLPM_GIT_PASS_HELPER_PASS}\"; }; f"
prefix))
(values (nreverse prefix)
env)))
(defun call-with-git-dir (repo thunk)
"If repo is set, sets the current directory to the repo's local directory and
then calls the thunk."
(uiop:with-current-directory ((when repo (git-repo-local-dir repo)))
(funcall thunk)))
(defmacro with-git-dir ((&optional repo) &body body)
`(call-with-git-dir ,repo (lambda () ,@body)))
(defun git-archive (ref &key repo)
"Calls ~git archive~ with the provided ref and returns the output
stream. Uses ~uiop:launch-program~ to avoid needing for the process to complete
before returning. Therefore, it alos spawns a thread to wait on the process
completion."
(with-git-dir (repo)
(let ((proc (uiop:launch-program `("git" "archive" ,ref)
:output :stream)))
(bt:make-thread (lambda () (uiop:wait-process proc)))
(uiop:process-info-output proc))))
(defun git-cat-file (commit &key ignore-error-status repo)
"Calls ~git cat-file~ with the provided commit and returns the result,
optionally changing into the local dir for ~repo~."
(with-git-dir (repo)
(uiop:run-program `("git" "cat-file" "-e" ,(uiop:strcat commit "^{commit}"))
:output '(:string :stripped t)
:ignore-error-status ignore-error-status)))
(defun git-rev-parse (rev &key repo 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)