Fix issues #32, #38, rest-json APIs in general and improve performance significantly

api.lisp

@@ -27,6 +27,11 @@
            #:aws-request))
 (in-package #:aws-sdk/api)
 
+(defvar *keep-alive* t
+  "Determines if HTTP connections use keep-alive. Only affects requests made via AWS-SDK/API:AWS-REQUEST.")
+(defvar *use-connection-pool* t
+  "Determines if HTTP connections are pooled. Only affects requests made via AWS-SDK/API:AWS-REQUEST.")
+
 (defun aws-request (req &key want-stream)
   (check-type req request)
   (let* ((session (request-session req))
@@ -37,18 +42,25 @@
       (error "No credentials are found"))
     (unless region
       (error "AWS region is not configured"))
-    (let ((aws-sign4:*aws-credentials* (lambda () (credentials-keys credentials)))
-          (headers (append (credentials-headers credentials)
-                           (request-headers req)))
-          (payload (request-payload req)))
+    (let* ((aws-sign4:*aws-credentials* (lambda () (credentials-keys credentials)))
+           (payload (request-payload req))
+           (payload-hash
+             `(("X-Amz-Content-Sha256" . ,(aws-sdk/utils::sha-256 (or payload "")))))
+           (headers (append (credentials-headers credentials)
+                            (request-headers req)
+                            payload-hash)))
       (multiple-value-bind (authorization x-amz-date)
           (let ((uri (quri:uri (request-path req))))
             (aws-sign4:aws-sign4 :region region
                                  :service (or (request-signing-name req) (request-service req))
                                  :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
@@ -57,8 +69,8 @@
                         :method (request-method req)
                         :headers `(("Authorization" . ,authorization)
                                    ("X-Amz-Date" . ,x-amz-date)
-                                   ("X-Amz-Content-Sha256" . ,(aws-sdk/utils::sha-256 (or payload "")))
                                    ,@headers)
                         :content payload
-                        :keep-alive nil
+                        :keep-alive *keep-alive*
+                        :use-connection-pool *use-connection-pool*
                         :want-stream want-stream)))))))

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)
+       (<= (get-universal-time)
+           (+ (token-created-at token) (token-ttl token)))))
+
+(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

@@ -24,6 +24,8 @@
   (:import-from #:uiop
                 #:string-prefix-p)
   (:import-from #:xmls)
+  (:import-from #:str
+                #:replace-using)
   (:export #:compile-operation))
 (in-package #:aws-sdk/generator/operation)
 
@@ -75,31 +77,58 @@
            :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 aws-sign4-uri-encode (data &optional path?)
+  (replace-using
+   (append
+    '(
+      ;; See https://docs.aws.amazon.com/IAM/latest/UserGuide/reference_sigv-create-signed-request.html
+      ;; and https://github.com/aws/aws-sdk-java/blob/d9d27d23607ddcf09cc25f48a9d2fbfe697fe60c/aws-java-sdk-core/src/main/java/com/amazonaws/util/SdkHttpUtils.java#L66
+      "+"   "%20"
+      "*"   "%2A"
+      "%7E" "~")
+    (when path?
+      '("%2F" "/"
+        ;; The replacement below is not documented, but empirically,
+        ;; we need this to get lambda INVOKE requests to be properly
+        ;; signed when using full ARN function identifiers. Also,
+        ;; Amazon Q says this should be the case, although it is not
+        ;; a source of authoritative specification.
+        "%3A" ":")))
+   (quri:url-encode data)))
 
 (defun compile-path-pattern (path-pattern)
   (when path-pattern
@@ -113,15 +142,15 @@
                   (push
                     (if plus-ends
                         `(slot-value input ',slot-symbol)
-                        `(quri:url-encode (slot-value input ',slot-symbol)))
+                        `(aws-sign4-uri-encode (slot-value input ',slot-symbol) t))
                     slots))))))
       (if slots
           `(lambda (input)
              (format nil ,(ppcre:regex-replace-all "{[^}]+}" path-pattern "~A")
                      ,@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 +170,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

@@ -10,6 +10,8 @@
                 #:query-request)
   (:import-from #:aws-sdk/json-request
                 #:json-request)
+  (:import-from #:aws-sdk/rest-json-request
+                #:rest-json-request)
   (:import-from #:aws-sdk/rest-xml-request
                 #:rest-xml-request)
   (:import-from #:yason)
@@ -33,7 +35,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 +110,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)
@@ -105,7 +108,7 @@
              (lambda (key-value)
                (destructuring-bind (key . value) key-value
                  `(when-let (value (slot-value input ',(lispify key)))
-                    (cons ,(gethash "locationName" value) value))))
+                    (cons (cons ,(gethash "locationName" value) value) nil))))
              (filter-member "location" "header" members))
           ,@(mapcar
              (lambda (key-value)
@@ -119,15 +122,26 @@
        (defmethod input-params ((input ,shape-name))
          (append
           ,@(loop for key being each hash-key of members
-                  using (hash-value value)
-                  if (not (or (gethash "location" value)
+                    using (hash-value value)
+                  if (not (or (string= "Payload" key)
+                              (gethash "location" value)
                               (gethash "streaming" value)))
-                  collect `(when-let (value (slot-value input ',(lispify key)))
-                             (list (cons ,key (input-params value)))))))
+                    collect `(when-let (value (slot-value input ',(lispify key)))
+                               (list (cons ,key (input-params value)))))))
        (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)))