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

cli less work: clpi release

parent e9df3b6b
Loading
Loading
Loading
Loading
+7 −122
Original line number Original line Diff line number Diff line
@@ -5,16 +5,10 @@


(uiop:define-package #:clpm-cli/commands/clpi/release
(uiop:define-package #:clpm-cli/commands/clpi/release
    (:use #:cl
    (:use #:cl
          #:alexandria
          #:clpm-cli/common-args
          #:clpm-cli/common-args
          #:clpm-cli/commands/clpi/common
          #:clpm-cli/commands/clpi/common
          #:clpm-cli/interface-defs
          #:clpm-cli/interface-defs
          #:clpm/context
          #:clpm)
          #:clpm/groveler
          #:clpm/requirement
          #:clpm/source
          #:clpm/utils
          #:do-urlencode)
  (:import-from #:adopt)
  (:import-from #:adopt)
  (:import-from #:jsown)
  (:import-from #:jsown)
  (:import-from #:uiop
  (:import-from #:uiop
@@ -46,129 +40,20 @@ with an HTTP client to submit the data to a CLPI server.")


(defparameter *clpi-release-ui*
(defparameter *clpi-release-ui*
  (adopt:make-interface
  (adopt:make-interface
   :name "clpm clpi systems"
   :name "clpm clpi release"
   :summary "Print systems forms for CLPI"
   :summary "Print a json description of the release for a CLPI server"
   :usage "clpi systems [options]"
   :usage "clpi systems [options]"
   :help *help-string*
   :help *help-string*
   :contents (list *group-common*
   :contents (list *group-common*
                   *option-asds*
                   *option-asds*
                   *option-deps-from-lockfile*)))
                   *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)
(define-cli-command (("clpi" "release") *clpi-release-ui*) (arguments options)
  (destructuring-bind (project-name project-version release-url) arguments
  (destructuring-bind (project-name project-version release-url) arguments
    (let ((asds (gethash :asds options))
    (let ((asds (gethash :asds options))
          (*active-groveler* (make-groveler))
          (deps-from-lockfile-p (gethash :deps-from-lockfile options)))
          (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
          (context)
                                                            :clpmfile (when deps-from-lockfile-p
          system-objs)
                                                                        (merge-pathnames "clpmfile")))))
      (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))))
      (terpri *standard-output*)))
      (terpri *standard-output*)))
  t)
  t)

clpm/clpi.lisp

0 → 100644
+129 −0
Original line number Original line Diff line number Diff line
;;;; 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)))))
+3 −0
Original line number Original line Diff line number Diff line
@@ -8,6 +8,7 @@
  (:use #:cl
  (:use #:cl
        #:clpm/bundle
        #:clpm/bundle
        #:clpm/client
        #:clpm/client
        #:clpm/clpi
        #:clpm/config
        #:clpm/config
        #:clpm/context-diff
        #:clpm/context-diff
        #:clpm/context-queries
        #:clpm/context-queries
@@ -26,6 +27,8 @@
           #:bundle-update)
           #:bundle-update)
  ;; From client
  ;; From client
  (:export #:client-asd-pathname)
  (:export #:client-asd-pathname)
  ;; From clpi
  (:export #:make-release-jsown)
  ;; From config
  ;; From config
  (:export #:config-value)
  (:export #:config-value)
  ;; From context-queries
  ;; From context-queries