Skip to content
Permalink
Browse files

manifests: replace location/vc with url

This means the download-strategy detection for manifest packages is the
same as for those defined in qi.yaml, simplifying parts of the package
and manifest logic.
  • Loading branch information...
dunn committed Oct 31, 2016
1 parent d7bf0c0 commit cd68ae96c8f96b2080224e2cd7e51e46e3677ec6
Showing with 1,406 additions and 3,147 deletions.
  1. +1,323 −3,036 manifest/manifest.lisp
  2. +1 −28 src/manifest.lisp
  3. +36 −54 src/packages.lisp
  4. +26 −16 src/qi.lisp
  5. +11 −0 src/util.lisp
  6. +2 −3 t/integrations_test.lisp
  7. +3 −6 t/manifest_test.lisp
  8. +4 −4 t/packages_test.lisp

Large diffs are not rendered by default.

@@ -3,7 +3,6 @@
(:use :cl)
(:export :manifest-package
:make-manifest-package
:create-download-strategy
:manifest-get-by-name))
(in-package :qi.manifest)

@@ -22,13 +21,7 @@
manifest. `locations' is an ADT that holds an alist to allow searching for
a specific version of a package."
name
vc
(locations 'cons))

(adt:defdata version-location
"An algebraic data-type for storing a '(version . location) alist
inside of a manifest-package."
(ver-loc cons))
url)


(defun manifest-load ()
@@ -42,26 +35,6 @@ inside of a manifest-package."
(setf +manifest-packages+ (read-from-string out)))))


(defun create-download-strategy (pack &optional (version "latest"))
"Takes a `manifest-package' data type, and returns download location
for the specific version, and the download-strategy. Location is already
wrapped in the ADT."
(let ((vc (manifest-package-vc pack))
(available (manifest-package-locations pack))
(loc))
(loop
for v/l in available
when (string= version (car v/l))
do
(setf loc (cdr v/l))
(format t "~%---> Resolved version ~S for ~S" (car v/l) (manifest-package-name pack)))
(cond ((string= "http" vc)
(values loc "tarball"))
((string= "git" vc)
(values loc "git"))
(t (values loc "git")))))


(defun manifest-get-by-name (sys-name)
"Return a `manifest-package' by the given name. Returns NIL if the package
does not exist."
@@ -2,14 +2,17 @@
(defpackage qi.packages
(:use :cl :qi.paths)
(:import-from :qi.manifest
:create-download-strategy
:manifest-get-by-name
:manifest-package
:manifest-get-by-name)
:manifest-package-name
:manifest-package-url)
(:import-from :qi.util
:download-strategy)
(:export :*qi-dependencies*
:*qi-trans-dependencies*
:dependency
:dependency-name
:dependency-location
:dependency-url
:dependency-version
:dependency-sys-path
:make-dependency
@@ -58,19 +61,11 @@
"The base data structure for a dependency."
name
(download-strategy nil)
(location 'location)
(src-path nil)
(sys-path nil)
(url nil)
(version "latest"))

(adt:defdata location
"The location of a dependency."
(manifest t)
(local t)
(http t)
(git t)
(hg t))


(defstruct (manifest-dependency (:include dependency))
"Manifest dependency data structure.")
@@ -106,7 +101,7 @@ of its location."))

(defmethod dispatch-dependency ((dep local-dependency))
(format t "~%-> Preparing to copy local dependency.")
(format t "~%---> ~A" (dependency-location dep))
(format t "~%---> ~A" (dependency-url dep))
(install-dependency dep))

(defmethod dispatch-dependency ((dep http-dependency))
@@ -127,20 +122,7 @@ of its location."))
(dependency-name dep))
(if (not (ensure-dependency dep))
(format t "~%---X ~A not found in manifest" (dependency-name dep))
(progn
(let ((pack (manifest-get-by-name (dependency-name dep))))
(multiple-value-bind (location* strategy)
(create-download-strategy pack)
(cond ((string= "tarball" strategy)
(setf (dependency-location dep) (http location*))
(setf (dependency-download-strategy dep) strategy))
((string= "git" strategy)
(setf (dependency-location dep) (git location*))
(setf (dependency-download-strategy dep) strategy))
((string= "hg" strategy)
(setf (dependency-location dep) (git location*))
(setf (dependency-download-strategy dep) strategy)))
(install-dependency dep))))))
(install-dependency dep)))


