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

cli less work: clpi release

parent e9df3b6b
......@@ -5,16 +5,10 @@
(uiop:define-package #:clpm-cli/commands/clpi/release
(:use #:cl
#:alexandria
#:clpm-cli/common-args
#:clpm-cli/commands/clpi/common
#:clpm-cli/interface-defs
#:clpm/context
#:clpm/groveler
#:clpm/requirement
#:clpm/source
#:clpm/utils
#:do-urlencode)
#:clpm)
(:import-from #:adopt)
(:import-from #:jsown)
(:import-from #:uiop
......@@ -46,129 +40,20 @@ with an HTTP client to submit the data to a CLPI server.")
(defparameter *clpi-release-ui*
(adopt:make-interface
:name "clpm clpi systems"
:summary "Print systems forms for CLPI"
:name "clpm clpi release"
:summary "Print a json description of the release for a CLPI server"
:usage "clpi systems [options]"
:help *help-string*
:contents (list *group-common*
*option-asds*
*option-deps-from-lockfile*)))
(defun sort-dependencies (deps)
(labels ((find-system-name (dep)
(if (listp dep)
(ecase (first dep)
(:version
(second dep))
(:feature
(find-system-name (third dep)))
(:require
(second dep)))
dep)))
(sort (copy-list (remove-duplicates deps :test #'equal))
#'string< :key #'find-system-name)))
(defun asdf-feature-expression-to-jsown (f)
(if (listp f)
(ecase (first f)
((:and :or)
(jsown:new-js
("type" (string-downcase (symbol-name (first f))))
("features" (mapcar #'asdf-feature-expression-to-jsown (rest f)))))
(:not
(jsown:new-js
("type" "not")
("feature" (asdf-feature-expression-to-jsown (second f))))))
(string-downcase (symbol-name f))))
(defgeneric asdf-complex-dep-to-jsown (type args))
(defmethod asdf-complex-dep-to-jsown ((type (eql :feature)) args)
(jsown:new-js
("type" "feature")
("featureExpression" (asdf-feature-expression-to-jsown (first args)))
("dependency" (second args))))
(defmethod asdf-complex-dep-to-jsown ((type (eql :require)) args)
(jsown:new-js
("type" "require")
("name" (first args))))
(defmethod asdf-complex-dep-to-jsown ((type (eql :version)) args)
(jsown:new-js
("type" "version")
("name" (first args))
("version" (second args))))
(defun asdf-dep-to-jsown (dep)
(if (stringp dep)
dep
(asdf-complex-dep-to-jsown (first dep) (rest dep))))
(define-cli-command (("clpi" "release") *clpi-release-ui*) (arguments options)
(destructuring-bind (project-name project-version release-url) arguments
(let ((asds (gethash :asds options))
(*active-groveler* (make-groveler))
(deps-from-lockfile-p (gethash :deps-from-lockfile options))
(context)
system-objs)
(when deps-from-lockfile-p
(setf context (load-anonymous-context-from-pathname (merge-pathnames "clpmfile.lock"))))
(uiop:with-safe-io-syntax ()
(let ((*print-case* :downcase))
(dolist (asd asds)
(let ((absolute-asd-pathname (merge-pathnames asd)))
;; Load the asd into the groveler
(handler-bind ((groveler-dependency-missing
(lambda (c)
(when context
(let* ((missing-system-spec (groveler-dependency-missing-system c))
(missing-req (convert-asd-system-spec-to-req missing-system-spec))
(missing-system-name (requirement-name missing-req))
(matching-sr (find missing-system-name
(context-system-releases context)
:test #'equal
:key (compose #'system-name #'system-release-system))))
(when (and matching-sr
(system-release-satisfies-version-spec-p
matching-sr
(requirement-version-spec missing-req)))
(groveler-add-asd-and-retry
(system-release-absolute-asd-pathname matching-sr))))))))
(active-groveler-load-asd absolute-asd-pathname))
(dolist (system-name (active-groveler-systems-in-file absolute-asd-pathname))
(destructuring-bind (&key depends-on version defsystem-depends-on loaded-systems
license description
&allow-other-keys)
(active-groveler-system-deps system-name)
(let ((all-deps (append depends-on defsystem-depends-on loaded-systems))
(system-obj (jsown:new-js
("name" system-name)
("systemFile" asd))))
(when version
(jsown:extend-js system-obj
("version" version)))
(when description
(jsown:extend-js system-obj
("description" description)))
(when license
(jsown:extend-js system-obj
("license" (uiop:with-safe-io-syntax ()
(write-to-string license)))))
(when all-deps
(jsown:extend-js system-obj
("dependencies" (mapcar #'asdf-dep-to-jsown all-deps))))
(push system-obj
system-objs))))))))
(write-string (jsown:to-json
(jsown:new-js
("projectName" project-name)
("version" project-version)
("url" release-url)
("archiveType" "tar.gz")
("systems" system-objs))))
(deps-from-lockfile-p (gethash :deps-from-lockfile options)))
(write-string (jsown:to-json (clpm:make-release-jsown project-name project-version release-url asds
:clpmfile (when deps-from-lockfile-p
(merge-pathnames "clpmfile")))))
(terpri *standard-output*)))
t)
;;;; CLPI Server Integration - EXPERIMENTAL
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/clpi
(:use #:cl
#:alexandria
#:clpm/context
#:clpm/groveler
#:clpm/requirement
#:clpm/source)
(:import-from #:jsown)
(:export #:make-release-jsown))
(in-package #:clpm/clpi)
(defun sort-dependencies (deps)
(labels ((find-system-name (dep)
(if (listp dep)
(ecase (first dep)
(:version
(second dep))
(:feature
(find-system-name (third dep)))
(:require
(second dep)))
dep)))
(sort (copy-list (remove-duplicates deps :test #'equal))
#'string< :key #'find-system-name)))
(defun asdf-feature-expression-to-jsown (f)
(if (listp f)
(ecase (first f)
((:and :or)
(jsown:new-js
("type" (string-downcase (symbol-name (first f))))
("features" (mapcar #'asdf-feature-expression-to-jsown (rest f)))))
(:not
(jsown:new-js
("type" "not")
("feature" (asdf-feature-expression-to-jsown (second f))))))
(string-downcase (symbol-name f))))
(defgeneric asdf-complex-dep-to-jsown (type args))
(defmethod asdf-complex-dep-to-jsown ((type (eql :feature)) args)
(jsown:new-js
("type" "feature")
("featureExpression" (asdf-feature-expression-to-jsown (first args)))
("dependency" (second args))))
(defmethod asdf-complex-dep-to-jsown ((type (eql :require)) args)
(jsown:new-js
("type" "require")
("name" (first args))))
(defmethod asdf-complex-dep-to-jsown ((type (eql :version)) args)
(jsown:new-js
("type" "version")
("name" (first args))
("version" (second args))))
(defun asdf-dep-to-jsown (dep)
(if (stringp dep)
dep
(asdf-complex-dep-to-jsown (first dep) (rest dep))))
(defun make-release-jsown (project-name project-version release-url asds &key clpmfile)
(let ((*active-groveler* (make-groveler))
system-objs)
(labels ((load-into-groveler (absolute-asd-pathname clpmfile)
(handler-bind ((groveler-dependency-missing
(lambda (c)
(when clpmfile
(let* ((missing-system-spec (groveler-dependency-missing-system c))
(missing-req (convert-asd-system-spec-to-req missing-system-spec))
(missing-system-name (requirement-name missing-req))
(matching-sr (find missing-system-name
(context-system-releases clpmfile)
:test #'equal
:key (compose #'system-name #'system-release-system))))
(when (and matching-sr
(system-release-satisfies-version-spec-p
matching-sr
(requirement-version-spec missing-req)))
(groveler-add-asd-and-retry
(system-release-absolute-asd-pathname matching-sr))))))))
(active-groveler-load-asd absolute-asd-pathname)))
(process-asd (asd clpmfile)
(let ((absolute-asd-pathname (merge-pathnames asd)))
;; Load the asd into the groveler
(load-into-groveler absolute-asd-pathname clpmfile)
(dolist (system-name (active-groveler-systems-in-file absolute-asd-pathname))
(destructuring-bind (&key depends-on version defsystem-depends-on loaded-systems
license description
&allow-other-keys)
(active-groveler-system-deps system-name)
(let ((all-deps (append depends-on defsystem-depends-on loaded-systems))
(system-obj (jsown:new-js
("name" system-name)
("systemFile" asd))))
(when version
(jsown:extend-js system-obj
("version" version)))
(when description
(jsown:extend-js system-obj
("description" description)))
(when license
(jsown:extend-js system-obj
("license" (uiop:with-safe-io-syntax ()
(write-to-string license)))))
(when all-deps
(jsown:extend-js system-obj
("dependencies" (mapcar #'asdf-dep-to-jsown all-deps))))
(push system-obj
system-objs)))))))
(if clpmfile
(with-context (clpmfile)
(dolist (asd asds)
(process-asd asd clpmfile)))
(dolist (asd asds)
(process-asd asd clpmfile)))
(jsown:new-js
("projectName" project-name)
("version" project-version)
("url" release-url)
("archiveType" "tar.gz")
("systems" system-objs)))))
......@@ -8,6 +8,7 @@
(:use #:cl
#:clpm/bundle
#:clpm/client
#:clpm/clpi
#:clpm/config
#:clpm/context-diff
#:clpm/context-queries
......@@ -26,6 +27,8 @@
#:bundle-update)
;; From client
(:export #:client-asd-pathname)
;; From clpi
(:export #:make-release-jsown)
;; From config
(:export #:config-value)
;; From context-queries
......
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