diff --git a/src/main/lrsql/system/lrs.clj b/src/main/lrsql/system/lrs.clj index e1f5e14b..798fe661 100644 --- a/src/main/lrsql/system/lrs.clj +++ b/src/main/lrsql/system/lrs.clj @@ -36,6 +36,7 @@ [lrsql.util.oidc :as oidc-util] [lrsql.util.statement :as stmt-util] [lrsql.util :as util] + [lrsql.util.document :as doc-util] [lrsql.init.authority :refer [make-authority-fn]] [lrsql.system.util :refer [assert-config]] [lrsql.util.concurrency :refer [with-rerunable-txn]])) @@ -188,13 +189,28 @@ lrsp/DocumentResource (-set-document - [lrs _ctx _auth-identity params document merge?] - (let [conn (lrs-conn lrs) - input (doc-input/insert-document-input params document)] - (jdbc/with-transaction [tx conn] - (if merge? - (doc-cmd/upsert-document! backend tx input) - (doc-cmd/insert-document! backend tx input))))) + [lrs ctx _auth-identity params document merge?] + (let [conn (lrs-conn lrs) + input (doc-input/insert-document-input params document) + ;; Extract If-Match / If-None-Match headers from the request context + if-match (get-in ctx [:request :headers "if-match"]) + if-none-match (get-in ctx [:request :headers "if-none-match"])] + (jdbc/with-transaction [tx conn] + (if (or if-match if-none-match) + ;; Atomic etag validation: query + validate + write in one transaction + (let [query-input (doc-input/document-input params) + {:keys [document]} (doc-q/query-document backend tx query-input) + precond-err (doc-util/check-etag-precondition + if-match if-none-match document)] + (if precond-err + precond-err ;; returns {:error ex-info} — propagated as 412 + (if merge? + (doc-cmd/upsert-document! backend tx input) + (doc-cmd/insert-document! backend tx input)))) + ;; No etag headers — proceed directly + (if merge? + (doc-cmd/upsert-document! backend tx input) + (doc-cmd/insert-document! backend tx input)))))) (-get-document [lrs _ctx _auth-identity params] (let [conn (lrs-conn lrs) diff --git a/src/main/lrsql/util/document.clj b/src/main/lrsql/util/document.clj index bd82b280..1615733f 100644 --- a/src/main/lrsql/util/document.clj +++ b/src/main/lrsql/util/document.clj @@ -1,4 +1,71 @@ -(ns lrsql.util.document) +(ns lrsql.util.document + (:require [com.yetanalytics.lrs.xapi.document :as doc]) + (:import [java.security MessageDigest])) + +(defn compute-etag + "Compute an ETag (SHA-1 hex string) from document contents (byte array). + Matches the etag computation in the upstream LRS interceptor layer + (com.yetanalytics.lrs.util.hash/sha-1)." + ^String [^bytes contents] + (apply str + (map #(.substring + (Integer/toString + (+ (bit-and % 0xff) 0x100) 16) 1) + (.digest (MessageDigest/getInstance "SHA-1") + contents)))) + +(defn parse-etag-header + "Parse an If-Match or If-None-Match header value into a set of etag strings. + Strips surrounding quotes. Returns nil if header is nil." + [header-value] + (when header-value + (into #{} (re-seq #"\w+" header-value)))) + +(defn check-etag-precondition + "Validate If-Match / If-None-Match preconditions against the current document. + Returns nil if preconditions pass, or an error map if they fail. + + - `if-match`: If present, the request etag must match the current document's etag. + '*' means any document must exist. + - `if-none-match`: If present, the request etag must NOT match. + '*' means no document must exist. + - `current-doc`: The current document map from query-document (may have :contents), + or nil if no document exists." + [if-match if-none-match current-doc] + (let [current-etag (when-let [contents (:contents current-doc)] + (compute-etag (if (bytes? contents) + contents + (.getBytes (str contents) "UTF-8")))) + doc-exists? (some? current-doc)] + (cond + ;; If-Match validation + (and if-match (= if-match "*") (not doc-exists?)) + {:error (ex-info "Precondition Failed: If-Match * but no document exists" + {:type ::doc/precondition-failed})} + + (and if-match (not= if-match "*")) + (let [match-etags (parse-etag-header if-match)] + (when-not (and current-etag (contains? match-etags current-etag)) + {:error (ex-info "Precondition Failed: If-Match etag mismatch" + {:type ::doc/precondition-failed + :expected match-etags + :actual current-etag})})) + + ;; If-None-Match validation + (and if-none-match (= if-none-match "*") doc-exists?) + {:error (ex-info "Precondition Failed: If-None-Match * but document exists" + {:type ::doc/precondition-failed})} + + (and if-none-match (not= if-none-match "*")) + (let [none-match-etags (parse-etag-header if-none-match)] + (when (and current-etag (contains? none-match-etags current-etag)) + {:error (ex-info "Precondition Failed: If-None-Match etag matches" + {:type ::doc/precondition-failed + :rejected none-match-etags + :actual current-etag})})) + + ;; No precondition headers or all checks passed + :else nil))) (defn document-dispatch "Return either `:state-document`, `:agent-profile-document`, or diff --git a/src/test/lrsql/etag_race_test.clj b/src/test/lrsql/etag_race_test.clj new file mode 100644 index 00000000..57597a9c --- /dev/null +++ b/src/test/lrsql/etag_race_test.clj @@ -0,0 +1,211 @@ +(ns lrsql.etag-race-test + "Tests for atomic etag validation — verifying that the TOCTOU race + condition on document PUT/POST with If-Match headers is prevented." + (:require [clojure.test :refer [deftest testing is use-fixtures]] + [clojure.core.async :as a] + [com.stuartsierra.component :as component] + [com.yetanalytics.lrs.protocol :as lrsp] + [lrsql.test-support :as support] + [lrsql.test-constants :as tc]) + (:import [java.security MessageDigest])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Init +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(use-fixtures :once support/instrumentation-fixture) + +(use-fixtures :each support/fresh-db-fixture) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def auth-ident + {:agent {"objectType" "Agent" + "account" {"homePage" "http://example.org" + "name" "12341234-0000-4000-1234-123412341234"}} + :scopes #{:scope/all}}) + +(def state-params + {:stateId "race-test-state" + :activityId "https://example.org/race-activity" + :agent {"mbox" "mailto:racer@example.org"}}) + +(defn- make-doc [content] + (let [bs (.getBytes content "UTF-8")] + {:content-length (count bs) + :content-type "application/json" + :contents bs})) + +(defn- ctx-with-headers + "Build a ctx map with If-Match / If-None-Match request headers." + [& {:keys [if-match if-none-match]}] + (cond-> {:com.yetanalytics.lrs/version "1.0.3" + :request {:headers {}}} + if-match + (assoc-in [:request :headers "if-match"] if-match) + if-none-match + (assoc-in [:request :headers "if-none-match"] if-none-match))) + +(defn- compute-sha1 + "Compute SHA-1 hex string from bytes — matches the upstream LRS etag computation." + ^String [^bytes bs] + (apply str + (map #(.substring (Integer/toString (+ (bit-and % 0xff) 0x100) 16) 1) + (.digest (MessageDigest/getInstance "SHA-1") bs)))) + +(defn- get-etag + "Get the current etag for a document by reading it and computing SHA-1." + [lrs params] + (let [{:keys [document]} (lrsp/-get-document lrs tc/ctx auth-ident params)] + (when-let [contents (:contents document)] + (compute-sha1 (if (bytes? contents) + contents + (.getBytes (str contents) "UTF-8")))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest etag-precondition-basic-test + (testing "If-Match against existing document" + (let [sys (support/test-system) + sys' (component/start sys) + lrs (:lrs sys')] + (try + ;; Create initial document (no headers needed) + (lrsp/-set-document lrs tc/ctx auth-ident state-params + (make-doc "{\"v\":1}") false) + (let [etag (get-etag lrs state-params)] + (is (some? etag) "Document should exist and have an etag") + + (testing "matching etag allows write" + (let [result (lrsp/-set-document + lrs + (ctx-with-headers :if-match etag) + auth-ident state-params + (make-doc "{\"v\":2}") false)] + (is (nil? (:error result)) + "Write with matching etag should succeed"))) + + (testing "stale etag is rejected" + (let [result (lrsp/-set-document + lrs + (ctx-with-headers :if-match etag) + auth-ident state-params + (make-doc "{\"v\":3}") false)] + (is (some? (:error result)) + "Write with stale etag should be rejected")))) + (finally (component/stop sys'))))) + + (testing "If-None-Match * prevents overwrite" + (let [sys (support/test-system) + sys' (component/start sys) + lrs (:lrs sys')] + (try + ;; First write with If-None-Match * should succeed (no doc exists) + (let [result (lrsp/-set-document + lrs + (ctx-with-headers :if-none-match "*") + auth-ident state-params + (make-doc "{\"v\":1}") false)] + (is (nil? (:error result)) + "If-None-Match * on empty should succeed")) + + ;; Second write with If-None-Match * should fail (doc exists) + (let [result (lrsp/-set-document + lrs + (ctx-with-headers :if-none-match "*") + auth-ident state-params + (make-doc "{\"v\":2}") false)] + (is (some? (:error result)) + "If-None-Match * on existing doc should fail")) + (finally (component/stop sys')))))) + +(deftest etag-race-condition-test + (testing "concurrent PUT with same If-Match etag — only one should win" + (let [sys (support/test-system) + sys' (component/start sys) + lrs (:lrs sys') + num-threads 10] + (try + ;; Create initial document + (lrsp/-set-document lrs tc/ctx auth-ident state-params + (make-doc "{\"initial\":true}") false) + (let [etag (get-etag lrs state-params)] + (is (some? etag) "Should have initial etag") + + ;; Fire concurrent writes all using the same stale etag + (let [results + (let [result-chan (a/chan num-threads)] + (dotimes [i num-threads] + (a/thread + (let [res (try + (lrsp/-set-document + lrs + (ctx-with-headers :if-match etag) + auth-ident state-params + (make-doc (format "{\"writer\":%d}" i)) + false) + (catch Exception e + {:error e}))] + (a/>!! result-chan res)))) + (repeatedly num-threads #(a/!! result-chan res)))) + (repeatedly num-threads #(a/