(defgeneric ensure-dependency (dependency)
@@ -161,45 +143,41 @@ of the information we need to get it."))

(defmethod install-dependency ((dep git-dependency))
(format t "~%---> Resolving repository location.")
(clone-git-repo (dependency-location dep) dep)
(clone-git-repo (dependency-url dep) dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))

(defmethod install-dependency ((dep hg-dependency))
(format t "~%---> Resolving repository location.")
(clone-hg-repo (dependency-location dep) dep)
(clone-hg-repo (dependency-url dep) dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))

(defmethod install-dependency ((dep http-dependency))
(let ((loc (dependency-location dep)))
(let ((loc (dependency-url dep)))
(format t "~%---> Resolving tarball dependency location.")
(adt:match location loc
((http url) ; manifest holds an http url
(download-tarball url dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))
(_ (error (format t "~%---> Unable able to resolve location of: ~S" loc))))))
(download-tarball loc dep)
(make-dependency-available dep)
(install-transitive-dependencies dep)))

(defmethod install-dependency ((dep manifest-dependency))
(let ((loc (dependency-location dep)))
(adt:match location loc

((http url) ; has an http url
(download-tarball url dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))
(let ((strat (dependency-download-strategy dep))
(url (dependency-url dep)))
(cond ((eq :tarball strat)
(download-tarball url dep)
;; The dependency must be made available before it is
;; installed so ASDF can determine its dependencies in turn
(make-dependency-available dep)
(install-transitive-dependencies dep))

((local path) ; has a local path (should not happen)
(error (format t "~%---X LOCAL PACKAGES NOT YET SUPPORTED: ~S~%" path)))
((eq :git strat)
(clone-git-repo url dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))

((git repo) ; has a git url
(clone-git-repo repo dep)
(make-dependency-available dep)
(install-transitive-dependencies dep))
(t ; unsupported strategy
(error (format t "~%---X Download strategy \"~S\" is not yet supported" strat))))))

(_ ; unsupported strategy
(error (format t "~%---X Cannot resolve package type: ~S" (dependency-name dep)))))))

(defun download-tarball (url dep)
"Downloads tarball from <url>, and updates <dep> with the local src-path
@@ -328,12 +306,16 @@ local src-path and sys-path."
(dependency-name dep)))
(set-trans-dep d (dependency-name dep))))
(t
(make-trans-dep-from-manifest d (dependency-name dep)))))))))))
(make-trans-dep-from-manifest manifest-package (dependency-name dep)))))))))))


(defun make-trans-dep-from-manifest (name caller)
(defun make-trans-dep-from-manifest (package caller)
(dispatch-dependency
(make-transitive-dependency :name name :caller caller)))
(make-transitive-dependency
:name (manifest-package-name package)
:url (manifest-package-url package)
:download-strategy (download-strategy (manifest-package-url package))
:caller caller)))


(defun set-trans-dep (name caller)
@@ -3,6 +3,7 @@
(:use :cl)
(:import-from :qi.util
:asdf-system-path
:download-strategy
:load-asdf-system
:is-tar-url?
:is-git-url?
@@ -15,7 +16,7 @@
:*qi-trans-dependencies*
:dependency
:dependency-name
:dependency-location
:dependency-url
:dependency-version
:dependency-sys-path
:dispatch-dependency
@@ -30,6 +31,10 @@
:make-hg-dependency
:http
:location)
(:import-from :qi.manifest
:manifest-get-by-name
:manifest-package
:manifest-package-url)
(:export :hello
:install
:install-global
@@ -88,42 +93,47 @@ be in the CWD that specifies <project>'s dependencies."


(defun extract-dependency (p)
"Extract dependency from package."
"Generate a dependency from package P."
(cond ((eql nil (gethash "url" p))
(make-manifest-dependency :name (gethash "name" p)
:version (or (gethash "version" p)
"latest")))
(let ((man (manifest-get-by-name (gethash "name" p))))
(unless man
(error "---X Package \"~S\" is not in the manifest; please provide a URL"
(gethash "name" p)))
(make-manifest-dependency :name (gethash "name" p)
:url (manifest-package-url man)
:download-strategy (download-strategy (manifest-package-url man))
:version (or (gethash "version" p)
"latest"))))
;; Dependency is a tarball url
((is-tar-url? (gethash "url" p))
(make-http-dependency :name (gethash "name" p)
:download-strategy "tarball"
:download-strategy :tarball
:version (or (gethash "version" p)
"latest")
:location (http (gethash "url" p))))
:url (gethash "url" p)))
;; Dependency is git url
((or (is-git-url? (gethash "url" p))
(is-gh-url? (gethash "url" p)))
(make-git-dependency :name (gethash "name" p)
:download-strategy "git"
:download-strategy :git
:version (or (gethash "version" p)
"latest")
:location (or (gethash "url" p)
nil)))
:url (gethash "url" p)))
;; Dependency is mercurial url
((is-hg-url? (gethash "url" p))
(make-hg-dependency :name (gethash "name" p)
:download-strategy "hg"
:download-strategy :hg
:version (or (gethash "version" p)
"latest")
:location (or (car (cl-ppcre:split ".hg" (gethash "url" p)))
nil)))
:url (car (cl-ppcre:split ".hg" (gethash "url" p)))))

