Add the implementation to request in REST-XML format (ex. S3).

Author: fukamachi

api.lisp

@@ -48,7 +48,11 @@
                                  :method (request-method req)
                                  :host (request-host req region)
                                  :path (quri:uri-path uri)
-                                 :params (quri:uri-query-params uri)
+                                 :params (mapcar (lambda (kv)
+                                                   (if (null (cdr kv))
+                                                       (cons (car kv) "")
+                                                       kv))
+                                                 (quri:uri-query-params uri))
                                  :headers headers
                                  :payload (or payload "")))
         (multiple-value-list

generator/operation.lisp

@@ -75,31 +75,36 @@
            :status status
            :body body-str)))
 
-(defun parse-response (response body-type wrapper-name error-map)
+(defun parse-response (response body-type wrapper-name error-map &optional default-content-type)
   (destructuring-bind (body status headers &rest ignore-args)
       response
+    ;; TODO: Parse also from headers
     (declare (ignore ignore-args))
-    (let ((content-type (gethash "content-type" headers)))
+    (let ((content-type (or (gethash "content-type" headers)
+                            default-content-type)))
       (if (<= 400 status 599)
           (parse-response-error body status content-type error-map)
-          (if (equal body-type "blob")
-              body
-              (let ((body-str (ensure-string (or body ""))))
-                (cond
-                  ((or (string-prefix-p "text/xml" content-type)
-                       (string-prefix-p "application/xml" content-type))
-                   (let* ((output (xmls-to-alist (xmls:parse-to-list body-str)))
-                          (output ;; Unwrap the root element
-                            (cdr (first output))))
-                     (if wrapper-name
-                         (values (aget output wrapper-name)
-                                 (aget output "ResponseMetadata"))
-                         output)))
-                  ((member content-type '("application/json" "application/x-amz-json-1.1" "application/x-amz-json-1.0")
-                           :test #'string=)
-                   (yason:parse body-str :object-as :alist))
-                  (t
-                   body-str))))))))
+          (values
+           (if (equal body-type "blob")
+               body
+               (let ((body-str (ensure-string (or body ""))))
+                 (cond
+                   ((or (string-prefix-p "text/xml" content-type)
+                        (string-prefix-p "application/xml" content-type))
+                    (let* ((output (xmls-to-alist (xmls:parse-to-list body-str)))
+                           (output ;; Unwrap the root element
+                             (cdr (first output))))
+                      (if wrapper-name
+                          (values (aget output wrapper-name)
+                                  (aget output "ResponseMetadata"))
+                          output)))
+                   ((member content-type '("application/json" "application/x-amz-json-1.1" "application/x-amz-json-1.0")
+                            :test #'string=)
+                    (yason:parse body-str :object-as :alist))
+                   (t
+                    body-str))))
+           status
+           headers)))))
 
 (defun compile-path-pattern (path-pattern)
   (when path-pattern
@@ -121,7 +126,7 @@
                      ,@slots))
           path-pattern))))
 
-(defun compile-operation (service name options params body-type error-map)
+(defun compile-operation (service name options params body-type error-map protocol)
   (let* ((output (gethash "output" options))
          (method (gethash "method" (gethash "http" options)))
          (request-uri (gethash "requestUri" (gethash "http" options))))
@@ -141,7 +146,10 @@
                   ,body-type
                   ,(and output
                         (gethash "resultWrapper" output))
-                  ,error-map)))
+                  ,error-map
+                  ,(case protocol
+                     ((:json :rest-json) "application/json")
+                     (:rest-xml "application/xml")))))
              (export ',(lispify name))))
         `(progn
            (defun ,(lispify name) ()

generator/service.lisp

@@ -108,7 +108,8 @@
                                                      (find-output-type
                                                       (gethash+ `("shapes" ,(gethash "shape" shape)) hash))))))
                                    (find-output-type payload-shape))))
-                          (intern (string :*error-map*)))))
+                          (intern (string :*error-map*))
+                          protocol)))
         (force-output stream)))))
 
 (defun dump-service-base-file-to-stream (service service-dir &optional (stream *standard-output*))

generator/shape.lisp

@@ -39,6 +39,8 @@
   (:method (input) input))
 (defgeneric input-headers (input))
 (defgeneric input-payload (input))
