Initial partial keystone API implementation

Change-Id: I25b216936cd902bc9cf05dee517859fd1756f751

cl-openstack-client-test.asd

@@ -10,8 +10,7 @@
                #:local-time)
   :description "OpenStack client libraries tests"
   :components
-  ((:file "keystone"
+  ((:module "tests"
-          :pathname "tests/keystone"
+    :components
-          :depends-on ("openstack"))
+    ((:file "keystone" :depends-on ("openstack"))
-   (:file "openstack"
+     (:file "openstack")))))
-          :pathname "tests/openstack")))

cl-openstack-client.asd

@@ -1,6 +1,7 @@
 (defsystem cl-openstack-client
   :author "Julien Danjou <julien@danjou.info>"
-  :depends-on (#:drakma #:cl-json #:local-time)
+  :depends-on (#:drakma #:cl-json #:local-time #:alexandria #:uri-template)
   :description "OpenStack client libraries"
   :components
-  ((:file "keystone")))
+  ((:file "openstack")
+   (:file "keystone" :depends-on ("openstack"))))

keystone.lisp

@@ -1,9 +1,23 @@
 (defpackage cl-keystone-client
-  (:use cl cl-json drakma)
+  (:use cl drakma)
-  (:import-from :local-time
+  (:import-from #:cl-openstack-client
-                :parse-timestring
+                #:assoc*)
-                :timestamp>
+  (:import-from #:local-time
-                :now)
+                #:parse-timestring
+                #:timestamp>
+                #:now)
+  (:import-from #:cl-json
+                #:*json-input*
+                #:*json-identifier-name-to-lisp*
+                #:with-explicit-encoder
+                #:encode-json
+                #:encode-json-to-string)
+  (:import-from #:alexandria
+                #:alist-plist
+                #:with-gensyms)
+  (:import-from #:uri-template
+                #:uri-template
+                #:read-uri-template)
   (:export connection-v2
            authenticate
            keystone-error
@@ -17,7 +31,29 @@
            connection-token-id
            connection-token-expires
            connection-token-issued-at
-           connection-token-valid-p))
+           connection-token-valid-p
+           resource-id
+           resource-name
+           resource-connection
+           tenant-id
+           tenant-name
+           tenant-enabled
+           tenant-description
+           list-tenants
+           user-id
+           user-name
+           user-tenant
+           user-enabled
+           user-email
+           user-roles
+           add-user
+           get-user
+           delete-user
+           list-users
+           role-id
+           role-name
+           role-enabled
+           list-roles))
 
 (in-package :cl-keystone-client)
 
@@ -33,11 +69,22 @@
    (password :initarg :password
              :initform (error ":PASSWORD is required when creating a connection.")
              :reader connection-password)
+   (endpoint :initarg :endpoint
+             :initform :public-url
+             :reader connection-endpoint)
    (token :initarg :password)
+   (user)
+   (tenant)
+   (metadata)
+   (service-catalog :reader connection-service-catalog)
    (url :initarg :url
         :reader connection-url
         :initform (error ":URL is required when creating a connection."))))
 
+;; Add API compatability with the resource object
+(defmethod resource-connection ((connection connection))
+  connection)
+
 (defmethod encode-json ((connection connection)
                         &optional (stream json:*json-output*))
   "Write the JSON representation (Object) of the keystone CONNECTION
@@ -62,6 +109,10 @@ to STREAM (or to *JSON-OUTPUT*)."
 (defclass connection-v2 (connection)
   ((version :initform 2 :reader connection-version)))
 
+(defmethod headers-for ((connection connection-v2) &optional action)
+  (declare (ignore action))
+  nil)
+
 (defvar *cached-stream* nil)
 
 (define-condition keystone-error (error)
@@ -82,10 +133,10 @@ to STREAM (or to *JSON-OUTPUT*)."
 
 (defun json-error (json)
   "Raise an error using the contents of a JSON error plist."
-  (let ((error-message (cdr (assoc :error json))))
+  (let ((error-message (assoc* :error json)))
     (error 'keystone-error
-           :message (cdr (assoc :message error-message))
+           :message (assoc* :message error-message)
-           :code (cdr (assoc :code error-message)))))
+           :code (assoc* :code error-message))))
 
 (defun unknown-error (url status-code)
   "Raise an error with the url and status code."
@@ -94,14 +145,50 @@ to STREAM (or to *JSON-OUTPUT*)."
 
 (defun json-response-p (headers)
   "Return true if the response content type is json."
-  (string-equal (cdr (assoc :content-type headers))
+  (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
+with underscores to hyphens."
+  (declare (string camel-string))
+  (let ((*print-pretty* nil))
+    (with-output-to-string (result)
+      (loop :for c :across camel-string
+            :with last-was-lowercase
+            :when (and last-was-lowercase
+                       (upper-case-p c))
+              :do (princ "-" result)
+            :if (lower-case-p c)
+              :do (setf last-was-lowercase t)
+            :else
+              :do (setf last-was-lowercase nil)
+            :if (member c (list #\_))
+              :do (princ "-" result)
+            :else
+              :do (princ (char-upcase c) result)))))
+
+(defun decode-json (&optional (stream *json-input*))
+  (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."))
 
 (defmethod authenticate ((connection connection-v2))
-  (with-slots (url token) connection
+  (with-slots (url token user service-catalog metadata tenant) connection
     (multiple-value-bind (body status-code headers uri stream must-close reason-phrase)
         (http-request (format nil "~a/v2.0/tokens" url)
                       :method :POST
@@ -111,35 +198,34 @@ to STREAM (or to *JSON-OUTPUT*)."
                       :content
                       (encode-json-to-string connection))
       (declare (ignore must-close reason-phrase body))
-      (cond
+      (handle-http-error uri status-code headers stream)
-        ((and (eql status-code 200)
+      (let ((access (assoc* :access (decode-json stream))))
-              (json-response-p headers))
+        (setf user (assoc* :user access))
-         (setf token
+        (setf service-catalog (assoc* :service-catalog access))
-               (cdr (assoc :token (cdr (assoc :access (decode-json stream)))))))
+        (setf tenant (assoc* :tenant access))
-        ((json-response-p headers)
+        (setf metadata (assoc* :metadata access))
-         (json-error (decode-json stream)))
+        (setf token (assoc* :token access)))))
-        (t
+  connection)
-         (unknown-error uri status-code))))))
 
 (defgeneric connection-token-id (connection)
   (:documentation "Retrieve token id for CONNECTION."))
 
 (defmethod connection-token-id ((connection connection-v2))
-  (cdr (assoc :id (slot-value connection 'token))))
+  (assoc* :id (slot-value connection 'token)))
 
 (defgeneric connection-token-issued-at (connection)
   (:documentation "Return the time the CONNECTION's token was issued
 at."))
 
 (defmethod connection-token-issued-at ((connection connection-v2))
-  (parse-timestring (cdr (assoc :issued--at (slot-value connection 'token)))))
+  (parse-timestring (assoc* :issued--at (slot-value connection 'token))))
 
 (defgeneric connection-token-expires (connection)
   (:documentation "Return the time when the CONNECTION's token will
 expire."))
 
 (defmethod connection-token-expires ((connection connection-v2))
-  (parse-timestring (cdr (assoc :expires (slot-value connection 'token)))))
+  (parse-timestring (assoc* :expires (slot-value connection 'token))))
 
 (defgeneric connection-token-valid-p (connection)
   (:documentation "Return T if the CONNECTION's token is still
@@ -149,3 +235,352 @@ valid."))
   (timestamp>
    (connection-token-expires connection)
    (now)))
+
+;; Service catalog queries
+
+(defun filter-endpoints (endpoints &key (type :public-url) region)
+  (loop :for endpoint :in endpoints
+        :when (or (not region)
+                  (equal (assoc* :region endpoint) region))
+          :collect (assoc* type endpoint)))
+
+(defmethod service-catalog-query ((connection connection-v2) service-type &key (type :public-url))
+  (loop :for service :in (connection-service-catalog connection)
+        :when (equal (assoc* :type service) service-type)
+          :append (filter-endpoints (assoc* :endpoints service)
+                                    :type type)))
+
+(defmethod service-url ((connection connection-v2) &optional (service "identity"))
+  (car (service-catalog-query connection service
+                              :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 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)))
+
+(defmethod print-object ((resource named-resource-v2) stream)
+  (if (slot-boundp resource 'name)
+      (print-unreadable-object
+          (resource stream :type t :identity t)
+        (format stream "~a"
+                (cond
+                  ((and (slot-exists-p resource 'name)
+                        (slot-boundp resource 'name))
+                   (slot-value resource 'name))
+                  ((and (slot-exists-p resource 'id)
+                        (slot-boundp resource 'id))
+                   (slot-value resource 'id))
+                  (t "UNKNOWN"))))
+      (print-unreadable-object (resource stream :type t :identity t))))
+
+
+;; Tenants
+
+(defclass tenant (named-resource-v2)
+  ((id :initarg :id :reader tenant-id)
+   (name :initarg :name :reader tenant-name)
+   (enabled :initarg :enabled :reader tenant-enabled)
+   (description :initarg :description :reader tenant-description)))
+
+(defclass tenant-v2 (tenant)
+  ())
+
+(defmethod encode-json ((tenant tenant-v2)
+                        &optional (stream json:*json-output*))
+  "Write the JSON representation (Object) of the keystone CONNECTION
+to STREAM (or to *JSON-OUTPUT*)."
+  (with-slots (id name enabled description) tenant
+    (with-explicit-encoder
+      (encode-json
+       `(:object
+         :tenant
+         (:object
+          :id ,id
+          :name ,name
+          :description ,description
+          :enabled ,enabled))
+       stream))))
+
+(defmethod decode-resource ((type (eql 'tenant-v2)) (parent connection-v2) stream)
+  (loop :for tenant :in (assoc* :tenants (decode-json stream))
+        :collect (apply #'make-instance
+                        type
+                        :connection parent
+                        (alist-plist tenant))))
+
+(defgeneric list-tenants (resource))
+
+(def-rest-method list-tenants ((connection connection-v2))
+    ((:documentation "List all the tenants.")
+     (:uri "/tenants"))
+  (let ((json (request-resource connection :method :get)))
+    (decode-resource-list (assoc* :tenants json)
+                          connection 'tenant-v2)))
+
+;; Users
+
+(defclass user (named-resource-v2)
+  ((id :initarg :id :reader user-id)
+   (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)))
+
+(defclass user-v2 (user)
+  ())
+
+
+;;; Make the connection behave like the current user.
+
+(defmethod user-id ((connection connection-v2))
+  (assoc* :id (slot-value connection 'user)))
+
+(defmethod user-name ((connection connection-v2))
+  (assoc* :name (slot-value connection 'user)))
+
+(defgeneric list-users (resource))
+
+(def-rest-method list-users ((tenant tenant-v2))
+  ((:documentation "List all the users for tenant.")
+   (:uri "/tenants/{tenant}/users"))
+  (let ((json (request-resource tenant
+                                :method :get)))
+    (decode-resource-list (assoc* :users json)
+                          tenant
+                          'user-v2)))
+
+(def-rest-method list-users ((connection connection-v2))
+    ((:documentation "List all users in keystone.")
+     (:uri "/users"))
+  (let ((json (request-resource connection :method :get)))
+    (decode-resource-list (assoc* :users json)
+                          connection
+                          'user-v2)))
+
+(def-rest-method get-user (connection user)
+  ((:documentation "Gets information for a specified user.")
+   (:uri "/users/{user}"))
+  (let ((json (request-resource connection :method :get)))
+    (decode-resource (assoc* :user json)
+                     connection
+                     'user-v2)))
+
+(defgeneric add-user (connection &key name email enabled password))
+
+(def-rest-method add-user ((connection connection-v2) &key name email (enabled t) password)
+    ((:documentation "Add a user.")
+     (:uri "/users"))
+  (let ((json (request-resource
+               connection
+               :method :post
+               :content (with-output-to-string (stream)
+                          (with-explicit-encoder
+                            (encode-json
+                             `(:object
+                               :user
+                               (:object
+                                :name ,name
+                                :email ,email
+                                :enabled ,enabled
+                                :password ,password))
+                             stream))))))
+    (decode-resource (assoc* :user json)
+                     connection
+                     'user-v2)))
+
+
+(defgeneric delete-user (resource user-or-user-id))
+
+(def-rest-method delete-user ((connection connection-v2) user-or-user-id)
+  ((:documentation "Delete a user.")
+   (:uri "/users/{user-or-user-id}"))
+  (request-resource connection :method :delete))
+
+;; Roles
+
+(defclass role (named-resource-v2)
+  ((id :initarg :id :reader role-id)
+   (name :initarg :name :reader role-name)
+   (enabled :initarg :enabled :reader role-enabled)))
+
+(defclass role-v2 (role)
+  ())
+
+(defgeneric add-tenant-users-role (tenant user role))
+
+(def-rest-method add-tenant-users-role (tenant user role)
+  ((:documentation "Adds a specified role to a user for a tenant.")
+   (:uri "/tenants/{tenant}/users/{user}/roles/OS-KSADM/{role}"))
+  (request-resource tenant :method :put))
+
+(defgeneric delete-tenants-user-role (tenant user role))
+
+(def-rest-method delete-tenants-user-role (tenant user role)
+    ((:documentation "Deletes a specified role from a user on a tenant.")
+     (:uri "/tenants/{tenant}/users/{user}/roles/OS-KSADM/{role}"))
+  (request-resource tenant :method :delete))
+
+(defgeneric list-roles (resource))
+
+(def-rest-method list-roles ((connection connection-v2))
+    ((:documentation "List roles.")
+     (:uri "/OS-KSADM/roles/"))
+  (let ((json (request-resource connection :method :get)))
+    (decode-resource-list (assoc* :roles json) connection 'role-v2)))
+
+
+(def-rest-method list-roles ((user user-v2))
+  ((:documentation "Lists global roles for a specified user. Excludes
+tenant roles.")
+   (:uri "/users/{user}/roles"))
+  (let ((json (request-resource user :method :get)))
+    (decode-resource (assoc* :roles json) user 'role-v2)))

openstack.lisp

@@ -0,0 +1,11 @@
+(defpackage cl-openstack-client
+  (:use cl)
+  (:export assoc*))
+
+
+(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)))

requirements.txt

@@ -1,3 +1,5 @@
 cl-json
 drakma
 local-time
+uri-template
+alexandria

test-requirements.txt

@@ -1 +1,5 @@
 fiveam
+cl-ppcre
+chunga
+trivial-gray-streams
+flexi-streams

tests/keystone.lisp

@@ -1,26 +1,27 @@
 (defpackage cl-keystone-client.test
   (:use fiveam
         cl
-        trivial-gray-streams
         cl-keystone-client)
-  (:import-from :local-time
+  (:import-from #:drakma
-                :encode-timestamp
+                #:header-value)
-                :timestamp-to-unix
+  (:import-from #:cl-openstack-client.test
-                :timestamp=
+                #:connection-fixture
-                :timestamp+
+                #:with-mock-http-stream
-                :format-timestring
+                #:make-mock-http-stream
-                :now
+                #:mock-response
-                :+utc-zone+)
+                #:read-mock-request
+                #:mock-http-stream
+                #:is-valid-request)
+  (:import-from #:local-time
+                #:encode-timestamp
+                #:timestamp-to-unix
+                #:timestamp=
+                #:timestamp+
+                #:format-timestring
+                #:now
+                #:+utc-zone+)
   (:import-from :cl-ppcre
-                :regex-replace-all)
+                #:regex-replace-all))
-  (:import-from :flexi-streams
-                :string-to-octets
-                :make-flexi-stream
-                :octets-to-string)
-  (:import-from :drakma
-                :+latin-1+)
-  (:import-from :chunga
-                :make-chunked-stream))
 
 (in-package :cl-keystone-client.test)
 
@@ -36,46 +37,6 @@
     (:hour 2) #\: (:min 2) #\: (:sec 2)
     :gmt-offset-or-z))
 
-(defun connection-fixture (&key
-                             (url "http://localhost:5000")
-                             (username "demo")
-                             (password "demo"))
-  (make-instance 'connection-v2 :url url
-                                :password password
-                                :username username))
-
-(defclass mock-http-stream (fundamental-binary-input-stream
-                            fundamental-binary-output-stream
-                            fundamental-character-input-stream
-                            fundamental-character-output-stream)
-  ((mock-requests :accessor mock-request-stream
-                  :initform nil)
-   (mock-responses-location :initform 0
-                           :accessor mock-response-location)
-   (mock-responses :accessor mock-response-stream
-                   :initform nil)))
-
-(defmethod stream-read-byte ((stream mock-http-stream))
-  (if (<= (length (mock-response-stream stream))
-           (mock-response-location stream))
-      :eof
-      (prog1
-          (aref (mock-response-stream stream) (mock-response-location stream))
-        (incf (mock-response-location stream)))))
-
-(defmethod stream-write-byte ((stream mock-http-stream) byte)
-  (push byte (mock-request-stream stream)))
-
-(defmethod stream-write-char ((stream mock-http-stream) char)
-  (push char (mock-request-stream stream)))
-
-(defmethod mock-response ((stream mock-http-stream) response)
-  (setf (mock-response-stream stream)
-        (string-to-octets
-         (regex-replace-all (string #\Newline)
-                            response
-                            (coerce '(#\Return #\Linefeed) 'string)))))
-
 (test make-connection
   "Make a connection testing required fields."
   (is-true
@@ -133,27 +94,85 @@ object."
 (test authentication-error-404
   "Test that the correct condition is signalled when a 404 is returned
 from the keystone server."
-  (let* ((mock-stream (make-instance 'mock-http-stream))
+  (with-mock-http-stream (mock-stream)
-         (cl-keystone-client::*cached-stream*
-           (make-flexi-stream (make-chunked-stream mock-stream)
-                              :external-format +latin-1+)))
     (mock-response mock-stream
-                   "HTTP/1.1 404 Not Found
+                   404
-Vary: X-Auth-Token
+                   :content "{\"error\": {\"message\": \"The resource could not be found.\", \"code\": 404, \"title\": \"Not Found\"}}")
-Content-Type: application/json
-Content-Length: 93
-Date: Sat, 12 Oct 2013 23:03:22 GMT
-Connection: close
-
-{\"error\": {\"message\": \"The resource could not be found.\", \"code\": 404, \"title\": \"Not Found\"}}
-")
     (handler-case
-     (authenticate (make-instance 'connection-v2
+        (authenticate (make-instance 'connection-v2
-                                  :tenant-name "test"
+                                     :tenant-name "test"
-                                  :url "http://test"
+                                     :url "http://test:33"
-                                  :username "test"
+                                     :username "test"
-                                  :password "test"))
+                                     :password "test"))
       (keystone-error (keystone-error)
         (is (eql (error-code keystone-error)
                  404))))
-    ))
+    (destructuring-bind (status headers content)
+        (read-mock-request mock-stream)
+      (is (equal content
+                 "{\"auth\":{\"passwordCredentials\":{\"username\":\"test\",\"password\":\"test\"},\"tenantName\":\"test\"}}"))
+      (is (string-equal "application/json"
+                        (header-value :content-type headers)))
+      (is (string-equal "test:33"
+                        (header-value :host headers)))
+      (is (eql (getf status :method) :post))
+      (is (string-equal (getf status :uri) "/v2.0/tokens")))))
+
+
+(test list-tenants
+  "Test the parsing of a tenants list response."
+  (with-mock-http-stream (mock-stream)
+    (mock-response mock-stream
+                   200
+                   :content "{\"tenants_links\": [], \"tenants\": [{\"description\": null, \"enabled\": true, \"id\": \"010c021c\", \"name\": \"service\"}, {\"description\": null, \"enabled\": true, \"id\": \"39dd2c\", \"name\": \"invisible_to_admin\"}, {\"description\": null, \"enabled\": true, \"id\": \"45ca25c\", \"name\": \"admin\"}, {\"description\": \"test description\", \"enabled\": true, \"id\": \"5dbb9f7\", \"name\": \"alt_demo\"}, {\"description\": null, \"enabled\": false, \"id\": \"968075c\", \"name\": \"demo\"}]}")
+    (let ((tenants (list-tenants (connection-fixture))))
+      (is-valid-request mock-stream :get "/v2.0//tenants")
+      (is (equal (mapcar #'tenant-name tenants)
+                 '("service" "invisible_to_admin" "admin"
+                   "alt_demo" "demo")))
+      (is (equal (mapcar #'tenant-id tenants)
+                 '("010c021c" "39dd2c" "45ca25c"
+                   "5dbb9f7" "968075c")))
+      (is (equal (mapcar #'tenant-enabled tenants)
+                 '(t t t t nil)))
+      (is (equal (mapcar #'tenant-description tenants)
+                 '(nil nil nil "test description" nil))))))
+
+
+(test list-users
+  "Test the parsing of a user list response."
+  (with-mock-http-stream (mock-stream)
+    (mock-response mock-stream
+                   200
+                   :content "{\"users\": [{\"name\": \"admin\", \"enabled\": true, \"email\": \"admin@example.com\", \"id\": \"6d205b8\"}, {\"name\": \"demo\", \"enabled\": false, \"email\": \"demo@example.com\", \"id\": \"db82b12\"}]}")
+    (let ((users (list-users (connection-fixture))))
+      (is-valid-request mock-stream :get "/v2.0//users")
+      (is (equal (mapcar #'user-name users)
+                 '("admin" "demo")))
+      (is (equal (mapcar #'user-id users)
+                 '("6d205b8" "db82b12")))
+      (is (equal (mapcar #'user-enabled users)
+                 '(t nil)))
+      (is (equal (mapcar #'user-email users)
+                 '("admin@example.com" "demo@example.com"))))))
+
+(test add-user
+  "Test the adding a user."
+  (with-mock-http-stream (mock-stream)
+    (mock-response mock-stream
+                   200
+                   :content "{\"user\": {\"name\": \"test\", \"enabled\": true, \"email\": \"test@example.com\", \"id\": \"xxxxxxx\"}}")
+    (let ((user (add-user (connection-fixture)
+                             :name "test" :email "test@example.com"
+                             :password "secret" :enabled t)))
+      (is-valid-request mock-stream :post "/v2.0//users"
+                        "{\"user\":{\"name\":\"test\",\"email\":\"test@example.com\",\"enabled\":true,\"password\":\"secret\"}}")
+
+      (is (equal (user-name user)
+                 "test"))
+      (is (equal (user-id user)
+                 "xxxxxxx"))
+      (is (equal (user-enabled user)
+                 t))
+      (is (equal (user-email user)
+                 "test@example.com")))))

tests/openstack.lisp

@@ -1,9 +1,232 @@
 (defpackage cl-openstack-client.test
   (:use cl
+        trivial-gray-streams
         fiveam)
-  (:export tests))
+  (:import-from #:drakma
+                #:+latin-1+
+                #:header-value
+                #:read-http-headers)
+  (:import-from #:local-time
+                #:encode-timestamp
+                #:timestamp+
+                #:format-timestring
+                #:now)
+  (:import-from #:cl-keystone-client
+                #:connection-v2)
+  (:import-from #:flexi-streams
+                #:string-to-octets
+                #:make-flexi-stream
+                #:make-in-memory-input-stream
+                #:octets-to-string
+                #:octet)
+  (:import-from #:chunga
+                #:make-chunked-stream)
+  (:export tests
+           connection-fixture
+           with-mock-http-stream
+           make-mock-http-stream
+           read-mock-request
+           mock-http-stream))
 
 (in-package :cl-openstack-client.test)
 
 (def-suite tests
   :description "cl-openstack-client tests")
+
+(defun connection-fixture (&key
+                             (url "http://localhost:5000")
+                             (username "demo")
+                             (password "demo"))
+
+  (let ((connection (make-instance 'connection-v2 :url url
+                                                  :password password
+                                                  :username username)))
+    (setf (slot-value connection 'cl-keystone-client::token)
+          `((:issued-at . ,(now))
+            (:expires . ,(timestamp+ (now) 24 :hour))
+            (:id
+             . "MIINUAYJKoZIhvcNAQ==")
+            (:tenant
+             (:description)
+             (:enabled . t)
+             (:id . "45ca25c")
+             (:name . "admin"))))
+    (setf (slot-value connection 'cl-keystone-client::service-catalog)
+          '(((:endpoints
+              ((:admin-url . "http://192.168.1.9:8774/v2/45ca25c")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:8774/v2/45ca25c")
+               (:id . "25210b1")
+               (:public-url . "http://192.168.1.9:8774/v2/45ca25c")))
+             (:endpoints-links) (:type . "compute") (:name . "nova"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:8776/v2/45ca25c")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:8776/v2/45ca25c")
+               (:id . "46d0cc5")
+               (:public-url . "http://192.168.1.9:8776/v2/45ca25c")))
+             (:endpoints-links) (:type . "volumev2") (:name . "cinder"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:8774/v3")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:8774/v3")
+               (:id . "5ed56fb")
+               (:public-url . "http://192.168.1.9:8774/v3")))
+             (:endpoints-links) (:type . "computev3") (:name . "nova"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:3333")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:3333")
+               (:id . "a590747")
+               (:public-url . "http://192.168.1.9:3333")))
+             (:endpoints-links) (:type . "s3") (:name . "s3"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:9292")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:9292")
+               (:id . "010d69f")
+               (:public-url . "http://192.168.1.9:9292")))
+             (:endpoints-links) (:type . "image") (:name . "glance"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:8776/v1/45ca25c")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:8776/v1/45ca25c")
+               (:id . "3698a28")
+               (:public-url . "http://192.168.1.9:8776/v1/45ca25c")))
+             (:endpoints-links) (:type . "volume") (:name . "cinder"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:8773/services/Admin")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:8773/services/Cloud")
+               (:id . "aa700cc")
+               (:public-url . "http://192.168.1.9:8773/services/Cloud")))
+             (:endpoints-links) (:type . "ec2") (:name . "ec2"))
+            ((:endpoints
+              ((:admin-url . "http://192.168.1.9:35357/v2.0")
+               (:region . "RegionOne")
+               (:internal-url . "http://192.168.1.9:5000/v2.0")
+               (:id . "2c04749")
+               (:public-url . "http://192.168.1.9:5000/v2.0")))
+             (: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
+                            fundamental-character-output-stream)
+  ((mock-requests :accessor mock-request-stream
+                  :initform nil)
+   (mock-responses-location :initform 0
+                           :accessor mock-response-location)
+   (mock-responses :accessor mock-response-stream
+                   :initform nil)))
+
+
+(defmethod stream-read-byte ((stream mock-http-stream))
+  (if (<= (length (mock-response-stream stream))
+           (mock-response-location stream))
+      :eof
+      (prog1
+          (aref (mock-response-stream stream) (mock-response-location stream))
+        (incf (mock-response-location stream)))))
+
+(defmethod stream-write-byte ((stream mock-http-stream) byte)
+  (push byte (mock-request-stream stream)))
+
+(defmethod stream-write-char ((stream mock-http-stream) char)
+  (push char (mock-request-stream stream)))
+
+(defun make-mock-http-stream (&optional (stream (make-instance 'mock-http-stream)))
+  (make-flexi-stream (make-chunked-stream stream) :external-format +latin-1+))
+
+(defun mock-response (stream code &key headers content)
+  (setf (mock-response-stream stream)
+        (string-to-octets
+         (with-output-to-string (http-stream)
+           (labels ((write-http-line (fmt &rest args)
+                      (format http-stream "~?~C~C" fmt args #\Return #\Linefeed))
+                    (write-header (name value-fmt &rest value-args)
+                      (write-http-line "~A: ~?" name value-fmt value-args)))
+             (write-http-line "HTTP/1.1 ~D" code)
+             (loop :for (header . value) :in headers
+                   :do (write-header header "~A" value))
+             (write-header "Content-Type" "~A" "application/json")
+             (write-header "Content-Length" "~D" (length content))
+             (write-header "Connection" "~A" "close")
+             (format http-stream "~C~C" #\Return #\Linefeed)
+             (write-string content http-stream))))))
+
+(defun read-status-line (stream)
+  (let* ((line (or (chunga:read-line* stream)
+                   (error "No status line")))
+         (first-space-pos (or (position #\Space line :test #'char=)
+                              (error "No space in status line ~S." line)))
+         (second-space-pos (position #\Space line
+                                     :test #'char=
+                                     :start (1+ first-space-pos))))
+    (list
+     (cond ((string-equal line "POST" :end1 first-space-pos) :post)
+           ((string-equal line "GET" :end1 first-space-pos) :get)
+           ((string-equal line "DELETE" :end1 first-space-pos) :delete)
+           ((string-equal line "PUT" :end1 first-space-pos) :put)
+           ((string-equal line "PATCH" :end1 first-space-pos) :patch)
+           (t (error "Unknown protocol in ~S." line)))
+     (cond ((string-equal line "HTTP/1.0" :start1 (1+ second-space-pos)) :http/1.0)
+           ((string-equal line "HTTP/1.1" :start1 (1+ second-space-pos)) :http/1.1)
+           (t (error "Unknown protocol in ~S." line)))
+     (subseq line (1+ first-space-pos) second-space-pos))))
+
+(defmethod read-mock-request ((stream mock-http-stream))
+  "Read a request out of a MOCK-HTTP-STREAM.  The result is a list in
+form (parsed-status-line headers contents)"
+  (let ((http-stream (make-in-memory-input-stream
+                      (reverse
+                       (slot-value stream 'mock-requests)))))
+    (destructuring-bind (method protocol uri)
+        (read-status-line http-stream)
+      (let ((headers (read-http-headers http-stream)))
+        (list (list :method method :protocol protocol :uri uri)
+              headers
+              (when (header-value :content-length headers)
+                (let ((result (make-array (parse-integer (header-value :content-length headers))
+                                          :element-type 'octet)))
+                  (read-sequence result http-stream)
+                  (octets-to-string result))))))))
+
+
+(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+)))
+     ,@body))
+
+
+(defun is-valid-request (stream method uri &optional content)
+  (destructuring-bind (status headers content1)
+      (read-mock-request stream)
+    (is (equal content1
+               content))
+    (when (header-value :content-length headers)
+      (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 (string-equal (getf status :uri) uri))))