diff --git a/frontend/src/arthur/events/footage.cljs b/frontend/src/arthur/events/footage.cljs index a88f926..7a25a0a 100644 --- a/frontend/src/arthur/events/footage.cljs +++ b/frontend/src/arthur/events/footage.cljs @@ -334,12 +334,32 @@ (.catch (fn [error] (rf/dispatch [::failed (or (ex-message error) (str error))]))))) +(defn- sending + "A progress callback that puts the whole percentage sent in the status line. + + ONLY WHEN THE PERCENTAGE MOVES. The browser fires upload progress as often as + it pleases and a status line has something new to say a hundred times at most, + and each dispatch here re-renders the pane. + + Worth having at all because the transfer is the longest part of an import on + anything but a local server, and it was the part with no number on it: + `uploading video…` sat unchanged from the first byte to the last, however many + there were, and only the extraction that followed it ever counted. See + `arthur.fx.http/POST-form`." + [label] + (let [reported (atom -1)] + (fn [fraction] + (let [percent (js/Math.round (* 100 fraction))] + (when (not= percent @reported) + (reset! reported percent) + (rf/dispatch [::progress (str label " " percent "%")])))))) + (rf/reg-fx ::upload! (fn [file] (let [form (js/FormData.)] (.append form "file" file) - (-> (http/POST-form "/api/sources" form) + (-> (http/POST-form "/api/sources" form (sending "uploading video…")) (.then (fn [^js source] (rf/dispatch [::progress "queued for extraction…"]) (http/POST "/api/extractions" #js {:source (.-id source) @@ -353,7 +373,7 @@ (fn [file] (let [form (js/FormData.)] (.append form "file" file) - (-> (http/POST-form "/api/sounds" form) + (-> (http/POST-form "/api/sounds" form (sending "uploading sound…")) (.then (fn [^js sound] (rf/dispatch [::uploaded (.-id sound) "sound imported"]))) (.catch (fn [error] (rf/dispatch [::failed (or (ex-message error) (str error))]))))))) @@ -363,7 +383,7 @@ (fn [file] (let [form (js/FormData.)] (.append form "file" file) - (-> (http/POST-form "/api/images" form) + (-> (http/POST-form "/api/images" form (sending "uploading image…")) (.then (fn [^js image] (rf/dispatch [::uploaded (.-id image) "image imported"]))) (.catch (fn [error] (rf/dispatch [::failed (or (ex-message error) (str error))]))))))) diff --git a/frontend/src/arthur/fx/http.cljs b/frontend/src/arthur/fx/http.cljs index f4e3650..29d5ec5 100644 --- a/frontend/src/arthur/fx/http.cljs +++ b/frontend/src/arthur/fx/http.cljs @@ -19,17 +19,28 @@ (when (= "csrftoken" (str/trim (or k ""))) v))) (str/split (or (.-cookie js/document) "") #";"))) -(defn- fail +(defn- failure "Turn a non-2xx into an ex-info carrying what the server said. The server's message is the useful one — \"this clip names tier-2 blocks the server does not have\" — and a status code alone would put the interesting half - of it in a console nobody is watching." - [response body] - (throw (ex-info (or (some-> body .-error) - (str "the server answered " (.-status response))) - {:status (.-status response) - :body (when body (js->clj body :keywordize-keys true))}))) + of it in a console nobody is watching. + + Built rather than thrown, because the two transports below raise it in + different ways: `fetch` throws inside a `.then` and XHR has to reject a promise + by hand." + [status body] + (ex-info (or (some-> body .-error) + (str "the server answered " status)) + {:status status + :body (when body (js->clj body :keywordize-keys true))})) + +(defn- parse + "A response body as a parsed JS value, or nil. An empty 204 and a 500 whose + body is an HTML error page both land here, and neither is worth an exception." + [text] + (when (seq text) + (try (js/JSON.parse text) (catch :default _ nil)))) (defn request! ([method url] (request! method url nil)) @@ -47,14 +58,58 @@ (.then (fn [response] (-> (.text response) (.then (fn [text] - (let [parsed (when (seq text) - (try (js/JSON.parse text) (catch :default _ nil)))] + (let [parsed (parse text)] (if (.-ok response) parsed - (fail response parsed)))))))))))) + (throw (failure (.-status response) parsed))))))))))))) + +(defn POST-form + "A multipart POST, optionally reporting how much of the body has gone out. + + XMLHttpRequest RATHER THAN `fetch`, for the one thing fetch cannot do: a + Request built from a FormData gives no way to observe its own upload, so the + promise settles when the response arrives and everything before that is a + single unknown. On the one call that sends a whole video that unknown is + minutes long, and a spinner with no number on it is most of what \"slow\" means + to whoever is waiting — so this is worth the twenty lines XHR costs. + + `on-progress` is called with the fraction sent, 0.0 to 1.0. Only while the + browser can say what the total is: a body whose length it cannot compute + reports nothing rather than a made-up number. + + CONTENT-TYPE IS DELIBERATELY NOT SET. The browser has to write the multipart + boundary into it, and setting it by hand sends a body the server cannot parse." + ([url body] (request! "POST" url body)) + ([url body on-progress] + (js/Promise. + (fn [resolve reject] + (let [xhr (js/XMLHttpRequest.)] + (.open xhr "POST" url) + (.setRequestHeader xhr "Accept" "application/json") + (.setRequestHeader xhr "X-CSRFToken" (or (csrf-token) "")) + (set! (.. xhr -upload -onprogress) + (fn [^js event] + (when (and (.-lengthComputable event) (pos? (.-total event))) + (on-progress (/ (.-loaded event) (.-total event)))))) + (set! (.-onload xhr) + (fn [] + (let [parsed (parse (.-responseText xhr))] + (if (<= 200 (.-status xhr) 299) + (resolve parsed) + (reject (failure (.-status xhr) parsed)))))) + ;; The three ways a send produces no response at all. None of them has a + ;; status, so none of them can go through `failure` — and a dropped + ;; upload has to say so, because it is the one failure here that is + ;; routine rather than a bug. + (set! (.-onerror xhr) + (fn [_] (reject (ex-info "the upload did not reach the server" {})))) + (set! (.-onabort xhr) + (fn [_] (reject (ex-info "the upload was cancelled" {})))) + (set! (.-ontimeout xhr) + (fn [_] (reject (ex-info "the upload timed out" {})))) + (.send xhr body)))))) (defn GET [url] (request! "GET" url)) (defn POST [url body] (request! "POST" url body)) -(defn POST-form [url body] (request! "POST" url body)) (defn PUT [url body] (request! "PUT" url body)) (defn PATCH [url body] (request! "PATCH" url body))