Merge pull request #30 from dunn/manifest-structure

manifests: replace location/vc with url

src/manifest.lisp

@@ -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."

src/packages.lisp

@@ -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)

src/qi.lisp

@@ -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))
 

src/util.lisp

@@ -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."

t/integrations_test.lisp

@@ -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+))

t/manifest_test.lisp

@@ -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)

t/packages_test.lisp

@@ -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)