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

Compare commits

base: noe:1ae4251a34d4417887dd64097dc52a2ec692eed1
Branches Tags
noe:main
..
compare: noe:79a87403b52b0e213f10181fc7edbdfa3205004e
Branches Tags
noe:main

No commits in common. "1ae4251a34d4417887dd64097dc52a2ec692eed1" and "79a87403b52b0e213f10181fc7edbdfa3205004e" have entirely different histories.
1ae4251a34 ... 79a87403b5

11 changed files with 60 additions and 1017 deletions
Download patch file Download diff file Expand all files Collapse all files

50
scenes/consumers.py
View file

@ -1,60 +1,22 @@
import json
import uuid
from channels.generic.websocket import AsyncWebsocketConsumer
class SceneConsumer(AsyncWebsocketConsumer):
"""One connection per open project. Two things ride it.
Scene deltas: relayed from what the server broadcasts on a save (see
scenes.views.scene). Read-only — edits still go through the PUT endpoint,
which is the broadcast source.
Presence: who's viewing, which ad-hoc party they're in, and where that party
is looking. Peers gossip it between themselves and work the party out
locally (tl.party); all this does is hand out a connection id, stamp the
sender's server-side identity onto every message — so nobody can post as
somebody else — and relay. Nothing about a party is stored anywhere.
"""
RELAYED = ("state", "nav")
"""One connection per open project. Joins the project's group and relays
scene deltas the server broadcasts (see scenes.views.scene). Read-only:
edits still go through the PUT endpoint, which is the broadcast source."""
async def connect(self):
self.pk = self.scope["url_route"]["kwargs"]["pk"]
self.group = f"project_{self.pk}"
self.cid = uuid.uuid4().hex[:12]
user = self.scope.get("user")
self.username = user.get_username() if user and user.is_authenticated else None
self.pk = self.scope['url_route']['kwargs']['pk']
self.group = f'project_{self.pk}'
await self.channel_layer.group_add(self.group, self.channel_name)
await self.accept()
await self.send(text_data=json.dumps(
{"kind": "welcome", "cid": self.cid, "user": self.username}))
# the room answers a join with their own state, so rosters fill in both ways
await self._relay({"kind": "join"})
async def disconnect(self, code):
if hasattr(self, "cid"):
await self._relay({"kind": "leave"})
await self.channel_layer.group_discard(self.group, self.channel_name)
async def receive(self, text_data=None, bytes_data=None):
try:
msg = json.loads(text_data or "{}")
except ValueError:
return
if isinstance(msg, dict) and msg.get("kind") in self.RELAYED:
await self._relay(msg)
async def _relay(self, msg):
await self.channel_layer.group_send(
self.group,
{"type": "peer.msg", "msg": {**msg, "cid": self.cid, "user": self.username}})
# broadcast handler: {type: "peer.msg", msg: {...}} — presence gossip
async def peer_msg(self, event):
await self.send(text_data=json.dumps(event["msg"]))
# broadcast handler: {type: "scene.delta", delta: {...}}
async def scene_delta(self, event):
await self.send(text_data=json.dumps(event["delta"]))
await self.send(text_data=json.dumps(event['delta']))

60
scenes/tests.py
View file

@ -1,12 +1,9 @@
import json
from channels.testing import WebsocketCommunicator
from django.contrib.auth import get_user_model
from django.contrib.auth.models import AnonymousUser
from django.test import Client, TestCase, TransactionTestCase
from django.test import Client, TestCase
from scenes.models import Project, Revision
from server.asgi import application
User = get_user_model()
@ -106,58 +103,3 @@ class AccessTests(SceneApiTestCase):
User.objects.create_user("carol", password="pw")
carol = Client(); carol.login(username="carol", password="pw")
self.assertEqual(self.put(carol, changed={"a1": ann("x")}).status_code, 404)
class PresenceRelayTests(TransactionTestCase):
"""The socket hands out connection ids and stamps identity; the party itself
is worked out in the browsers, so there is nothing here to store or trust."""
def setUp(self):
self.alice = User.objects.create_user("alice", password="pw")
self.project = Project.objects.create(owner=self.alice, name="p")
async def open(self, user=None):
comm = WebsocketCommunicator(application, f"/ws/projects/{self.project.pk}/")
comm.scope["user"] = user or AnonymousUser()
connected, _ = await comm.connect()
self.assertTrue(connected)
return comm, await comm.receive_json_from()
async def test_welcome_carries_an_id_and_the_signed_in_name(self):
comm, welcome = await self.open(self.alice)
self.assertEqual(welcome["kind"], "welcome")
self.assertEqual(welcome["user"], "alice")
self.assertTrue(welcome["cid"])
await comm.disconnect()
async def test_presence_is_stamped_with_the_server_side_identity(self):
a, a_hello = await self.open(self.alice)
await a.receive_json_from() # our own join, echoed back
b, _ = await self.open()
self.assertEqual((await a.receive_json_from())["kind"], "join")
await b.send_json_to({"kind": "state", "party": a_hello["cid"],
"joinable": True, "joining": a_hello["cid"],
"user": "alice", "cid": "forged"})
seen = await a.receive_json_from()
self.assertEqual(seen["party"], a_hello["cid"])
self.assertIsNone(seen["user"]) # anonymous, not "alice"
self.assertNotEqual(seen["cid"], "forged")
await a.disconnect(); await b.disconnect()
async def test_scene_edits_are_not_accepted_over_the_socket(self):
a, _ = await self.open(self.alice)
await a.receive_json_from() # join
await a.send_json_to({"kind": "scene", "changed": {"a1": ann("x")}})
self.assertTrue(await a.receive_nothing(timeout=0.2))
await a.disconnect()
async def test_leaving_tells_the_room(self):
a, _ = await self.open(self.alice)
await a.receive_json_from() # join
b, b_hello = await self.open()
await a.receive_json_from() # b's join
await b.disconnect()
bye = await a.receive_json_from()
self.assertEqual((bye["kind"], bye["cid"]), ("leave", b_hello["cid"]))
await a.disconnect()

42
tl/resources/public/css/app.css
View file

