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).
bundle.
#+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
+ ~name~ :: must be a string, unique in the file.
+ ~: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
none of branch, commit, or tag are specified, the branch defaults to the
default branch from the server.
......
......@@ -31,8 +31,8 @@
*bundle-arguments*
*common-arguments*))
(defun ensure-git-req-installed-and-rewrite-req (req)
"Given a git requirement, install it and return a new requirement on the
(defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a VCS requirement, install it and return a new requirement on the
correct commit."
(let* ((project-name (requirement/name req))
(branch (requirement/branch req))
......@@ -49,8 +49,8 @@ correct commit."
(tag
`(:tag ,tag))))))
(install-release vcs-release)
(make-instance 'git-project-requirement
:commit (git-release/commit vcs-release)
(make-instance 'vcs-project-requirement
:commit (vcs-release/commit vcs-release)
:repo (requirement/repo req)
:source (requirement/source req)
:name (requirement/name req)
......@@ -62,11 +62,11 @@ correct commit."
(let* ((sources (clpmfile/sources clpmfile))
(raw-reqs (clpmfile/all-requirements clpmfile))
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.
(dolist (r raw-reqs)
(if (typep r 'git-requirement)
(push (ensure-git-req-installed-and-rewrite-req r) reqs)
(if (typep r 'vcs-requirement)
(push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs)))
;; Resolve the requirements!
......
......@@ -31,8 +31,8 @@
*bundle-arguments*
*common-arguments*))
(defun ensure-git-req-installed-and-rewrite-req (req)
"Given a git requirement, install it and return a new requirement on the
(defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a VCS requirement, install it and return a new requirement on the
correct commit."
(let* ((project-name (requirement/name req))
(branch (requirement/branch req))
......@@ -49,8 +49,8 @@ correct commit."
(tag
`(:tag ,tag))))))
(install-release vcs-release)
(make-instance 'git-project-requirement
:commit (git-release/commit vcs-release)
(make-instance 'vcs-project-requirement
:commit (vcs-release/commit vcs-release)
:repo (requirement/repo req)
:source (requirement/source req)
:name (requirement/name req)
......@@ -67,8 +67,8 @@ correct commit."
;; Make sure all git releases are installed and replace their requirements
;; with a requirement on the commit.
(dolist (r raw-reqs)
(if (typep r 'git-requirement)
(push (ensure-git-req-installed-and-rewrite-req r) reqs)
(if (typep r 'vcs-requirement)
(push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs)))
;; Resolve the requirements!
......
......@@ -10,6 +10,7 @@
#:iterate
#:clpm/config
#:clpm/deps
#:clpm/repos
#:clpm/requirement
#:clpm/source)
(:export #:clpmfile/all-requirements
......@@ -49,6 +50,12 @@
:accessor clpmfile/fs-source
:documentation
"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
:initform nil
:accessor clpmfile/implicit-sources
......@@ -132,6 +139,7 @@ clpmfile is located."
(defun clpmfile/sources (clpmfile)
"Return a list of all the sources associated with ~clpmfile~."
(list* (clpmfile/fs-source clpmfile)
(clpmfile/vcs-source clpmfile)
(append (clpmfile/implicit-sources clpmfile)
(clpmfile/user-global-sources clpmfile))))
......@@ -145,30 +153,10 @@ or raise an error if it does not exist."
(defun parse-req-statement (clpmfile name
&key (type :project) version source
git systems)
systems)
"Parse a ~:req~ statement from a ~clpmfile~ into a ~requirement~ instance."
(assert (null systems))
(let ((req nil))
(if git
(destructuring-bind (type
&key branch commit tag repo host
&allow-other-keys)
git
(let ((source (get-git-source type host)))
;; 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))
(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)
......@@ -179,7 +167,7 @@ or raise an error if it does not exist."
source))
:version-spec (when version
(cons (first version)
(second version))))))
(second version)))))
(push req (clpmfile/user-requirements clpmfile))))
(defun parse-system-statement (clpmfile name &key source)
......@@ -192,37 +180,16 @@ instance."
source)))
(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
&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
~git-project-requirement~ instance."
(let ((source (get-git-source :gitlab host)))
;; This may be the first time this source is seen. Record it.
(pushnew source (clpmfile/implicit-sources clpmfile))
~vcs-project-requirement~ instance."
(let ((source (clpmfile/vcs-source clpmfile))
(repo (make-repo-from-description (list :gitlab :host host :path path))))
;; Register the git project.
(git-source-register-project! source repo name)
(vcs-source-register-project! source repo name)
(assert (xor branch commit tag))
(push (make-instance 'git-project-requirement
(push (make-instance 'vcs-project-requirement
:systems systems
:name name
:source source
......@@ -284,8 +251,6 @@ sources."
(ecase type
(:source
(apply #'parse-source-statement clpmfile args))
(:git
(apply #'parse-git-statement clpmfile args))
(:gitlab
(apply #'parse-gitlab-statement clpmfile args))
(:system
......@@ -323,28 +288,17 @@ sources."
(push system-file (lockfile/system-files lockfile))
lockfile))
(defmethod parse-system-file-statement (lockfile (statement-type (eql :git))
&key type host repo commit system-files
(defmethod parse-system-file-statement (lockfile (statement-type (eql :gitlab))
&key host path commit system-files
name)
;; First, look for a local override.
(let ((local (config-value :bundle :local name :path)))
(if local
;; A local override exists.
(let* ((local-path (uiop:ensure-directory-pathname
(merge-pathnames local
(uiop:pathname-directory-pathname
(lockfile/pathname lockfile)))))
(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))
(error "local overrides currently broken.")
(let* ((source (clpmfile/vcs-source (lockfile/clpmfile lockfile)))
(repo (make-repo-from-description `(:gitlab :host ,host :path ,path)))
(project (vcs-source-register-project! source repo name))
(release (project/release project `(:commit ,commit)))
(system-files (mapcar (curry #'release/system-file release) system-files)))
(setf (lockfile/system-files lockfile)
......@@ -402,9 +356,25 @@ sources."
,@(when-let ((source (requirement/source req)))
(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)
:git ,(requirement/repo req)))
:type :vcs
:vcs-type ,@(repo-to-sexp (requirement/repo req) req)))
(defun lockfile-system-file-sexps (lockfile)
"Return a list of system file statements from ~lockfile~ suitable for writing
......@@ -428,18 +398,20 @@ to a file."
(collect `(:local-asd
:path ,(system-file/asd-enough-namestring file)))))
;; TODO: Make this handle local vs remote git repos
((typep release 'git-release)
(let ((version (release/version release))
(source (release/source release)))
((typep release 'vcs-release)
(let* ((version (release/version release))
(project (release/project release))
(repo (project/repo project)))
(assert (listp version))
(assert (eql :commit (first version)))
(assert (stringp (second version)))
(collect `(:git
(collect `(,(etypecase repo
(gitlab-repo
:gitlab))
:name ,(project/name (release/project release))
:type ,(git-source-type-keyword source)
:host ,(git-source/host source)
:repo ,(vcs-project/path (release/project release))
:host ,(gitlab-repo-host repo)
:path ,(gitlab-repo-path repo)
:commit ,(second version)
:system-files ,(mapcar #'system-file/asd-enough-namestring system-files-in-release)))))
(t
......
......@@ -82,6 +82,6 @@
(defgeneric install-release (release &key activate-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))
(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)
(uiop:run-program `("git" "rev-parse" ,rev)
:output '(:string :stripped t)
:ignore-error-status ignore-error-status)))
(defun fetch-repo! (repo)
"Given a repo, fetch all of its tags and branches locally."
(let* ((local-dir (git-repo-local-dir repo))
(uri-string (git-repo-uri-string repo))
(credentials (git-repo-credentials repo)))
(multiple-value-bind (prefix env)
(authenticated-git-command-list credentials)
(uiop:with-current-directory (local-dir)
(multiple-value-bind (output error-output exit-code)
(apply
#'uiop:run-program
`(,@prefix "fetch" "--tags" "--prune" ,uri-string "+refs/*:refs/*")
:input :interactive
:output '(:string :stripped t)
:error-output '(:string :stripped t)
(run-program-augment-env-args env))
(unless (zerop exit-code)
(format *error-output* "~&git exited with code ~S~%stdout: ~S~%stderr: ~S~%"
exit-code output error-output)
(error 'retriable-error)))))))
(defun clone-repo! (repo)
"Given a repo, clone it locally."
(let* ((local-dir (git-repo-local-dir repo))
(uri-string (git-repo-uri-string repo))
(credentials (git-repo-credentials repo)))
(multiple-value-bind (prefix env)
(authenticated-git-command-list credentials)
(multiple-value-bind (output error-output exit-code)
(apply
#'uiop:run-program
`(,@prefix "clone"
"--bare"
"--verbose"
"--mirror"
,uri-string
,(namestring local-dir))
:input :interactive
:output '(:string :stripped t)
:error-output '(:string :stripped t)
:ignore-error-status t
(run-program-augment-env-args env))
(unless (zerop exit-code)
(format *error-output* "~&git exited with code ~S~%stdout: ~S~%stderr: ~S~%"
exit-code output error-output)
(error 'retriable-error))))))
(defmethod ref-present-p ((repo git-repo) &key commit branch tag)
(assert (xor commit branch tag))
(let ((local-dir (git-repo-local-dir repo)))
(and (uiop:probe-file* local-dir)
(if commit
(zerop (nth-value 2 (git-cat-file commit :repo repo :ignore-error-status t)))
(zerop (nth-value 2 (git-rev-parse (or branch tag) :repo repo :ignore-error-status t)))))))
(defmethod ensure-ref-present-locally! ((repo git-repo) &key commit branch tag)
"Given a repo and a reference (either a commit, branch, or tag), ensure that
ref is present locally, fetching or cloning the repo as necessary."
(assert (xor commit branch tag))
(let ((local-dir (git-repo-local-dir repo)))
(if (uiop:probe-file* local-dir)
;; Repo is present, need to fetch if the ref is not present.
(unless (ref-present-p repo :commit commit :tag tag :branch branch)
(with-retries (:max 5 :sleep 2)
(fetch-repo! repo))
;; Make sure the ref is actually present, raising an error otherwise.
(unless (ref-present-p repo :commit commit :tag tag :branch branch)
(error "ref is not present, even after updating.")))
;; Repo is not present at all, need to clone it.
(with-retries (:max 5 :sleep 2)
(clone-repo! repo)
;; Make sure the ref is actually present, raising an error otherwise.
(unless (ref-present-p repo :commit commit :tag tag :branch branch)
(error "ref is not present, even after updating."))))))
(defmethod repo-archive-stream ((repo git-repo) &key branch tag commit)
(assert (xor branch tag commit))
(values
(git-archive (or branch tag commit) :repo repo)
'tar-archive))
(defmethod resolve-ref-to-commit ((repo git-repo) &key branch tag commit)
(assert (xor branch tag commit))
(git-rev-parse (or branch tag commit) :repo repo))
;;;; Git Repositories hosted on Gitlab servers
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos/gitlab
(:use #:cl
#:alexandria
#:anaphora
#:clpm/archives
#:clpm/cache
#:clpm/config