openapi2cl.lisp

;; TODO:
;; openapi v3 doesn't use scheme anymore. remove.
;; parse servers and select form them on client instantiation
;; add documentation to methods generating a proper defgeneric.

(defpackage :openapi2cl
  (:use #:cl)
  (:import-from #:yason)
  (:import-from #:cl-yaml)
  (:import-from #:cl-strings)
  (:import-from #:kebab)
  (:export
   #:with-directory-generate-files
   #:with-directory-generate
   #:with-yaml-generate
   #:with-json-generate))

(in-package :openapi2cl)

;; NOTE: The generation occurs by building up sexps. Any symbols which
;; are written into these sexps must be prepended by the cl-user
;; namespace; otherwise the symbols in the generated code will be
;; prepended by this package's namespace.

(defun generate (openapi client-name)
  "Generates a client and a list of its methods. These are returned in
a 2-tuple.

openapi: the sexp representation of a openapi document.
client-name: the name of the class that hosts all the client methods."
  (check-type client-name symbol)
  (let* ((servers (gethash "servers" openapi))
         (host (or (and servers (gethash "url" (first servers))) ""))
         (base-path (or (gethash "basePath" openapi) ""))
         (consumes-media-types (gethash "consumes" openapi))
         (produces-media-types (gethash "produces" openapi))
         (schemes (or (gethash "schemes" openapi)
                      '("https")))
         (security-schemes (let ((security-schemes (gethash "securitySchemes" (gethash "components" openapi))))
                             (when security-schemes
                               (parse-security-schemes security-schemes))))
         (client (generate-client client-name schemes host base-path
                                  consumes-media-types produces-media-types
                                  security-schemes))
         (*package* (find-package :cl-user)))
    (values
     client
     (loop for path-name being the hash-keys of (gethash "paths" openapi)
             using (hash-value path-operation)
           nconc (generate-path-methods openapi client-name path-name path-operation
                                        consumes-media-types)))))

(defun with-yaml-generate (openapi-yaml client-name)
  "Generate a client and a list of its methods based on a YAML file.

openapi-yaml: a string containing the YAML representation of a openapi document, or a pathname to a YAML document.
client-name: the name of the class that hosts all the client methods."
  (generate (yaml:parse openapi-yaml) client-name))

(defun with-json-generate (openapi-json client-name)
  "Generate a client and a list of its methods based on a YAML file.

openapi-json: a string containing the JSON representation of a openapi document, or a pathname to a JSON document.
client-name: the name of the class that hosts all the client methods."
  (generate (yason:parse openapi-json) client-name))

(defun with-directory-generate (path process-results-fn)
  "Given a pathname, process the YAML and JSON files within, and
call `process-results-fn'. This function should take these
arguments: (1) The file-path (2) the client definition (3) the list of
methods for this client."
  (check-type process-results-fn function)
  (flet ((with-file-generate (file-path)
           (let* ((type (pathname-type file-path))
                  (name (kebab-symbol-from-string (pathname-name file-path)))
                  (output-path (make-pathname :type "lisp" :defaults file-path)))
             (multiple-value-bind (client-def methods-list)
                 (cond ((string= type "yaml")
                        (with-yaml-generate file-path name))
                       ((string= type "json")
                        (with-json-generate file-path name)))
               (funcall process-results-fn output-path client-def methods-list)))))
    (mapcar #'with-file-generate (directory path))))

(defun with-directory-generate-files (input-path output-path package-root &key preamble export)
  "Given a pathname, generate lisp files for every specification
encountered and processed.

package-root will be used as the root of each file's package. The
file's name will be appended to this forming the fully qualified
package name.

If EXPORT is T, then all methods are exported. If a list of symbols, then that list of symbols is exported."
  (check-type package-root symbol)
  (flet ((write-defs-out (file-path client-def methods-list)
           (let ((file-path (make-pathname :defaults file-path
                                           :directory output-path))
                 (*package* (find-package :cl-user)))
             (with-open-file (stream file-path :direction :output
                                               :if-exists :supersede
                                               :if-does-not-exist :create)
               (format t "Output path: ~a~%" file-path)
               (when preamble (format stream "~a~%~%" preamble))
               (when package-root
                 (dolist (pkg-clause (generate-package-clauses
                                      (intern (string-upcase (format nil "~a/~a" package-root (pathname-name file-path))))
                                      :packages-using '(#:cl)
                                      :packages-import '(#:cl-strings)
                                      :client-name (second client-def)
                                      :export (when export
                                                (if (listp export)
                                                    export
                                                    (mapcar #'second methods-list)))))
                   (format stream "~s~%" pkg-clause))
                 (format stream "~%~%"))
               (format stream "~s" client-def)
               (dolist (m methods-list) (format stream "~%~%~s" m))))))
    (with-directory-generate input-path #'write-defs-out)))

;;; Unexported

(defun parameter-name (param)
  (check-type param hash-table)
  (gethash "name" param))

(defun kebab-symbol-from-string (s)
  (check-type s string)
  (intern (string-upcase (kebab:to-lisp-case s))))

(defun lisp-parameter-name (param)
  "Converts a string parameter name to a symbol for use in generated
code."
  (check-type param hash-table)
  (kebab-symbol-from-string (parameter-name param)))

(defun parameter-location (param)
  (check-type param hash-table)
  (gethash "in" param))

(defun parameter-type (param)
  (check-type param hash-table)
  (gethash "type" (gethash "schema" param)))

(defun parameter-required-p (param)
  (check-type param hash-table)
  (or (parameter-location-path-p param)
      (parameter-location-schema-p param)
      (gethash "required" param)))

(defun parameter-location-schema-p (param)
  (check-type param hash-table)
  (gethash "schema" param))

(defun parameter-location-query-p (param)
  (check-type param hash-table)
  (string= (string-downcase (parameter-location param)) "query"))

(defun parameter-location-header-p (param)
  (check-type param hash-table)
  (string= (string-downcase (parameter-location param)) "header"))

(defun parameter-location-path-p (param)
  (check-type param hash-table)
  (string= (string-downcase (parameter-location param)) "path"))

(defun parameter-location-body-p (param)
  (check-type param hash-table)
  (string= (string-downcase (parameter-location param)) "body"))

(defun parameter-location-form-p (param)
  (check-type param hash-table)
  (string= (string-downcase (parameter-location param)) "formdata"))

(defun openapi-schemes-p (schemes)
  (and (listp schemes)
       (= (length schemes)
          ;; TODO(katco): ws and wss are also valid, but we don't yet handle these.
          (length (intersection schemes '("https" "http") :test #'string=)))))

(defun select-scheme (schemes)
  "Pick a scheme from a list of options in order of preference."
  (check-type schemes list)
  (or (find "https" schemes :test #'string=)
      (find "http" schemes :test #'string=)))

(defun media-type-form-p (media-type)
  (and media-type
       (find media-type '("application/x-www-form-urlencoded"
                          "multipart/form-data")
             :test #'string=)))

(defun media-type-subtype (media-type)
  (check-type media-type string)
  (subseq media-type (+ 1 (or (position #\+ media-type)
                              (position #\/ media-type)))))

(defun select-media-type (media-types)
  (check-type media-types list)
  (let ((media-subtypes (mapcar #'media-type-subtype media-types)))
    (or (find-if (lambda (e) (or (string= e "json") (string= e "yaml"))) media-subtypes)
        (nth (random (length media-subtypes)) media-subtypes))))

(defun generate-package-clauses (package-name &key client-name packages-using packages-import export documentation)
  (check-type package-name symbol)
  (check-type packages-using list)
  (check-type packages-import list)
  `((defpackage ,package-name
      ,@(when packages-using `((:use ,@packages-using)))
      ,@(when packages-import
          (loop for pkg in packages-import
                collect `(:import-from ,pkg)))
      (:export ,client-name ,@export)
      ,@(when documentation
          `((:documentation ,documentation ""))))
    (in-package ,package-name)))

(defun generate-path-methods (openapi client-name path-name path global-media-types)
  (check-type client-name symbol)
  (check-type path-name string)
  (check-type path hash-table)
  (check-type global-media-types list)
  (let (methods)
    (loop for operation-name being the hash-keys of path
            using (hash-value operation)
          ;; Enumerate through the known valid operations that we know
          ;; how to handle. Ignore all else.
          when (find operation-name '("get" "put" "post" "delete") :test 'equalp)
            do
               (push (generate-operation-method openapi client-name path-name operation-name operation)
                     methods))
    methods))

(defun generate-operation-method (openapi client-name path-name operation-name operation)
  "Generates a method for a generated client. Methods distinguish
between required parameters and optional parameters, and optional
parameters are defined as &key arguments. All arguments are run
through `check-type' to both ensure the correct type is used and that
the provided values meet any defined constraints."
  (let* ((summary (gethash "summary" operation))
         (description (gethash "description" operation))
         (operation-id (gethash "operationId" operation))
         ;;(produces-media-types (gethash "produces" operation))
         (consumes-media-types (gethash "consumes" operation))
         ;;(responses (gethash "responses" operation))
         ;;(schemes (gethash "schemes" operation))
         (parameters (mapcar (lambda (param) (resolve-object openapi param))
                             (gethash "parameters" operation)))
         (request-body (gethash "requestBody" operation))
         ;; Synthesized fields
         (method-name (if operation-id operation-id (format nil "~a-~a" operation-name path-name)))
         (required-parameters (remove-if-not #'parameter-required-p parameters))
         (optional-parameters (remove-if #'parameter-required-p parameters))
         (param-descriptions (generate-parameter-comments (append required-parameters
                                                                  optional-parameters)))
         (method-comment (concatenate 'string
                                      (when summary (format nil "~a~%~%" summary))
                                      (when description (format nil "~a~%~%" description))
                                      (when param-descriptions param-descriptions)))
         (lisp-required-parameters (mapcar #'lisp-parameter-name required-parameters))
         (lisp-optional-parameters (mapcar #'lisp-parameter-name optional-parameters))
         (path-params (append
                       (remove-if-not #'parameter-location-path-p required-parameters)
                       (remove-if-not #'parameter-location-path-p optional-parameters)))
         (query-params (append
                        (remove-if-not #'parameter-location-query-p required-parameters)
                        (remove-if-not #'parameter-location-query-p optional-parameters)))
         (headers (append
                   (remove-if-not #'parameter-location-header-p required-parameters)
                   (remove-if-not #'parameter-location-header-p optional-parameters)))
         (body-params (append
                       (remove-if-not #'parameter-location-body-p required-parameters)
                       (remove-if-not #'parameter-location-body-p optional-parameters)))
         (form-params (append
                       (remove-if-not #'parameter-location-form-p required-parameters)
                       (remove-if-not #'parameter-location-form-p optional-parameters)))
         (consumes-media-type (when consumes-media-types (select-media-type consumes-media-types))))
    ;; Generated method begins here
    `(defgeneric ,(kebab-symbol-from-string method-name)
         (cl-user::client
          ,@(when request-body '(cl-user::request-body))
          ,@lisp-required-parameters
          ,@(when lisp-optional-parameters
              `(&key ,@lisp-optional-parameters)))
       ,@(when method-comment
           `((:documentation ,method-comment)))
       (:method
           ((cl-user::client ,(intern (symbol-name client-name) :cl-user))
            ,@(when request-body '(cl-user::request-body))
            ,@lisp-required-parameters
            ,@(when lisp-optional-parameters
                `(&key ,@lisp-optional-parameters)))
         ,@(generate-check-type (append required-parameters optional-parameters))
         ;; If the content-type requests form params, put all the
         ;; body parameters in the form params list. Otherwise, move
         ;; all the form parameters into the body list so that they
         ;; can be encoded properly.
         ,(progn
            (if (media-type-form-p consumes-media-type)
                (setf form-params (append form-params body-params)
                      body-params nil)
                (setf body-params (append body-params form-params)
                      form-params nil))
            `(let (,@(when path-params '((cl-user::path-params (list))))
                   ,@(when query-params '((cl-user::query-params (list))))
                   ,@(when headers '((cl-user::headers (list))))
                   ,@(when body-params '((cl-user::body-params (list))))
                   ,@(when (and (media-type-form-p consumes-media-type)
                                form-params)
                       '((cl-user::form-params (list))))
                   (cl-user::consumes-media-type ,(if consumes-media-type
                                                      consumes-media-type
                                                      '(cl-user::consumes-media-type cl-user::client)))
                   ;; If the operation's declared content-type is form
                   ;; we don't need a hash-table to populate the body.
                   ;; If the operation doesn't have a declared
                   ;; content-type, we can't make the decision at
                   ;; gen-time and we must reflect on what's defined in
                   ;; the client.
                   ,@(when (and body-params
                                (or (not consumes-media-type)
                                    (media-type-form-p consumes-media-type)))
                       '((cl-user::req-body (make-hash-table)))))
               ;; Build up alist of query params
               ,@(generate-http-request-population path-params 'cl-user::path-params)
               ,@(generate-http-request-population query-params 'cl-user::query-params)
               ,@(generate-http-request-population headers 'cl-user::headers)
               ,@(if (media-type-form-p consumes-media-type)
                     (generate-http-request-population form-params 'cl-user::form-params)
                     (generate-http-request-body-population body-params 'cl-user::req-body))
               ;; Make the request
               (flet ((cl-user::replace-path-params (cl-user::uri cl-user::path-vars)
                        (funcall (cl-strings:make-template-parser "{" "}") cl-user::uri cl-user::path-vars)))
                 (declare (ignorable #'cl-user::replace-path-params))
                 (funcall (cl-user::http-request cl-user::client)
                          (format nil "~a~a~a"
                                  (cl-user::host cl-user::client)
                                  (cl-user::base-path cl-user::client)
                                  ,(if path-params
                                       `(cl-user::replace-path-params ,path-name cl-user::path-params)
                                       path-name))
                          :method ,(intern (string-upcase operation-name) "KEYWORD")
                          :content-type cl-user::consumes-media-type
                          ,@(when headers `(:additional-headers cl-user::headers))
                          ,@(when request-body
                              `(:content cl-user::request-body))
                          ,@(when body-params
                              `(:content (funcall (gethash cl-user::consumes-media-type
                                                           (cl-user::encoder-from-media-type cl-user::client))
                                                  cl-user::req-body)))
                          ,@(when query-params `(:parameters cl-user::query-params))
                          ,@(when form-params `(:multipart-params cl-user::form-params))))))))))

(defun generate-client (client-name schemes host base-path consumes-media-types produces-media-types security-schemes)
  "Generates a client that all the methods will hang off of."
  (check-type client-name symbol)
  (assert (openapi-schemes-p schemes))
  (check-type host string)
  (check-type base-path string)
  (check-type consumes-media-types list)
  (check-type produces-media-types list)
  `(defclass ,(intern (symbol-name client-name) :cl-user) ()
     ((cl-user::scheme
       :type string
       :documentation
       "The scheme to use for requests when the operation doesn't provide a preference of its own."
       :initarg :schemes
       :initform ,(select-scheme schemes)
       :accessor cl-user::scheme)
      (cl-user::host
       :type string
       :documentation
       "The host all requests for this client will be sent to."
       :initarg :host
       :initform ,host
       :accessor cl-user::host)
      (cl-user::base-path
       :type string
       :documentation
       "The base path that will be prepended to the path of all requests."
       :initarg :base-path
       :initform ,base-path
       :accessor cl-user::base-path)
      (cl-user::consumes-media-type
       :type string
       :documentation
       "The media-type to encode parameters to when operations do not declare a media-type."
       :initarg :consumes-media-type
       ,@(when consumes-media-types `(:initform ,(select-media-type consumes-media-types)))
       :accessor cl-user::consumes-media-type)
      (cl-user::produces-media-type
       :type string
       :documentation
       "The media-type to dencode results from when operations do not declare a media-type."
       :initarg :produces-media-type
       ,@(when produces-media-types `(:initform ,(select-media-type produces-media-types)))
       :accessor cl-user::produces-media-type)
      (cl-user::http-request
       :type function
       :documentation
       "A function for making HTTP requests. It needs to have the following signature: (lambda (uri &key method additional-headers content-type content parameters multipart-params))"
       :initarg :http-request
       :accessor cl-user::http-request)
      (cl-user::encoder-from-media-type
       :type hash-table
       :documentation
       "A hash table where the keys are media types the client can handle, and the values are functions which encode these media types to strings for inclusion into the http request."
       :initarg :encoder-from-media-type
       :initform (make-hash-table :test #'equalp)
       :accessor cl-user::encoder-from-media-type)
      ,@(loop for (name . schema) in security-schemes
              when (eq (security-type schema) 'api-key)
                collect
                (let ((lisp-name (kebab-symbol-from-string (name schema))))
                  `(,lisp-name
                    :type string
                    :documentation
                    ,(or (description schema) "")
                    :accessor ,lisp-name))))))

(defun read-path (path-string)
  (split-sequence:split-sequence #\/ path-string))

(defun access-path (object path)
  (let ((path (if (stringp path)
                  (read-path path)
                  path)))
    (let ((result (if (equalp (first path) "#")
                      object
                      (error "Don't know how to resolve: ~A" path))))
      (loop for part in (rest path) do
        (setf result (gethash part result)))
      result)))

(defun resolve-$ref (openapi $ref)
  "Returns the referenced object"
  (or (access-path openapi $ref)
      (error "Reference not found: ~a" $ref)))

(defun resolve-object (openapi object)
  "If object is a reference, then return the referenced object. Otherwise, just return the object."
  (if (not (null (gethash "$ref" object)))
      (resolve-$ref openapi (gethash "$ref" object))
      object))

(defun generate-check-type (parameters)
  (check-type parameters list)
  (loop for param in parameters
        for param-name = (lisp-parameter-name param)
        for param-type = (parameter-type param)
        for lisp-param-type = (when param-type (kebab-symbol-from-string param-type))
        ;; Type must both be present and correspond to a check
        ;; function in order to perform type checking.
        when (find lisp-param-type '(string number integer array)
                   :test #'string=)
          collect (if (parameter-required-p param)
                      `(check-type ,param-name ,lisp-param-type)
                      `(when ,param-name (check-type ,param-name ,lisp-param-type)))))

(defun generate-http-request-body-population (params req-body-name)
  (check-type params list)
  (loop for param in params
        for param-name = (parameter-name param)
        for lisp-param-name = (lisp-parameter-name param)
        for set-value-sexp = `(setf (gethash ,param-name ,req-body-name) ,lisp-param-name)
        collect
        (if (parameter-required-p param) set-value-sexp `(when ,lisp-param-name ,set-value-sexp))))

(defun generate-http-request-population (params request-alist)
  "Generates code to populate an alist intended to be passed into an
http-request."
  (check-type params list)
  (check-type request-alist symbol)
  (loop for param in params
        for param-name = (parameter-name param)
        for lisp-param-name = (lisp-parameter-name param)
        collect
        (if (parameter-required-p param)
            `(setf ,request-alist (push (cons ,param-name ,lisp-param-name) ,request-alist))
            `(when ,lisp-param-name (setf ,request-alist (push (cons ,param-name  ,lisp-param-name) ,request-alist))))))

(defun generate-parameter-comments (parameters)
  "Generates a single string describing a list of parameters for
inclusion in a method's docstring."
  (check-type parameters list)
  (with-output-to-string (parameter-desc)
    (loop for param in parameters
          for lisp-param-name = (lisp-parameter-name param)
          for param-desc = (gethash "description" param)
          when param-desc
            do (format parameter-desc "~a: ~a~%" lisp-param-name param-desc))))

(defun generate-schema-object-parameters (schema-object)
  "Generates hash-tables which look like openapi parameters from
schema object properties. This is so that we can pass these into
generation code that synthesizes CL method parameters from openapi
parameters."
  ;; TODO(katco): Create types since properties and parameters have similarities
  (check-type schema-object hash-table)
  (let ((schema-properties (gethash "properties" schema-object))
        (required-parameters (list))
        (optional-parameters (list))
        (declared-as-required (gethash "required" schema-object)))
    (when schema-properties
      (loop for prop-name being the hash-keys of schema-properties
              using (hash-value prop)
            for prop-type = (parameter-type prop)
            for prop-desc = (gethash "description" prop)
            for faux-param = (make-hash-table :test #'equalp)
            do (setf (gethash "required" faux-param) (find prop-name declared-as-required :test #'string=)
                     (gethash "name" faux-param) prop-name
                     (gethash "type" faux-param) prop-type
                     (gethash "in" faux-param) "body"
                     (gethash "description" faux-param) prop-desc)
               (if (find prop-name declared-as-required :test #'string=)
                   (setf required-parameters (push faux-param required-parameters))
                   (setf optional-parameters (push faux-param optional-parameters)))))
    (values required-parameters optional-parameters)))

;;; Security Scheme Objects

(deftype flow () '(member implicit password application access-code))
(deftype security-type () '(member http api-key oauth2))
(deftype variable-location () '(member query header path body form-data))

(defclass security-scheme ()
  ((type
    :type security-type
    :documentation
    "The type of the security scheme."
    :initarg :type
    :initform (error "type not specified")
    :reader security-type)
   (description
    :type (or string null)
    :documentation
    "A short description for security scheme."
    :initarg :description
    :reader description)))

(defclass http-security-scheme (security-scheme)
  ((scheme :type string
           :initarg :scheme
           :initform "http"))
  (:default-initargs
   :type 'http))

(defclass api-key-security-scheme (security-scheme)
  ((name
    :type string
    :documentation
    "The name of the header or query parameter to be used."
    :initarg :name
    :reader name)
   (in
    :type variable-location
    :documentation
    "Where in the HTTP request the variable is placed. Valid values
are '(query header path body form-data)"
    :initarg :in
    :reader in))
  (:default-initargs
   :type 'api-key))

(defclass oauth2-security-scheme (security-scheme)
  ((flow
    :type (or flow null)
    :documentation
    "The flow used by the OAuth2 security scheme."
    :initarg :flow)
   (authorization-url
    :type (or string null)
    :documentation
    "The authorization URL to be used for this flow. This SHOULD be in
the form of a URL."
    :initarg :authorization-url)
   (token-url
    :type (or string null)
    :documentation
    "The token URL to be used for this flow. This SHOULD be in the
form of a URL."
    :initarg :token-url)
   (scopes
    :documentation
    "The available scopes for the OAuth2 security scheme."
    :initarg :scopes))
  (:default-initargs
   :type 'oauth2)
  (:documentation
   "A security schema that an OpenAPI endpoint accepts."))

(defun parse-security-scheme (security-scheme-class json)
  (ecase security-scheme-class
    (api-key-security-scheme
     (make-instance 'api-key-security-scheme
                    :name (gethash "name" json)
                    :description (gethash "description" json)
                    :in (kebab-symbol-from-string (gethash "in" json))))
    (oauth2-security-scheme
     (make-instance 'oauth2-security-scheme
                    :description (gethash "description" json)
                    :flow (alexandria:when-let (flow (gethash "flow" json)) (intern flow))
                    :authorization-url (gethash "authorizationUrl" json)
                    :token-url (gethash "tokenUrl" json)
                    :scopes (gethash "scopes" json)))))


(defun parse-security-schemes (json)
  "Collects security schemes into an alist of (name . instance)."
  (let ((security-classes '(("http" . http-security-scheme)
                            ("oauth2" . oauth2-security-scheme)
                            ("apiKey" . api-key-security-scheme))))
    (loop for schema-name being the hash-keys of json
          for schema being the hash-values of json
          for security-scheme-class := (or (cdr (assoc (gethash "type" schema) security-classes :test 'string=))
                                           (error "Security scheme not supported: ~s" (gethash "type" schema)))
          collect (cons schema-name (parse-security-scheme security-scheme-class schema)))))