noe/arthur
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Projects live at URLs, have owners, and are edited together live

Browse source 
A project is only ever at /p/<id>/<slug>; / is the index of the projects
you own or edit. Every project has an owner, who can name editors;
anyone with the link can view. Every edit saves itself, one request in
flight at a time, as a patch of the leaves that changed, and a websocket
(channels + daphne) carries presence and each committed write to
everyone else in the project. The first write to a leaf wins, and the
loser is told.

Undo is per person: a step undoes only if the leaves it touched still
hold what it left, so it never takes a collaborator's work with it.
Named snapshots replace saving, and restore as an ordinary write.

An empty symbol now survives the leaf round trip with `:nodes {}`.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
Olive Vaughn 2026-09-29 22:04:03 -04:00
parent c17ee138f2
commit 6a53adb5e0
31 changed files with 1918 additions and 158 deletions
Download patch file Download diff file Expand all files Collapse all files

9
frontend/src/arthur/core.cljs
View file

@ -4,7 +4,9 @@
port-plan step 3: the hand-written scene plays at 30fps against audio, scrubs,
and runs at ½× and ¼×."
(:require [arthur.db :as db]
[arthur.events.collab :as collab]
[arthur.events.footage :as footage]
[arthur.events.history :as history]
[arthur.events.playback]
[arthur.events.paint]
[arthur.events.project :as project]
@ -12,6 +14,7 @@
[arthur.subs.playback]
[arthur.subs.render]
[arthur.subs.ui]
[arthur.ui.index :as index]
[arthur.ui.player :as player]
[arthur.ui.shell :as shell]
[re-frame.core :as rf]
@ -26,7 +29,7 @@
;; the loop would otherwise sit on an unchanged frame number and never redraw.
(rf/clear-subscription-cache!)
(player/refresh-subs!)
(rdc/render @root [shell/view]))
(rdc/render @root [:<> [shell/view] [index/view]]))
(defn init []
(rf/dispatch-sync [::init])
@ -39,6 +42,10 @@
;; picker be a picker rather than a path to type.
(rf/dispatch [::footage/refresh])
(rf/dispatch [::project/list-symbols])
;; After the blank document, so an address that names a project opens it over
;; the blank one, and the blank one is what a bad address leaves on screen.
(collab/start!)
(history/install-keys!)
(reset! root (rdc/create-root (js/document.getElementById "app")))
(mount)
(player/start!))

113
frontend/src/arthur/domain/history.cljs Normal file
View file

