diff --git a/keystone.lisp b/keystone.lisp index f387b2c..92bcb44 100644 --- a/keystone.lisp +++ b/keystone.lisp @@ -1,7 +1,25 @@ (defpackage cl-keystone-client - (:use cl drakma) + (:use cl) (:import-from #:cl-openstack-client - #:assoc*) + #:*http-stream* + #:assoc* + #:decode-resource + #:decode-resource-list + #:def-rest-method + #:error-code + #:error-message + #:handle-http-error + #:id + #:openstack-error + #:request-resource + #:resource + #:resource-authentication-headers + #:resource-connection + #:resource-error-class + #:resource-id + #:service-url) + (:import-from #:drakma + #:http-request) (:import-from #:local-time #:parse-timestring #:timestamp> @@ -13,11 +31,7 @@ #:encode-json #:encode-json-to-string) (:import-from #:alexandria - #:alist-plist - #:with-gensyms) - (:import-from #:uri-template - #:uri-template - #:read-uri-template) + #:alist-plist) (:export connection-v2 authenticate keystone-error @@ -57,6 +71,7 @@ (in-package :cl-keystone-client) +(define-condition keystone-error (openstack-error) ()) (defclass connection () ((username :initarg :username @@ -85,6 +100,9 @@ (defmethod resource-connection ((connection connection)) connection) +(defmethod resource-error-class ((resource connection)) + 'keystone-error) + (defmethod encode-json ((connection connection) &optional (stream json:*json-output*)) "Write the JSON representation (Object) of the keystone CONNECTION @@ -113,41 +131,6 @@ to STREAM (or to *JSON-OUTPUT*)." (declare (ignore action)) nil) -(defvar *cached-stream* nil) - -(define-condition keystone-error (error) - ((message - :initarg :message - :accessor error-message - :initform nil - :documentation "The error message returned by keystone.") - (code - :initarg :code - :accessor error-code - :initform nil - :documentation "The error code returned by keystone.")) - (:report (lambda (condition stream) - (format stream "Keystone ERROR: ~A, ~A" - (error-code condition) - (error-message condition))))) - -(defun json-error (json) - "Raise an error using the contents of a JSON error plist." - (let ((error-message (assoc* :error json))) - (error 'keystone-error - :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 openstack-camel-case-to-lisp (camel-string) "Convert camel case JSON keys to lisp symbol names. This function handles keys with names like publicURL better and will convert keys @@ -173,17 +156,6 @@ with underscores to hyphens." (let ((*json-identifier-name-to-lisp* #'openstack-camel-case-to-lisp)) (cl-json:decode-json stream))) -(defun handle-http-error (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 (decode-json stream))) - (t - (unknown-error uri status-code))))) - (defgeneric authenticate (connection) (:documentation "Authenticate and retrieve a token.")) @@ -193,12 +165,12 @@ with underscores to hyphens." (http-request (format nil "~a/v2.0/tokens" url) :method :POST :want-stream t - :stream *cached-stream* + :stream *http-stream* :content-type "application/json" :content (encode-json-to-string connection)) (declare (ignore must-close reason-phrase body)) - (handle-http-error uri status-code headers stream) + (handle-http-error connection uri status-code headers stream) (let ((access (assoc* :access (decode-json stream)))) (setf user (assoc* :user access)) (setf service-catalog (assoc* :service-catalog access)) @@ -236,6 +208,9 @@ valid.")) (connection-token-expires connection) (now))) +(defmethod resource-authentication-headers ((resource connection-v2)) + `(("x-auth-token" . ,(connection-token-id resource)))) + ;; Service catalog queries (defun filter-endpoints (endpoints &key (type :public-url) region) @@ -255,154 +230,18 @@ valid.")) :type (connection-endpoint connection)))) -;;; REST method helpers - -(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))))) - -(defvar *resource-url* nil) - -(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. - -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-url* - (format nil "~a/~a" - (service-url (resource-connection - ,(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))))) - - -;; Resources act as a base class for all types within keystone. - -(defclass resource () - ((id :initarg :id - :reader resource-id) - (connection :initarg :connection - :reader resource-connection) - (attributes :initform (make-hash-table)))) - -(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) - (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))) - (defclass resource-v2 (resource) ()) +(defmethod resource-error-class ((resource resource-v2)) + 'keystone-error) + +(defmethod resource-authentication-headers ((resource resource-v2)) + (resource-authentication-headers (resource-connection resource))) + (defmethod service-url ((resource resource-v2) &optional (service "identity")) (service-url (resource-connection resource) service)) -(defun request-resource (resource &key method additional-headers content - (uri *resource-url*) - (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 *cached-stream* - :additional-headers - (concatenate 'list - `(("x-auth-token" . ,(connection-token-id - (resource-connection 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 uri status-code headers stream) - (cond - ((equal content-type "application/json") - (decode-json stream)) - (t stream)))) - (defclass named-resource-v2 (resource-v2) ((name :initarg :name :reader resource-name))) @@ -469,12 +308,14 @@ to STREAM (or to *JSON-OUTPUT*)." ;; Users (defclass user (named-resource-v2) - ((id :initarg :id :reader user-id) - (name :initarg :name :reader user-name) + ((name :initarg :name :reader user-name) (tenant-id :initarg :tenant-id :reader user-tenant) (enabled :initarg :enabled :reader user-enabled) (email :initarg :email :reader user-email))) +(defmethod user-id ((user user)) + (resource-id user)) + (defclass user-v2 (user) ()) diff --git a/openstack.lisp b/openstack.lisp index cc7d9a0..c2598a9 100644 --- a/openstack.lisp +++ b/openstack.lisp @@ -1,6 +1,45 @@ (defpackage cl-openstack-client (:use cl) - (:export assoc*)) + (: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) @@ -9,3 +48,203 @@ "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))))) diff --git a/tests/openstack.lisp b/tests/openstack.lisp index 1451c94..09918b1 100644 --- a/tests/openstack.lisp +++ b/tests/openstack.lisp @@ -13,6 +13,8 @@ #:now) (:import-from #:cl-keystone-client #:connection-v2) + (:import-from #:cl-openstack-client + #:*http-stream*) (:import-from #:flexi-streams #:string-to-octets #:make-flexi-stream @@ -110,20 +112,6 @@ (:endpoints-links) (:type . "identity") (:name . "keystone")))) connection)) -(defun is-valid-response (stream method uri content) - (destructuring-bind (status headers content) - (read-mock-request mock-stream) - (is (equal content - "{\"user\":{\"name\":\"test\",\"email\":\"test@example.com\",\"enabled\":true,\"password\":\"secret\"}}")) - (is (string-equal "application/json" - (header-value :content-type headers))) - (is (string-equal "MIINUAYJKoZIhvcNAQ==" - (header-value :x-auth-token headers))) - (is (string-equal "192.168.1.9:5000" - (header-value :host headers))) - (is (eql (getf status :method) method)) - (is (eql (getf status :uri) uni)))) - (defclass mock-http-stream (fundamental-binary-input-stream fundamental-binary-output-stream fundamental-character-input-stream @@ -210,9 +198,8 @@ form (parsed-status-line headers contents)" (defmacro with-mock-http-stream ((stream) &body body) `(let* ((,stream (make-instance 'mock-http-stream)) - (cl-keystone-client::*cached-stream* - (make-flexi-stream (make-chunked-stream ,stream) - :external-format +latin-1+))) + (*http-stream* (make-flexi-stream (make-chunked-stream ,stream) + :external-format +latin-1+))) ,@body))