Pull in Fukamachi's advances

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

credentials/ec2role.lisp

@@ -6,7 +6,8 @@
                 #:retrieve
                 #:provider-expiration)
   (:import-from #:aws-sdk/ec2metadata
-                #:ec2metadata)
+                #:ec2metadata
+                #:ec2token)
   (:import-from #:trivial-timeout
                 #:timeout-error)
   (:import-from #:cl-ppcre)
@@ -18,13 +19,44 @@
 (defclass ec2role-provider (provider)
   ())
 
+(defvar *default-token-ttl* 21600)
+(defvar *token* nil)
+(defvar *use-imds-v2* t)
+
+(defstruct token
+  (ttl *default-token-ttl* :type integer)
+  (value nil :type string)
+  (created-at (get-universal-time) :type integer))
+
+(defun token-alive-p (token)
+  (and (token-p token)
+       (<= (+ (token-created-at token) (token-ttl token))
+           (get-universal-time))))
+
+(defun fetch-token ()
+  (when *use-imds-v2*
+    (if (token-alive-p *token*)
+        (token-value *token*)
+        (handler-case
+            (let ((new-token (ec2token *default-token-ttl*)))
+              (setf *token* (make-token :value new-token))
+              new-token)
+          ((or dex:http-request-forbidden
+               dex:http-request-not-found
+               dex:http-request-method-not-allowed) ()
+            (setf *use-imds-v2* nil)
+            nil)))))
+
 (defmethod retrieve ((provider ec2role-provider))
   (handler-case
-      (let ((role (ppcre:scan-to-strings "^.+?(?=(?:[\\r\\n]|$))"
-                                         (ec2metadata "/iam/security-credentials/"))))
+      (let* ((token (fetch-token))
+             (role (ppcre:scan-to-strings "^.+?(?=(?:[\\r\\n]|$))"
+                                          (ec2metadata "/iam/security-credentials/"
+                                                       :token token))))
         (when role
           (let ((res (yason:parse
-                      (ec2metadata (format nil "/iam/security-credentials/~A" role)))))
+                      (ec2metadata (format nil "/iam/security-credentials/~A" role)
+                                   :token token))))
             (setf (provider-expiration provider)
                   (local-time:parse-timestring (gethash "Expiration" res)))
             (make-credentials

ec2metadata.lisp

@@ -5,13 +5,22 @@
                 #:with-timeout
                 #:timeout-error)
   (:export #:ec2metadata
+           #:ec2token
            #:ec2-region))
 (in-package #:aws-sdk/ec2metadata)
 
-(defun ec2metadata (path)
+(defun ec2metadata (path &key token)
   (with-timeout (5)
     (dex:get (format nil "http://169.254.169.254/latest/meta-data~A"
                      (or path "/"))
+             :headers `(,@(and token `(("x-aws-ec2-metadata-token" . ,token))))
+             :keep-alive nil)))
+
+(defun ec2token (ttl)
+  (check-type ttl (integer 1))
+  (with-timeout (5)
+    (dex:put "http://169.254.169.254/latest/api/token"
+             :headers `(("x-aws-ec2-metadata-token-ttl-seconds" . ,ttl))
              :keep-alive nil)))
 
 (defun ec2-region ()

generator/operation.lisp

@@ -75,31 +75,39 @@
            :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 (or (= status 204)
+                   (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))
+                    (if (string= body-str "")
+                        body-str
+                        (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 +129,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 +149,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

@@ -33,7 +33,7 @@
           (request-name (intern (format nil "~:@(~A-REQUEST~)" service))))
       (format stream "~&;; DO NOT EDIT: File is generated by AWS-SDK/GENERATOR.~2%")
       (format stream "~&~S~%"
-              `(defpackage ,package-name
+              `(uiop:define-package ,package-name
                  (:use)
                  (:nicknames ,(make-symbol (format nil "~:@(~A/~A~)" :aws service)))
                  (:import-from #:aws-sdk/generator/shape)
@@ -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 (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))