;; Dependency is local path
((not (null (gethash "path" p)))
(make-local-dependency :name (gethash "name" p)
:download-strategy "local"
:download-strategy :local
:version (or (gethash "version" p)
"latest")
:location (or (gethash "url" p) nil)))
:url (or (gethash "url" p) nil)))
(t nil)))


@@ -136,7 +146,7 @@ be in the CWD that specifies <project>'s dependencies."
do (let ((dep (extract-dependency p)))
(if dep
(dispatch-dependency dep)
(format t "~%---X Cannot resolve dependency type"))))
(error (format t "~%---X Cannot resolve dependency type")))))
(asdf:oos 'asdf:load-op name :verbose nil))
(dependency-report))

@@ -2,6 +2,7 @@
(defpackage qi.util
(:use :cl)
(:export :asdf-system-path
:download-strategy
:load-asdf-system
:is-tar-url?
:is-git-url?
@@ -38,6 +39,16 @@
"Is <str> a github url."
(ppcre:scan "^https://github.*" str))

(defun download-strategy (url)
(cond ((is-tar-url? url)
:tarball)
((or (is-git-url? url)
(is-gh-url? url))
:git)
((is-hg-url? url)
:hg)
(t
(error "Could not determine download strategy for ~S" url))))

(defun asdf-system-path (sys)
"Find the pathname for a system, return NIL if it's not available."
@@ -12,10 +12,9 @@
;; Tests that even if the tarball doesn't have the same name as what we expect, we still
;; sucessfully unpack it and load it.
(let ((dep (qi::make-dependency :name "anaphora"
:location (qi.packages::http "https://github.com/tokenrove/anaphora/tarball/master")
:url "https://github.com/tokenrove/anaphora/tarball/master"
:src-path (merge-pathnames tar-dir "anaphora-master.tar.gz")
:sys-path (merge-pathnames tar-dir "anaphora-latest")
:version "latest"))
:sys-path (merge-pathnames tar-dir "anaphora-latest")))
(tmpfile (merge-pathnames "anaphora-latest.tar.gz" (qi.paths:+dep-cache+))))
(qi::bootstrap (qi.packages::dependency-name dep))
(ensure-directories-exist (qi.paths:+dep-cache+))
@@ -5,15 +5,12 @@
:prove))
(in-package :qi-manifest-util)

(plan 4)
(plan 3)

(qi.manifest::manifest-load)

(let ((strat (multiple-value-list
(qi.manifest:create-download-strategy
(qi.manifest:manifest-get-by-name "alexandria")))))
(is (first strat) "https://gitlab.common-lisp.net/alexandria/alexandria.git")
(is (last strat) '("git")))
(let ((manifest (qi.manifest:manifest-get-by-name "alexandria")))
(is (qi.manifest::manifest-package-url manifest) "https://gitlab.common-lisp.net/alexandria/alexandria.git"))

(is-type (qi.manifest:manifest-get-by-name "alexandria")
'qi.manifest:manifest-package)
@@ -19,8 +19,8 @@
(ok "qi-git-test" (gethash "name" config))
(let* ((p (car (gethash "packages" config)))
(dep (qi::extract-dependency p)))
(is (qi.packages::dependency-download-strategy dep) "git")
(is (qi.packages::dependency-location dep)
(is (qi.packages::dependency-download-strategy dep) :git)
(is (qi.packages::dependency-url dep)
"https://github.com/sharplispers/split-sequence.git")))

(let ((config
@@ -29,8 +29,8 @@
(ok "qi-hg-test" (gethash "name" config))
(let* ((p (car (gethash "packages" config)))
(dep (qi::extract-dependency p)))
(is (qi.packages::dependency-download-strategy dep) "hg")
(is (qi.packages::dependency-location dep)
(is (qi.packages::dependency-download-strategy dep) :hg)
(is (qi.packages::dependency-url dep)
"https://bitbucket.org/tarballs_are_good/map-set")))

(finalize)

0 comments on commit cd68ae9

Please sign in to comment.
You can’t perform that action at this time.