961 lines
43 KiB
Clojure
961 lines
43 KiB
Clojure
(ns arthur.events.project
|
|
"Save and open: the document over HTTP.
|
|
|
|
THE ORDER OF A SAVE IS THE TIER SPLIT, and it is not an arrangement of
|
|
convenience — each step is the precondition for the next one to be checkable:
|
|
|
|
1. the ANALYSIS record, so that every block stored afterwards can name the
|
|
detector version that produced it. The server refuses a block whose
|
|
analysis it does not know, for exactly that reason.
|
|
2. ask which BLOCKS are missing, and upload only those. A re-save after a
|
|
document edit moves kilobytes, which is the whole return on content
|
|
addressing.
|
|
3. the DOCUMENT. The server refuses a clip that names blocks it does not hold,
|
|
so a saved document cannot load into a blank stage somewhere else.
|
|
|
|
Open is the same order backwards: the document, then the blocks it names. It
|
|
needs no analysis step, because the document carries the analysis record — a
|
|
content address alone would make a take unreadable the first time a detector
|
|
upgrade orphaned one, and \"sha256:7f2…\" is not an answer to \"which model
|
|
produced this\".
|
|
|
|
Nothing here touches app-db except through events. The promise chain lives in an
|
|
fx, which is the only thing in this namespace that is not pure."
|
|
(:require [arthur.db :as db]
|
|
[arthur.domain.bring :as bring]
|
|
[arthur.domain.channel :as ch]
|
|
[arthur.domain.clip :as clip]
|
|
[arthur.domain.span :as span]
|
|
[arthur.domain.leaf :as leaf]
|
|
[arthur.domain.node :as node]
|
|
[arthur.domain.palette :as pal]
|
|
[arthur.events.edit :as edit]
|
|
[arthur.demo.stage :as stage]
|
|
[arthur.domain.feature :as feature]
|
|
[arthur.domain.project :as project]
|
|
[arthur.domain.wire :as wire]
|
|
[arthur.events.footage :as footage]
|
|
[arthur.events.playback :as pb]
|
|
[arthur.events.ui :as ui]
|
|
[arthur.footage.store :as store]
|
|
[arthur.flow.address :as address]
|
|
[arthur.flow.ingest :as ingest]
|
|
[arthur.flow.regenerate :as regenerate]
|
|
[arthur.flow.source :as source]
|
|
[arthur.flow.take :as take]
|
|
[arthur.fx.http :as http]
|
|
[arthur.synth :as synth]
|
|
[clojure.string :as str]
|
|
[re-frame.core :as rf]))
|
|
|
|
(defn- analysis-payload [analysis]
|
|
#js {:key (:id analysis)
|
|
:descriptor (address/analysis-descriptor analysis)
|
|
:footage (:footage analysis)})
|
|
|
|
(defn- block-keys [^js doc]
|
|
(into-array (map #(.-key %) (array-seq (.-blocks doc)))))
|
|
|
|
(defn- block-bytes [value]
|
|
(if (string? value)
|
|
(wire/bytes-of value)
|
|
(js/Uint8Array. (.-buffer value) (.-byteOffset value) (.-byteLength value))))
|
|
|
|
(defn- block-form [^js block]
|
|
(let [form (js/FormData.)]
|
|
(.append form "key" (.-key block))
|
|
(.append form "descriptor" (.-descriptor block))
|
|
(.append form "data" (js/Blob. #js [(block-bytes (.-data block))]) "block.bin")
|
|
(when-let [state (.-state block)]
|
|
(.append form "state" (js/Blob. #js [(block-bytes state)]) "state.bin"))
|
|
form))
|
|
|
|
(defn- upload-missing!
|
|
"POST the blocks the server said it does not have, and nothing else.
|
|
|
|
ONE AT A TIME. `Promise.all` over eleven uploads is the obvious way to write
|
|
this and it made sqlite answer \"database is locked\" on a save — which reaches
|
|
the page as a 500 with nothing wrong with the request. The backend was fixed too
|
|
(WAL, and a busy timeout, in server/settings.py), and this stays sequential
|
|
anyway: most uploads are small, and a burst of parallel writes to buy nothing
|
|
is how the same bug comes back the first time a take has sixty blocks instead
|
|
of eleven."
|
|
[^js doc]
|
|
(-> (http/POST "/api/blocks/missing" #js {:keys (block-keys doc)})
|
|
(.then (fn [^js answer]
|
|
(let [missing (set (array-seq (.-missing answer)))
|
|
todo (filterv #(contains? missing (.-key ^js %))
|
|
(array-seq (.-blocks doc)))]
|
|
(-> (reduce (fn [chain block]
|
|
(.then chain
|
|
(fn [_]
|
|
(http/POST-form "/api/blocks" (block-form block)))))
|
|
(js/Promise.resolve nil)
|
|
todo)
|
|
(.then (fn [_] (count todo)))))))))
|
|
|
|
(defn- ensure-project! [id name]
|
|
(if id
|
|
(js/Promise.resolve id)
|
|
(-> (http/POST "/api/projects" #js {:name name})
|
|
(.then (fn [^js created] (.-id created))))))
|
|
|
|
(defn- opened-entry! [^js clip-json]
|
|
(-> (js/Promise.all
|
|
(into-array (map #(http/GET (str "/api/blocks/" %))
|
|
(array-seq (.-blocks clip-json)))))
|
|
(.then (fn [blocks]
|
|
(let [cid (.-cid clip-json)
|
|
loaded (project/load
|
|
cid #js {:leaves (.-leaves clip-json)
|
|
:blocks blocks})
|
|
;; Project FPS and the root timeline are one clock. This
|
|
;; also normalizes documents saved by the earlier model,
|
|
;; where changing project FPS left the root on its old
|
|
;; editing grid.
|
|
built (-> (:clip loaded)
|
|
clip/pin-root
|
|
(clip/set-root-fps (:fps (:clip loaded))))]
|
|
(let [entry (merge (select-keys built [:fps :width :height])
|
|
{:label (str (or (.-name clip-json) cid) " (saved)")
|
|
:cid cid
|
|
;; What the server holds, as of the seq
|
|
;; this was opened at: a save sends what
|
|
;; differs from it, and a collaborator's
|
|
;; write lands on what does not.
|
|
:synced (project/tier1 (.-leaves clip-json))
|
|
:clip built :store (:store loaded)
|
|
;; The document's OWN file, unmixed. What
|
|
;; the symbol actually sounds like is the
|
|
;; clock's business and is fetched once,
|
|
;; by `::pb/clock!`, when it goes on
|
|
;; screen — this used to mix it here as
|
|
;; well, and the two encodes of the same
|
|
;; audio were most of a project open.
|
|
:audio "/static/arthur/audio.wav"})]
|
|
entry))))))
|
|
|
|
(defn- saved-clip!
|
|
"Promise of clip `cid` of saved project `pid`, as `{:clip :store}`: its
|
|
document and the blocks it names, and nothing played or mixed."
|
|
[pid cid]
|
|
(-> (http/GET (str "/api/projects/" pid))
|
|
(.then (fn [^js doc]
|
|
(let [^js c (or (first (filter #(= cid (.-cid ^js %)) (array-seq (.-clips doc))))
|
|
(throw (ex-info "that project no longer has that clip" {:cid cid})))]
|
|
(-> (js/Promise.all (into-array (map #(http/GET (str "/api/blocks/" %))
|
|
(array-seq (.-blocks c)))))
|
|
(.then (fn [blocks]
|
|
(project/load cid #js {:leaves (.-leaves c) :blocks blocks})))))))))
|
|
|
|
(rf/reg-fx
|
|
::import!
|
|
(fn [{:keys [project cid] :as request}]
|
|
(-> (saved-clip! project cid)
|
|
(.then #(rf/dispatch [::imported request %]))
|
|
(.catch (fn [error]
|
|
(js/console.error error)
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-event-fx
|
|
::import
|
|
;; A symbol out of another saved project, dropped at `frame` of the open symbol
|
|
;; and, from the stage, with its middle on `point`.
|
|
(fn [{:keys [db]} [_ carried frame point target]]
|
|
{:db (update db :project merge {:status (str "fetching " (:label carried) "…")})
|
|
::import! (assoc (select-keys carried [:project :cid :symbol :label])
|
|
:host (get-in db [:ui :open]) :frame frame :point point
|
|
:target target)}))
|
|
|
|
(rf/reg-event-fx
|
|
::import-palette
|
|
(fn [{:keys [db]} [_ {:keys [project cid palette name]}]]
|
|
{:db (update db :project merge {:status (str "fetching " name "…")})
|
|
::import-palette! {:project project :cid cid :palette palette}}))
|
|
|
|
(rf/reg-fx
|
|
::import-palette!
|
|
(fn [{:keys [project cid palette]}]
|
|
(-> (saved-clip! project cid)
|
|
(.then (fn [{other :clip}]
|
|
(let [source (leaf/unsegment palette)
|
|
p (get-in other [:palettes source])]
|
|
(if p
|
|
(rf/dispatch [::palette-imported p])
|
|
(rf/dispatch [::failed "that palette no longer exists"])))))
|
|
(.catch (fn [error]
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-event-db
|
|
::palette-imported
|
|
(fn [db [_ palette]]
|
|
(let [id (random-uuid)]
|
|
(-> (edit/edit db #(assoc-in % [:palettes id]
|
|
(assoc palette :id id :name (str (:name palette) " copy"))))
|
|
(assoc-in [:ui :palette] id)
|
|
(assoc-in [:project :status] (str "imported " (:name palette)))))))
|
|
|
|
(rf/reg-event-fx
|
|
::imported
|
|
;; As drawing: its tracking stays with the analysis that measured it. See
|
|
;; `arthur.domain.bring`.
|
|
(fn [{:keys [db]} [_ {:keys [symbol frame point label target]} other]]
|
|
(let [entry (store/entry (:clip/current db))
|
|
sid (leaf/unsegment symbol)
|
|
uuid (random-uuid)
|
|
{:keys [clip ids]} (bring/symbols (:clip entry) (:clip other) [sid] {})
|
|
st (merge (:store entry) (:store other))
|
|
;; A symbol from another project arrives as an ordinary clip, the same
|
|
;; as one from this project's pool.
|
|
where (if point
|
|
(ui/creation-destination db clip st frame)
|
|
(ui/drop-destination db clip st frame target))
|
|
point (ui/destination-point where point)
|
|
result (if (:refused where)
|
|
where
|
|
(span/place-symbol (:clip where) st (:sid where)
|
|
uuid (ids sid) (:at where)
|
|
{:extent :grow-symbol :point point
|
|
:remainder-id (random-uuid)}))]
|
|
(if-let [why (or (:refused where) (:refused result))]
|
|
{:db (update db :project merge {:status why})}
|
|
{:db (-> (edit/edit-entry db #(assoc % :clip (:clip result) :store st))
|
|
(ui/selected
|
|
[:node (:sid where) uuid (conj (vec (:path where)) uuid)])
|
|
(update :project merge {:status (str "brought in " label)}))
|
|
:dispatch [::pb/refresh-clock]}))))
|
|
|
|
(defn- clip-payload
|
|
"One clip of a save. With `base` — the seq the open document last caught up
|
|
to — only the leaves that differ from what the server held then, and the ones
|
|
since deleted: a collaborator's leaves are not ours to write back. Without it,
|
|
the whole clip."
|
|
[^js doc base local synced]
|
|
(if base
|
|
(let [all (.-leaves doc)
|
|
out (js-obj)]
|
|
(doseq [[path v] local :when (not= v (get synced path))]
|
|
(aset out path (aget all path)))
|
|
#js {:leaves out
|
|
:removed (into-array (remove #(contains? local %) (keys synced)))})
|
|
#js {:leaves (.-leaves doc)}))
|
|
|
|
(defonce ^:private uploaded-blocks
|
|
;; Block keys this page has already put on the server. Content addressed, so
|
|
;; once there they are there: a save of a moved vertex asks for none again.
|
|
(atom #{}))
|
|
|
|
(defonce ^:private linked-analyses (atom #{}))
|
|
|
|
(defn- upload-new! [^js doc]
|
|
(let [keys (array-seq (block-keys doc))]
|
|
(if (every? @uploaded-blocks keys)
|
|
(js/Promise.resolve 0)
|
|
(.then (upload-missing! doc) (fn [n] (swap! uploaded-blocks into keys) n)))))
|
|
|
|
(defn- analyses-of [entry]
|
|
(vals (get-in entry [:clip :analyses])))
|
|
|
|
(defn- upload-sources! [sources]
|
|
(reduce
|
|
(fn [chain [analysis-id {:keys [source-blocks]}]]
|
|
(.then chain
|
|
(fn [_]
|
|
(when (and (seq source-blocks)
|
|
(not (@linked-analyses analysis-id)))
|
|
(-> (upload-missing! #js {:blocks (source/upload-blocks source-blocks)})
|
|
(.then #(http/PUT
|
|
(str "/api/analyses/" analysis-id)
|
|
#js {:source_blocks
|
|
(into-array (source/block-keys source-blocks))}))
|
|
(.then (fn [answer]
|
|
(swap! linked-analyses conj analysis-id)
|
|
answer)))))))
|
|
(js/Promise.resolve nil)
|
|
sources))
|
|
|
|
(rf/reg-fx
|
|
::save!
|
|
(fn [{:keys [id cid label clip base]}]
|
|
(let [entry clip
|
|
analyses (analyses-of entry)
|
|
doc (project/save cid entry)
|
|
local (leaf/leaves cid (:clip entry))
|
|
base (when (and id (:synced entry)) base)
|
|
sources (:sources entry)]
|
|
(-> (ensure-project! id label)
|
|
(.then (fn [pid]
|
|
(-> (reduce (fn [chain one]
|
|
(.then chain
|
|
#(http/POST "/api/analyses"
|
|
(analysis-payload one))))
|
|
(js/Promise.resolve nil)
|
|
analyses)
|
|
(.then (fn [_]
|
|
(upload-sources! sources)))
|
|
(.then (fn [_]
|
|
(upload-new! doc)))
|
|
(.then (fn [uploaded]
|
|
(-> (http/PUT (str "/api/projects/" pid)
|
|
#js {:name label
|
|
:base base
|
|
:clips #js [(js/Object.assign
|
|
#js {:cid cid
|
|
:name label
|
|
:analyses (into-array
|
|
(keys (get-in entry [:clip :analyses])))
|
|
:blocks (block-keys doc)}
|
|
(clip-payload doc base local
|
|
(:synced entry)))]})
|
|
(.then (fn [^js saved]
|
|
(rf/dispatch [::saved pid cid label
|
|
(.-seq saved)
|
|
(count (array-seq (.-written saved)))
|
|
uploaded
|
|
{:synced local :base base}])))))))))
|
|
(.catch (fn [error]
|
|
(js/console.error error)
|
|
(if-let [conflicts (get-in (ex-data error) [:body :conflicts])]
|
|
(rf/dispatch [::conflicted (count conflicts)])
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))))
|
|
|
|
(rf/reg-fx
|
|
::list!
|
|
(fn [_]
|
|
(-> (http/GET "/api/projects")
|
|
(.then (fn [^js listed]
|
|
(rf/dispatch [::listed
|
|
(mapv (fn [^js row]
|
|
{:id (.-id row) :name (.-name row)
|
|
:owner (.-owner row)
|
|
:seq (.-seq row) :updated (.-updated row)})
|
|
(array-seq (.-projects listed)))])))
|
|
(.catch (fn [error]
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-fx
|
|
::list-symbols!
|
|
(fn [_]
|
|
(-> (http/GET "/api/symbols")
|
|
(.then (fn [^js listed]
|
|
(rf/dispatch [::symbols-listed
|
|
(mapv (fn [^js r]
|
|
{:project (.-project r) :project-name (.-project_name r)
|
|
:cid (.-cid r) :symbol (.-symbol r)
|
|
:name (.-name r) :frames (.-frames r)})
|
|
(array-seq (.-symbols listed)))
|
|
(mapv (fn [^js r]
|
|
{:project (.-project r) :project-name (.-project_name r)
|
|
:cid (.-cid r) :palette (.-palette r) :name (.-name r)})
|
|
(array-seq (.-palettes listed)))])))
|
|
(.catch (fn [error]
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-event-fx
|
|
::list-symbols
|
|
(fn [{:keys [db]} _]
|
|
{:db (assoc-in db [:assets :loading?] true)
|
|
::list-symbols! nil}))
|
|
|
|
(rf/reg-event-db
|
|
::symbols-listed
|
|
(fn [db [_ rows palettes]]
|
|
(assoc db :assets {:symbols rows :palettes palettes :loading? false})))
|
|
|
|
(rf/reg-sub ::assets (fn [db _] (:assets db)))
|
|
|
|
(declare blank-entry)
|
|
|
|
(rf/reg-fx
|
|
::open!
|
|
(fn [id]
|
|
(-> (if id
|
|
(js/Promise.resolve #js {:id id})
|
|
;; No id: the most recently updated project, which is what "open" means
|
|
;; when there is no project browser yet.
|
|
(-> (http/GET "/api/projects")
|
|
(.then (fn [^js listed]
|
|
(or (first (array-seq (.-projects listed)))
|
|
(throw (ex-info "there is no saved project to open" {})))))))
|
|
(.then (fn [^js row] (http/GET (str "/api/projects/" (.-id row)))))
|
|
(.then (fn [^js loaded]
|
|
(let [^js clip-json (first (array-seq (.-clips loaded)))]
|
|
(when (not= project/schema-version (.-schema_version loaded))
|
|
(throw (ex-info (str "that project is stored as schema "
|
|
(.-schema_version loaded) " and this client reads "
|
|
project/schema-version)
|
|
{})))
|
|
;; A project made from the index has nothing in it yet: it
|
|
;; opens on a blank document, of which the server has seen
|
|
;; nothing, so the first save sends all of it.
|
|
(-> (if clip-json
|
|
(opened-entry! clip-json)
|
|
(js/Promise.resolve (assoc (blank-entry) :synced {})))
|
|
(.then (fn [entry]
|
|
(rf/dispatch [::opened
|
|
(store/install! entry "project")
|
|
(.-id loaded)
|
|
(.-name loaded)
|
|
(.-seq loaded)
|
|
{:owner (.-owner loaded)
|
|
:editors (vec (.-editors loaded))
|
|
:can-edit? (.-can_edit loaded)}])))))))
|
|
(.catch (fn [error]
|
|
(js/console.error error)
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-fx
|
|
::stage!
|
|
(fn [_]
|
|
(-> (http/GET (str "/api/projects/" (:source-project stage/layout)))
|
|
(.then (fn [^js saved]
|
|
(or (first (filter #(= (:source-cid stage/layout) (.-cid ^js %))
|
|
(array-seq (.-clips saved))))
|
|
(throw (ex-info "the saved 8625 clip is missing" {})))))
|
|
(.then opened-entry!)
|
|
(.then (fn [entry]
|
|
(let [built (stage/compose (:clip entry))
|
|
entry (assoc entry :clip built :label (:name built)
|
|
:cid "stage-8625"
|
|
:width (:width built) :height (:height built))]
|
|
(rf/dispatch [::stage-opened (store/install! entry "stage")]))))
|
|
(.catch (fn [error]
|
|
(js/console.error error)
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(defonce ^:private retained-source (atom nil))
|
|
(defonce ^:private retained-interior (atom nil))
|
|
|
|
(defn- retained-interior! [analysis subject settings inputs]
|
|
(let [frames (count (:crops inputs))
|
|
block-key (source/interior-key analysis subject settings frames)]
|
|
(-> (http/GET (str "/api/blocks/" block-key))
|
|
(.then (fn [block]
|
|
(assoc inputs
|
|
:interior (source/unpack-interior block settings frames)
|
|
:interior-key block-key)))
|
|
(.catch (fn [error]
|
|
(if (= 404 (:status (ex-data error)))
|
|
(-> (footage/measure-one! settings (dissoc inputs :interior) nil)
|
|
(.then (fn [measured]
|
|
(let [{:keys [key descriptor data]}
|
|
(source/interior-block analysis subject settings
|
|
(:interior measured))]
|
|
(-> (upload-missing!
|
|
#js {:blocks #js [#js {:key key
|
|
:descriptor descriptor
|
|
:data data}]})
|
|
(.then (fn [_]
|
|
(assoc measured :interior-key block-key))))))))
|
|
(throw error)))))))
|
|
|
|
(defn- source-for! [entry edit]
|
|
(let [subject (:subject (regenerate/plan (:clip entry) edit))
|
|
subject-record (get-in entry [:clip :subjects subject])
|
|
analysis-id (:analysis subject-record)
|
|
analysis (get-in entry [:clip :analyses analysis-id])
|
|
source-subject (:source-subject subject-record)
|
|
local (get-in entry [:sources analysis-id :source-inputs :subjects subject])]
|
|
(if local
|
|
(js/Promise.resolve {:subjects {subject local}})
|
|
(if (= [analysis-id subject] (:key @retained-source))
|
|
(:promise @retained-source)
|
|
(let [promise
|
|
(if (= "synth" (:detector analysis))
|
|
(js/Promise.resolve
|
|
{:subjects
|
|
{subject {:dense (synth/synth-dense (:frames analysis)
|
|
{:seed (:seed analysis)})}}})
|
|
(.then (ingest/manifest! (:footage subject-record))
|
|
(fn [manifest]
|
|
(.then (footage/saved-source!
|
|
analysis-id [(:width manifest) (:height manifest)])
|
|
(fn [inputs]
|
|
(when-not inputs
|
|
(throw (ex-info "saved analysis has no source blocks" {})))
|
|
{:subjects
|
|
{subject
|
|
(assoc (get-in inputs [:subjects source-subject])
|
|
:presence
|
|
(footage/presence-for manifest
|
|
source-subject))}})))))]
|
|
(do
|
|
(reset! retained-source {:key [analysis-id subject] :promise promise})
|
|
promise))))))
|
|
|
|
(defn- inputs-for-edit!
|
|
"Bring the EDITED SUBJECT's retained pixel measurements up to the settings this
|
|
edit needs. Only that subject's: a knob dragged on the second face does not
|
|
re-measure the first face's mouth."
|
|
[entry edit inputs]
|
|
(let [{clip :changed fids :features subject :subject} (regenerate/plan (:clip entry) edit)
|
|
teeth (first (filter #(= :teeth (get-in clip [:features % :area])) fids))
|
|
one (get-in inputs [:subjects subject])]
|
|
(if (and teeth (:crops one))
|
|
(let [settings (merge take/knobs (feature/effective-params clip teeth))
|
|
analysis (get-in clip [:subjects subject :analysis])
|
|
source-subject (get-in clip [:subjects subject :source-subject])
|
|
frames (count (:crops one))
|
|
key (source/interior-key analysis source-subject settings frames)
|
|
done (fn [measured] (assoc-in inputs [:subjects subject] measured))]
|
|
(if (and (:interior one)
|
|
(or (= (:interior-key one) key)
|
|
(and (nil? (:interior-key one))
|
|
(= key (source/interior-key analysis source-subject take/knobs frames)))))
|
|
(js/Promise.resolve inputs)
|
|
(.then (if (= key (:key @retained-interior))
|
|
(:promise @retained-interior)
|
|
(let [promise (retained-interior! analysis source-subject settings one)]
|
|
(reset! retained-interior {:key key :promise promise})
|
|
promise))
|
|
done)))
|
|
(js/Promise.resolve inputs))))
|
|
|
|
(rf/reg-fx
|
|
::preview-settings!
|
|
(fn [{:keys [id entry edit request]}]
|
|
(-> (source-for! entry edit)
|
|
(.then (fn [inputs] (inputs-for-edit! entry edit inputs)))
|
|
(.then (fn [inputs]
|
|
(regenerate/change (assoc entry :source-inputs inputs) edit)))
|
|
(.then (fn [changed]
|
|
(rf/dispatch [::settings-previewed id request changed])))
|
|
(.catch (fn [error]
|
|
(js/console.error error)
|
|
(rf/dispatch [::failed (or (ex-message error) (str error))]))))))
|
|
|
|
(rf/reg-event-fx
|
|
::preview-settings
|
|
(fn [{:keys [db]} [_ edit]]
|
|
(let [id (:clip/current db)
|
|
entry (store/entry id)]
|
|
(if (or (get-in db [:project :busy?]) (empty? (:analyses (:clip entry))))
|
|
{}
|
|
(let [plan (regenerate/plan (:clip entry) edit)
|
|
report (select-keys plan [:features :roles])
|
|
request (inc (or (:preview-request db) 0))]
|
|
(js/console.info "arthur regeneration" (clj->js (assoc report :edit edit)))
|
|
{:db (-> db
|
|
(assoc :preview-request request)
|
|
(update :project merge {:status "previewing…"})
|
|
(assoc :regeneration (assoc report :edit edit)))
|
|
::preview-settings! {:id id :entry entry :edit edit
|
|
:request request}})))))
|
|
|
|
(rf/reg-sub ::regeneration (fn [db _] (:regeneration db)))
|
|
(rf/reg-sub ::listing (fn [db _] (:projects db)))
|
|
|
|
(rf/reg-event-fx
|
|
::settings-previewed
|
|
(fn [{:keys [db]} [_ previous request entry]]
|
|
(if (and (= previous (:clip/current db))
|
|
(= request (:preview-request db)))
|
|
(let [id (store/install! entry "edited")]
|
|
{:db (-> db
|
|
(assoc :clip/current id)
|
|
(update :project merge {:status "preview · unsaved"}))})
|
|
{})))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; events
|
|
|
|
(def blank-audio
|
|
"The audio a new document opens on, until it gets one of its own.
|
|
|
|
It is no longer load-bearing. The frame is derived from a position, and the
|
|
graph backend can hold one for a symbol with no sound at all — see
|
|
`mix/clock-source!` — so a silent stage has time and `play` works. This stays
|
|
because a new document borrowing the synthetic take's soundtrack is a
|
|
convenience worth keeping, not because the clock would stop without it."
|
|
"/static/arthur/audio.wav")
|
|
|
|
(defn blank-entry
|
|
"A blank clip, in the shape `footage/store` and the transport expect."
|
|
[]
|
|
(let [c (clip/blank)]
|
|
{:label "untitled" :clip c :store nil
|
|
:audio blank-audio
|
|
;; A content id of its own from the start: `::save!` addresses the clip by
|
|
;; it, and two untitled documents saved from two tabs are two documents.
|
|
:cid (str (random-uuid))
|
|
:fps (:fps c) :width (:width c) :height (:height c)}))
|
|
|
|
(rf/reg-event-fx
|
|
::new
|
|
(fn [{:keys [db]} _]
|
|
;; A document with no id on the server, so the next `save` creates one. This
|
|
;; is also what the app opens on: nothing is loaded until something is asked
|
|
;; for, and the built-in scenes are rows in the media pool like anything else.
|
|
(let [entry (blank-entry)
|
|
id (store/install! entry "new")]
|
|
{:db (-> (assoc db :ui (:ui db/default))
|
|
(pb/show id)
|
|
(assoc :project {:id nil :cid (:cid entry) :name nil :seq nil
|
|
:busy? false :status "new document"}))
|
|
;; The readout goes home with the document; so must the clock, or play
|
|
;; picks up wherever the last document's audio had got to.
|
|
::pb/seek! [(:fps entry) (clip/output-frames (:clip entry) (clip/opens-on (:clip entry))) 0]
|
|
::pb/pause! nil
|
|
::pb/clock! {:id id :sid (clip/opens-on (:clip entry))}})))
|
|
|
|
(rf/reg-event-fx
|
|
::save
|
|
;; `auto?` is the save an edit schedules (see `arthur.events.collab`): it does
|
|
;; not lock the controls the way a save you asked for does, and it never saves
|
|
;; somebody else's project as a copy. Either kind waits its turn behind one in
|
|
;; flight, and writes nothing when nothing changed. `force?` saves what is not a leaf —
|
|
;; the name.
|
|
(fn [{:keys [db]} [_ {:keys [auto? force?] :as how}]]
|
|
(let [id (:clip/current db)
|
|
clip (store/entry id)
|
|
{pid :id :keys [busy? saving? can-edit?]} (:project db)
|
|
cid (or (:cid clip) (name id))]
|
|
(cond
|
|
(nil? clip)
|
|
{}
|
|
|
|
;; Behind the one in flight, never instead of it: an edit made while a
|
|
;; save is on the wire is not in that save. One request at a time, and
|
|
;; the next carries everything that changed meanwhile — so a drag goes
|
|
;; out as fast as the round trip allows, and no faster.
|
|
(or busy? saving?)
|
|
{:db (assoc-in db [:project :again] (or how {}))}
|
|
|
|
(and auto? (false? can-edit?))
|
|
{}
|
|
|
|
(and pid (:synced clip) (not force?) (empty? (:behind clip))
|
|
(= (:synced clip) (try (leaf/leaves cid (:clip clip)) (catch :default _ nil))))
|
|
{}
|
|
|
|
;; Somebody else wrote leaves we had changed too, first. The first
|
|
;; write wins: theirs goes on screen over ours, which stays in our undo
|
|
;; list. See `arthur.events.collab/landed`.
|
|
(seq (:behind clip))
|
|
{:dispatch [:arthur.events.collab/remote
|
|
{:seq (get-in db [:project :seq]) :take? true
|
|
:written (into {} (remove (comp nil? val)) (:behind clip))
|
|
:removed (keep (fn [[p v]] (when (nil? v) p)) (:behind clip))}]}
|
|
|
|
:else
|
|
;; Somebody else's project, which we may look at and not write, saves as
|
|
;; a copy of our own.
|
|
{:db (update db :project merge {(if auto? :saving? :busy?) true :status "saving…"})
|
|
::save! {:id (when-not (false? can-edit?) pid)
|
|
:base (get-in db [:project :seq])
|
|
:cid cid
|
|
:label (or (not-empty (get-in db [:project :name]))
|
|
(:label clip) (name id))
|
|
:clip clip}}))))
|
|
|
|
(rf/reg-event-fx
|
|
::rename
|
|
(fn [{:keys [db]} [_ value]]
|
|
{:db (assoc-in db [:project :name] (not-empty (str/trim value)))
|
|
:dispatch [::save {:auto? true :force? true}]}))
|
|
|
|
(rf/reg-event-fx
|
|
::project-setting
|
|
(fn [{:keys [db]} [_ key value]]
|
|
(if (or (not (#{:fps :width :height} key))
|
|
(not (and (integer? value) (pos? value))))
|
|
{}
|
|
(let [db' (edit/edit db #(if (= key :fps) (clip/set-root-fps % value) (assoc % key value)))
|
|
db' (assoc-in db' [:clip key] value)
|
|
frame (min (dec (pb/frames db'))
|
|
(js/Math.floor (* (get-in db [:playback :frame])
|
|
(/ value (get-in db [:clip :fps])))))]
|
|
(cond-> {:db db'}
|
|
(= key :fps) (assoc :db (assoc-in db' [:playback :frame] frame)
|
|
::pb/seek! [value (pb/frames db') frame]
|
|
:dispatch [::pb/refresh-clock]))))))
|
|
|
|
(rf/reg-event-db
|
|
::rename-symbol
|
|
(fn [db [_ sid value]]
|
|
;; A transaction, so one rename is one undo step: `edit/edit` alone would let
|
|
;; a rename coalesce with whatever edit happened next.
|
|
;;
|
|
;; BLANK REMOVES THE NAME rather than storing an empty one. `clip/symbol-name`
|
|
;; falls back to the id, so a symbol cleared of its name reads as `main`
|
|
;; again instead of as a row with nothing on it — and the document carries no
|
|
;; field it did not need.
|
|
(let [value (not-empty (str/trim (str value)))]
|
|
(if-not (clip/symbol (:clip (store/entry (:clip/current db))) sid)
|
|
db
|
|
(edit/transaction db #(if value
|
|
(assoc-in % [:symbols sid :name] value)
|
|
(update-in % [:symbols sid] dissoc :name)))))))
|
|
|
|
(rf/reg-event-db
|
|
::symbol-setting
|
|
(fn [db [_ sid key value]]
|
|
(if-not (and (#{:frames :fps :width :height} key)
|
|
(or (nil? value) (and (integer? value) (pos? value))))
|
|
db
|
|
(edit/edit db
|
|
(fn [c]
|
|
(if (nil? value)
|
|
(update-in c [:symbols sid] dissoc key)
|
|
(assoc-in c [:symbols sid key] value)))))))
|
|
|
|
(rf/reg-event-db
|
|
::new-palette
|
|
(fn [db _]
|
|
(let [id (random-uuid)
|
|
p {:id id :name "Untitled palette"
|
|
:slots (mapv #(select-keys % [:name :hex]) (:slots pal/default-palette))}]
|
|
(-> (edit/edit db #(assoc-in % [:palettes id] p))
|
|
(assoc-in [:ui :palette] id)))))
|
|
|
|
(rf/reg-event-db
|
|
::duplicate-palette
|
|
;; A copy of an existing palette, selected so the next colour edit lands on the
|
|
;; copy rather than the original. The point is a variant: start from a palette
|
|
;; that works and change two tones, instead of 16 colour pickers from black.
|
|
;; `pal/palettes` is the source so the implicit default - a project that has
|
|
;; never had a palette asset of its own - can be duplicated like any other.
|
|
(fn [db [_ id]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
p (get (pal/palettes clip) id)]
|
|
(if-not p
|
|
db
|
|
(let [new-id (random-uuid)]
|
|
(-> (edit/edit db #(assoc-in % [:palettes new-id]
|
|
(assoc p :id new-id
|
|
:name (str (:name p) " copy"))))
|
|
(assoc-in [:ui :palette] new-id)))))))
|
|
|
|
(rf/reg-event-db
|
|
::palette-name
|
|
(fn [db [_ id value]]
|
|
(let [value (str/trim (str value))]
|
|
(if (str/blank? value) db
|
|
(edit/edit db #(assoc-in % [:palettes id :name] value))))))
|
|
|
|
(rf/reg-event-db
|
|
::palette-color
|
|
(fn [db [_ id slot hex]]
|
|
(if-not (re-matches #"#[0-9a-fA-F]{6}" (str hex))
|
|
db
|
|
(edit/edit db #(assoc-in % [:palettes id :slots slot :hex] (str/lower-case hex))))))
|
|
|
|
(rf/reg-event-db
|
|
::default-palette
|
|
(fn [db [_ id]]
|
|
(edit/edit db #(if (get-in % [:palettes id]) (assoc % :default-palette id) %))))
|
|
|
|
(rf/reg-event-db
|
|
::symbol-palette
|
|
(fn [db [_ sid id]]
|
|
(edit/edit db #(if id
|
|
(assoc-in % [:symbols sid :palette] id)
|
|
(update-in % [:symbols sid] dissoc :palette)))))
|
|
|
|
(rf/reg-event-db
|
|
::set-channel
|
|
;; `frame` is the node's own, as for a drawing key.
|
|
(fn [db [_ sid id path frame value]]
|
|
(let [put (if (get-in db [:ui :auto-key?]) node/set-keyed-channel node/set-channel)]
|
|
(edit/edit db #(update-in % [:symbols sid :nodes id] put path frame value)))))
|
|
|
|
(rf/reg-event-db
|
|
::instance-playback
|
|
(fn [db [_ sid id field value]]
|
|
(let [valid? (case field
|
|
:mode (#{:once :loop :frame} value)
|
|
(:in :speed) (and (node/finite-number? value) (<= 0 value))
|
|
false)]
|
|
(if-not valid?
|
|
db
|
|
(edit/edit
|
|
db
|
|
(fn [document]
|
|
(let [path [:symbols sid :nodes id]
|
|
n (get-in document path)]
|
|
(if-not (= :instance (:kind n))
|
|
document
|
|
(let [{:keys [speed]} (node/playback-of n)
|
|
updated (if (= :mode field)
|
|
(-> n
|
|
(update :time dissoc :loop?)
|
|
(assoc-in [:playback :end] (if (= :loop value) :loop :stop))
|
|
(assoc-in [:playback :speed]
|
|
(if (= :frame value) 0 (if (pos? speed) speed 1))))
|
|
(assoc-in n [:playback field] value))]
|
|
(assoc-in document path updated))))))))))
|
|
|
|
(defn- seed-palette-choice [document sid id]
|
|
(if (get-in document [:symbols sid :nodes id :channels [:palette]])
|
|
document
|
|
(let [source (get-in document [:symbols sid :nodes id :source :symbol])
|
|
palette-id (or (get-in document [:symbols source :palette-ref]) pal/inherit)]
|
|
(assoc-in document [:symbols sid :nodes id :channels [:palette]]
|
|
(assoc (ch/framed palette-id) :semantic :palette)))))
|
|
|
|
(rf/reg-event-db
|
|
::set-palette-choice
|
|
(fn [db [_ sid id frame palette-id]]
|
|
(let [put (if (get-in db [:ui :auto-key?]) node/set-keyed-channel node/set-channel)]
|
|
(edit/edit db
|
|
(fn [document]
|
|
(update-in (seed-palette-choice document sid id)
|
|
[:symbols sid :nodes id]
|
|
put [:palette] frame palette-id))))))
|
|
|
|
(rf/reg-event-db
|
|
::toggle-palette-key
|
|
(fn [db [_ sid id frame]]
|
|
(let [st (:store (store/entry (:clip/current db)))]
|
|
(edit/edit db
|
|
(fn [document]
|
|
(update-in (seed-palette-choice document sid id)
|
|
[:symbols sid :nodes id]
|
|
node/toggle-key [:palette] frame st))))))
|
|
|
|
(rf/reg-event-db
|
|
::set-channels
|
|
;; One property assignment over a stage selection is one document edit.
|
|
(fn [db [_ edits]]
|
|
(let [put (if (get-in db [:ui :auto-key?]) node/set-keyed-channel node/set-channel)]
|
|
(edit/edit db
|
|
#(reduce (fn [c {:keys [sid id path frame value]}]
|
|
(update-in c [:symbols sid :nodes id] put path frame value))
|
|
% edits)))))
|
|
|
|
(rf/reg-event-db
|
|
::toggle-key
|
|
(fn [db [_ sid id path frame]]
|
|
(let [st (:store (store/entry (:clip/current db)))]
|
|
(edit/edit db #(update-in % [:symbols sid :nodes id] node/toggle-key path frame st)))))
|
|
|
|
;; A hold on node `id`'s own frame `frame`, or none there if there was one: the
|
|
;; frames a tracing layer holds its picture on — a face's trace keys are its
|
|
;; plate's — and, for any node, `node/hold`. Taking the last one off removes the
|
|
;; floor rather than leaving an empty list behind.
|
|
(rf/reg-event-db
|
|
::toggle-hold
|
|
(fn [db [_ sid id frame]]
|
|
(edit/edit db #(update-in % [:symbols sid :nodes id :time]
|
|
(fn [t]
|
|
(let [hs (get t :holds [])
|
|
hs (vec (sort (if (some #{frame} hs)
|
|
(remove #{frame} hs)
|
|
(conj hs frame))))]
|
|
(if (seq hs) (assoc t :holds hs) (dissoc t :holds))))))))
|
|
|
|
;; How a face's head moves between its footage's holds — `symbol`'s `:reads`.
|
|
;; Nil reads every frame.
|
|
(rf/reg-event-db
|
|
::set-reads
|
|
(fn [db [_ sid reads]]
|
|
(edit/edit db #(update-in % [:symbols sid :nodes :head]
|
|
(fn [n] (if reads (assoc n :reads reads) (dissoc n :reads)))))))
|
|
|
|
|
|
(rf/reg-event-db
|
|
::set-segment-interp
|
|
(fn [db [_ sid id path left interp]]
|
|
(edit/edit db #(update-in % [:symbols sid :nodes id] node/set-segment-interp path left interp))))
|
|
|
|
(rf/reg-event-fx
|
|
::list
|
|
(fn [{:keys [db]} _]
|
|
{:db (assoc-in db [:projects :loading?] true)
|
|
::list! nil}))
|
|
|
|
(rf/reg-event-db
|
|
::listed
|
|
(fn [db [_ rows]] (assoc db :projects {:items rows :loading? false})))
|
|
|
|
(rf/reg-event-fx
|
|
::open
|
|
(fn [{:keys [db]} [_ id]]
|
|
;; `id` names which project. Without one it is the open document's own id, and
|
|
;; without that the most recently updated — which is what "open" meant when
|
|
;; there was no list to pick from.
|
|
(if (:busy? (:project db))
|
|
{}
|
|
{:db (update db :project merge {:busy? true :status "opening…"})
|
|
::pb/pause! nil
|
|
::open! (or id (:id (:project db)))})))
|
|
|
|
(rf/reg-event-fx
|
|
::load-stage
|
|
(fn [{:keys [db]} _]
|
|
(if (:busy? (:project db))
|
|
{}
|
|
{:db (update db :project merge {:busy? true :status "loading 8625 stage…"})
|
|
::pb/pause! nil
|
|
::stage! nil})))
|
|
|
|
(rf/reg-event-fx
|
|
::stage-opened
|
|
(fn [{:keys [db]} [_ clip-id]]
|
|
(let [db (-> (pb/show db clip-id)
|
|
(assoc :project {:id nil :cid nil :name nil :seq nil
|
|
:busy? false :status "loaded 8625 stage study"}))]
|
|
{:db db
|
|
::pb/seek! [(get-in db [:clip :fps]) (pb/frames db) 0]
|
|
::pb/clock! {:id clip-id :sid (get-in db [:ui :open])}})))
|
|
|
|
(rf/reg-event-fx
|
|
::saved
|
|
(fn [{:keys [db]} [_ id cid label seq written uploaded {:keys [synced base]}]]
|
|
(let [fresh? (not= id (get-in db [:project :id]))]
|
|
{:db (-> db
|
|
(update :clip/current #(or (store/edit-entry! % (fn [e] (-> (assoc e :synced synced)
|
|
(dissoc :behind))))
|
|
%))
|
|
(update :project dissoc :again)
|
|
(update :project merge
|
|
{:id id :cid cid :name label :seq seq :busy? false :saving? false
|
|
:status (str "saved r" seq " · " written
|
|
(if (= 1 written) " leaf" " leaves")
|
|
" · " uploaded (if (= 1 uploaded) " block" " blocks"))}
|
|
(when fresh?
|
|
{:owner (get-in db [:me :username]) :editors [] :can-edit? true})))
|
|
:fx [;; The all-assets folder lists saved symbols, so a save can add rows to it.
|
|
[:dispatch [::list-symbols]]
|
|
;; Somebody wrote between what we last saw and this save. Their
|
|
;; deltas may still be on the wire, and a seq we have jumped past
|
|
;; would drop them, so ask for the document instead.
|
|
(when (and base (not= seq (inc base)))
|
|
[:dispatch [:arthur.events.collab/catch-up]])
|
|
(when-let [how (get-in db [:project :again])]
|
|
[:dispatch [::save how]])]})))
|
|
|
|
(rf/reg-event-fx
|
|
::conflicted
|
|
;; Nothing was written: somebody else's write to the same leaves got there
|
|
;; first. Catching up TAKES theirs, over ours — then the rest of ours saves.
|
|
(fn [{:keys [db]} [_ n]]
|
|
{:db (-> db
|
|
(update :project dissoc :again)
|
|
(update :project merge {:busy? false :saving? false}))
|
|
:fx [[:dispatch [:arthur.events.collab/catch-up true]]
|
|
[:dispatch [::save {:auto? true}]]]}))
|
|
|
|
(rf/reg-event-fx
|
|
::opened
|
|
(fn [{:keys [db]} [_ clip-id project-id name seq access]]
|
|
{:db (-> (pb/show db clip-id)
|
|
(update :project merge access
|
|
{:id project-id :name name :seq seq
|
|
:cid (:cid (store/entry clip-id))
|
|
:busy? false
|
|
:status (str "opened " name " r" seq)}))
|
|
::pb/pause! nil
|
|
::pb/seek! (let [{c :clip fps :fps} (store/entry clip-id)]
|
|
[fps (clip/output-frames c (clip/opens-on c)) 0])
|
|
::pb/clock! {:id clip-id
|
|
:sid (clip/opens-on (:clip (store/entry clip-id)))}}))
|
|
|
|
(rf/reg-event-fx
|
|
::failed
|
|
(fn [{:keys [db]} [_ message]]
|
|
(cond-> {:db (-> db
|
|
(update :project dissoc :again)
|
|
(update :project merge {:busy? false :saving? false
|
|
:status (str "failed: " message)}))}
|
|
(get-in db [:project :again]) (assoc :dispatch [::save (get-in db [:project :again])]))))
|