88cc72ff95
To allow other clients to more easily use the REST API helpers, they have been re-factored out of keystone package. Change-Id: I5fde703293ff8f2668789053a36e293dc6fc6c53
251 lines
8.8 KiB
Common Lisp
251 lines
8.8 KiB
Common Lisp
(defpackage cl-openstack-client
|
||
(:use cl)
|
||
(:export #:*resource-uri*
|
||
#:*http-stream*
|
||
|
||
;; REST resource definitions
|
||
#:def-rest-method
|
||
#:def-rest-generic
|
||
|
||
;; Error handling
|
||
#:openstack-error
|
||
#:handle-http-error
|
||
#:error-code
|
||
#:error-message
|
||
|
||
;; Resources
|
||
#:resource
|
||
#:resource-connection
|
||
#:resource-authentication-headers
|
||
#:resource-error-class
|
||
#:decode-resource-list
|
||
#:request-resource
|
||
#:decode-resource
|
||
#:service-url
|
||
#:resource-id
|
||
|
||
;; Resource Slots
|
||
#:id
|
||
|
||
;; Generic Utilities
|
||
#:assoc*)
|
||
(:import-from #:drakma
|
||
#:http-request)
|
||
(:import-from #:cl-json
|
||
#:encode-json
|
||
#:decode-json
|
||
#:encode-json-to-string)
|
||
(:import-from #:alexandria
|
||
#:alist-plist)
|
||
(:import-from #:uri-template
|
||
#:uri-template
|
||
#:read-uri-template))
|
||
|
||
|
||
(in-package :cl-openstack-client)
|
||
|
||
(defun assoc* (item alist &rest rest &key key test test-not)
|
||
"Return the CDR of the ASSOC result."
|
||
(declare (ignore key test test-not))
|
||
(cdr (apply #'assoc item alist rest)))
|
||
|
||
|
||
;;; REST method helpers
|
||
|
||
(defvar *http-stream* nil
|
||
"This stream is primarily used for dependency injection in
|
||
testcases.")
|
||
|
||
(define-condition openstack-error (error)
|
||
((message
|
||
:initarg :message
|
||
:accessor error-message
|
||
:initform nil
|
||
:documentation "The error message returned by Openstack.")
|
||
(code
|
||
:initarg :code
|
||
:accessor error-code
|
||
:initform nil
|
||
:documentation "The error code returned by Openstack."))
|
||
(:report (lambda (condition stream)
|
||
(format stream "Openstack ERROR: ~A, ~A"
|
||
(error-code condition)
|
||
(error-message condition)))))
|
||
|
||
(defun json-error (resource json)
|
||
"Raise an error using the contents of a JSON error plist."
|
||
(let ((error-message (assoc* :error json)))
|
||
(error (resource-error-class resource)
|
||
:message (assoc* :message error-message)
|
||
:code (assoc* :code error-message))))
|
||
|
||
(defun unknown-error (url status-code)
|
||
"Raise an error with the url and status code."
|
||
(error (format nil "ERROR: received response code of ~A when accessing ~A"
|
||
status-code url)))
|
||
|
||
(defun json-response-p (headers)
|
||
"Return true if the response content type is json."
|
||
(string-equal (assoc* :content-type headers)
|
||
"application/json"))
|
||
|
||
(defun handle-http-error (resource uri status-code headers stream)
|
||
(block nil
|
||
(cond
|
||
((and (member status-code '(200 204))
|
||
(json-response-p headers))
|
||
(return))
|
||
((json-response-p headers)
|
||
(json-error resource (decode-json stream)))
|
||
(t
|
||
(unknown-error uri status-code)))))
|
||
|
||
(defun convert-header-resources (headers)
|
||
"Take a list of headers and resolve any RESOURCE types to their
|
||
RESOURCE-ID's"
|
||
(loop :for (header . value) :in headers
|
||
:when (subtypep (class-of value) (find-class 'resource))
|
||
:collect (cons header (resource-id value))
|
||
:else
|
||
:collect (cons header value)))
|
||
|
||
(defun return-first-connection (resources)
|
||
(loop :for r :in resources
|
||
:when (or (subtypep (class-of r) (find-class 'resource))
|
||
(subtypep (class-of r) (find-class 'connection)))
|
||
:return r))
|
||
|
||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
(defun lambda-list-variables (&rest rest)
|
||
(loop :for l :in rest
|
||
:for element = (if (listp l) (car l) l)
|
||
:until (eql (char (symbol-name element) 0) #\&)
|
||
:collect element)))
|
||
|
||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
(defun convert-lambda-list-resources (&rest rest)
|
||
(loop :for l :in rest
|
||
:for element = (if (listp l) (car l) l)
|
||
:until (eql (char (symbol-name element) 0) #\&)
|
||
:collect `(,element (if (subtypep (class-of ,element) (find-class 'resource))
|
||
(resource-id ,element)
|
||
,element)))))
|
||
|
||
;; Resources act as a base class for all types.
|
||
|
||
(defclass resource ()
|
||
((id :initarg :id
|
||
:reader resource-id)
|
||
(connection :initarg :connection
|
||
:reader resource-connection)
|
||
(attributes :initform (make-hash-table))))
|
||
|
||
(defmethod resource-error-class ((resource resource))
|
||
'openstack-error)
|
||
|
||
(defmethod print-object ((resource resource) stream)
|
||
(if (slot-boundp resource 'id)
|
||
(print-unreadable-object (resource stream :type t :identity t)
|
||
(format stream "~A" (resource-id resource)))
|
||
(print-unreadable-object (resource stream :type t :identity t))))
|
||
|
||
(defmethod decode-resource (resource parent type)
|
||
;; TODO (RS) currently extra keys are just ignored in all resources,
|
||
;; it would be best if they were saved somewhere.
|
||
(apply #'make-instance
|
||
type
|
||
:connection (resource-connection parent)
|
||
:parent parent
|
||
(concatenate 'list
|
||
(alist-plist resource)
|
||
'(:allow-other-keys t))))
|
||
|
||
(defmethod decode-resource-list (resources parent type)
|
||
(loop :for resource :in resources
|
||
:collect (decode-resource resource parent type)))
|
||
|
||
(defgeneric resource-authentication-headers (resource)
|
||
(:documentation "Return a list of the authentication headers that
|
||
should be added to the request."))
|
||
|
||
(defvar *resource-uri* nil)
|
||
|
||
(defun request-resource (resource &key method additional-headers content
|
||
(uri *resource-uri*)
|
||
(content-type "application/json"))
|
||
(multiple-value-bind (body status-code headers uri stream must-close reason-phrase)
|
||
(http-request uri
|
||
:method method
|
||
:content-type "application/json"
|
||
:stream *http-stream*
|
||
:additional-headers
|
||
(concatenate 'list
|
||
(resource-authentication-headers resource)
|
||
(convert-header-resources additional-headers))
|
||
:content (cond
|
||
((null content)
|
||
nil)
|
||
((stringp content)
|
||
content)
|
||
(t
|
||
(encode-json-to-string content)))
|
||
:want-stream t)
|
||
(declare (ignore body must-close reason-phrase))
|
||
(handle-http-error resource uri status-code headers stream)
|
||
(cond
|
||
((equal content-type "application/json")
|
||
(decode-json stream))
|
||
(t stream))))
|
||
|
||
(defgeneric service-url (resource &optional service-name))
|
||
|
||
(defmacro def-rest-method (name lambda-list options &body body)
|
||
"A convenience wrapper around request-resource.
|
||
|
||
NAME is the name of the method. LAMBDA-LIST is a method lambda list,
|
||
it's first element will be used to source a connection, so it must be
|
||
of the type RESOURCE or CONNECTION.
|
||
|
||
OPTIONS is in the form of an ALIST and can contain URI or
|
||
DOCUMENTATION elements.
|
||
|
||
URI is the uri to the resource you are looking for it supports
|
||
RFC6570 tempting and will be evaluated in the context of the method as
|
||
if in a PROGN so values from the LAMBDA-LIST will be substituted in
|
||
provided the symbol names match. Any RESOURCE types will have their
|
||
RESOURCE-ID methods called before substitution. Only simple expansion
|
||
is supported from the RFC. The resulting URI will be bound to the
|
||
*RESOURCE-URI* variable for use within other helper functions.
|
||
|
||
DOCUMENTATION a documentation string that will be assigned to the
|
||
method.
|
||
|
||
BODY is a for the method body.
|
||
"
|
||
(let ((uri (or (cadr (assoc :uri options))
|
||
(error ":URI is required.")))
|
||
(documentation (cdr (assoc :documentation options))))
|
||
`(defmethod ,name ,lambda-list
|
||
,@documentation
|
||
(let ((*resource-uri*
|
||
(format nil "~a/~a"
|
||
(service-url ,(car (apply #'lambda-list-variables lambda-list)))
|
||
(let ,(apply #'convert-lambda-list-resources lambda-list)
|
||
(declare (ignorable ,@(apply #'lambda-list-variables lambda-list)))
|
||
(uri-template
|
||
,@(with-input-from-string (stream uri)
|
||
(read-uri-template stream t)))))))
|
||
,@body))))
|
||
|
||
(defmacro def-rest-generic (name lambda-list &body options)
|
||
"Define a generic with REST methods."
|
||
(let ((documentation (or (cadr (assoc :documentation options)) ""))
|
||
(methods (loop :for body :in options
|
||
:when (eql (car body) :method)
|
||
:collect (cdr body))))
|
||
`(progn
|
||
(defgeneric ,name ,lambda-list
|
||
(:documentation ,documentation))
|
||
,@(loop :for method :in methods
|
||
:collect `(def-rest-method ,name ,@method)))))
|