x/cl-openstack-client
Code Issues Proposed changes

Initial partial keystone API implementation

Browse Source 
Change-Id: I25b216936cd902bc9cf05dee517859fd1756f751
This commit is contained in:
Russell Sim 2013-10-17 16:13:56 +11:00
parent 210ded8b38
commit 2b75f1821d
8 changed files with 802 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
cl-openstack-client-test.asd
View File

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

5
cl-openstack-client.asd
View File

@ -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"))))

481
keystone.lisp
View File

@ -1,9 +1,23 @@
(defpackage cl-keystone-client
(:use cl cl-json drakma)
(:import-from :local-time
:parse-timestring
:timestamp>
:now)
(:use cl drakma)
(:import-from #:cl-openstack-client
#:assoc*)
(:import-from #:local-time
#: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))
:code (cdr (assoc :code error-message)))))
: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."
@ -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
((and (eql status-code 200)
(json-response-p headers))
(setf token
(cdr (assoc :token (cdr (assoc :access (decode-json stream)))))))
((json-response-p headers)
(json-error (decode-json stream)))
(t
(unknown-error uri status-code))))))
(handle-http-error uri status-code headers stream)
(let ((access (assoc* :access (decode-json stream))))
(setf user (assoc* :user access))
(setf service-catalog (assoc* :service-catalog access))
(setf tenant (assoc* :tenant access))
(setf metadata (assoc* :metadata access))
(setf token (assoc* :token access)))))
connection)
(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)))

11
openstack.lisp Normal file
View File

@ -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)))

2
requirements.txt
View File

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

4
test-requirements.txt
View File

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

173
tests/keystone.lisp
View File

@ -1,26 +1,27 @@
(defpackage cl-keystone-client.test
(:use fiveam
cl
trivial-gray-streams
cl-keystone-client)
(:import-from :local-time
:encode-timestamp
:timestamp-to-unix
:timestamp=
:timestamp+
:format-timestring
:now
:+utc-zone+)
(:import-from #:drakma
#:header-value)
(:import-from #:cl-openstack-client.test
#:connection-fixture
#:with-mock-http-stream
#:make-mock-http-stream
#:mock-response
#: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)
(:import-from :flexi-streams
:string-to-octets
:make-flexi-stream
:octets-to-string)
(:import-from :drakma
:+latin-1+)
(:import-from :chunga
:make-chunked-stream))
#:regex-replace-all))
(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))
(cl-keystone-client::*cached-stream*
(make-flexi-stream (make-chunked-stream mock-stream)
:external-format +latin-1+)))
(with-mock-http-stream (mock-stream)
(mock-response mock-stream
"HTTP/1.1 404 Not Found
Vary: X-Auth-Token
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\"}}
")
404
:content "{\"error\": {\"message\": \"The resource could not be found.\", \"code\": 404, \"title\": \"Not Found\"}}")
(handler-case
(authenticate (make-instance 'connection-v2
:tenant-name "test"
:url "http://test"
:username "test"
:password "test"))
(authenticate (make-instance 'connection-v2
:tenant-name "test"
:url "http://test:33"
:username "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")))))

225
tests/openstack.lisp
View File

@ -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))))