Count the upload in the status line

The transfer is the longest part of an import on anything but a local
server, and it was the only 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. Most of what "slow"
means to whoever is waiting was a spinner of unknown length.

`fetch` cannot report this. A Request built from a FormData gives no way to
observe its own upload — the promise settles when the response arrives — so
`POST-form` gained an XMLHttpRequest arity, which is the one thing XHR can
still do that fetch cannot. `fail` became `failure`, building the ex-info
rather than throwing it, because the two transports raise it differently:
fetch throws inside a `.then` and XHR has to reject by hand.

`sending` dispatches only when the whole percentage moves, since the
browser fires progress as often as it pleases and each dispatch re-renders
the pane. Video, sound and image uploads all report.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
Your Name 2026-10-04 23:22:58 -04:00
parent e26ad723fa
commit a6b6c116c6
2 changed files with 89 additions and 14 deletions

View file

@ -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))])))))))

View file

@ -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))