@ -658,48 +658,6 @@ html.dark .timeline-head {
font-family: var(--chicago); font-size: 11px; white-space: nowrap; }
.menu-pop button:hover { background: var(--ink); color: var(--paper); }
/* --- who's viewing: presence cluster + party menu ----------------------- */
.presence { display: flex; align-items: center; gap: 5px; }
.avatars { display: flex; align-items: center; gap: 3px; padding: 1px 4px;
background: var(--paper); border: 1px solid transparent; cursor: pointer; }
.avatars:hover, .presence.in-party .avatars { border-color: var(--ink); }
.avatar { width: 18px; height: 18px; flex: 0 0 auto; border: 1px solid var(--ink);
border-radius: 50%; display: inline-flex; align-items: center;
justify-content: center; font-family: var(--chicago); font-size: 10px;
color: #000; box-sizing: border-box; }
/* party-mates wear the badge; everyone else is just present */
.avatar.mate { box-shadow: 0 0 0 2px var(--paper), 0 0 0 3px var(--ink); }
.avatar.more { background: var(--paper) !important; color: var(--ink); font-size: 9px; }
.party-tag { font-family: var(--chicago); font-size: 9px; letter-spacing: 1px;
text-transform: uppercase; padding: 0 3px; margin-right: 2px;
background: var(--ink); color: var(--paper); }
.solo-btn { font-size: 10px; }
/* detached while authoring: still in the party, just not being steered by it */
.presence.detached .party-tag { background: var(--paper); color: var(--ink);
border: 1px solid var(--ink); }
.presence.detached .avatar.mate { box-shadow: none; opacity: 0.5; }
.peer-pop { min-width: 232px; padding: 0; }
.peer-group { padding: 4px; border-bottom: 1px solid var(--ink); }
.peer-group:last-of-type { border-bottom: none; }
.peer-group.mine { background: var(--shade); }
.peer-group-head { display: flex; align-items: center; justify-content: space-between;
gap: 8px; padding: 2px 4px 4px; font-family: var(--chicago);
font-size: 10px; letter-spacing: 0.5px; text-transform: uppercase;
color: var(--mute); }
.peer-group.mine .peer-group-head { color: var(--ink); }
.peer-row { display: flex; align-items: center; gap: 6px; padding: 3px 4px; }
.peer-name { flex: 1; min-width: 0; overflow: hidden; text-overflow: ellipsis;
white-space: nowrap; font-size: 12px; }
.peer-you { color: var(--mute); }
.peer-closed { font-size: 10px; color: var(--mute); }
.link-btn { background: none; border: none; padding: 0 2px; cursor: pointer;
font-family: var(--chicago); font-size: 10px; color: var(--ink);
text-decoration: underline; }
.link-btn:hover { background: var(--ink); color: var(--paper); text-decoration: none; }
.peer-setting { display: flex; align-items: center; gap: 6px; padding: 6px 8px;
border-top: 2px solid var(--ink); font-size: 11px; cursor: pointer; }
/* --- annotation / script pane tabs ------------------------------------- */
.pane-wrap { flex: 1; min-width: 0; display: flex; flex-direction: column; }
.pane-tabs { display: flex; gap: 0; background: var(--paper); border-bottom: 1px solid var(--ink); }

101
tl/src/tl/api.cljs
View file

@ -70,96 +70,25 @@
nil)
fallback))
;; --- realtime: the project socket ----------------------------------------
;; Two things ride it: scene deltas the server broadcasts after a PUT (the
;; untagged message, kept as the default branch below), and the presence gossip
;; peers send each other — who's viewing, who's in which party, and where the
;; party is looking. Not fetches, so they can't ride :http-xhrio; each message
;; dispatches its own event.
;; --- realtime: live peer deltas over a websocket --------------------------
;; Not a fetch, so it can't ride :http-xhrio; it dispatches ::peer-delta itself.
(defn- ->clj [x] (js->clj x :keywordize-keys true))
(defonce ^:private socket (atom nil))
(defonce ^:private conn (atom {:id nil :tries 0 :timer nil}))
(defn- event-for [{:keys [kind] :as msg}]
[(case kind
"welcome" :tl.events/peer-welcome
"join" :tl.events/peer-join
"state" :tl.events/peer-state
"leave" :tl.events/peer-leave
"nav" :tl.events/peer-nav
:tl.events/peer-delta) ; untagged = a scene delta
msg])
(defn- ws-url [id]
(let [l js/window.location
proto (if (= "https:" (.-protocol l)) "wss:" "ws:")
host (if (= "" api-port) (.-host l) (str (.-hostname l) ":" api-port))]
(str proto "//" host "/ws/projects/" id "/")))
(declare open!)
;; A dropped socket is the normal case, not the exception — a laptop lid, a
;; tunnel, a backend redeploy. Back off up to ~15s and keep trying; the welcome
;; that comes back is what tells the app to catch up on what it missed.
(defn- retry-later! [id]
(let [tries (:tries @conn)]
(swap! conn assoc
:tries (inc tries)
:timer (js/setTimeout #(open! id) (min 15000 (* 500 (js/Math.pow 2 tries)))))))
(defn- open! [id]
(when (= id (:id @conn))
(let [s (js/WebSocket. (ws-url id))]
(reset! socket s)
(set! (.-onopen s) (fn [_] (swap! conn assoc :tries 0)))
(set! (.-onerror s) (fn [_] (js/console.warn "scene sync socket error; peer updates paused")))
(set! (.-onmessage s) (fn [e] (rf/dispatch (event-for (->clj (js/JSON.parse (.-data e)))))))
;; off the wire we stop hearing about peers, so stop claiming to see them.
;; Only the *current* socket does this — closing the previous one on a
;; project switch must not wipe the new one's roster or retry into it.
(set! (.-onclose s) (fn [_]
(when (identical? s @socket)
(reset! socket nil)
(rf/dispatch [:tl.events/peers-reset])
(retry-later! id)))))))
(defn connect-scene!
"Open (or replace) the websocket for project `id`, and keep it open."
"Open (or replace) the websocket that streams peer scene deltas for project
`id`. Incoming messages dispatch ::peer-delta, which merges them in."
[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})
(when id (open! id)))
(defn- send! [msg]
(when-let [s @socket]
(when (= 1 (.-readyState s)) ; OPEN — silently skip otherwise
(.send s (js/JSON.stringify (clj->js msg))))))
;; our presence state (party membership + whether we let people in) — rare
;; enough to go straight out
(def send-state! send!)
;; Nav rides every scrub and every jump, so it is throttled: leading edge for a
;; snappy first move, trailing edge so the party lands on the final position
;; rather than wherever the last tick happened to fall.
(def ^:private nav-gap-ms 120)
(defonce ^:private nav-last (atom 0))
(defonce ^:private nav-timer (atom nil))
(defonce ^:private nav-pending (atom nil))
(defn- flush-nav! []
(reset! nav-timer nil)
(reset! nav-last (js/Date.now))
(when-let [m @nav-pending] (reset! nav-pending nil) (send! m)))
(defn send-nav! [msg]
(reset! nav-pending msg)
(when @nav-timer (js/clearTimeout @nav-timer))
(let [due (max 0 (- nav-gap-ms (- (js/Date.now) @nav-last)))]
(if (zero? due)
(flush-nav!)
(reset! nav-timer (js/setTimeout flush-nav! due)))))
(when-let [s @socket] (.close s))
(when id
(let [l js/window.location
proto (if (= "https:" (.-protocol l)) "wss:" "ws:")
host (if (= "" api-port) (.-host l) (str (.-hostname l) ":" api-port))
url (str proto "//" host "/ws/projects/" id "/")
s (js/WebSocket. url)]
(reset! socket s)
(set! (.-onerror s) (fn [_] (js/console.warn "scene sync socket error; peer updates paused")))
(set! (.-onmessage s)
(fn [e] (rf/dispatch [:tl.events/peer-delta (->clj (js/JSON.parse (.-data e)))]))))))

4
tl/src/tl/db.cljs
View file

@ -19,10 +19,6 @@
:scene {:tracks {}
:groups {:root {:type :timeline :name "root"}}}
;; who else is viewing, and the ad-hoc party we're in (see tl.party).
;; :me is our connection id, handed out by the server; the roster is gossip.
:peers {:me nil :roster {} :joinable true :parked nil}
;; view state
:view {:stack [:root] ; timeline-stack; top = current context
:playheads {} ; per-context local playhead

330
tl/src/tl/events.cljs
View file

@ -6,7 +6,6 @@
[tl.api :as api]
[tl.db :as db]
[tl.otio :as otio]
[tl.party :as party]
[tl.routes :as routes]
[tl.scene :as scene]))
@ -89,49 +88,6 @@
(assoc fx :route/replace-project-state (route-state db))
fx))
(defn- seek-fx
"Effect map putting the video on the current context's playhead (nothing when
the context resolves to no footage)."
[db]
(let [ctx (peek (get-in db [:view :stack]))
segs (scene/content-segments (:scene db) ctx)
sf (scene/local->source segs (scene/playhead (:view db) ctx))]
(when sf {:player/seek (/ sf (:fps db))})))
;; --- parties: telling the others where we're looking ----------------------
;; The roster and the party maths live in tl.party; these are the two ends of
;; it inside the event layer — what we broadcast, and the gate on broadcasting.
(defn- roster [db] (get-in db [:peers :roster] {}))
(defn- my-cid [db] (get-in db [:peers :me]))
(defn- nav-state
"Where we're looking, as the party sees it: which timeline we're in, where the
playhead sits, and whether we're rolling."
[db]
(let [stack (get-in db [:view :stack])]
{:kind "nav"
:stack (mapv name stack)
:playhead (scene/playhead (:view db) (peek stack))
:playing (boolean (get-in db [:view :playing?]))}))
(defn- authoring?
"Is a draft open? Authoring means hunting around the timeline for marks, which
is nobody else's business — so while it's open we detach from the party: we
don't drive it (here) and it doesn't drive us (::peer-nav), and we catch up
with wherever it got to when the form closes (::finish-edit)."
[db]
(boolean (some :draft (vals (get-in db [:scene :groups])))))
(defn- sync-view
"URL + party for an event that moved the view. Only deliberate moves go out:
playback ticks are left alone, because every member is running the same clip
off its own clock and a stream of positions would just fight them."
[fx db]
(cond-> (sync-route fx db)
(and (seq (party/peers (roster db) (my-cid db))) (not (authoring? db)))
(assoc :peer/nav (nav-state db))))
;; --- auth + routing -------------------------------------------------------
(rf/reg-event-fx ::set-auth
@ -175,21 +131,14 @@
;; the next one) doesn't flash the previous project's name/scene/thumbnails or a
;; stale load error while the next one loads.
(defn- reset-project [db]
(merge db (select-keys db/default-db [:project :scene :fps :view :load :save-error :peers])))
(merge db (select-keys db/default-db [:project :scene :fps :view :load :save-error])))
;; Leaving also drops the socket. It isn't just tidiness any more: an open
;; socket keeps us in the project's roster, so peers would go on seeing us
;; viewing something we walked away from — and its deltas would land in the
;; next project's db while that one loads.
(rf/reg-event-fx ::nav-list
(fn [{:keys [db]} _] {:db (-> (reset-project db) (assoc :page :list))
:connect-scene nil
:fetch-projects true}))
(rf/reg-event-db ::set-projects (fn [db [_ ps]] (assoc db :projects ps :projects-error nil)))
(rf/reg-event-fx ::nav-create (fn [{:keys [db]} _]
{:db (-> (reset-project db)
(assoc :page :create :create-error nil))
:connect-scene nil}))
(rf/reg-event-db ::nav-create (fn [db _] (-> (reset-project db)
(assoc :page :create :create-error nil))))
;; loading a project is a three-hop chain: detail → OTIO file → scene, each
;; feeding the next, and any hop's failure lands the editor in :error.
@ -199,7 +148,6 @@
(assoc :page :editor)
(assoc-in [:load :status] :loading)
(assoc-in [:view :route-state] view-state))
:connect-scene nil ; the previous project's, until ::project-ready
:http-xhrio (api/GET (str "/api/projects/" id "/")
{:on-success [::project-detail-loaded]
:on-failure [::project-load-error]})}))
@ -242,230 +190,16 @@
;; A peer saved: merge their attributed groups in (and drop deletions). We keep
;; any group we're currently editing (flagged :draft) so a peer save can't yank
;; an in-progress edit out from under us — our own save is authoritative for it.
(defn- merge-delta [db {:keys [changed deleted]}]
(rf/reg-event-db
::peer-delta
(fn [db [_ {:keys [changed deleted]}]]
(let [restored (scene/restore-annotations changed)
drafts (into #{} (keep (fn [[gid g]] (when (:draft g) gid))
(get-in db [:scene :groups])))]
(update-in db [:scene :groups]
(fn [groups]
(-> (apply dissoc groups (map keyword deleted))
(into (remove (fn [[gid _]] (contains? drafts gid)) restored)))))))
(defn- prune-stack
"A peer deleted a timeline we were standing in: fall back to the nearest
surviving ancestor rather than rendering an empty context."
[db]
(let [stack (get-in db [:view :stack])
live (vec (valid-stack (:scene db) stack))]
(cond-> db (not= live stack) (assoc-in [:view :stack] live))))
(rf/reg-event-fx
::peer-delta
(fn [{:keys [db]} [_ delta]]
(let [was (get-in db [:view :stack])
db (-> db (merge-delta delta) prune-stack)
parked (get-in db [:peers :parked])]
(cond-> {:db db}
(not= was (get-in db [:view :stack])) (merge (seek-fx db))
;; a party jump we had to park (below) may be applicable now that this
;; delta has landed — the group it pointed at was probably in it.
parked (assoc :dispatch [::peer-nav parked])))))
;; --- presence: who else is viewing, and the party we're in ---------------
;; Everything the peers know about each other arrives here as gossip; tl.party
;; turns the roster into parties. The server only stamps identity and relays,
;; so a party forms, drives and dissolves entirely between the browsers in it.
(def ^:private joinable-key "tl/joinable")
(rf/reg-fx :peer/nav api/send-nav!)
(rf/reg-fx :peer/state api/send-state!)
(rf/reg-fx :peer/remember-joinable
(fn [on?] (.setItem js/localStorage joinable-key (if on? "1" "0"))))
(defn- joinable-pref [] (not= "0" (.getItem js/localStorage joinable-key)))
(defn- state-msg
"Our presence state. `joining` names the peer we just clicked Join on — they
adopt the party id if they're solo and letting people in; everyone else reads
it as \"the sender is the newcomer\"."
([db] (state-msg db nil))
([db joining]
{:kind "state"
:party (party/party-of (roster db) (my-cid db))
:joinable (boolean (get-in db [:peers :joinable]))
:joining joining}))
(defn- upsert-peer [db {:keys [cid user] :as msg}]
(cond-> db
cid (update-in [:peers :roster cid] merge
(cond-> {:cid cid :user (or user "guest")}
(contains? msg :party) (assoc :party (:party msg))
(contains? msg :joinable) (assoc :joinable (boolean (:joinable msg)))))))
;; Off the wire: everyone we could see is now a guess, so drop the roster. The
;; party *id* we keep — it's just a name the members still carry, so coming back
;; is a matter of saying it again rather than asking anyone's permission.
(rf/reg-event-db
::peers-reset
(fn [db _]
(assoc db :peers (merge (:peers db/default-db)
{:dropped true
:rejoin (party/party-of (roster db) (my-cid db))}))))
;; The server hands us our connection id. Answer with our own state so the room
;; learns whether we're joinable before anyone tries — and, if this is a socket
;; coming *back*, pull the scene we missed while we were gone.
(rf/reg-event-fx
::peer-welcome
(fn [{:keys [db]} [_ msg]]
(let [{:keys [dropped rejoin]} (:peers db)
cid (:cid msg)
db (-> db
(assoc-in [:peers :me] cid)
(assoc-in [:peers :joinable] (joinable-pref))
(upsert-peer msg)
(assoc-in [:peers :roster cid :party] rejoin)
(update :peers merge {:dropped false :rejoin nil}))
id (get-in db [:project :id])]
(cond-> {:db db :peer/state (state-msg db)}
(and dropped id)
(assoc :http-xhrio (api/GET (str "/api/projects/" id "/scene/")
{:on-success [::scene-resynced]
:on-failure [::ignore-error]}))))))
;; Back after a drop: the socket only streams deltas, so anything saved while we
;; were away never reached us. Merge the server's authored layer in the same way
;; a live delta merges — drafts we're holding stay ours.
;;
;; Deliberately additive. "Absent from the server" can also mean "saved a
;; moment ago and the PUT hasn't landed", and a wrong deletion costs someone
;; their work while a stale extra group costs a reload — so a deletion missed
;; while we were offline lingers until one.
(rf/reg-event-db
::scene-resynced
(fn [db [_ resp]]
(merge-delta db {:changed (get-in resp [:scene :groups] {})})))
;; someone arrived: note them, and announce ourselves so their roster fills in.
(rf/reg-event-fx
::peer-join
(fn [{:keys [db]} [_ msg]]
(let [db (upsert-peer db msg)]
(cond-> {:db db}
(not= (my-cid db) (:cid msg)) (assoc :peer/state (state-msg db))))))
(rf/reg-event-db
::peer-leave
(fn [db [_ {:keys [cid]}]]
(update-in db [:peers :roster] dissoc cid)))
(rf/reg-event-fx
::peer-state
(fn [{:keys [db]} [_ {:keys [cid joining party] :as msg}]]
(let [me (my-cid db)
db (upsert-peer db msg)
;; they clicked Join on us while we were flying solo: take on the id
;; they derived from our cid. Nobody hosts — we both just carry it.
adopt? (and me (= me joining)
(nil? (party/party-of (roster db) me))
(get-in db [:peers :joinable]))
db (cond-> db adopt? (assoc-in [:peers :roster me :party] party))
r (roster db)
mine (party/party-of r me)]
(cond-> {:db db}
adopt? (assoc :peer/state (state-msg db))
;; a newcomer landed in our party and we drew the short straw: show them
;; where we are, instead of parking them until somebody moves.
(and joining mine (= mine (party/party-of r cid))
(= me (party/responder r mine cid)))
(assoc :peer/nav (nav-state db))))))
;; Changing party drops anything parked: it's a position from the party we just
;; left, and replaying it later (on the way out of a form, say) would drag us
;; back to people we're no longer with.
(defn- set-party [db pid]
(-> db (assoc-in [:peers :roster (my-cid db) :party] pid)
(assoc-in [:peers :parked] nil)))
(rf/reg-event-fx
::join
(fn [{:keys [db]} [_ cid]]
(let [me (my-cid db) r (roster db)]
(if (party/joinable? r me cid)
(let [db (set-party db (party/join-id r cid))]
{:db db :peer/state (state-msg db cid)})
{:db db}))))
(rf/reg-event-fx
::go-solo
(fn [{:keys [db]} _]
(if (my-cid db)
(let [db (set-party db nil)]
{:db db :peer/state (state-msg db)})
{:db db})))
(rf/reg-event-fx
::set-joinable
(fn [{:keys [db]} [_ on?]]
(let [db (assoc-in db [:peers :joinable] (boolean on?))]
{:db db :peer/state (state-msg db) :peer/remember-joinable (boolean on?)})))
;; Nav is the only message that steers another browser, and it arrives relayed
;; from whatever a peer chose to send. Nothing downstream should have to cope
;; with a shape it can't use — a bad frame reaching scene/assert-frame would
;; throw inside the event loop and take the editor down with it.
(defn- nav-stack
"The peer's stack as context keywords, or nil if it isn't one we could stand
in: it has to start at the root and name timelines all the way down."
[stack]
(let [ks (when (sequential? stack) (mapv #(when (string? %) (keyword %)) stack))]
(when (and (seq ks) (= :root (first ks)) (every? some? ks)) ks)))
(defn- nav-frame [n]
(when (and (number? n) (not (neg? n)) (== n (js/Math.floor n))) n))
(defn- standable? [db gid]
(contains? #{:timeline :annotation} (get-in db [:scene :groups gid :type])))
;; A party-mate moved. We take their whole view — which timeline, where in it,
;; rolling or not — because in a party anyone drives.
(rf/reg-event-fx
::peer-nav
(fn [{:keys [db]} [_ {:keys [cid playing] :as msg}]]
(let [stack (nav-stack (:stack msg))
playhead (nav-frame (:playhead msg))]
(cond
(not (party/mirrors? (roster db) (my-cid db) cid))
;; not (or no longer) one of ours — and if we were holding their move
;; from when they were, it's stale now
{:db (cond-> db (= cid (get-in db [:peers :parked :cid]))
(assoc-in [:peers :parked] nil))}
(not (and stack playhead)) {:db db} ; nothing we can act on
;; Two reasons to hold a move rather than take it, and one answer to
;; both — park the latest one and replay it when the reason clears:
;; · we're authoring, so we're off on our own (::finish-edit replays)
;; · they jumped into a group we haven't been told about yet, because
;; they made it a moment ago and its scene delta is still in flight
;; (::peer-delta replays). Truncating to an ancestor instead would
;; strand us somewhere they aren't.
(or (authoring? db) (not (every? #(standable? db %) stack)))
{:db (assoc-in db [:peers :parked] msg)}
:else
(let [ctx (peek stack)
playing? (boolean (get-in db [:view :playing?]))
transport (not= (boolean playing) playing?)
db (-> db
(assoc-in [:peers :parked] nil)
(assoc-in [:peers :echo] transport)
(assoc-in [:view :stack] stack)
(assoc-in [:view :playheads ctx] playhead))]
(cond-> (merge (sync-route {:db db} db) (seek-fx db))
(and transport playing) (assoc :player/play true)
(and transport (not playing)) (assoc :player/pause true)))))))
(into (remove (fn [[gid _]] (contains? drafts gid)) restored))))))))
(rf/reg-event-fx
@ -877,29 +611,14 @@
sf (scene/local->source segs local)]
{:db db :player/seek (when sf (/ sf (:fps db)))})))
;; `source` is :tick when the playback clock moved us rather than the user; the
;; party hears about deliberate moves only (see sync-view).
(rf/reg-event-fx ::set-playhead
(fn [{:keys [db]} [_ ctx lf source]]
(fn [{:keys [db]} [_ ctx lf]]
(let [lf (scene/assert-frame "playhead" lf)
next-db (-> db
(assoc-in [:view :playheads ctx] lf)
(sync-draft-mark-for-playhead ctx lf))]
(if (= :tick source)
(sync-route {:db next-db} next-db)
(sync-view {:db next-db} next-db)))))
;; The <video> is the source of truth here, so this fires both for our own
;; transport and for a play the party started. Re-broadcasting the latter would
;; bounce the starter's playhead back at them, so ::peer-nav flags the plays it
;; asked for and we swallow exactly those.
(rf/reg-event-fx ::set-playing
(fn [{:keys [db]} [_ p]]
(let [echo? (get-in db [:peers :echo])
next-db (-> db (assoc-in [:view :playing?] p)
(assoc-in [:peers :echo] false))]
(if echo?
{:db next-db}
(sync-view {:db next-db} next-db)))))
(sync-route {:db next-db} next-db))))
(rf/reg-event-db ::set-playing (fn [db [_ p]] (assoc-in db [:view :playing?] p)))
;; reveal an annotation's immediate children into the current timeline lane
(rf/reg-event-db ::toggle-children
(fn [db [_ gid]]
@ -913,8 +632,11 @@
;; we land in, at its remembered playhead (0 = that context's start).
(defn- enter-ctx
[db stack-fn]
(let [db (update-in db [:view :stack] stack-fn)]
(sync-view (merge {:db db :player/pause true} (seek-fx db)) db)))
(let [db (update-in db [:view :stack] stack-fn)
ctx (peek (get-in db [:view :stack]))
segs (scene/content-segments (:scene db) ctx)
sf (scene/local->source segs (scene/playhead (:view db) ctx))]
(sync-route {:db db :player/pause true :player/seek (when sf (/ sf (:fps db)))} db)))
(rf/reg-event-fx ::expand (fn [{:keys [db]} [_ gid]] (enter-ctx db #(conj % gid))))
(rf/reg-event-fx ::collapse (fn [{:keys [db]} _] (enter-ctx db #(if (> (count %) 1) (pop %) %))))
@ -963,17 +685,15 @@
;; Edit the annotation you're currently inside: drop into its parent timeline so
;; its marks are editable there, remembering to pop back when done. Root has no
;; parent (and no marks) — edit it in place. The draft flag goes on *before* the
;; pop, so that pop is ours alone and doesn't drag the party up a level with us.
;; parent (and no marks) — edit it in place.
(rf/reg-event-fx ::edit-here
(fn [{:keys [db]} [_ gid]]
(let [root? (= :timeline (get-in db [:scene :groups gid :type]))
db (-> db (assoc-in [:scene :groups gid :draft] :edit)
(assoc-in [:view :pt] :new)
(assoc-in [:view :edit-return] (when-not root? gid)))
fx (if root? {:db db} (enter-ctx db pop))]
(update fx :db #(assoc-in % [:view :edit-context]
(peek (get-in % [:view :stack])))))))
(update fx :db #(-> % (assoc-in [:scene :groups gid :draft] :edit)
(assoc-in [:view :pt] :new)
(assoc-in [:view :edit-context] (peek (get-in % [:view :stack])))
(assoc-in [:view :edit-return] (when-not root? gid)))))))
(rf/reg-event-fx ::finish-edit
(fn [{:keys [db]} _]
;; leaving the form (save OR cancel): tear down all authoring
@ -984,16 +704,8 @@
(assoc-in [:view :pt] nil)
(assoc-in [:view :draft-stage] nil)
(assoc-in [:view :edit-return] nil)
(assoc-in [:view :edit-context] nil))
;; back on the party's clock: whatever it did while we
;; were heads-down is parked, and replaying it now puts
;; us exactly where the others are. It also takes
;; priority over hopping back into the annotation we
;; were editing — that hop would only broadcast a
;; position we're about to leave.
parked (get-in db [:peers :parked])]
(assoc-in [:view :edit-context] nil))]
(cond
parked {:db db :dispatch [::peer-nav parked]}
return-g (enter-ctx db #(conj % return-g))
:else {:db db}))))
(rf/reg-event-db ::draft-focus (fn [db [_ pt]] (assoc-in db [:view :pt] pt)))