@ -0,0 +1,113 @@
(ns arthur.domain.history
"Undo, per person, as leaf writes. docs/architecture.md, \"Undo is per-user\".
A step is the leaves one edit changed: what they held before, and what they
held after. Undoing writes the befores back as an ordinary edit, which the
next save sends like any other — so undo needs nothing from the server, and
nothing about it is shared.
ONLY YOUR OWN CHANGES. A step undoes only if every leaf it touched still holds
what the step left there. Somebody else's write to one of them since — their
edit to the shape you made — refuses the step rather than taking their work
with it; it is dropped, and the next undo is the step before. With nobody else
in the document the values always match, and this is ordinary undo.
A nil value is an absent leaf: a step that made a node has nil befores for its
leaves, so undoing it removes them."
(:require [clojure.string :as str]))
(def gap-ms
"Edits to the same leaves closer together than this are one step: a drag
writes a vertex per pointermove, and is one thing to undo. Only when each
starts where the last left off — anything landing between them, a
collaborator's write included, makes the next edit a step of its own."
1000)
(def depth 200)
(defn- changes
"`[before after]`, restricted to the paths that differ."
[before after]
(reduce (fn [[b a :as acc] path]
(let [x (get before path)
y (get after path)]
(if (= x y) acc [(assoc b path x) (assoc a path y)])))
[{} {}]
(distinct (concat (keys before) (keys after)))))
(defn- node-name [leaves path]
(let [[_ _ _ sid _ nid] (str/split path #"/")
node (get leaves (str/join "/" ["clip" "u" "symbol" sid "node" nid]))]
(or (:name node) (str/replace nid "~" "/"))))
(defn- said
"What one changed leaf was, in words, and how much it outranks the others:
making or deleting a thing names the step before editing it does."
[before after path]
(let [[_ _ kind a b] (str/split path #"/")
leaves (merge before after)]
(case [kind b]
["symbol" nil] [1 (str "symbol " (or (:name (get leaves path)) (str/replace a "~" "/")))]
["symbol" "node"]
(cond (nil? (get before path)) [0 (str "add " (node-name leaves path))]
(nil? (get after path)) [0 (str "delete " (node-name leaves path))]
:else [1 (str "edit " (node-name leaves path))])
(if (#{"channel" "measured"} b)
[1 (str "edit " (node-name leaves path))]
[2 (case kind
("timing" "stage" "name") "project settings"
("subject" "feature" "group") "tracking settings"
kind)]))))
(defn label
"A step in words: \"add shape 3\", \"edit mouth, brow-l\"."
[before after paths]
(let [said (->> paths (map #(said before after %)) distinct sort)
top (first (first said))
words (distinct (map second (filter #(= top (first %)) said)))]
(str (str/join ", " (take 2 words)) (when (< 2 (count words)) " …"))))
(defn record
"History `h` with an edit from leaves `before` to `after` at time `now`."
[{:keys [done] :as h} before after now]
(let [[b a] (changes before after)
top (peek done)]
(cond
(empty? a) h
(and top (< (- now (:at top)) gap-ms) (= b (:after top)))
{:done (conj (pop done) (assoc top :after a :at now)) :undone []}
:else
{:done (conj (vec (take-last (dec depth) done))
{:before b :after a :at now :label (label before after (keys a))})
:undone []})))
(defn steps
"The labels, newest first: `:done` is what undo would take off, `:undone`
what redo would put back."
[h]
{:done (mapv :label (rseq (or (:done h) [])))
:undone (mapv :label (rseq (or (:undone h) [])))})
(defn- holds? [leaves m]
(every? (fn [[path v]] (= v (get leaves path))) m))
(defn- put-all [leaves m]
(reduce-kv (fn [ls path v] (if (nil? v) (dissoc ls path) (assoc ls path v))) leaves m))
(defn- move
"One step from `from` to `to`, if `leaves` still hold what it expects."
[h leaves from to expect write]
(when-let [step (peek (get h from))]
(let [h (update h from pop)]
(if (holds? leaves (expect step))
{:leaves (put-all leaves (write step)) :history (update h to (fnil conj []) step)}
{:blocked step :history h}))))
(defn undo
"`{:leaves :history}`, `{:blocked :history}` when somebody else has since
changed what the step touched, or nil with nothing to undo."
[h leaves]
(move h leaves :done :undone :after :before))
(defn redo [h leaves]
(move h leaves :undone :done :before :after))

4
frontend/src/arthur/domain/leaf.cljs
View file

@ -177,7 +177,9 @@
(let [sid (unsegment a)
acc (assoc-in acc [:symbols sid :id] sid)]
(case b
nil (update-in acc [:symbols sid] merge v)
;; `:nodes` is there before any node leaf is: an empty
;; symbol has none, and is still a symbol.
nil (update-in acc [:symbols sid] #(merge {:nodes {}} % v))
"node" (update-in acc [:symbols sid :nodes (unsegment c)] merge v)
"measured" (assoc-in acc [:symbols sid :nodes (unsegment c) :measured] v)
"channel" (assoc-in acc [:symbols sid :nodes (unsegment c)

32
frontend/src/arthur/domain/project.cljs
View file

@ -89,19 +89,27 @@
:state (when state (wire/base64 state))}))
(block-keys leaves)))})))
(defn tier1
"A response's leaves object -> `{path value}`, the shape `leaf/leaves` returns."
[^js leaves]
(into {} (map (fn [path] [path (wire/decode-json (aget leaves path))]))
(js-keys leaves)))
(defn store
"Fetched blocks -> the store `save` reads them back out of."
[blocks]
(into {}
(map (fn [^js b]
[(.-key b)
(cond-> {:descriptor (.-descriptor b)
:data (wire/typed (block-type (.-descriptor b))
(.-data b))}
(.-state b) (assoc :state (wire/bytes-of (.-state b))))]))
(array-seq (or blocks #js []))))
(defn load
"The parsed response -> `{:clip :store}`, which is what `flow/freeze` returns
and therefore what the player already knows how to play."
[cid ^js doc]
(let [leaves (.-leaves doc)
tier1 (into {} (map (fn [path] [path (wire/decode-json (aget leaves path))]))
(js-keys leaves))]
{:clip (leaf/clip cid tier1)
:store (into {}
(map (fn [^js b]
[(.-key b)
(cond-> {:descriptor (.-descriptor b)
:data (wire/typed (block-type (.-descriptor b))
(.-data b))}
(.-state b) (assoc :state (wire/bytes-of (.-state b))))]))
(array-seq (or (.-blocks doc) #js [])))}))
{:clip (leaf/clip cid (tier1 (.-leaves doc)))
:store (store (.-blocks doc))})

438
frontend/src/arthur/events/collab.cljs Normal file
View file

@ -0,0 +1,438 @@
(ns arthur.events.collab
"Everything that makes a document somewhere other people are: its address, who
you are, who else is in it, and their writes arriving while you work.
docs/architecture.md, Collaboration, and tl's model with the four additions it
asks for. Writes stay on HTTP; the socket carries presence and the deltas the
server broadcasts after a write commits.
ONE RULE FOR THE ADDRESS AND THE ROOM. They follow `[:project :id]`, whatever
event changed it — open, save, new, a copy — through one interceptor, so no
event that loads a document has to remember to join its room.
THE OUTBOX RULE, without an outbox. A remote leaf lands unless we have a change
to that leaf the server has not seen — a leaf whose local value differs from the
last value we synced. Otherwise their write would snap our unsaved edit back.
The next save sends ours, and if theirs moved since, it answers 409 and we catch
up, and the save after that is ours."
(:require [arthur.domain.leaf :as leaf]
[arthur.domain.project :as project]
[arthur.events.edit :as edit]
[arthur.events.playback :as pb]
[arthur.events.project :as events.project]
[arthur.footage.store :as store]
[arthur.fx.http :as http]
[clojure.string :as str]
[re-frame.core :as rf]))
;; ---------------------------------------------------------------------------
;; the address
(defn- path-id
"The project a path names: `/p/<uuid>/<slug>`. The slug is for people; the
id is what finds it."
[path]
(second (re-matches #"/p/([0-9a-fA-F-]{36})(?:/.*)?" path)))
(defn slug [name]
(or (not-empty (-> (str/lower-case (or name ""))
(str/replace #"[^a-z0-9]+" "-")
(str/replace #"^-+|-+$" "")))
"untitled"))
(defn project-path [id name] (str "/p/" id "/" (slug name)))
(defn- route! []
(rf/dispatch [::routed (path-id (.. js/window -location -pathname))]))
(defn navigate! [path]
(.pushState js/history nil "" path)
(route!))
(rf/reg-event-fx
::routed
;; `/` is the index of your projects; a project is only ever at its address.
(fn [{:keys [db]} [_ id]]
(cond
(nil? id) {:db (assoc db :route :index)
:dispatch [::events.project/list]}
(= id (get-in db [:project :id])) {:db (assoc db :route [:project id])}
:else {:db (assoc db :route [:project id])
:dispatch [::events.project/open id]})))
(rf/reg-sub ::route (fn [db _] (:route db)))
(rf/reg-fx
::create!
(fn [name]
(-> (http/POST "/api/projects" #js {:name name})
(.then (fn [^js made] (navigate! (project-path (.-id made) (.-name made)))))
(.catch #(rf/dispatch [::refused (ex-message %)])))))
(rf/reg-event-fx ::create (fn [_ [_ name]] {::create! (or name "untitled")}))
;; ---------------------------------------------------------------------------
;; the socket
(defonce ^:private socket (atom nil))
(defonce ^:private conn (atom {:id nil :tries 0 :timer nil}))
(defn- ws-url [id]
(str (if (= "https:" (.. js/window -location -protocol)) "wss://" "ws://")
(.. js/window -location -host) "/ws/projects/" id))
(declare open!)
(defn- retry-later! [id]
(let [tries (:tries @conn)
delay (min 30000 (* 500 (js/Math.pow 2 tries)))]
(swap! conn assoc :tries (inc tries)
:timer (js/setTimeout #(when (= id (:id @conn)) (open! id)) delay))))
(defn- open! [id]
(let [s (js/WebSocket. (ws-url id))]
(reset! socket s)
(set! (.-onopen s) (fn [_] (swap! conn assoc :tries 0)))
(set! (.-onmessage s) (fn [e] (rf/dispatch [::message (js/JSON.parse (.-data e))])))
;; Only the CURRENT socket clears the roster and retries: closing the last
;; project's on a switch must not wipe the new one's.
(set! (.-onclose s) (fn [_]
(when (identical? s @socket)
(reset! socket nil)
(rf/dispatch [::peers-reset])
(retry-later! id))))))
(defn- connect! [id]
(some-> (:timer @conn) js/clearTimeout)
(when-let [s @socket] (set! (.-onclose s) nil) (.close s))
(reset! socket nil)
(reset! conn {:id id :tries 0 :timer nil})
(rf/dispatch [::peers-reset])
(when id (open! id)))
(rf/reg-fx
::follow!
(fn [{:keys [id name]}]
(when id
(let [here (.. js/window -location -pathname)
path (project-path id name)]
(cond
(= path here) nil
;; Renamed: the same page, a new slug, and no new history entry.
(= id (path-id here)) (.replaceState js/history nil "" path)
:else (.pushState js/history nil "" path))))
(set! (.-title js/document) (if name (str name " — arthur") "arthur"))
(when (not= id (:id @conn))
(connect! id))))
(rf/reg-fx ::reconnect! (fn [_] (connect! (:id @conn))))
(def autosave?
"Every edit saves. Off only for tests that need an edit held unsaved."
true)
(def ^:private follow
"The address, the title and the room follow the open project, and the
document saves itself on every edit — `:paint/revision` is what moves when
the document does. A save with nothing to send sends nothing, and one made
while another is in flight goes when it lands.
THERE IS NO BARE PROJECT. A document with no id on screen at a project's
address — a built-in example, opened from the menu — is saved at once, and
becomes a project with an address of its own."
(rf/->interceptor
:id ::follow
:after (fn [ctx]
(let [db (get-in ctx [:effects :db] (get-in ctx [:coeffects :db]))
before (get-in ctx [:coeffects :db :project])
after (:project db)]
(cond-> ctx
(not= (select-keys before [:id :name]) (select-keys after [:id :name]))
(update-in [:effects :fx] (fnil conj [])
[::follow! (select-keys after [:id :name])])
(and autosave? (:id after) (vector? (:route db))
(not= (:paint/revision db) (get-in ctx [:coeffects :db :paint/revision])))
(update-in [:effects :fx] (fnil conj [])
[:dispatch [::events.project/save {:auto? true}]])
(and (nil? (:id after)) (vector? (:route db))
(or (:id before) (not= (:cid before) (:cid after))))
(update-in [:effects :fx] (fnil conj [])
[:dispatch [::events.project/save]]))))))
;; ---------------------------------------------------------------------------
;; presence
(rf/reg-event-db ::peers-reset (fn [db _] (assoc db :peers {})))
(defn- peer [^js m] {:cid (.-cid m) :user (.-user m)})
(rf/reg-event-fx
::message
(fn [{:keys [db]} [_ ^js m]]
(case (.-kind m)
"welcome" {:db (assoc db :peers {} :peer-cid (.-cid m))
;; Anything written between our GET and our joining the room
;; was broadcast to a room we were not in yet.
:dispatch [::catch-up]}
"roster" {:db (update db :peers into (map (fn [^js p] [(.-cid p) (peer p)]))
(array-seq (.-peers m)))}
("join" "state") {:db (assoc-in db [:peers (.-cid m)] (peer m))}
"leave" {:db (update db :peers dissoc (.-cid m))}
"delta" {:dispatch [::delta m]}
"access" {:dispatch [::catch-up]}
{})))
(rf/reg-sub
::peers
(fn [db _]
(->> (vals (:peers db))
(remove #(= (:cid %) (:peer-cid db)))
(sort-by (juxt (comp nil? :user) :user)))))
;; ---------------------------------------------------------------------------
;; their writes
(defn- put [m path v] (if (nil? v) (dissoc m path) (assoc m path v)))
(defn- landed
"Their change laid over ours, as `[local synced behind]`; a nil value is a
removal.
A leaf we have changed and not saved keeps our value, and theirs waits in
`behind` rather than in `synced`: `synced` is what we have SEEN, and putting
theirs there would let our next save overwrite it without a word. `take?` is
the first write winning — theirs was, so it goes on screen over ours."
[local synced behind theirs take?]
(let [pending? #(not= (get local %) (get synced %))]
(reduce-kv (fn [[now seen behind] path v]
(cond
(not (pending? path)) [(put now path v) (put seen path v) behind]
take? [(put now path v) (put seen path v) (dissoc behind path)]
:else [now seen (assoc behind path v)]))
[local synced behind] theirs)))
(rf/reg-fx
::fetch-blocks!
(fn [{:keys [keys then]}]
(-> (js/Promise.all (into-array (map #(http/GET (str "/api/blocks/" %)) keys)))
(.then #(rf/dispatch (conj then (project/store %))))
(.catch #(rf/dispatch [::events.project/failed (ex-message %)])))))
(rf/reg-event-fx
::remote
;; `written` and `removed` against what we last synced; `blocks` is the store
;; of any the new leaves name that we do not hold, once fetched.
(fn [{:keys [db]} [_ {:keys [by written removed take?] at :seq :as change} blocks]]
(let [cid (get-in db [:project :cid])
entry (store/entry (:clip/current db))
local (leaf/leaves cid (:clip entry))
theirs (merge written (zipmap removed (repeat nil)))
lost (if take?
(count (filter #(not= (get local %) (get (:synced entry) %)) (keys theirs)))
0)
[now synced behind] (landed local (:synced entry) (:behind entry) theirs take?)
have (merge (:store entry) blocks)
lack (remove #(contains? have %) (project/block-keys now))
status (fn [now synced]
(if (pos? lost)
(str lost (if (= 1 lost) " change" " changes")
" of yours lost to someone else's at the same moment — in your undo list")
(str (or by "someone") " saved r" at
(when (not= now synced) " · yours unsaved"))))]
(cond
(seq lack)
{::fetch-blocks! {:keys lack :then [::remote change]}}
(= now local)
{:db (-> db
(update :clip/current
#(or (store/edit-entry! % (fn [e] (assoc e :synced synced
:behind behind)))
%))
(assoc-in [:project :seq] at)
;; Our own write, back from the room, changes nothing to say.
(cond-> (or take? (not= by (get-in db [:me :username])))
(assoc-in [:project :status] (status now synced))))}
:else
(let [clip (leaf/clip cid now)
;; Theirs, so not a step of ours to undo.
db' (-> (edit/replace-entry db #(-> %
(assoc :clip clip :synced synced
:behind behind)
(update :store merge blocks)))
(edit/transport clip)
(update :project merge
{:seq at :status (status now synced)}))]
(cond-> {:db db'}
(not= (:fps clip) (get-in db [:clip :fps]))
(assoc ::pb/seek! [(:fps clip) (pb/frames db') (get-in db [:playback :frame])])))))))
(defn- ours
"The clip in a delta or a document that is the one open here."
[db clips]
(let [cid (get-in db [:project :cid])]
(first (filter #(= cid (.-cid ^js %)) (array-seq clips)))))
(rf/reg-event-fx
::delta
(fn [{:keys [db]} [_ ^js m]]
(let [local (get-in db [:project :seq])
seq (.-seq m)]
(cond
(or (nil? local) (<= seq local)) {}
;; A missed delta is a stale document forever, unless it is noticed.
(> seq (inc local)) {:dispatch [::catch-up]}
:else
(let [^js c (ours db (.-clips m))]
(cond-> {:db (cond-> (assoc-in db [:project :seq] seq)
(.-name m) (assoc-in [:project :name] (.-name m)))}
c (assoc :dispatch [::remote {:seq seq :by (.-by m)
:written (project/tier1 (.-leaves c))
:removed (vec (.-removed c))}])))))))
(rf/reg-fx
::catch-up!
(fn [[id take?]]
(-> (http/GET (str "/api/projects/" id))
(.then #(rf/dispatch [::caught-up % take?]))
(.catch #(js/console.warn "catching up failed" %)))))
(rf/reg-event-fx
::catch-up
(fn [{:keys [db]} [_ take?]]
(if-let [id (get-in db [:project :id])]
{::catch-up! [id take?]}
{})))
(rf/reg-event-fx
::caught-up
;; The whole document, diffed against what we last synced: which leaves they
;; wrote, and which they deleted.
(fn [{:keys [db]} [_ ^js loaded take?]]
(let [^js c (ours db (.-clips loaded))
synced (:synced (store/entry (:clip/current db)))
theirs (when c (project/tier1 (.-leaves c)))
access {:owner (.-owner loaded) :editors (vec (.-editors loaded))
:can-edit? (.-can_edit loaded)}]
(cond-> {:db (update db :project merge access)}
(and c (or take? (not= (.-seq loaded) (get-in db [:project :seq]))))
(assoc :dispatch [::remote {:seq (.-seq loaded) :by nil :take? take?
:written (into {} (remove (fn [[p v]] (= v (get synced p))))
theirs)
:removed (remove #(contains? theirs %) (keys synced))}])))))
;; ---------------------------------------------------------------------------
;; who you are, and who else may write
(rf/reg-fx
::request!
(fn [{:keys [method url body then]}]
(-> (http/request! method url body)
(.then #(rf/dispatch (conj then %)))
(.catch #(rf/dispatch [::refused (ex-message %)])))))
(rf/reg-event-fx ::who (fn [_ _] {::request! {:method "GET" :url "/api/me" :then [::signed]}}))
(rf/reg-event-fx
::sign-in
(fn [_ [_ mode username password]]
{::request! {:method "POST" :url (str "/api/" (name mode))
:body #js {:username username :password password}
:then [::signed]}}))
(rf/reg-event-fx
::sign-out
(fn [_ _] {::request! {:method "POST" :url "/api/logout" :then [::signed]}}))
(rf/reg-event-fx
::signed
;; Who you are changes what you may write and what the room calls you.
(fn [{:keys [db]} [_ ^js who]]
(let [username (.-username who)
changed? (not= username (get-in db [:me :username]))]
(cond-> {:db (assoc db :me {:username username})}
(and changed? (contains? db :me)) (assoc ::reconnect! nil
:fx [[:dispatch [::catch-up]]
[:dispatch [::events.project/list]]])))))
(rf/reg-event-db ::refused (fn [db [_ message]] (assoc-in db [:me :error] message)))
(rf/reg-sub ::me (fn [db _] (:me db)))
(rf/reg-event-fx
::add-editor
(fn [{:keys [db]} [_ username]]
{::request! {:method "POST" :url (str "/api/projects/" (get-in db [:project :id]) "/editors")
:body #js {:username username} :then [::editors]}}))
(rf/reg-event-fx
::remove-editor
(fn [{:keys [db]} [_ username]]
{::request! {:method "DELETE"
:url (str "/api/projects/" (get-in db [:project :id]) "/editors/"
(js/encodeURIComponent username))
:then [::editors]}}))
(rf/reg-event-db
::editors
(fn [db [_ ^js answer]]
(-> (assoc-in db [:project :editors] (vec (.-editors answer)))
(update :me dissoc :error))))
;; ---------------------------------------------------------------------------
;; snapshots: named versions, now that every edit saves itself
(defn- snapshots-url [db] (str "/api/projects/" (get-in db [:project :id]) "/revisions"))
(rf/reg-event-fx
::snapshots
(fn [{:keys [db]} _]
{::request! {:method "GET" :url (snapshots-url db) :then [::snapshots-listed]}}))
(rf/reg-event-db
::snapshots-listed
(fn [db [_ ^js answer]]
(assoc db :snapshots
(mapv (fn [^js r] {:id (.-id r) :name (.-summary r) :author (.-author r)
:seq (.-seq r) :created (.-created r)})
(array-seq (.-revisions answer))))))
(rf/reg-sub ::snapshot-list (fn [db _] (:snapshots db)))
(rf/reg-event-fx
::snapshot
(fn [{:keys [db]} [_ name]]
{::request! {:method "POST" :url (snapshots-url db) :body #js {:summary name}
:then [::snapshotted name]}}))
(rf/reg-event-fx
::snapshotted
(fn [{:keys [db]} [_ name _]]
{:db (assoc-in db [:project :status] (str "snapshot \"" name "\" taken"))
:dispatch [::snapshots]}))
(rf/reg-event-fx
::restore
;; An ordinary write on the server, which comes back to every open tab —
;; this one included — as a delta.
(fn [{:keys [db]} [_ {:keys [id name]}]]
{::request! {:method "POST" :url (str (snapshots-url db) "/" id "/restore")
:then [::restored name]}}))
(rf/reg-event-db
::restored
(fn [db [_ name _]] (assoc-in db [:project :status] (str "restored \"" name "\""))))
;; ---------------------------------------------------------------------------
(defn start!
"Follow the open project from now on, show what the address names — the
index, or a project — and answer the back button."
[]
(rf/reg-global-interceptor follow)
(rf/dispatch [::who])
(route!)
(.addEventListener js/window "popstate" route!))

46
frontend/src/arthur/events/edit.cljs
View file

@ -11,13 +11,32 @@
the edit.
It started life private inside `events/paint`, which was right while polygons
were the only thing anyone could edit. They are not."
(:require [arthur.footage.store :as store]))
were the only thing anyone could edit. They are not.
(defn edit-entry
"Apply `f` to the loaded ENTRY — the document and the blocks, footage and
source tracks beside it — and return the new db. For an edit that brings tier-2
data in with it, which a document edit alone cannot."
It is also where UNDO is recorded, for the same reason: being the one way a
person changes the document, it is the one place that sees every change they
make — and nothing else. A collaborator's write and an undo itself go through
`replace-entry`, which is this without the recording."
(:require [arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.footage.store :as store]))
(defn leaves
"The clip as leaves, which is what a history step is made of; nil for a clip
that has no leaf form."
[clip]
(try (leaf/leaves "u" clip) (catch :default _ nil)))
(defn- recorded [f]
(fn [entry]
(let [after (f entry)
b (when-not (identical? (:clip entry) (:clip after)) (leaves (:clip entry)))
a (when b (leaves (:clip after)))]
(cond-> after
a (assoc :history (history/record (:history entry) b a (js/Date.now)))))))
(defn replace-entry
"Apply `f` to the loaded entry without recording it as a step of yours."
[db f]
(let [id (store/edit-entry! (:clip/current db) f)]
(if id
@ -27,6 +46,21 @@
(update :project merge {:status "edited · unsaved"}))
db)))
(defn edit-entry
"Apply `f` to the loaded ENTRY — the document and the blocks, footage and
source tracks beside it — and return the new db. For an edit that brings tier-2
data in with it, which a document edit alone cannot."
[db f]
(replace-entry db (recorded f)))
(defn transport
"App-db's copy of what the transport reads off the clip, after the clip was
replaced under it — as `::events.project/project-setting` writes it."
[db clip]
(cond-> (update db :clip merge (select-keys clip [:width :height]))
(not= (:fps clip) (get-in db [:clip :fps]))
(update :clip merge {:fps (:fps clip) :display-fps (:fps clip)})))
(defn edit
"Apply `f` to the loaded clip and return the new db."
[db f]

81
frontend/src/arthur/events/history.cljs Normal file
View file

@ -0,0 +1,81 @@
(ns arthur.events.history
"Undo and redo: `domain/history` against the open document, and the keys.
An undone step is an ordinary unsaved edit afterwards, and the next save sends
it — so undo reaches a collaborator the way any change of yours does."
(:require [arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.events.edit :as edit]
[arthur.events.playback :as pb]
[arthur.footage.store :as store]
[re-frame.core :as rf]))
(defn- step
"One step of `move` on `db`: `{:db :fps :ok?}`, `:ok?` false when there was
nothing to do or the step was refused."
[db move done]
(let [entry (store/entry (:clip/current db))
leaves (edit/leaves (:clip entry))
r (when leaves (move (:history entry) leaves))]
(cond
(nil? r)
{:db (assoc-in db [:project :status] (str "nothing to " (subs done 0 4))) :ok? false}
(:blocked r)
{:db (-> (edit/replace-entry db #(assoc % :history (:history r)))
(assoc-in [:project :status]
(str "not " done ": " (:label (:blocked r))
" — someone else has changed it since")))
:ok? false}
:else
(let [clip (leaf/clip "u" (:leaves r))
[kind host node] (get-in db [:ui :selection])
label (:label (peek (get (:history r) (if (= done "undone") :undone :done))))]
{:ok? true
:db (-> (edit/replace-entry db #(assoc % :clip clip :history (:history r)))
(edit/transport clip)
;; A selection of what the step removed selects nothing.
(cond-> (and (= :node kind) (nil? (get-in clip [:symbols host :nodes node])))
(update :ui dissoc :selection))
(assoc-in [:project :status] (str done " " label " · unsaved")))}))))
(defn- steps
"`n` steps, stopping at the first that cannot be taken."
[db move done n]
(let [fps (get-in db [:clip :fps])
db (loop [db db n n]
(let [r (step db move done)]
(if (and (:ok? r) (< 1 n)) (recur (:db r) (dec n)) (:db r))))]
(cond-> {:db db}
(not= fps (get-in db [:clip :fps]))
(assoc ::pb/seek! [(get-in db [:clip :fps]) (pb/frames db) (get-in db [:playback :frame])]))))
(rf/reg-event-fx ::undo (fn [{:keys [db]} [_ n]] (steps db history/undo "undone" (or n 1))))
(rf/reg-event-fx ::redo (fn [{:keys [db]} [_ n]] (steps db history/redo "redone" (or n 1))))
(rf/reg-sub
::steps
;; The history is on the entry, outside app-db; the revision is what moves
;; when the entry does, undo and redo included.
(fn [db _]
(:paint/revision db)
(history/steps (:history (store/entry (:clip/current db))))))
(defn- typing? [^js target]
(or (#{"INPUT" "TEXTAREA" "SELECT"} (.-tagName target)) (.-isContentEditable target)))
(defn install-keys!
"⌘Z / Ctrl+Z undoes, with Shift redoes, and Ctrl+Y redoes. Not while typing
in a field, where the browser's own undo is the one wanted."
[]
(.addEventListener
js/window "keydown"
(fn [^js e]
(when (and (or (.-metaKey e) (.-ctrlKey e)) (not (typing? (.-target e))))
(let [k (.toLowerCase (.-key e))]
(when-let [ev (cond (and (= k "z") (.-shiftKey e)) ::redo
(= k "z") ::undo
(= k "y") ::redo)]
(.preventDefault e)
(rf/dispatch [ev])))))))

187
frontend/src/arthur/events/project.cljs
View file

@ -113,6 +113,11 @@
(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))
:display-fps (:fps built)
:clip built :store (:store loaded)
:footage-id footage-id
@ -168,19 +173,48 @@
(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 on-server
;; Analyses and 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 of it again, and is one request.
(atom #{}))
(defn- upload-new! [^js doc]
(let [keys (array-seq (block-keys doc))]
(if (every? @on-server keys)
(js/Promise.resolve 0)
(.then (upload-missing! doc) (fn [n] (swap! on-server into keys) n)))))
(rf/reg-fx
::save!
(fn [{:keys [id cid label clip]}]
(fn [{:keys [id cid label clip base]}]
(let [analysis (:analysis (:clip clip))
doc (project/save cid clip)
local (leaf/leaves cid (:clip clip))
base (when (and id (:synced clip)) base)
source-blocks (:source-blocks clip)]
(-> (ensure-project! id label)
(.then (fn [pid]
(-> (if analysis
(-> (if (and analysis (not (@on-server (:id analysis))))
(http/POST "/api/analyses" (analysis-payload analysis))
(js/Promise.resolve nil))
(.then (fn [_]
(when (seq source-blocks)
(when (and (seq source-blocks) (not (@on-server (:id analysis))))
(-> (upload-missing!
#js {:blocks (source/upload-blocks source-blocks)})
(.then (fn [_]
@ -192,24 +226,32 @@
#js {:source_blocks
(into-array
(source/block-keys source-blocks))})))))))
(.then (fn [_] (upload-missing! doc)))
(.then (fn [_]
(when analysis (swap! on-server conj (:id analysis)))
(upload-new! doc)))
(.then (fn [uploaded]
(-> (http/PUT (str "/api/projects/" pid)
#js {:name label
:clips #js [#js {:cid cid
:name label
:analysis (:id analysis)
:footage (:footage-id clip)
:leaves (.-leaves doc)
:blocks (block-keys doc)}]})
:base base
:clips #js [(js/Object.assign
#js {:cid cid
:name label
:analysis (:id analysis)
:footage (:footage-id clip)
:blocks (block-keys doc)}
(clip-payload doc base local
(:synced clip)))]})
(.then (fn [^js saved]
(rf/dispatch [::saved pid cid label
(.-seq saved)
(count (array-seq (.-written saved)))
uploaded])))))))))
uploaded
{:synced local :base base}])))))))))
(.catch (fn [error]
(js/console.error error)
(rf/dispatch [::failed (or (ex-message error) (str 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!
@ -219,6 +261,7 @@
(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]
@ -250,6 +293,8 @@
(rf/reg-sub ::assets (fn [db _] (:assets db)))
(declare blank-entry)
(rf/reg-fx
::open!
(fn [id]
@ -269,15 +314,21 @@
(.-schema_version loaded) " and this client reads "
project/schema-version)
{})))
(when-not clip-json
(throw (ex-info "that project has no clips" {})))
(-> (opened-entry! clip-json)
;; 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)])))))))
(.-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))]))))))
@ -481,14 +532,50 @@
(rf/reg-event-fx
::save
(fn [{:keys [db]} _]
;; `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)]
(if (or (:busy? (:project db)) (nil? clip))
clip (store/entry id)
{pid :id :keys [busy? saving? can-edit?]} (:project db)
cid (or (:cid clip) (name id))]
(cond
(nil? clip)
{}
{:db (update db :project merge {:busy? true :status "saving…"})
::save! {:id (:id (:project db))
:cid (or (:cid clip) (name id))
;; 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 (:label clip) (name id))
:clip clip}}))))
@ -534,20 +621,46 @@
(rf/reg-event-fx
::saved
(fn [{:keys [db]} [_ id cid label seq written uploaded]]
{:db (update db :project merge
{:id id :cid cid :name label :seq seq :busy? false
:status (str "saved r" seq " · " written
(if (= 1 written) " leaf" " leaves")
" · " uploaded (if (= 1 uploaded) " block" " blocks"))})
;; The all-assets folder lists saved symbols, so a save can add rows to it.
:dispatch [::list-symbols]}))
(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]]
(fn [{:keys [db]} [_ clip-id project-id name seq access]]
{:db (-> (pb/show db clip-id)
(update :project merge
(update :project merge access
{:id project-id :name name :seq seq
:cid (:cid (store/entry clip-id))
:busy? false
@ -556,7 +669,11 @@
::pb/seek! (let [{c :clip fps :fps} (store/entry clip-id)]
[fps (clip/frames c (clip/opens-on c)) 0])}))
(rf/reg-event-db
(rf/reg-event-fx
::failed
(fn [db [_ message]]
(update db :project merge {:busy? false :status (str "failed: " message)})))
(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])]))))

44
frontend/src/arthur/ui/index.cljs Normal file
View file

@ -0,0 +1,44 @@
(ns arthur.ui.index
"`/`: the projects you own and edit, and a way to make one. A project is only
ever at its own address, so this is where you are when you are in none.
Over the editor rather than instead of it: the stage, the audio element and
the draw loop stay mounted, and opening a project is showing them again."
(:require [arthur.events.collab :as collab]
[arthur.events.project :as project]
[arthur.ui.share :as share]
[re-frame.core :as rf]))
(defn view []
(when (= :index @(rf/subscribe [::collab/route]))
(let [{:keys [username error]} @(rf/subscribe [::collab/me])
{:keys [items loading?]} @(rf/subscribe [::project/listing])]
[:div.index
[:header.top
[:span.brand "arthur"]
[:span.status]
[share/account]]
[:main.index-body
(if-not username
[:<>
[:h1 "arthur"]
[:p.dim "Sign in, or create an account, to see your projects and make new ones."]]
[:<>
[:div.index-head
[:h1 "projects"]
[:button {:on-click #(rf/dispatch [::collab/create])} "new project"]]
(when error [:p.warn error])
(cond
loading? [:p.dim "…"]
(empty? items) [:p.dim "Nothing yet. A new project starts empty."]
:else
[:ul.index-list
(doall
(for [{:keys [id name owner seq updated]} items
:let [path (collab/project-path id name)]]
^{:key id}
[:li
[:a {:href path :on-click (fn [e] (.preventDefault e) (collab/navigate! path))}
(or name "untitled")]
[:span.dim (str (when (not= owner username) (str owner " · "))
"r" seq " · " (subs (str updated) 0 10))]]))])])]])))

99
frontend/src/arthur/ui/share.cljs Normal file
View file

@ -0,0 +1,99 @@
(ns arthur.ui.share
"Who is here, who may write, and who you are: the top bar's right-hand end.
The same drop-down as `openmenu` — a button, a scrim, a panel — because these
are the same kind of thing: a few rows about the document, gone on the next
click."
(:require [arthur.events.collab :as collab]
[arthur.events.project :as project]
[arthur.subs.playback :as playback]
[clojure.string :as str]
[re-frame.core :as rf]
[reagent.core :as r]))
(defn- menu
([label open? body] (menu label open? nil body))
([label open? class body]
[:div.menu-wrap
[:button {:class [class (when @open? "on")] :on-click #(swap! open? not)} label]
(when @open?
[:<> [:div.menu-scrim {:on-click #(reset! open? false)}]
(into [:div.menu] body)])]))
(defn- initial [user] (str/upper-case (subs (or user "?") 0 1)))
(defn- roster []
(let [peers @(rf/subscribe [::collab/peers])]
(when (seq peers)
[:span.roster {:title (str/join ", " (map #(or (:user %) "guest") peers))}
(doall (for [{:keys [cid user]} (take 5 peers)]
^{:key cid} [:span.peer {:class (when-not user "guest")} (initial user)]))
(when (< 5 (count peers)) [:span.dim (str "+" (- (count peers) 5))])])))
(defn- sharing []
(r/with-let [open? (r/atom false)
draft (r/atom "")]
(let [{:keys [id name owner editors can-edit?]} @(rf/subscribe [::playback/project])
{:keys [username error]} @(rf/subscribe [::collab/me])
owner? (and owner (= owner username))
link (str (.. js/window -location -origin) (collab/project-path id name))]
(when id
[menu (if (false? can-edit?) "view only ▾" "Share") open? "share-button"
[[:h2 "link"]
[:div.row
[:input.share-link {:read-only true :value link :on-focus #(.select (.-target %))}]
[:button {:on-click #(.writeText (.-clipboard js/navigator) link)} "copy"]]
(if (false? can-edit?)
[:<>
[:p.dim "you can view this; to change it, make a copy of your own"]
(when username
[:button {:on-click (fn [] (reset! open? false)
(rf/dispatch [::project/save]))}
"make a copy"])]
[:p.dim "anyone with the link can view"])
(when owner
[:<>
[:h2 "can edit"]
[:div.menu-item.static owner [:span.sub "owner"]]
(doall (for [e editors]
^{:key e}
[:div.menu-item.static e
(when owner?
[:button.link {:on-click #(rf/dispatch [::collab/remove-editor e])}
"remove"])]))
(when owner?
[:form.row {:on-submit (fn [ev]
(.preventDefault ev)
(when (seq (str/trim @draft))
(rf/dispatch [::collab/add-editor (str/trim @draft)])
(reset! draft "")))}
[:input {:placeholder "username" :value @draft
:on-change #(reset! draft (.. % -target -value))}]
[:button {:type "submit"} "add"]])
(when error [:p.warn error])])]]))))
(defn account []
(r/with-let [open? (r/atom false)
username (r/atom "")
password (r/atom "")]
(let [{signed-in :username :keys [error]} @(rf/subscribe [::collab/me])
go! (fn [mode] (rf/dispatch [::collab/sign-in mode @username @password])
(reset! password ""))]
(if signed-in
[menu (str signed-in " ▾") open?
[[:button.menu-item {:on-click (fn [] (reset! open? false)
(rf/dispatch [::collab/sign-out]))}
"sign out"]]]
[menu "sign in ▾" open?
[[:form.account {:on-submit (fn [e] (.preventDefault e) (go! :login))}
[:input {:placeholder "username" :auto-complete "username" :value @username
:on-change #(reset! username (.. % -target -value))}]
[:input {:type "password" :placeholder "password" :auto-complete "current-password"
:value @password :on-change #(reset! password (.. % -target -value))}]
[:div.row
[:button {:type "submit"} "sign in"]
[:button {:type "button" :on-click #(go! :signup)} "create account"]]
(when error [:p.warn error])]]]))))
(defn view []
[:<> [roster] [sharing] [account]])

44
frontend/src/arthur/ui/snapshots.cljs Normal file
View file

@ -0,0 +1,44 @@
(ns arthur.ui.snapshots
"Named versions. Every edit saves itself, so there is nothing to save — only
moments worth a name, to go back to."
(:require [arthur.events.collab :as collab]
[arthur.subs.playback :as playback]
[clojure.string :as str]
[re-frame.core :as rf]
[reagent.core :as r]))
(defn view []
(r/with-let [open? (r/atom false)
draft (r/atom "")]
(let [{:keys [can-edit?]} @(rf/subscribe [::playback/project])
rows @(rf/subscribe [::collab/snapshot-list])
editable? (not (false? can-edit?))]
[:div.menu-wrap
[:button {:class (when @open? "on")
:on-click (fn [] (when-not @open? (rf/dispatch [::collab/snapshots]))
(swap! open? not))}
"snapshots ▾"]
(when @open?
[:<> [:div.menu-scrim {:on-click #(reset! open? false)}]
[:div.menu.menu-left
(when editable?
[:form.row {:on-submit (fn [e]
(.preventDefault e)
(rf/dispatch [::collab/snapshot
(or (not-empty (str/trim @draft)) "snapshot")])
(reset! draft ""))}
[:input {:placeholder "name this version" :value @draft :auto-focus true
:on-change #(reset! draft (.. % -target -value))}]
[:button {:type "submit"} "take snapshot"]])
[:h2 "snapshots"]
(if (empty? rows)
[:div.dim "none yet"]
(doall
(for [{:keys [id name author created] :as row} rows]
^{:key id}
[:div.menu-item.static
[:span name [:span.sub (str author " · " (subs (str created) 0 16))]]
(when editable?
[:button.link {:on-click (fn [] (reset! open? false)
(rf/dispatch [::collab/restore row]))}
"restore"])])))]])])))

15
frontend/src/arthur/ui/topbar.cljs
View file

@ -5,10 +5,14 @@
Save, open and export are here rather than in a pane because none of them is a
property of a selection — they act on the document, and the document is the
window."
(:require [arthur.events.export :as export]
(:require [arthur.events.collab :as collab]
[arthur.events.export :as export]
[arthur.events.project :as project]
[arthur.subs.playback :as playback]
[arthur.ui.openmenu :as openmenu]
[arthur.ui.share :as share]
[arthur.ui.snapshots :as snapshots]
[arthur.ui.undo :as undo]
[re-frame.core :as rf]))
(defn- exporter []
@ -47,7 +51,8 @@
{footage-status :status} @(rf/subscribe [::playback/footage])
{export-status :status} @(rf/subscribe [::export/state])]
[:header.top
[:span.brand "arthur"]
[:a.brand {:href "/" :title "your projects"
:on-click (fn [e] (.preventDefault e) (collab/navigate! "/"))} "arthur"]
[:span.status
(str (or project-name "untitled") (when seq (str " r" seq))
;; One line, and the most recent thing to have happened wins it. A
@ -55,6 +60,8 @@
(when-let [said (or export-status project-status footage-status)]
(str " · " said)))]
[exporter]
[:button {:disabled busy? :on-click #(rf/dispatch [::project/new])} "new"]
[:button {:disabled busy? :on-click #(rf/dispatch [::collab/create])} "new"]
[openmenu/view]
[:button {:disabled busy? :on-click #(rf/dispatch [::project/save])} "save"]]))
[undo/view]
[snapshots/view]
[share/view]]))

32
frontend/src/arthur/ui/undo.cljs Normal file
View file

@ -0,0 +1,32 @@
(ns arthur.ui.undo
"Undo, redo, and the list of what undo would take off — newest first, so
choosing the third row undoes three steps."
(:require [arthur.events.history :as history]
[re-frame.core :as rf]
[reagent.core :as r]))
(defn view []
(r/with-let [open? (r/atom false)]
(let [{:keys [done undone]} @(rf/subscribe [::history/steps])]
[:div.menu-wrap.undo
[:button {:disabled (empty? done) :title (if (seq done) (str "undo " (first done) " (⌘Z)") "nothing to undo")
:on-click #(rf/dispatch [::history/undo])}
"undo"]
[:button.undo-list {:disabled (empty? done) :class (when @open? "on")
:title "undo history" :on-click #(swap! open? not)}
"▾"]
[:button {:disabled (empty? undone) :title (if (seq undone) (str "redo " (first undone) " (⇧⌘Z)") "nothing to redo")
:on-click #(rf/dispatch [::history/redo])}
"redo"]
(when (and @open? (seq done))
[:<> [:div.menu-scrim {:on-click #(reset! open? false)}]
[:div.menu.menu-left
[:h2 "undo"]
(doall
(map-indexed
(fn [i label]
^{:key i}
[:button.menu-item {:on-click (fn [] (reset! open? false)
(rf/dispatch [::history/undo (inc i)]))}
label (when (pos? i) [:span.sub (str (inc i) " steps")])])
(take 30 done)))]])])))

63
frontend/test/arthur/domain/history_test.cljs Normal file
View file

@ -0,0 +1,63 @@
(ns arthur.domain.history-test
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.history :as history]))
(def empty-doc {"t" 1})
(deftest undo-and-redo-walk-your-own-steps
(let [made (assoc empty-doc "b" :shape)
moved (assoc made "b" :moved)
h (-> nil
(history/record empty-doc made 0)
(history/record made moved 5000))
one (history/undo h moved)
two (history/undo (:history one) (:leaves one))]
(is (= made (:leaves one)))
(is (= empty-doc (:leaves two)))
(is (nil? (history/undo (:history two) (:leaves two))))
(is (= made (:leaves (history/redo (:history two) (:leaves two)))))))
(deftest a-drag-is-one-step
(let [h (reduce (fn [h [x t]] (history/record h {"v" (dec x)} {"v" x} t))
nil [[1 0] [2 100] [3 200]])]
(is (= 1 (count (:done h))))
(is (= {"v" 0} (:leaves (history/undo h {"v" 3}))))))
(deftest their-write-between-two-of-mine-keeps-them-apart
(let [h (-> nil
(history/record {"fps" 30} {"fps" 12} 0)
;; theirs lands: 12 -> 9, not recorded
(history/record {"fps" 9} {"fps" 15} 300))]
(is (= 2 (count (:done h))))
(is (= {"fps" 9} (:leaves (history/undo h {"fps" 15}))))))
(deftest undo-never-takes-somebody-elses-work
(testing "I make b; they edit it; I edit it; I undo twice"
(let [made {"b" :shape}
theirs {"b" :their-edit}
mine {"b" :my-edit}
h (-> nil
(history/record {} made 0)
;; their edit arrives as a remote write: not recorded
(history/record theirs mine 5000))
one (history/undo h mine)
two (history/undo (:history one) (:leaves one))]
(is (= theirs (:leaves one)) "my edit comes off, theirs is what is left")
(is (:blocked two) "removing b would remove their edit, so it is refused")
(is (empty? (:done (:history two))) "and the refused step is dropped"))))
(deftest a-new-edit-clears-redo
(let [h (history/record nil {} {"a" 1} 0)
u (history/undo h {"a" 1})
h (history/record (:history u) (:leaves u) {"c" 1} 9000)]
(is (nil? (history/redo h {"c" 1})))))
(deftest a-step-says-what-it-was
(let [node "clip/u/symbol/main/node/b"
pts "clip/u/symbol/main/channel/b/geom.pts"
made {node {:id :b :name "shape 3"} pts :p}]
(is (= "add shape 3" (history/label {} made [node pts])))
(is (= "edit shape 3" (history/label made (assoc made pts :q) [pts])))
(is (= "delete shape 3" (history/label made {} [node pts])))
(is (= "project settings" (history/label {} {"clip/u/timing" {:fps 9}} ["clip/u/timing"])))
(is (= ["add shape 3"] (:done (history/steps (history/record nil {} made 0)))))))

6
frontend/test/arthur/domain/leaf_test.cljs
View file

@ -30,6 +30,12 @@
(testing label
(is (= c (leaf/clip :c1 (leaf/leaves :c1 c)))))))
(deftest an-empty-symbol-comes-back-a-symbol
;; No node leaves, and still `:nodes {}`: nil there is what `symbol/nodes-of`
;; refuses, so a saved blank document would not open.
(is (= (get-in (clip/blank) [:symbols :main])
(get-in (leaf/clip :c1 (leaf/leaves :c1 (clip/blank))) [:symbols :main]))))
(deftest the-leaves-are-the-paths-the-sync-design-names
(let [ls (leaf/leaves :c7 @take/clip)]
(is (contains? ls "clip/c7/timing"))

51
frontend/test/browser/take.mjs
View file

@ -303,10 +303,27 @@ async function main() {
if (!probe) throw new Error('no canvas.stage on the page — ' +
(page.logs.slice(0, 3).join(' | ') || 'is `shadow-cljs watch app` running?'));
console.log(`\ncanvas ${probe.w}x${probe.h}, ${probe.doc}`);
// `/` is the index, and a project is only ever at its own address, so the
// suite signs up, makes one, and opens it — the page's own navigation, so
// this CDP session and its console stay attached.
const home = await page.eval(`(async () => {
const post = (url, body) => fetch(url, {method: 'POST', body: JSON.stringify(body),
headers: {'Content-Type': 'application/json',
'X-CSRFToken': document.cookie.match(/csrftoken=([^;]+)/)[1]}}).then(r => r.json());
await post('/api/signup', {username: 'suite-' + Date.now().toString(36), password: 'password1'});
const made = await post('/api/projects', {name: 'untitled'});
arthur.events.collab.navigate_BANG_(arthur.events.collab.project_path(made.id, made.name));
return location.pathname; })()`);
for (let i = 0; i < 100; i++) {
probe = await page.eval(PROBE);
if (/opened/.test(probe.doc)) break;
await sleep(100);
}
check(probe.drawn === 0 && /new document/.test(probe.doc),
'the app opens on a blank document',
console.log(`\ncanvas ${probe.w}x${probe.h}, ${probe.doc} at ${home}`);
check(probe.drawn === 0 && /opened untitled/.test(probe.doc),
'a new project opens on a blank document',
`${probe.drawn} px drawn — ${probe.doc}`);
check(probe.w === 320 && probe.h === 200, 'the canvas is the stage size',
`${probe.w}x${probe.h}`);
@ -432,9 +449,10 @@ async function main() {
await sleep(150);
const sent = await sample(FRAMES);
check(await page.eval(CLICK('save')), 'save is clickable');
// There is no save: every edit saves itself, and a built-in example opened
// in a project becomes a project of its own at once.
const saved = await statusMatching(/saved r\d+/);
check(saved !== null, 'the document saves', saved ?? (await page.eval(STATUS)));
check(saved !== null, 'the take becomes a saved project by itself', saved ?? (await page.eval(STATUS)));
// Upload count may be zero when the content-addressed blocks already exist
// on this server. The saved clip must still reference them.
const savedBlocks = await page.eval(`(async () => {
@ -445,14 +463,16 @@ async function main() {
check(savedBlocks > 0, 'the saved clip references its tier 2 blocks',
`${savedBlocks} blocks`);
// Again, unchanged. Content addressing means the second save uploads nothing
// and rewrites nothing: this is the assertion that the keys are stable across
// two independent freezes of the same take, and that an unchanged leaf keeps
// its version rather than being rewritten.
check(await page.eval(CLICK('save')), 'save is clickable again');
const resaved = await statusMatching(/saved r\d+ · 0 leaves · 0 blocks/);
check(resaved !== null, 'saving an unchanged document writes nothing',
resaved ?? (await page.eval(STATUS)));
// Unchanged, nothing is written: the project's seq stands still. This is
// the assertion that the keys are stable and a clean document is clean.
const seqOf = `(async () => {
const id = location.pathname.split('/')[2];
return (await fetch('/api/projects/' + id).then(r => r.json())).seq; })()`;
const seqBefore = await page.eval(seqOf);
await sleep(800);
const seqAfter = await page.eval(seqOf);
check(seqBefore === seqAfter, 'an unchanged document writes nothing',
`seq ${seqBefore} -> ${seqAfter}`);
check(await fromMenu(MENU_PICK_NEWEST), 'open is clickable');
const opened = await statusMatching(/opened /);
@ -550,9 +570,8 @@ async function main() {
.find(el => el.textContent.startsWith('key 8 → 16'));
return label?.querySelector('select')?.value === 'linear';
})()`), 'the second drawing gap can be set to tween');
check(await page.eval(CLICK('save')), 'the painted document can be saved');
check((await statusMatching(/saved r\d+ · \d+ leaves/)) !== null,
'the painted shape is saved', await page.eval(STATUS));
check((await statusMatching(/saved r\d+/)) !== null,
'the painted shape saves by itself', await page.eval(STATUS));
check(await fromMenu(MENU_PICK_NEWEST), 'the painted document can be reopened');
check((await statusMatching(/opened /)) !== null,
'the painted shape is reopened', await page.eval(STATUS));