+(defgeneric input-payload-properties (input)
+  (:method (input) (declare (ignore input)) nil))
 
 (defun add-query-with-input (uri input)
   (quri:make-uri :defaults uri
@@ -55,15 +57,16 @@
 (defun make-request-with-input (request-class input method path-conversion action)
   (make-instance request-class
                  :method method
-                 :path (quri:uri-path (add-query-with-input
-                                        (etypecase path-conversion
-                                          (string path-conversion)
-                                          (function (funcall path-conversion input))
-                                          (null "/"))
-                                        input))
+                 :path (quri:render-uri (add-query-with-input
+                                         (etypecase path-conversion
+                                           (string path-conversion)
+                                           (function (funcall path-conversion input))
+                                           (null "/"))
+                                         input))
                  :params (input-params input)
                  :headers (input-headers input)
                  :payload (input-payload input)
+                 :payload-properties (input-payload-properties input)
                  :operation action))
 
 (defun filter-member (key value members)
@@ -127,7 +130,17 @@
        (defmethod input-payload ((input ,shape-name))
          ,(if payload
               `(slot-value input ',(lispify payload))
-              'nil)))))
+              'nil))
+       ,@(when (and payload
+                    (gethash payload members))
+           (let ((props (gethash payload members)))
+             `((defmethod input-payload-properties ((input ,shape-name))
+                 (declare (ignore input))
+                 (list ,@(and (gethash "locationName" props)
+                              `(:location-name ,(gethash "locationName" props)))
+                       ,@(and (gethash "xmlNamespace" props)
+                              (gethash "uri" (gethash "xmlNamespace" props))
+                              `(:xml-namespace ,(gethash "uri" (gethash "xmlNamespace" props))))))))))))
 
 (defun compile-exception-shape (name &key members exception)
   (let ((condition-name (lispify* name)))

request.lisp

@@ -62,6 +62,9 @@
    (payload :initarg :payload
             :initform nil
             :accessor request-payload)
+   (payload-properties :initarg :payload-properties
+                       :initform nil
+                       :accessor request-payload-properties)
    (session :initarg :session
             :initform *session*
             :reader request-session)))

rest-xml-request.lisp

@@ -3,21 +3,44 @@
   (:import-from #:aws-sdk/request
                 #:request
                 #:request-headers
-                #:request-path)
+                #:request-path
+                #:request-payload)
   (:import-from #:aws-sdk/session
                 #:*session*)
+  (:import-from #:xml-emitter)
   (:export #:rest-xml-request))
 (in-package #:aws-sdk/rest-xml-request)
 
 (defclass rest-xml-request (request)
   ())
 
+(defun object-to-xml (object location-name &optional xml-namespace)
+  (assert location-name)
+  (typecase object
+    (null)
+    ;; XXX: Should see if it's flattened or not.
+    (cons (map nil (lambda (obj) (object-to-xml obj location-name))
+               object))
+    (standard-object
+     (xml-emitter:with-simple-tag (location-name nil xml-namespace)
+       (loop for slot in (c2mop:class-direct-slots (class-of object))
+             for value = (slot-value object (c2mop:slot-definition-name slot))
+             for tag-name = (or (aws-sdk/generator/shape::member-slot-location-name slot)
+                                (aws-sdk/generator/shape::member-slot-shape slot))
+             when value
+             do (if tag-name
+                    (object-to-xml value tag-name)
+                    (xml-emitter:xml-out value)))))
+    (otherwise
+     (xml-emitter:simple-tag location-name object nil xml-namespace))))
 
-(defmethod initialize-instance :after ((req rest-xml-request) &rest args &key params path &allow-other-keys)
+(defmethod initialize-instance :after ((req rest-xml-request) &rest args &key path payload payload-properties &allow-other-keys)
   (declare (ignore args))
-  (let ((uri (quri:uri path)))
-    (setf (request-path req)
-          (quri:render-uri
-           (quri:make-uri :path (quri:uri-path uri)
-                          :query (quri:url-encode-params (append (quri:uri-query-params uri)
-                                                                 params)))))))
+  (when (typep payload 'standard-object)
+    (destructuring-bind (&key location-name xml-namespace)
+        payload-properties
+      (setf (request-payload req)
+            (with-output-to-string (s)
+              (xml-emitter:with-xml-output (s :encoding "UTF-8")
+                (object-to-xml payload location-name xml-namespace))))))
+  (setf (request-path req) path))