85
tl/src/tl/party.cljs
View file

@ -1,85 +0,0 @@
(ns tl.party
"Ad-hoc viewing parties, derived from the presence roster.
Presence is a flat map of cid → {:cid :user :party :joinable}, gossiped over
the project socket (tl.api). A party is nothing but an id that its members
carry: nobody hosts one, you only join one. Joining someone who is flying
solo adopts *their cid* as the id, so two people clicking Join in the same
instant land in the same party, and the party outlives whoever was joined
first. Everyone in a party drives everyone else — a nav from any member
moves all the others — which is why joining someone needs their consent
(:joinable), and why leaving is one click.
Everything here is a pure function of the roster, so every peer computes the
same answer from the same gossip and the server never has to know any of it."
(:refer-clojure :exclude [groups]))
(defn party-of [roster cid] (get-in roster [cid :party]))
(defn members
"cids carrying party id `pid`. nil isn't a party, so it has no members."
[roster pid]
(if pid
(into #{} (keep (fn [[cid p]] (when (= pid (:party p)) cid))) roster)
#{}))
(defn peers
"The OTHER members of `cid`'s party."
[roster cid]
(disj (members roster (party-of roster cid)) cid))
(defn in-party?
"A party id nobody else carries isn't a party — it's a join that went
unanswered, or the last one standing. Either way: solo."
[roster cid]
(boolean (seq (peers roster cid))))
(defn join-id
"The party id you take on by joining `cid`: theirs if they're in one, else
their own cid. Deriving it from the target rather than minting a fresh one
is what makes simultaneous joins converge on a single party."
[roster cid]
(or (party-of roster cid) cid))
(defn joinable?
"May `me` join `cid`? They have to be someone else, have to be letting people
in, and have to not already be in the party we're in."
[roster me cid]
(boolean (and me cid (not= me cid)
(get-in roster [cid :joinable])
(let [theirs (party-of roster cid)]
(or (nil? theirs) (not= theirs (party-of roster me)))))))
(defn mirrors?
"Does `me` apply a nav broadcast from `sender`? Same party, different person."
[roster me sender]
(let [mine (party-of roster me)]
(boolean (and me (not= me sender) mine (= mine (party-of roster sender))))))
(defn responder
"The one member of `pid` that answers `newcomer` with the party's current
position, so a join draws a single reply instead of one per member: the
lowest cid among the members who were already there. Deterministic, and
still hostless — it's recomputed from whoever is present."
[roster pid newcomer]
(first (sort (disj (members roster pid) newcomer))))
(defn groups
"The roster laid out for the who's-viewing menu: parties first — mine, then
the rest largest-first — and everyone flying solo in a final {:id nil} group.
Members are named maps (:cid merged in), sorted by username."
[roster me]
(let [named (fn [cid] (assoc (get roster cid) :cid cid))
by-user (fn [cids] (mapv named (sort-by (juxt #(str (get-in roster [% :user])) str) cids)))
mine (party-of roster me)
parties (->> (keep :party (vals roster))
distinct
(keep (fn [pid]
(let [m (members roster pid)]
(when (> (count m) 1)
{:id pid :members (by-user m)}))))
(sort-by (juxt #(not= mine (:id %)) #(- (count (:members %))) #(str (:id %))))
vec)
solo (by-user (remove #(in-party? roster %) (keys roster)))]
(cond-> parties
(seq solo) (conj {:id nil :members solo}))))

51
tl/src/tl/subs.cljs
View file

@ -2,7 +2,6 @@
(:require [clojure.string :as str]
[re-frame.core :as rf]
[tl.filter :as filter]
[tl.party :as party]
[tl.scene :as scene]))
(rf/reg-sub ::status (fn [db] (get-in db [:load :status])))
@ -54,46 +53,6 @@
(rf/reg-sub ::context :<- [::stack] (fn [stack _] (peek stack)))
;; --- presence / parties ---------------------------------------------------
(rf/reg-sub ::my-cid (fn [db] (get-in db [:peers :me])))
(rf/reg-sub ::roster (fn [db] (get-in db [:peers :roster] {})))
(rf/reg-sub ::joinable (fn [db] (boolean (get-in db [:peers :joinable]))))
;; everyone on the socket, me first, for the avatar cluster — each flagged with
;; whether they're in the party I'm in.
(rf/reg-sub
::peers
:<- [::roster] :<- [::my-cid]
(fn [[r me] _]
(let [mates (party/peers r me)]
(->> (vals r)
(sort-by (juxt #(not= me (:cid %)) #(str (:user %)) :cid))
(mapv #(assoc % :you? (= me (:cid %)) :mate? (contains? mates (:cid %))))))))
(rf/reg-sub ::in-party? :<- [::roster] :<- [::my-cid]
(fn [[r me] _] (party/in-party? r me)))
;; authoring detaches us from the party until the form closes (see ::finish-edit)
(rf/reg-sub ::detached? :<- [::in-party?] :<- [::draft-group]
(fn [[in? draft] _] (boolean (and in? draft))))
;; the who's-viewing menu: parties (mine first) then everyone flying solo, with
;; each row told whether I'm allowed to join it.
(rf/reg-sub
::peer-groups
:<- [::roster] :<- [::my-cid]
(fn [[r me] _]
(let [mine (party/party-of r me)]
(mapv (fn [g]
(-> g
(assoc :mine? (and (:id g) (= (:id g) mine)))
(update :members
(fn [ms] (mapv #(assoc % :you? (= me (:cid %))
:join? (party/joinable? r me (:cid %)))
ms)))))
(party/groups r me)))))
;; Any non-draft annotation can receive marks from the current context.
(rf/reg-sub
::associate-targets
@ -305,16 +264,12 @@
(defn- binding-bars [scene ctx segs annotations bound]
(vec
(mapcat (fn [gid]
(let [g (get-in scene [:groups gid])
segments (scene/resolve scene gid)
bars #(if (= gid ctx)
(scene/merge-bars (map :local %))
(scene/project-bars % segs))]
(let [g (get-in scene [:groups gid])]
(concat
(when (seq (bound g))
[{:gids (bound g) :bars (bars segments)}])
[{:gids (bound g) :bars (scene/project-bars (scene/resolve scene gid) segs)}])
(for [m (:marks g) :when (seq (bound m))]
{:gids (bound m) :bars (bars (filter #(= (:id m) (:mark %)) segments))}))))
{:gids (bound m) :bars (scene/mark-bars scene gid (:id m) segs)}))))
(conj (set (map :id annotations)) ctx))))
(rf/reg-sub ::drawing-bars

88
tl/src/tl/views.cljs
View file

@ -152,10 +152,10 @@
discontinuity? (assoc :pending-ns ns))))
(when discontinuity?
(seek-video! fps ns))
(rf/dispatch [::events/set-playhead ctx nl :tick]))
(do (rf/dispatch [::events/set-playhead ctx (+ ls (- se ss)) :tick]) ; snap to the very end
(rf/dispatch [::events/set-playhead ctx nl]))
(do (rf/dispatch [::events/set-playhead ctx (+ ls (- se ss))]) ; snap to the very end
(.pause v))) ; end → pause event disengages
(rf/dispatch [::events/set-playhead ctx (+ ls (- sf ss)) :tick])))))
(rf/dispatch [::events/set-playhead ctx (+ ls (- sf ss))])))))
(when @play (reset! raf (js/requestAnimationFrame play-tick)))))
(defn- engage-play!
@ -188,15 +188,6 @@
;; effects the stack events use to keep the player on the current context
(rf/reg-fx :player/pause (fn [_] (when-let [v @video-el] (.pause v))))
;; A party-mate started playback. .play() can be refused (autoplay policy, if
;; this tab has had no interaction yet) — say so rather than leaving an
;; unhandled rejection, because ::set-playing is also what clears the flag that
;; stops us echoing a mirrored play back at them.
(rf/reg-fx :player/play (fn [_] (when-let [v @video-el]
(when (.-paused v)
(some-> (.play v)
(.catch (fn [_]
(rf/dispatch [::events/set-playing false]))))))))
(rf/reg-fx :player/seek (fn [secs] (when (and @video-el secs) (set! (.-currentTime @video-el) secs))))
(defn- ann-scroll-to?
@ -1214,13 +1205,13 @@
(when (has-type? e "text/ann")
(.stopPropagation e) (.preventDefault e) (reset! over? true)))
:on-drag-leave (fn [_] (reset! over? false))
;; plain drop MOVES the edge you grabbed onto this card; SHIFT-drop LINKS
;; (adds this edge, keeping the source one) — Blender's M / ⇧M.
;; plain drop MOVES the edge you grabbed onto this card; ⌜⌥/Alt⌟-drop ADDS
;; (links, keeping the source edge).
:on-drop (fn [e]
(let [src (.. e -dataTransfer (getData "text/ann"))]
(when (seq src)
(.stopPropagation e) (.preventDefault e) (reset! over? false)
(rf/dispatch [::events/reparent (keyword src) (:id a) (.-shiftKey e)]))))}))
(rf/dispatch [::events/reparent (keyword src) (:id a) (.-altKey e)]))))}))
(defn- annotation-card [a scene ctx segs nmap authed? open by-parent revealed source-parent seen]
(r/with-let [over? (r/atom false) hov? (r/atom false)]
@ -2101,72 +2092,6 @@
[:button {:on-click #(grab (routes/project-url id [:root] nil) :project)}
(if (= @copied :project) "✓ Link copied" "Copy link to the whole project")]]])]))))
;; --- who's viewing: presence + ad-hoc parties -----------------------------
;; The cluster of faces is the Google-Docs part; the menu behind it is where a
;; party is joined or left. Nobody hosts a party — see tl.party — so every row
;; offers the same thing: Join, or (for the one you're in) Leave.
(defn- avatar [{:keys [user you? mate?]}]
[:span.avatar {:class (str (when mate? "mate ") (when you? "you"))
:style {:background (str "hsl(" (mod (hash (or user "guest")) 360)
" 58% 58%)")}
:title (str user (when you? " (you)"))}
(str/upper-case (subs (if (seq user) user "?") 0 1))])
(defn- peer-group-row [{:keys [id mine? members]}]
[:div.peer-group {:class (when mine? "mine")}
[:div.peer-group-head
[:span (cond mine? (str "Your party · " (count members))
(nil? id) "Not in a party"
:else (str "Party · " (count members)))]
(cond
mine? [:button.link-btn {:on-click #(rf/dispatch [::events/go-solo])} "Leave"]
id (when-let [door (some #(when (:join? %) (:cid %)) members)]
[:button.link-btn {:on-click #(rf/dispatch [::events/join door])} "Join"]))]
(for [p members]
^{:key (:cid p)}
[:div.peer-row
[avatar p]
[:span.peer-name (:user p) (when (:you? p) [:span.peer-you " (you)"])]
(cond
(:you? p) nil
(:join? p) [:button.link-btn {:on-click #(rf/dispatch [::events/join (:cid p)])} "Join"]
;; only once we've actually heard them say so — an absent flag just
;; means their state hasn't come round yet
(false? (:joinable p)) [:span.peer-closed "not joinable"])])])
(defn presence []
(let [open? (r/atom false)]
(fn []
(let [peers @(rf/subscribe [::subs/peers])
in? @(rf/subscribe [::subs/in-party?])
off? @(rf/subscribe [::subs/detached?])
joinable @(rf/subscribe [::subs/joinable])
extra (max 0 (- (count peers) 4))]
(when (seq peers)
[:div.menu-wrap.presence {:class (str (when in? "in-party ") (when off? "detached"))}
[:button.avatars {:on-click #(swap! open? not)
:title (cond off? "Editing on your own — you'll catch up with the party when you're done"
in? "You're in a party"
:else "Who's viewing")}
(when in? [:span.party-tag (if off? "editing" "party")])
(for [p (take 4 peers)] ^{:key (:cid p)} [avatar p])
(when (pos? extra) [:span.avatar.more (str "+" extra)])]
(when in?
[:button.bar-btn.solo-btn {:on-click #(rf/dispatch [::events/go-solo])
:title "Watch on your own again"} "Leave"])
(when @open?
[:<>
[:div.menu-backdrop {:on-click #(reset! open? false)}]
[:div.menu-pop.peer-pop
(for [g @(rf/subscribe [::subs/peer-groups])]
^{:key (str (:id g))} [peer-group-row g])
[:label.peer-setting
[:input {:type "checkbox" :checked joinable
:on-change #(rf/dispatch [::events/set-joinable
(.. % -target -checked)])}]
"Let others join me"]]])])))))
(defn user-menu []
(let [open? (r/atom false)]
(fn []
@ -2196,7 +2121,6 @@
[:span.title-name (or (:name proj)
(when (= :loading @(rf/subscribe [::subs/status])) "Loading…"))]]
[:div.titlebar-right
[presence]
[share-menu]
(when authed? [user-menu])]]))

193
tl/test/tl/flow_test.cljs
View file

@ -8,17 +8,10 @@
[tl.scene :as s]
[tl.scene-test :as fixture]))
(doseq [k [:player/pause :player/play :player/seek :http-xhrio :route
:route/replace-project-state :connect-scene :fetch-projects
:poll-thumbnails :upload-project :peer/remember-joinable]]
(doseq [k [:player/pause :player/seek :http-xhrio :route :route/replace-project-state
:connect-scene :fetch-projects :poll-thumbnails :upload-project]]
(rf/reg-fx k (fn [_] nil)))
;; presence effects are the wire; capture instead of stubbing so the tests can
;; assert on what the party would actually hear.
(defonce sent (atom []))
(rf/reg-fx :peer/nav (fn [m] (swap! sent conj [:nav m])))
(rf/reg-fx :peer/state (fn [m] (swap! sent conj [:state m])))
(defn seed []
(let [sc (-> fixture/base
(fixture/annotation :a1 [:root] (s/make-mark fixture/base :root 0 100))
@ -28,16 +21,6 @@
(defn setup! [scene stack]
(reset! rdb/app-db {:scene scene :fps 24 :project {:id nil}
:view {:stack stack :playheads {} :revealed #{} :zoom 1 :row-h 20}}))
(defn peers!
"Put us on the socket as `me`, in a party with `mates` when there are any."
[me mates]
(reset! sent [])
(swap! rdb/app-db assoc :project {:id 7}
:peers {:me me :joinable true
:roster (into {me {:cid me :user me :party (when (seq mates) "p")}}
(map (fn [c] [c {:cid c :user c :party "p" :joinable true}]))
mates)}))
(defn scene* [] (:scene @rdb/app-db))
(defn group [gid] (get-in (scene*) [:groups gid]))
(defn pane-ids [] (set (map :id @(rf/subscribe [::subs/all-annotations]))))
@ -174,28 +157,6 @@
(is (= [:d] (mapv :id @(rf/subscribe [::subs/active-drawings]))))
(is (= #{:n} @(rf/subscribe [::subs/active-note-set])))))
(deftest repeated-marks-bind-to-own-occurrences-but-project-in-other-contexts
(rf-test/run-test-sync
(let [marks (mapv (fn [i [a b]]
(assoc (fixture/mark i (fixture/part :a a b))
:drawings [i] :notes [i]))
[:d1 :d2 :d3 :d4] [[12 72] [51 96] [22 77] [22 90]])
sc (reduce #(assoc-in %1 [:groups %2] {:type :drawing :strokes []})
(apply fixture/annotation fixture/base :repeat [:root] marks)
[:d1 :d2 :d3 :d4])]
(setup! sc [:root :repeat])
(doseq [[frame expected] [[0 #{:d1}] [55 #{:d1}] [59 #{:d1}]
[60 #{:d2}] [104 #{:d2}] [105 #{:d3}]
[159 #{:d3}] [160 #{:d4}] [227 #{:d4}] [228 #{}]]]
(rf/dispatch [::ev/set-playhead :repeat frame])
(is (= expected (set (map :id @(rf/subscribe [::subs/active-drawings])))))
(is (= expected @(rf/subscribe [::subs/active-note-set]))))
(setup! sc [:root])
(rf/dispatch [::ev/set-playhead :root 67])
(is (= #{:d1 :d2 :d3 :d4}
(set (map :id @(rf/subscribe [::subs/active-drawings])))))
(is (= #{:d1 :d2 :d3 :d4} @(rf/subscribe [::subs/active-note-set]))))))
(deftest nested-repeat-projection-is-shared-by-editor-and-lane
(rf-test/run-test-sync
(setup! fixture/base [:root])
@ -267,153 +228,3 @@
(rf/dispatch [::ev/reparent :x :b1])
(is (= #{:b1} (s/membership (scene*) :x)))
(is (not (contains? (pane-ids) :x)))))
;; --- presence / ad-hoc parties -------------------------------------------
(deftest a-party-mates-jump-takes-us-with-them
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root" "a1"] :playhead 5 :playing false}])
(is (= [:root :a1] @(rf/subscribe [::subs/stack])))
(is (= 5 @(rf/subscribe [::subs/playhead])))
(testing "someone outside the party doesn't move us"
(rf/dispatch [::ev/peer-nav {:cid "stranger" :stack ["root"] :playhead 0 :playing false}])
(is (= [:root :a1] @(rf/subscribe [::subs/stack]))))
(testing "and neither does our own broadcast coming back"
(rf/dispatch [::ev/peer-nav {:cid "me" :stack ["root"] :playhead 0 :playing false}])
(is (= [:root :a1] @(rf/subscribe [::subs/stack]))))))
(deftest a-jump-into-an-annotation-we-have-not-been-told-about-waits-for-it
;; the save that created it is a PUT and the jump rides the socket, so the two
;; can land out of order. Park the jump rather than stranding us at the root.
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root" "fresh"] :playhead 0 :playing false}])
(is (= [:root] @(rf/subscribe [::subs/stack])))
(rf/dispatch [::ev/peer-delta {:changed {:fresh {:type "annotation" :in ["root"]
:name "fresh" :marks []}}}])
(is (= [:root :fresh] @(rf/subscribe [::subs/stack])))
(is (nil? (get-in @rdb/app-db [:peers :parked])))))
(deftest a-peer-deleting-the-timeline-we-are-standing-in-pops-us-out
(rf-test/run-test-sync
(setup! (seed) [:root :a1])
(peers! "me" [])
(rf/dispatch [::ev/peer-delta {:deleted ["a1"]}])
(is (= [:root] @(rf/subscribe [::subs/stack])))))
(deftest being-joined-adopts-the-party-and-answers-with-where-we-are
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" [])
(rf/dispatch [::ev/peer-state {:cid "you" :user "you" :party "me"
:joinable true :joining "me"}])
(is (= "me" (get-in @rdb/app-db [:peers :roster "me" :party])))
(is (= #{:state :nav} (set (map first @sent))))
(testing "with the door shut, a join doesn't pull us in"
(peers! "solo" [])
(swap! rdb/app-db assoc-in [:peers :joinable] false)
(rf/dispatch [::ev/peer-state {:cid "you" :user "you" :party "solo"
:joinable true :joining "solo"}])
(is (nil? (get-in @rdb/app-db [:peers :roster "solo" :party]))))))
(deftest only-deliberate-moves-reach-the-party
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/set-playhead :root 10 :tick]) ; the playback clock ticking
(is (= [] @sent))
(rf/dispatch [::ev/set-playhead :root 20]) ; a scrub
(rf/dispatch [::ev/expand :a1])
(is (= [["root"] ["root" "a1"]] (map (comp :stack second) @sent)))
(testing "and a party of one says nothing at all"
(peers! "me" [])
(rf/dispatch [::ev/set-playhead :root 30])
(is (= [] @sent)))))
(deftest a-mirrored-play-is-not-echoed-back-at-the-peer-who-started-it
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root"] :playhead 0 :playing true}])
(reset! sent [])
(rf/dispatch [::ev/set-playing true]) ; our <video> reporting the play
(is (= [] @sent))
(testing "our own next transport change still goes out"
(rf/dispatch [::ev/set-playing false])
(is (= [:nav] (map first @sent))))))
(deftest authoring-detaches-from-the-party-and-catches-up-on-the-way-out
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/edit-annotation :a1]) ; hunting for marks
(reset! sent [])
(testing "our mark-hunting is our own business"
(rf/dispatch [::ev/set-playhead :root 40])
(rf/dispatch [::ev/expand :b1])
(is (= [] @sent)))
(testing "and the party can't drag us off the form"
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root"] :playhead 120 :playing false}])
(is (= [:root :b1] @(rf/subscribe [::subs/stack])))
(is (some? (get-in @rdb/app-db [:peers :parked]))))
(testing "closing the form puts us exactly where the party got to"
(rf/dispatch [::ev/save-group :a1 (group :a1) (group :a1)])
(rf/dispatch [::ev/finish-edit])
(is (= [:root] @(rf/subscribe [::subs/stack])))
(is (= 120 @(rf/subscribe [::subs/playhead])))
(is (nil? (get-in @rdb/app-db [:peers :parked]))))))
(deftest opening-an-annotation-to-edit-it-does-not-pull-the-party-up-a-level
(rf-test/run-test-sync
(setup! (seed) [:root :a1])
(peers! "me" ["you"])
(rf/dispatch [::ev/edit-here :a1]) ; pops to :root to expose marks
(is (= [:root] @(rf/subscribe [::subs/stack])))
(is (= [] @sent))))
(deftest a-malformed-nav-is-ignored-not-obeyed-and-never-throws
;; nav is the only message that steers another browser, and it arrives
;; relayed from whatever a peer chose to send
(rf-test/run-test-sync
(setup! (seed) [:root :a1])
(peers! "me" ["you"])
(doseq [bad [{:stack ["root" "a1"] :playhead 10.5} ; not a frame
{:stack ["root" "a1"] :playhead -4}
{:stack ["root" "a1"] :playhead nil}
{:stack ["a1"] :playhead 0} ; doesn't start at the root
{:stack [] :playhead 0}
{:stack nil :playhead 0}
{:stack ["root" 7] :playhead 0}]]
(rf/dispatch [::ev/peer-nav (assoc bad :cid "you" :playing false)])
(is (= [:root :a1] @(rf/subscribe [::subs/stack])) (pr-str bad))
(is (nil? (get-in @rdb/app-db [:peers :parked])) (pr-str bad)))
(testing "and a context we could never stand in is held, not entered"
;; :a is a clip — it exists, so it is not a not-yet-synced group
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root" "a"] :playhead 0 :playing false}])
(is (= [:root :a1] @(rf/subscribe [::subs/stack]))))))
(deftest leaving-the-party-drops-a-move-we-were-holding
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/edit-annotation :a1]) ; detached: their move parks
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root" "b1"] :playhead 3 :playing false}])
(is (some? (get-in @rdb/app-db [:peers :parked])))
(rf/dispatch [::ev/go-solo]) ; …but then we leave
(is (nil? (get-in @rdb/app-db [:peers :parked])))
(rf/dispatch [::ev/save-group :a1 (group :a1) (group :a1)])
(rf/dispatch [::ev/finish-edit])
(is (= [:root] @(rf/subscribe [::subs/stack])) "not dragged back to people we left")))
(deftest a-held-move-from-someone-who-left-the-party-is-dropped-on-replay
(rf-test/run-test-sync
(setup! (seed) [:root])
(peers! "me" ["you"])
(rf/dispatch [::ev/edit-annotation :a1])
(rf/dispatch [::ev/peer-nav {:cid "you" :stack ["root" "b1"] :playhead 3 :playing false}])
(swap! rdb/app-db assoc-in [:peers :roster "you" :party] nil) ; they went solo
(rf/dispatch [::ev/peer-delta {}]) ; triggers the replay
(is (nil? (get-in @rdb/app-db [:peers :parked])))))

61
tl/test/tl/party_test.cljs
View file

@ -1,61 +0,0 @@
(ns tl.party-test
(:require [cljs.test :refer-macros [deftest is testing]]
[tl.party :as party]))
(defn- roster [& entries]
(into {} (map (fn [[cid user p joinable]]
[cid {:cid cid :user user :party p :joinable (not (false? joinable))}]))
entries))
(def ^:private solo (roster ["a" "ann" nil] ["b" "bo" nil] ["c" "cy" nil]))
(deftest joining-a-solo-peer-takes-their-cid-as-the-party-id
;; deterministic, so two people clicking Join at once converge instead of
;; minting two parties that each end up with one member
(is (= "a" (party/join-id solo "a")))
(is (= "a" (party/join-id (assoc-in solo ["b" :party] "a") "b"))))
(deftest a-party-id-nobody-else-carries-is-not-a-party
(let [r (assoc-in solo ["b" :party] "a")] ; b joined a; a hasn't answered
(is (not (party/in-party? r "b")))
(is (empty? (party/peers r "b")))))
(deftest members-drive-each-other-and-nobody-else
(let [r (-> solo (assoc-in ["a" :party] "a") (assoc-in ["b" :party] "a"))]
(is (party/in-party? r "a"))
(is (= #{"b"} (party/peers r "a")))
(is (party/mirrors? r "a" "b"))
(is (party/mirrors? r "b" "a"))
(is (not (party/mirrors? r "a" "a"))) ; never our own broadcast
(is (not (party/mirrors? r "c" "a"))) ; outsider stays put
(is (not (party/mirrors? r "a" "c")))))
(deftest joining-needs-consent-and-is-not-offered-twice
(let [r (-> solo (assoc-in ["a" :party] "a") (assoc-in ["b" :party] "a")
(assoc-in ["c" :joinable] false))]
(is (party/joinable? r "c" "a")) ; c may join a's party
(is (not (party/joinable? r "a" "c"))) ; c is not letting people in
(is (not (party/joinable? r "a" "b"))) ; already in it together
(is (not (party/joinable? r "a" "a"))))) ; not ourselves
(deftest one-member-answers-a-newcomer-and-it-is-never-the-newcomer
(let [r (-> solo (assoc-in ["a" :party] "a") (assoc-in ["b" :party] "a")
(assoc-in ["c" :party] "a"))]
(is (= "a" (party/responder r "a" "c")))
(is (= "a" (party/responder r "a" "b")))
;; the peer that was joined answers, even though the joiner minted the id
(is (= "b" (party/responder (-> solo (assoc-in ["a" :party] "b")
(assoc-in ["b" :party] "b"))
"b" "a")))))
(deftest menu-groups-my-party-first-then-parties-then-everyone-solo
(let [r (-> (roster ["a" "ann" nil] ["b" "bo" nil] ["c" "cy" nil]
["d" "di" nil] ["e" "ed" nil])
(assoc-in ["a" :party] "a") (assoc-in ["b" :party] "a")
(assoc-in ["d" :party] "d") (assoc-in ["e" :party] "d"))
gs (party/groups r "d")]
(is (= ["d" "a" nil] (mapv :id gs)))
(is (= [["di" "ed"] ["ann" "bo"] ["cy"]]
(mapv #(mapv :user (:members %)) gs)))
(testing "an unanswered join shows its author as solo, not as a party"
(is (= [nil] (mapv :id (party/groups (assoc-in solo ["b" :party] "a") "b")))))))