Document Routes: support delegation of ETag Compare-And-Swap to implementation

src/main/com/yetanalytics/lrs/pedestal/interceptor.cljc

@@ -10,6 +10,7 @@
             [io.pedestal.http.body-params :as body-params]
             [io.pedestal.http.ring-middlewares :as middlewares]
             [com.yetanalytics.lrs.pedestal.interceptor.xapi :as xapi]
+            [com.yetanalytics.lrs.xapi.document :as doc]
             [com.yetanalytics.lrs.util.hash :refer [sha-1]]
             [com.yetanalytics.lrs.pedestal.interceptor.xapi.statements :as si]
             [xapi-schema.spec :as xs :include-macros true]
@@ -182,13 +183,12 @@
 (defn calculate-etag [x]
   (sha-1 x))
 
-;; TODO: handle weak etags
 (def etag-string-pattern
-  #"\w+")
+  doc/etag-string-pattern)
 
 (defn etag-header->etag-set
   [etag-header]
-  (into #{} (re-seq etag-string-pattern etag-header)))
+  (doc/etag-header->etag-set etag-header))
 
 (defn- quote-etag [etag]
   (str "\"" etag "\""))

src/main/com/yetanalytics/lrs/pedestal/routes/documents.cljc

@@ -4,6 +4,7 @@
             [com.yetanalytics.lrs.protocol :as p]
             [com.yetanalytics.lrs.pedestal.interceptor :as i]
             [com.yetanalytics.lrs.pedestal.interceptor.xapi :as xi]
+            [com.yetanalytics.lrs.xapi.document :as doc]
             [clojure.spec.alpha :as s :include-macros true]
             [clojure.core.async :as a :include-macros true]
             #?(:clj [cheshire.core :as json])))
@@ -155,39 +156,24 @@
       :xapi.agents.profile.GET.request/params))))
 
 (defn etags-preproc
-  "Process if-match rules and etags for the handler. Will call `handle-get`
-   to check doc state."
+  "Normalize ETag preconditions for document mutations. Implementations that
+   opt into atomic validation receive them directly; other implementations use
+   the preliminary `handle-get` check before receiving them."
   [enter-fn]
   (fn wrap-enter
     [{:keys [xapi
              request
              com.yetanalytics/lrs] :as ctx}]
-    (let [;; Destructuring
-          {:keys [headers]} request
-          ;; VSCode incorrectly marks `if-match` and `if-none-match` as
-          ;; if macros
-          {hif-match      "if-match"
-           hif-none-match "if-none-match"} headers
-          ;; Helper fns
-          hif-match-ok?
-          (fn [ctx hif-match]
-            (case hif-match
-              nil true
-              "*" (= 200 (get-in ctx [:response :status]))
-              ;; else
-              (contains? (i/etag-header->etag-set hif-match)
-                         (::i/etag ctx))))
-          hif-none-match-ok?
-          (fn [ctx hif-none-match]
-            (case hif-none-match
-              nil true
-              "*" (= 404 (get-in ctx [:response :status]))
-              ;; else
-              (not (contains? (i/etag-header->etag-set hif-none-match)
-                              (::i/etag ctx)))))]
-      (if (= nil hif-match hif-none-match)
-        ;; If no headers provided, go ahead
-        (enter-fn ctx)
+    (let [preconditions (doc/parse-etag-preconditions
+                         (get request :headers))
+          operation-ctx (cond-> ctx
+                          (seq preconditions)
+                          (assoc ::doc/preconditions preconditions))]
+      (if (or (empty? preconditions)
+              (p/atomic-document-preconditions? lrs))
+        ;; No condition to validate, or the implementation validates it
+        ;; authoritatively while applying the mutation.
+        (enter-fn operation-ctx)
         (let [;; TODO: Params overhaul, very silly rn
               get-params-enter   (get-params-enter-fn xapi)
               {get-enter :enter
@@ -202,10 +188,14 @@
                         get-params-enter
                         get-enter
                         a/<!
-                        get-leave)]
-                (if (and (hif-match-ok? get-ctx hif-match)
-                         (hif-none-match-ok? get-ctx hif-none-match))
-                  (a/<! (enter-fn ctx))
+                        get-leave)
+                    status (get-in get-ctx [:response :status])]
+                (if (and (contains? #{200 404} status)
+                         (doc/etag-preconditions-met?
+                          preconditions
+                          {:exists? (= 200 status)
+                           :etag    (::i/etag get-ctx)}))
+                  (a/<! (enter-fn operation-ctx))
                   (assoc ctx :response
                          (let [{{:keys [status] :as get-response} :response}
                                get-ctx]
@@ -219,10 +209,14 @@
                       (assoc-in [:request :request-method] :get)
                       get-params-enter
                       get-enter
-                      get-leave)]
-              (if (and (hif-match-ok? get-ctx hif-match)
-                       (hif-none-match-ok? get-ctx hif-none-match))
-                (enter-fn ctx)
+                      get-leave)
+                  status (get-in get-ctx [:response :status])]
+              (if (and (contains? #{200 404} status)
+                       (doc/etag-preconditions-met?
+                        preconditions
+                        {:exists? (= 200 status)
+                         :etag    (::i/etag get-ctx)}))
+                (enter-fn operation-ctx)
                 (assoc ctx :response
                        (let [{{:keys [status] :as get-response} :response}
                              get-ctx]
@@ -237,11 +231,9 @@
 (defn put-response
   [ctx {:keys [error]}]
   (if error
-    (let [exd (ex-data error)]
-      (if (#{:com.yetanalytics.lrs.xapi.document/precondition-failed}
-           (:type exd))
-        (assoc ctx :response {:status 412})
-        (assoc ctx :io.pedestal.interceptor.chain/error error)))
+    (if (doc/precondition-failed? error)
+      (assoc ctx :response {:status 412})
+      (assoc ctx :io.pedestal.interceptor.chain/error error))
     (assoc ctx :response {:status 204})))
 
 
@@ -380,8 +372,7 @@
   (if error
     (let [exd (ex-data error)]
       (cond
-        (#{:com.yetanalytics.lrs.xapi.document/precondition-failed}
-         (:type exd))
+        (doc/precondition-failed? error)
         (assoc ctx :response {:status 412})
 
         (#{:com.yetanalytics.lrs.xapi.document/json-read-error
@@ -439,7 +430,9 @@
 (defn delete-response
   [ctx {:keys [error]}]
   (if error
-    (assoc ctx :io.pedestal.interceptor.chain/error error)
+    (if (doc/precondition-failed? error)
+      (assoc ctx :response {:status 412})
+      (assoc ctx :io.pedestal.interceptor.chain/error error))
     (assoc ctx :response {:status 204})))
 
 (def handle-delete

src/main/com/yetanalytics/lrs/protocol.cljc

@@ -114,6 +114,22 @@
 (s/def ::document-resource-instance
   document-resource?)
 
+(defprotocol AtomicDocumentPreconditions
+  "Optional capability for document implementations that atomically validate
+   ETag preconditions while applying mutations."
+  (-atomic-document-preconditions? [this]
+    "Return true when document mutation preconditions are validated atomically
+     by this implementation."))
+
+(defn atomic-document-preconditions?
+  "Return true when `lrs` opts into authoritative atomic document precondition
+   validation. Implementations that do not implement the optional capability
+   return false."
+  [lrs]
+  (boolean
+   (and (satisfies? AtomicDocumentPreconditions lrs)
+        (-atomic-document-preconditions? lrs))))
+
 (s/def ::set-document-params
   (s/or :state
         (sc/with-conform-gen :xapi.document.state/id-params)

src/main/com/yetanalytics/lrs/xapi/document.cljc

@@ -89,6 +89,70 @@
       (sgen/one-of [(document-gen-fn)
                     (json-document-gen-fn)]))))
 
+;; TODO: Handle weak ETags.
+(def etag-string-pattern
+  #"\w+")
+
+(defn etag-header->etag-set
+  "Parse an ETag header value into a set of unquoted ETags."
+  [etag-header]
+  (into #{} (re-seq etag-string-pattern etag-header)))
+
+(s/def ::etag-condition
+  (s/or :wildcard #{:*}
+        :etags (s/coll-of string? :kind set?)))
+
+(s/def ::if-match ::etag-condition)
+(s/def ::if-none-match ::etag-condition)
+
+(s/def ::preconditions
+  (s/keys :opt-un [::if-match ::if-none-match]))
+
+(defn parse-etag-preconditions
+  "Parse If-Match and If-None-Match request headers into normalized
+   preconditions. Wildcards are represented by `:*`; other values are sets of
+   unquoted ETags."
+  [{if-match      "if-match"
+    if-none-match "if-none-match"}]
+  (cond-> {}
+    if-match
+    (assoc :if-match (if (= "*" if-match)
+                       :*
+                       (etag-header->etag-set if-match)))
+    if-none-match
+    (assoc :if-none-match (if (= "*" if-none-match)
+                            :*
+                            (etag-header->etag-set if-none-match)))))
+
+(defn etag-preconditions-met?
+  "Return true when normalized ETag `preconditions` are satisfied by the
+   current resource state. `exists?` indicates whether the resource exists;
+   `etag` is its unquoted ETag when available."
+  [{:keys [if-match if-none-match]}
+   {:keys [exists? etag]}]
+  (and (case if-match
+         nil true
+         :* exists?
+         (contains? if-match etag))
+       (case if-none-match
+         nil true
+         :* (not exists?)
+         (not (contains? if-none-match etag)))))
+
+(defn precondition-failed-error
+  "Return a document operation error indicating that an ETag precondition
+   failed. Optional `data` is included in the exception data."
+  ([]
+   (precondition-failed-error {}))
+  ([data]
+   {:error (ex-info "Document precondition failed"
+                    (assoc data :type ::precondition-failed))}))
+
+(defn precondition-failed?
+  "Return true when `error` represents a document precondition failure."
+  [error]
+  (= ::precondition-failed (:type (ex-data error))))
+
 (defn updated-stamp
   [document]
   (or

src/test/com/yetanalytics/lrs/impl/memory_test.cljc

@@ -2,7 +2,8 @@
   (:require [clojure.test :as test :refer [deftest is] :include-macros true]
             [clojure.spec.test.alpha :as stest :include-macros true]
             [com.yetanalytics.test-support :refer [failures stc-opts]]
-            [com.yetanalytics.lrs.impl.memory :as mem]))
+            [com.yetanalytics.lrs.impl.memory :as mem]
+            [com.yetanalytics.lrs.protocol :as p]))
 
 (deftest store-ref-test
   (is (empty?
@@ -95,4 +96,8 @@
   (is (empty?
        (failures
         (stest/check `mem/new-lrs
-                     {stc-opts {:num-tests 1}})))))
+                     {stc-opts {:num-tests 1}}))))
+  (doseq [mode [:sync :async :both]]
+    (is (false? (p/atomic-document-preconditions?
+                 (mem/new-lrs {:mode mode})))
+        (str "memory LRS mode " (name mode) " remains unopted"))))