Merge branch 'multi-object-delete'

crypto.lisp

@@ -79,6 +79,10 @@
 (defun file-md5/hex (file)
   (ironclad:byte-array-to-hex-string (file-md5 file)))
 
+(defun vector-md5/b64 (vector)
+  (base64:usb8-array-to-base64-string
+   (ironclad:digest-sequence :md5 vector)))
+
 (defun file-etag (file)
   (format nil "\"~A\"" (file-md5/hex file)))
 

doc/index.html

@@ -1351,12 +1351,15 @@ <h2>Contents</h2>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
     </span>
-    <span class='result'>=> |</span>
+    <span class='result'>=> <var>deleted-count</var>, <var>errors</var></span>
   </div>
 
   <blockquote class='description'>
     <p>Deletes <var>keys</var>, which should be a sequence of keys,
-    from <var>bucket</var>.
+    from <var>bucket</var>. The primary value is the number of objects
+    deleted. The secondary value is a list of error plists; if there
+    are no errors deleting any of the keys, the secondary value is
+    NIL.
   </blockquote>
 </div>
 

interface.lisp

@@ -459,14 +459,56 @@ constraint."
                                  :bucket bucket
                                  :key key)))
 
+(defun bulk-delete-document (keys)
+  (cxml:with-xml-output (cxml:make-octet-vector-sink)
+    (cxml:with-element "Delete"
+      (dolist (key keys)
+        (cxml:with-element "Object"
+          (cxml:with-element "Key"
+            (cxml:text key)))))))
+
+(defparameter *delete-objects-binder*
+  (make-binder '("DeleteResult"
+                 (sequence :results
+                  (alternate
+                   ("Deleted"
+                    ("Key" (bind :deleted-key)))
+                   ("Error"
+                    ("Key" (bind :error-key))
+                    ("Code" (bind :error-code))
+                    ("Message" (bind :error-message))))))))
+
 (defun delete-objects (bucket keys &key
                        ((:credentials *credentials*) *credentials*))
-  "Delete the objects in BUCKET identified by KEYS."
-  (map nil
-       (lambda (key)
-         (delete-object bucket key))
-       keys)
-  (length keys))
+  "Delete the objects in BUCKET identified by the sequence KEYS."
+  (let ((deleted 0)
+        (failed '())
+        (subseqs (floor (length keys) 1000)))
+    (flet ((bulk-delete (keys)
+             (unless (<= (length keys) 1000)
+               (error "Can only delete 1000 objects per request."))
+             (let* ((content (bulk-delete-document keys))
+                    (md5 (vector-md5/b64 content)))
+               (let* ((response
+                       (submit-request (make-instance 'request
+                                                      :method :post
+                                                      :sub-resource "delete"
+                                                      :bucket bucket
+                                                      :content content
+                                                      :content-md5 md5)))
+                      (bindings (xml-bind *delete-objects-binder*
+                                          (body response)))
+                      (results (bvalue :results bindings)))
+                 (dolist (result results (values deleted failed))
+                   (if (bvalue :deleted-key result)
+                       (incf deleted)
+                       (push result failed)))))))
+      (loop for start from 0 by 1000
+              for end = (+ start 1000)
+              repeat subseqs do
+              (bulk-delete (subseq keys start end)))
+        (bulk-delete (subseq keys (* subseqs 1000)))
+        (values deleted failed))))
 
 (defun delete-all-objects (bucket &key
                            ((:credentials *credentials*) *credentials*))

xml-binding.lisp

@@ -74,7 +74,7 @@ alist of element names and their character contents."
 
 ;;; Match failure conditions
 
-(define-condition xml-binding-error ()
+(define-condition xml-binding-error (error)
   ((expected
     :initarg :expected
     :accessor expected)
@@ -164,25 +164,31 @@ effectively ending matching."
     (declare (ignore source k))
     (nreverse bindings)))
 
+(defmacro catching-xml-errors (&body body)
+  `(handler-case
+       (progn ,@body)
+     (xml-binding-error (c)
+       (values nil c))))
+
 (defun create-sequence-binder (key forms kk)
   "Return a function that creates a list of sub-bindings based on a
 sub-matcher, with KEY as the key."
-  (let ((binder (create-binder forms (create-bindings-returner)))
-        (element-name (first forms)))
+  (let ((binder (create-binder forms (create-bindings-returner))))
     (lambda (source bindings k)
       (let ((sub-bindings '()))
         (loop
-         (skip-characters source)
-         (multiple-value-bind (type uri lname)
-             (klacks:peek source)
-           (declare (ignore uri))
-           (unless (and (eql type :start-element)
-                        (string= lname element-name))
-             (return (funcall kk source (acons key
-                                               (nreverse sub-bindings)
-                                               bindings)
-                              k))))
-         (push (funcall binder source nil k) sub-bindings))))))
+          (skip-characters source)
+          (multiple-value-bind (sub-binding failure)
+              (catching-xml-errors
+                (funcall binder source nil k))
+            (if failure
+                (return (funcall kk
+                                 source
+                                 (acons key
+                                        (nreverse sub-bindings)
+                                        bindings)
+                                 k))
+                (push sub-binding sub-bindings))))))))
 
 (defun create-alist-binder (key kk)
   "Return a function that returns the rest of SOURCE as an alist of
@@ -193,26 +199,32 @@ element-name/element-content data."
              k)))
 
 (defun create-optional-binder (subforms kk)
-  (let ((binder (create-binder subforms kk))
-        (element-name (first subforms)))
+  (let ((binder (create-binder subforms kk)))
     (lambda (source bindings k)
       (skip-characters source)
-      (multiple-value-bind (type uri lname)
-          (klacks:peek source)
-        (declare (ignore uri))
-        (cond ((and (eql type :start-element)
-                    (string= element-name lname))
-               (funcall binder
-                        source
-                        bindings
-                        k))
-              (t (funcall kk source bindings k)))))))
-
+      (multiple-value-bind (optional-bindings failure)
+          (catching-xml-errors (funcall binder source bindings k))
+        (if failure
+            (funcall kk source bindings k)
+            optional-bindings)))))
+
+(defun create-alternate-binder (subforms kk)
+  (let ((binders (mapcar (lambda (form) (create-binder form kk)) subforms)))
+    (lambda (source bindings k)
+      ;; FIXME: This xml-binding-error needs :expected and :action
+      ;; ooptions. Can get actual with peeking and expected by getting
+      ;; the cl:cars of subforms...maybe.
+      (dolist (binder binders (error 'xml-binding-error))
+        (multiple-value-bind (alt-bindings failure)
+            (catching-xml-errors (funcall binder source bindings k))
+          (unless failure
+            (return alt-bindings)))))))
 
 (defun create-special-processor (operator form k)
   "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE,
 etc."
   (ecase operator
+    (alternate (create-alternate-binder (rest form) k))
     (bind (create-bindings-extender (second form) k))
     (optional (create-optional-binder (second form) k))
     (skip-rest (create-skipper *current-element-name* k))
@@ -258,6 +270,15 @@ process an XML source."
 (defun xml-bind (binder source)
   (funcall binder source))
 
+(defun try-to-xml-bind (binder source)
+  "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors
+  are caught, NIL is the primary value and the error object is the
+  secondary value."
+  (handler-case
+      (xml-bind binder source)
+    (xml-binding-error (c)
+      (values nil c))))
+
 (defun xml-document-element (source)
   (nth-value 2 (klacks:find-event (xml-source source) :start-element)))