mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-15 10:02:47 +03:00
Merge remote-tracking branch 'origin/la-convert' into philip/mall-real
This commit is contained in:
Philip Monk
commit
4a0c5be2ba
@ -80,11 +80,14 @@
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
=^ cards all-state (prep:tc ~)
|
||||
[cards this]
|
||||
:- [connect:tc]~
|
||||
%_ this
|
||||
audience [[our-self /] ~ ~]
|
||||
settings (sy %showtime %notify ~)
|
||||
width 80
|
||||
==
|
||||
::
|
||||
++ on-save
|
||||
!>(all-state)
|
||||
++ on-save !>(all-state)
|
||||
::
|
||||
++ on-load
|
||||
|= old-state=vase
|
||||
@ -122,7 +125,6 @@
|
||||
%fact
|
||||
?+ p.cage.sign ~|([%chat-cli-bad-sub-mark wire p.cage.sign] !!)
|
||||
%chat-update (diff-chat-update:tc wire !<(chat-update q.cage.sign))
|
||||
%chat-two-update (diff-chat-two-update:tc wire !<(chat-two-update q.cage.sign))
|
||||
==
|
||||
==
|
||||
[cards this]
|
||||
@ -223,20 +225,16 @@
|
||||
:- [prompt:sh-out ~]
|
||||
:: start with fresh sole state
|
||||
all-state(state.cli *sole-share:sole-sur)
|
||||
::
|
||||
++ diff-chat-two-update
|
||||
|= [=wire upd=chat-two-update]
|
||||
^- (quip card state)
|
||||
(read-envelopes (path-to-target path.upd) envelopes.upd)
|
||||
:: +diff-chat-update: get new mailboxes & messages
|
||||
::
|
||||
++ diff-chat-update
|
||||
|= [=wire upd=chat-update]
|
||||
^- (quip card state)
|
||||
?+ -.upd [~ all-state]
|
||||
%create (notice-create +.upd)
|
||||
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] all-state]
|
||||
%message (read-envelope (path-to-target path.upd) envelope.upd)
|
||||
%create (notice-create +.upd)
|
||||
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] all-state]
|
||||
%message (read-envelope (path-to-target path.upd) envelope.upd)
|
||||
%messages (read-envelopes (path-to-target path.upd) envelopes.upd)
|
||||
==
|
||||
::
|
||||
++ read-envelopes
|
||||
|
||||
510
pkg/arvo/app/chat-hook.hoon
Normal file
510
pkg/arvo/app/chat-hook.hoon
Normal file
@ -0,0 +1,510 @@
|
||||
:: chat-hook:
|
||||
:: mirror chat data from foreign to local based on read permissions
|
||||
:: allow sending chat messages to foreign paths based on write perms
|
||||
::
|
||||
/- *permission-store, *chat-hook, *invite-store
|
||||
/+ *chat-json, default-agent
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
::
|
||||
+$ versioned-state
|
||||
$% state-zero
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: %0
|
||||
synced=(map path ship)
|
||||
invite-created=_|
|
||||
allow-history=(map path ?)
|
||||
==
|
||||
::
|
||||
+$ poke
|
||||
$% [%chat-action chat-action]
|
||||
[%permission-action permission-action]
|
||||
[%invite-action invite-action]
|
||||
[%chat-view-action chat-view-action]
|
||||
==
|
||||
::
|
||||
+$ fact
|
||||
$% [%chat-update chat-update]
|
||||
==
|
||||
--
|
||||
=| state-zero
|
||||
=* state -
|
||||
^- agent:gall
|
||||
=<
|
||||
|_ bol=bowl:gall
|
||||
+* this .
|
||||
chat-core +>
|
||||
cc ~(. chat-core bol)
|
||||
def ~(. (default-agent this %|) bol)
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
:_ this(invite-created %.y)
|
||||
:~ (invite-poke:cc [%create /chat])
|
||||
[%pass /invites %agent [our.bol %invite-store] %watch /invitatory/chat]
|
||||
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]
|
||||
==
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
`this(state !<(state-zero old))
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card _this)
|
||||
=^ cards state
|
||||
?+ mark (on-poke:def mark vase)
|
||||
%json (poke-json:cc !<(json vase))
|
||||
%chat-action (poke-chat-action:cc !<(chat-action vase))
|
||||
%chat-hook-action (poke-chat-hook-action:cc !<(chat-hook-action vase))
|
||||
==
|
||||
[cards this]
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?+ path (on-watch:def path)
|
||||
[%backlog *] [(watch-backlog:cc t.path) this]
|
||||
[%mailbox *] [(watch-mailbox:cc t.path) this]
|
||||
==
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%watch-ack
|
||||
=^ cards state
|
||||
(watch-ack:cc wire p.sign)
|
||||
[cards this]
|
||||
::
|
||||
%kick
|
||||
=^ cards state
|
||||
(kick:cc wire)
|
||||
[cards this]
|
||||
::
|
||||
%fact
|
||||
?+ p.cage.sign (on-agent:def wire sign)
|
||||
%chat-update
|
||||
=^ cards state
|
||||
(fact-chat-update:cc wire !<(chat-update q.cage.sign))
|
||||
[cards this]
|
||||
::
|
||||
%invite-update
|
||||
=^ cards state
|
||||
(fact-invite-update:cc wire !<(invite-update q.cage.sign))
|
||||
[cards this]
|
||||
::
|
||||
%permission-update
|
||||
=^ cards state
|
||||
(fact-permission-update:cc wire !<(permission-update q.cage.sign))
|
||||
[cards this]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-arvo on-arvo:def
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
::
|
||||
::
|
||||
|_ bol=bowl:gall
|
||||
::
|
||||
++ poke-json
|
||||
|= jon=json
|
||||
^- (quip card _state)
|
||||
(poke-chat-action (json-to-action jon))
|
||||
::
|
||||
++ poke-chat-action
|
||||
|= act=chat-action
|
||||
^- (quip card _state)
|
||||
?> ?=(%message -.act)
|
||||
:: local
|
||||
:_ state
|
||||
?: (team:title our.bol src.bol)
|
||||
?. (~(has by synced) path.act)
|
||||
~
|
||||
=/ ship (~(got by synced) path.act)
|
||||
=/ appl ?:(=(ship our.bol) %chat-store %chat-hook)
|
||||
[%pass / %agent [ship appl] %poke %chat-action !>(act)]~
|
||||
:: foreign
|
||||
=/ ship (~(get by synced) path.act)
|
||||
?~ ship
|
||||
~
|
||||
?. =(u.ship our.bol)
|
||||
~
|
||||
:: scry permissions to check if write is permitted
|
||||
?. (permitted-scry [(scot %p src.bol) %chat (weld path.act /write)])
|
||||
~
|
||||
=: author.envelope.act src.bol
|
||||
when.envelope.act now.bol
|
||||
==
|
||||
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]~
|
||||
::
|
||||
++ poke-chat-hook-action
|
||||
|= act=chat-hook-action
|
||||
^- (quip card _state)
|
||||
?- -.act
|
||||
%add-owned
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ chat-path [%mailbox path.act]
|
||||
?: (~(has by synced) path.act)
|
||||
[~ state]
|
||||
=: synced (~(put by synced) path.act our.bol)
|
||||
allow-history (~(put by allow-history) path.act allow-history.act)
|
||||
==
|
||||
:_ state
|
||||
%+ weld
|
||||
[%pass chat-path %agent [our.bol %chat-store] %watch chat-path]~
|
||||
(create-permission [%chat path.act] security.act)
|
||||
::
|
||||
%add-synced
|
||||
?> (team:title our.bol src.bol)
|
||||
?: (~(has by synced) [(scot %p ship.act) path.act])
|
||||
[~ state]
|
||||
=. synced (~(put by synced) [(scot %p ship.act) path.act] ship.act)
|
||||
?. ask-history.act
|
||||
=/ chat-path [%mailbox (scot %p ship.act) path.act]
|
||||
:_ state
|
||||
[%pass chat-path %agent [ship.act %chat-hook] %watch chat-path]~
|
||||
:: TODO: only ask for backlog from previous point
|
||||
=/ chat-history [%backlog (scot %p ship.act) (weld path.act /0)]
|
||||
:_ state
|
||||
[%pass chat-history %agent [ship.act %chat-hook] %watch chat-history]~
|
||||
::
|
||||
%remove
|
||||
=/ ship (~(get by synced) path.act)
|
||||
?~ ship
|
||||
[~ state]
|
||||
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
|
||||
:: delete one of our.bol own paths
|
||||
:_ state(synced (~(del by synced) path.act))
|
||||
%- zing
|
||||
:~ (pull-wire [%backlog (weld path.act /0)])
|
||||
(pull-wire [%mailbox path.act])
|
||||
(delete-permission [%chat path.act])
|
||||
[%give %kick `[%mailbox path.act] ~]~
|
||||
==
|
||||
?. |(=(u.ship src.bol) (team:title our.bol src.bol))
|
||||
:: if neither ship = source or source = us, do nothing
|
||||
[~ state]
|
||||
:: delete a foreign ship's path
|
||||
:- (pull-wire [%mailbox path.act])
|
||||
state(synced (~(del by synced) path.act))
|
||||
==
|
||||
::
|
||||
++ watch-mailbox
|
||||
|= pax=path
|
||||
^- (list card)
|
||||
?> ?=(^ pax)
|
||||
?> (~(has by synced) pax)
|
||||
:: scry permissions to check if read is permitted
|
||||
?> (permitted-scry [(scot %p src.bol) %chat (weld pax /read)])
|
||||
=/ box (chat-scry pax)
|
||||
?~ box !!
|
||||
[%give %fact ~ %chat-update !>([%create (slav %p i.pax) pax])]~
|
||||
::
|
||||
++ watch-backlog
|
||||
|= pax=path
|
||||
^- (list card)
|
||||
?> ?=(^ pax)
|
||||
=/ last (dec (lent pax))
|
||||
=/ backlog-start=(unit @ud)
|
||||
%+ rush
|
||||
(snag last `(list @ta)`pax)
|
||||
dem:ag
|
||||
=/ pas `path`(oust [last 1] `(list @ta)`pax)
|
||||
?> ?=([* ^] pas)
|
||||
?> (~(has by synced) pas)
|
||||
:: scry permissions to check if read is permitted
|
||||
?> (permitted-scry [(scot %p src.bol) %chat (weld pas /read)])
|
||||
=/ box (chat-scry pas)
|
||||
?~ box !!
|
||||
:- [%give %fact ~ %chat-update !>([%create (slav %p i.pas) pas])]
|
||||
%- zing
|
||||
:~
|
||||
?: ?&(?=(^ backlog-start) (~(got by allow-history) pas))
|
||||
(paginate-messages pas u.box u.backlog-start)
|
||||
~
|
||||
[%give %kick `[%backlog pax] `src.bol]~
|
||||
==
|
||||
::
|
||||
++ paginate-messages
|
||||
|= [=path =mailbox start=@ud]
|
||||
^- (list card)
|
||||
=/ cards=(list card) ~
|
||||
=/ end (lent envelopes.mailbox)
|
||||
?: |((gte start end) =(end 0))
|
||||
cards
|
||||
=. envelopes.mailbox (slag start `(list envelope)`envelopes.mailbox)
|
||||
|- ^- (list card)
|
||||
?~ envelopes.mailbox
|
||||
cards
|
||||
?: (lte end 5.000)
|
||||
=. cards
|
||||
%+ snoc cards
|
||||
%- messages-fact
|
||||
[path start (lent envelopes.mailbox) envelopes.mailbox]
|
||||
$(envelopes.mailbox ~)
|
||||
=. cards
|
||||
%+ snoc cards
|
||||
%- messages-fact
|
||||
:^ path start
|
||||
(add start 5.000)
|
||||
(scag 5.000 `(list envelope)`envelopes.mailbox)
|
||||
=: start (add start 5.000)
|
||||
end (sub end 5.000)
|
||||
==
|
||||
$(envelopes.mailbox (slag 5.000 `(list envelope)`envelopes.mailbox))
|
||||
::
|
||||
++ fact-invite-update
|
||||
|= [wir=wire fact=invite-update]
|
||||
^- (quip card _state)
|
||||
?+ -.fact
|
||||
[~ state]
|
||||
::
|
||||
%accepted
|
||||
=/ ask-history
|
||||
?~ (chat-scry [(scot %p ship.invite.fact) path.invite.fact])
|
||||
%.y
|
||||
%.n
|
||||
:_ state
|
||||
[(chat-view-poke [%join ship.invite.fact path.invite.fact ask-history])]~
|
||||
==
|
||||
::
|
||||
++ fact-permission-update
|
||||
|= [wir=wire fact=permission-update]
|
||||
^- (quip card _state)
|
||||
:_ state
|
||||
?- -.fact
|
||||
%create ~
|
||||
%delete ~
|
||||
%add (handle-permissions [%add path.fact who.fact])
|
||||
%remove (handle-permissions [%remove path.fact who.fact])
|
||||
==
|
||||
::
|
||||
++ handle-permissions
|
||||
|= [kind=?(%add %remove) pax=path who=(set ship)]
|
||||
^- (list card)
|
||||
?> ?=([* *] pax)
|
||||
?. =(%chat i.pax) ~
|
||||
:: check path to see if this is a %read permission
|
||||
?. =(%read (snag (dec (lent pax)) `(list @t)`pax))
|
||||
~
|
||||
%- zing
|
||||
%+ turn ~(tap in who)
|
||||
|= =ship
|
||||
?: (permitted-scry [(scot %p ship) pax])
|
||||
~
|
||||
:: if ship is not permitted, kick their subscription
|
||||
=/ mail-path
|
||||
(oust [(dec (lent t.pax)) (lent t.pax)] `(list @t)`t.pax)
|
||||
[%give %kick `[%mailbox mail-path] `ship]~
|
||||
::
|
||||
++ fact-chat-update
|
||||
|= [wir=wire fact=chat-update]
|
||||
^- (quip card _state)
|
||||
?: (team:title our.bol src.bol)
|
||||
(handle-local fact)
|
||||
(handle-foreign fact)
|
||||
::
|
||||
++ handle-local
|
||||
|= fact=chat-update
|
||||
^- (quip card _state)
|
||||
?- -.fact
|
||||
%keys [~ state]
|
||||
%read [~ state]
|
||||
%config [~ state]
|
||||
%create [~ state]
|
||||
%delete
|
||||
?. (~(has by synced) path.fact)
|
||||
[~ state]
|
||||
:_ state(synced (~(del by synced) path.fact))
|
||||
[%pass [%mailbox path.fact] %agent [our.bol %chat-store] %leave ~]~
|
||||
::
|
||||
%message
|
||||
:_ state
|
||||
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
|
||||
::
|
||||
%messages
|
||||
:_ state
|
||||
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
|
||||
==
|
||||
::
|
||||
++ handle-foreign
|
||||
|= fact=chat-update
|
||||
^- (quip card _state)
|
||||
?- -.fact
|
||||
%keys [~ state]
|
||||
%read [~ state]
|
||||
%config [~ state]
|
||||
%create
|
||||
:_ state
|
||||
?> ?=([* ^] path.fact)
|
||||
=/ shp (~(get by synced) path.fact)
|
||||
?~ shp ~
|
||||
?. =(src.bol u.shp) ~
|
||||
[(chat-poke [%create ship.fact t.path.fact])]~
|
||||
::
|
||||
%delete
|
||||
?> ?=([* ^] path.fact)
|
||||
=/ shp (~(get by synced) path.fact)
|
||||
?~ shp
|
||||
[~ state]
|
||||
?. =(u.shp src.bol)
|
||||
[~ state]
|
||||
:_ state(synced (~(del by synced) path.fact))
|
||||
:- (chat-poke [%delete path.fact])
|
||||
[%pass [%mailbox path.fact] %agent [src.bol %chat-hook] %leave ~]~
|
||||
::
|
||||
%message
|
||||
:_ state
|
||||
?> ?=([* ^] path.fact)
|
||||
=/ shp (~(get by synced) path.fact)
|
||||
?~ shp ~
|
||||
?. =(src.bol u.shp) ~
|
||||
[(chat-poke [%message path.fact envelope.fact])]~
|
||||
::
|
||||
%messages
|
||||
:_ state
|
||||
?> ?=([* ^] path.fact)
|
||||
=/ shp (~(get by synced) path.fact)
|
||||
?~ shp ~
|
||||
?. =(src.bol u.shp) ~
|
||||
[(chat-poke [%messages path.fact envelopes.fact])]~
|
||||
==
|
||||
::
|
||||
++ kick
|
||||
|= wir=wire
|
||||
^- (quip card _state)
|
||||
~& chat-hook-kick+wir
|
||||
?: =(wir /permissions)
|
||||
:_ state
|
||||
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]~
|
||||
?: ?=([%mailbox @ *] wir)
|
||||
~& mailbox-kick+wir
|
||||
?. (~(has by synced) t.wir)
|
||||
:: no-op
|
||||
[~ state]
|
||||
~& %chat-hook-resubscribe
|
||||
:_ state
|
||||
[%pass wir %agent [(slav %p i.t.wir) %chat-hook] %watch wir]~
|
||||
?: ?=([%backlog @ *] wir)
|
||||
~& backlog-kick+wir
|
||||
=/ pax `path`(oust [(dec (lent t.wir)) 1] `(list @ta)`t.wir)
|
||||
=/ mailbox=(unit mailbox) (chat-scry pax)
|
||||
=. pax ?~(mailbox wir [%mailbox pax])
|
||||
~& chat-hook-resubscribe+pax
|
||||
:_ state
|
||||
[%pass pax %agent [(slav %p i.t.wir) %chat-hook] %watch pax]~
|
||||
!!
|
||||
::
|
||||
++ watch-ack
|
||||
|= [wir=wire saw=(unit tang)]
|
||||
^- (quip card _state)
|
||||
?~ saw
|
||||
[~ state]
|
||||
?> ?=(^ wir)
|
||||
:_ state(synced (~(del by synced) t.wir))
|
||||
%. ~
|
||||
%- slog
|
||||
:* leaf+"chat-hook failed subscribe on {(spud t.wir)}"
|
||||
leaf+"stack trace:"
|
||||
u.saw
|
||||
==
|
||||
::
|
||||
++ chat-poke
|
||||
|= act=chat-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
|
||||
::
|
||||
++ chat-view-poke
|
||||
|= act=chat-view-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %chat-view] %poke %chat-view-action !>(act)]
|
||||
::
|
||||
++ permission-poke
|
||||
|= act=permission-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %permission-store] %poke %permission-action !>(act)]
|
||||
::
|
||||
++ invite-poke
|
||||
|= act=invite-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %invite-store] %poke %invite-action !>(act)]
|
||||
::
|
||||
++ messages-fact
|
||||
|= [=path start=@ud end=@ud envelopes=(list envelope)]
|
||||
^- card
|
||||
[%give %fact ~ %chat-update !>([%messages path start end envelopes])]
|
||||
::
|
||||
++ create-permission
|
||||
|= [pax=path sec=rw-security]
|
||||
^- (list card)
|
||||
=/ read-perm (weld pax /read)
|
||||
=/ write-perm (weld pax /write)
|
||||
?- sec
|
||||
%channel
|
||||
:~ (permission-poke (sec-to-perm read-perm %black))
|
||||
(permission-poke (sec-to-perm write-perm %black))
|
||||
==
|
||||
::
|
||||
%village
|
||||
:~ (permission-poke (sec-to-perm read-perm %white))
|
||||
(permission-poke (sec-to-perm write-perm %white))
|
||||
==
|
||||
::
|
||||
%journal
|
||||
:~ (permission-poke (sec-to-perm read-perm %black))
|
||||
(permission-poke (sec-to-perm write-perm %white))
|
||||
==
|
||||
::
|
||||
%mailbox
|
||||
:~ (permission-poke (sec-to-perm read-perm %white))
|
||||
(permission-poke (sec-to-perm write-perm %black))
|
||||
==
|
||||
==
|
||||
::
|
||||
++ delete-permission
|
||||
|= pax=path
|
||||
^- (list card)
|
||||
=/ read-perm (weld pax /read)
|
||||
=/ write-perm (weld pax /write)
|
||||
:~ (permission-poke [%delete read-perm])
|
||||
(permission-poke [%delete write-perm])
|
||||
==
|
||||
::
|
||||
++ sec-to-perm
|
||||
|= [pax=path =kind]
|
||||
^- permission-action
|
||||
[%create pax kind *(set ship)]
|
||||
::
|
||||
++ chat-scry
|
||||
|= pax=path
|
||||
^- (unit mailbox)
|
||||
=. pax ;:(weld /=chat-store/(scot %da now.bol)/mailbox pax /noun)
|
||||
.^((unit mailbox) %gx pax)
|
||||
::
|
||||
++ invite-scry
|
||||
|= uid=serial
|
||||
^- (unit invite)
|
||||
=/ pax /=invite-store/(scot %da now.bol)/invite/chat/(scot %uv uid)/noun
|
||||
.^((unit invite) %gx pax)
|
||||
::
|
||||
++ permitted-scry
|
||||
|= pax=path
|
||||
^- ?
|
||||
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
|
||||
::
|
||||
++ pull-wire
|
||||
|= pax=path
|
||||
^- (list card)
|
||||
?> ?=(^ pax)
|
||||
=/ shp (~(get by synced) t.pax)
|
||||
?~ shp ~
|
||||
?: =(u.shp our.bol)
|
||||
[%pass pax %agent [our.bol %chat-store] %leave ~]~
|
||||
[%pass pax %agent [u.shp %chat-hook] %leave ~]~
|
||||
--
|
||||
@ -2,7 +2,7 @@
|
||||
::
|
||||
/+ *chat-json, *chat-eval, default-agent
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
+$ card card:agent:gall
|
||||
+$ versioned-state
|
||||
$% state-zero
|
||||
==
|
||||
@ -16,7 +16,6 @@
|
||||
$% [%chat-initial inbox]
|
||||
[%chat-configs chat-configs]
|
||||
[%chat-update chat-update]
|
||||
[%chat-two-update chat-two-update]
|
||||
==
|
||||
--
|
||||
::
|
||||
@ -199,7 +198,7 @@
|
||||
|- ^- (quip card _state)
|
||||
?~ envelopes.act
|
||||
:_ state(inbox (~(put by inbox) path.act u.mailbox))
|
||||
%+ send-two-diff path.act
|
||||
%+ send-diff path.act
|
||||
:* %messages
|
||||
path.act
|
||||
(sub length.config.u.mailbox (lent evaluated-envelopes))
|
||||
@ -240,9 +239,9 @@
|
||||
mailbox
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path act=chat-update]
|
||||
|= [pax=path update=chat-update]
|
||||
^- (list card)
|
||||
[%give %fact `pax %chat-update !>(act)]~
|
||||
[%give %fact `pax %chat-update !>(update)]~
|
||||
::
|
||||
++ send-diff
|
||||
|= [pax=path upd=chat-update]
|
||||
@ -258,18 +257,4 @@
|
||||
~
|
||||
(update-subscribers /keys upd)
|
||||
==
|
||||
::
|
||||
++ send-two-diff
|
||||
|= [pax=path upd=chat-two-update]
|
||||
^- (list card)
|
||||
%- zing
|
||||
:~ (update-two-subscribers /all upd)
|
||||
(update-two-subscribers /updates upd)
|
||||
(update-two-subscribers [%mailbox pax] upd)
|
||||
==
|
||||
::
|
||||
++ update-two-subscribers
|
||||
|= [pax=path upd=chat-two-update]
|
||||
^- (list card)
|
||||
[%give %fact `pax %chat-two-update !>(upd)]~
|
||||
--
|
||||
|
||||
313
pkg/arvo/app/chat-view.hoon
Normal file
313
pkg/arvo/app/chat-view.hoon
Normal file
@ -0,0 +1,313 @@
|
||||
:: chat-view: sets up chat JS client, paginates data, and combines commands
|
||||
:: into semantic actions for the UI
|
||||
::
|
||||
/- *permission-store,
|
||||
*permission-hook,
|
||||
*group-store,
|
||||
*permission-group-hook,
|
||||
*chat-hook
|
||||
/+ *server, *chat-json, default-agent
|
||||
/= index
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/index
|
||||
/| /html/
|
||||
/~ ~
|
||||
==
|
||||
/= tile-js
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/js/tile
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= script
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/js/index
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= style
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/css/index
|
||||
/| /css/
|
||||
/~ ~
|
||||
==
|
||||
/= chat-png
|
||||
/^ (map knot @)
|
||||
/: /===/app/chat/img /_ /png/
|
||||
::
|
||||
|%
|
||||
+$ card card:agent:gall
|
||||
::
|
||||
+$ poke
|
||||
$% [%launch-action [@tas path @t]]
|
||||
[%chat-action chat-action]
|
||||
[%group-action group-action]
|
||||
[%chat-hook-action chat-hook-action]
|
||||
[%permission-hook-action permission-hook-action]
|
||||
[%permission-group-hook-action permission-group-hook-action]
|
||||
==
|
||||
--
|
||||
^- agent:gall
|
||||
=<
|
||||
|_ bol=bowl:gall
|
||||
+* this .
|
||||
chat-core +>
|
||||
cc ~(. chat-core bol)
|
||||
def ~(. (default-agent this %|) bol)
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
=/ launcha [%launch-action !>([%chat-view /configs '/~chat/js/tile.js'])]
|
||||
:_ this
|
||||
:~ [%pass /updates %agent [our.bol %chat-store] %watch /updates]
|
||||
[%pass / %arvo %e %connect [~ /'~chat'] %chat-view]
|
||||
[%pass /chat-view %agent [our.bol %launch] %poke launcha]
|
||||
==
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?+ mark (on-poke:def mark vase)
|
||||
%handle-http-request
|
||||
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
|
||||
:_ this
|
||||
%+ give-simple-payload:app eyre-id
|
||||
%+ require-authorization:app inbound-request
|
||||
poke-handle-http-request:cc
|
||||
::
|
||||
%json
|
||||
:_ this
|
||||
(poke-chat-view-action:cc (json-to-view-action !<(json vase)))
|
||||
::
|
||||
%chat-view-action
|
||||
:_ this
|
||||
(poke-chat-view-action:cc !<(chat-view-action vase))
|
||||
==
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
|^
|
||||
?: ?=([%http-response *] path)
|
||||
[~ this]
|
||||
?: =(/primary path)
|
||||
:: create inbox with 100 messages max per mailbox and send that along
|
||||
:: then quit the subscription
|
||||
:_ this
|
||||
[%give %fact ~ %json !>((inbox-to-json truncated-inbox-scry))]~
|
||||
?: =(/configs path)
|
||||
[[%give %fact ~ %json !>(*json)]~ this]
|
||||
(on-watch:def path)
|
||||
::
|
||||
++ truncated-inbox-scry
|
||||
^- inbox
|
||||
=/ =inbox .^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
|
||||
%- ~(run by inbox)
|
||||
|= =mailbox
|
||||
^- ^mailbox
|
||||
[config.mailbox (truncate-envelopes envelopes.mailbox)]
|
||||
::
|
||||
++ truncate-envelopes
|
||||
|= envelopes=(list envelope)
|
||||
^- (list envelope)
|
||||
=/ length (lent envelopes)
|
||||
?: (lth length 100)
|
||||
envelopes
|
||||
(swag [(sub length 100) 100] envelopes)
|
||||
--
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%kick
|
||||
:_ this
|
||||
[%pass / %agent [our.bol %chat-store] %watch /updates]~
|
||||
::
|
||||
%fact
|
||||
?+ p.cage.sign (on-agent:def wire sign)
|
||||
%chat-update
|
||||
:_ this
|
||||
(diff-chat-update:cc !<(chat-update q.cage.sign))
|
||||
==
|
||||
==
|
||||
::
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- (quip card _this)
|
||||
?. ?=(%bound +<.sign-arvo)
|
||||
(on-arvo:def wire sign-arvo)
|
||||
[~ this]
|
||||
::
|
||||
++ on-save on-save:def
|
||||
++ on-load on-load:def
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
::
|
||||
::
|
||||
|_ bol=bowl:gall
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
|= =inbound-request:eyre
|
||||
^- simple-payload:http
|
||||
=+ url=(parse-request-line url.request.inbound-request)
|
||||
?+ site.url not-found:gen
|
||||
[%'~chat' %css %index ~] (css-response:gen style)
|
||||
[%'~chat' %js %tile ~] (js-response:gen tile-js)
|
||||
[%'~chat' %js %index ~] (js-response:gen script)
|
||||
::
|
||||
[%'~chat' %img @t *]
|
||||
=/ name=@t i.t.t.site.url
|
||||
=/ img (~(get by chat-png) name)
|
||||
?~ img
|
||||
not-found:gen
|
||||
(png-response:gen (as-octs:mimes:html u.img))
|
||||
::
|
||||
[%'~chat' %paginate @t @t *]
|
||||
=/ start (need (rush i.t.t.site.url dem))
|
||||
=/ end (need (rush i.t.t.t.site.url dem))
|
||||
=/ pax t.t.t.t.site.url
|
||||
=/ envelopes (envelope-scry [(scot %ud start) (scot %ud end) pax])
|
||||
%- json-response:gen
|
||||
%- json-to-octs
|
||||
%- update-to-json
|
||||
[%messages pax start end envelopes]
|
||||
::
|
||||
[%'~chat' *] (html-response:gen index)
|
||||
==
|
||||
::
|
||||
++ poke-json
|
||||
|= jon=json
|
||||
^- (list card)
|
||||
?. =(src.bol our.bol)
|
||||
~
|
||||
(poke-chat-view-action (json-to-view-action jon))
|
||||
::
|
||||
++ poke-chat-view-action
|
||||
|= act=chat-view-action
|
||||
^- (list card)
|
||||
?. =(src.bol our.bol)
|
||||
~
|
||||
?- -.act
|
||||
%create
|
||||
=/ pax [(scot %p our.bol) path.act]
|
||||
=/ group-read=path [%chat (weld pax /read)]
|
||||
=/ group-write=path [%chat (weld pax /write)]
|
||||
%- zing
|
||||
:~ :~ (group-poke [%bundle group-read])
|
||||
(group-poke [%bundle group-write])
|
||||
(group-poke [%add read.act group-read])
|
||||
(group-poke [%add write.act group-write])
|
||||
(chat-poke [%create our.bol path.act])
|
||||
(chat-hook-poke [%add-owned pax security.act allow-history.act])
|
||||
==
|
||||
(create-security [%chat pax] security.act)
|
||||
:~ (permission-hook-poke [%add-owned group-read group-read])
|
||||
(permission-hook-poke [%add-owned group-write group-read])
|
||||
==
|
||||
==
|
||||
::
|
||||
%delete
|
||||
=/ group-read [%chat (weld path.act /read)]
|
||||
=/ group-write [%chat (weld path.act /write)]
|
||||
:~ (chat-hook-poke [%remove path.act])
|
||||
(permission-hook-poke [%remove group-read])
|
||||
(permission-hook-poke [%remove group-write])
|
||||
(group-poke [%unbundle group-read])
|
||||
(group-poke [%unbundle group-write])
|
||||
(chat-poke [%delete path.act])
|
||||
==
|
||||
::
|
||||
%join
|
||||
=/ group-read [%chat (scot %p ship.act) (weld path.act /read)]
|
||||
=/ group-write [%chat (scot %p ship.act) (weld path.act /write)]
|
||||
:~ (chat-hook-poke [%add-synced ship.act path.act ask-history.act])
|
||||
(permission-hook-poke [%add-synced ship.act group-write])
|
||||
(permission-hook-poke [%add-synced ship.act group-read])
|
||||
==
|
||||
==
|
||||
::
|
||||
++ diff-chat-update
|
||||
|= upd=chat-update
|
||||
^- (list card)
|
||||
=/ updates-json (update-to-json upd)
|
||||
=/ configs-json (configs-to-json configs-scry)
|
||||
:~ [%give %fact `/primary %json !>(updates-json)]
|
||||
[%give %fact `/configs %json !>(configs-json)]
|
||||
==
|
||||
::
|
||||
:: +utilities
|
||||
::
|
||||
++ chat-poke
|
||||
|= act=chat-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
|
||||
::
|
||||
++ group-poke
|
||||
|= act=group-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %group-store] %poke %group-action !>(act)]
|
||||
::
|
||||
++ chat-hook-poke
|
||||
|= act=chat-hook-action
|
||||
^- card
|
||||
[%pass / %agent [our.bol %chat-hook] %poke %chat-hook-action !>(act)]
|
||||
::
|
||||
++ permission-hook-poke
|
||||
|= act=permission-hook-action
|
||||
^- card
|
||||
:* %pass / %agent [our.bol %permission-hook]
|
||||
%poke %permission-hook-action !>(act)
|
||||
==
|
||||
::
|
||||
++ perm-group-hook-poke
|
||||
|= act=permission-group-hook-action
|
||||
^- card
|
||||
:* %pass / %agent [our.bol %permission-group-hook]
|
||||
%poke %permission-group-hook-action !>(act)
|
||||
==
|
||||
::
|
||||
++ envelope-scry
|
||||
|= pax=path
|
||||
^- (list envelope)
|
||||
=. pax ;:(weld /=chat-store/(scot %da now.bol)/envelopes pax /noun)
|
||||
.^((list envelope) %gx pax)
|
||||
::
|
||||
++ configs-scry
|
||||
^- chat-configs
|
||||
.^(chat-configs %gx /=chat-store/(scot %da now.bol)/configs/noun)
|
||||
::
|
||||
++ create-security
|
||||
|= [pax=path sec=rw-security]
|
||||
^- (list card)
|
||||
=/ read (weld pax /read)
|
||||
=/ write (weld pax /write)
|
||||
?- sec
|
||||
%channel
|
||||
:~ (perm-group-hook-poke [%associate read [[read %black] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
|
||||
==
|
||||
::
|
||||
%village
|
||||
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %white] ~ ~]])
|
||||
==
|
||||
::
|
||||
%journal
|
||||
:~ (perm-group-hook-poke [%associate read [[read %black] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %white] ~ ~]])
|
||||
==
|
||||
::
|
||||
%mailbox
|
||||
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
|
||||
==
|
||||
==
|
||||
--
|
||||
@ -1,31 +1,24 @@
|
||||
:: invite-view: provide a json interface to invite-store
|
||||
::
|
||||
:: accepts subscriptions at the empty path.
|
||||
:: accepts subscriptions at the /primary path.
|
||||
:: passes through all invites and their updates.
|
||||
:: only accepts subcriptions from the host's team.
|
||||
::
|
||||
::TODO could maybe use /lib/proxy-hook, be renamed invite-proxy-hook
|
||||
::
|
||||
/+ *invite-json, default-agent, verb
|
||||
/+ *invite-json, default-agent
|
||||
::
|
||||
|%
|
||||
+$ state-0 [%0 ~]
|
||||
::
|
||||
+$ card card:agent:gall
|
||||
--
|
||||
::
|
||||
::
|
||||
=| state-0
|
||||
=* state -
|
||||
::
|
||||
=> |%
|
||||
++ watch-updates
|
||||
|= our=ship
|
||||
^- card
|
||||
[%pass /store %agent [our %invite-store] %watch /updates]
|
||||
--
|
||||
::
|
||||
%+ verb |
|
||||
=>
|
||||
|%
|
||||
++ watch-updates
|
||||
|= our=ship
|
||||
^- card
|
||||
[%pass /store %agent [our %invite-store] %watch /updates]
|
||||
--
|
||||
^- agent:gall
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
@ -35,17 +28,18 @@
|
||||
^- (quip card _this)
|
||||
[[(watch-updates our.bowl)]~ this]
|
||||
::
|
||||
++ on-save !>(state)
|
||||
++ on-save on-save:def
|
||||
++ on-load
|
||||
|= old=vase
|
||||
^- (quip card _this)
|
||||
[~ this(state !<(state-0 old))]
|
||||
[~ this]
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card _this)
|
||||
?> =(~ path)
|
||||
?> (team:title our.bowl src.bowl)
|
||||
?. =(/primary path)
|
||||
(on-watch:def path)
|
||||
:_ this
|
||||
=/ =invites
|
||||
.^(invites %gx /=invite-store/(scot %da now.bowl)/all/noun)
|
||||
@ -54,7 +48,6 @@
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- (quip card _this)
|
||||
?. =(/store wire) (on-agent:def wire sign)
|
||||
:_ this
|
||||
?- -.sign
|
||||
%poke-ack ~|([dap.bowl %unexpected-poke-ack] !!)
|
||||
@ -64,7 +57,11 @@
|
||||
%fact
|
||||
~| [dap.bowl %unexpected-fact-mark p.cage.sign]
|
||||
?> ?=(%invite-update p.cage.sign)
|
||||
[%give %fact `/ %json !>((update-to-json !<(invite-update q.cage.sign)))]~
|
||||
:~ :*
|
||||
%give %fact
|
||||
`/primary %json
|
||||
!>((update-to-json !<(invite-update q.cage.sign)))
|
||||
== ==
|
||||
==
|
||||
::
|
||||
++ on-poke on-poke:def
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
:: configured for them as `access-control`.
|
||||
::
|
||||
/- *permission-hook
|
||||
/+ *permission-json, default-agent, verb
|
||||
/+ *permission-json, default-agent
|
||||
::
|
||||
|%
|
||||
+$ state
|
||||
@ -26,7 +26,6 @@
|
||||
=| state-0
|
||||
=* state -
|
||||
::
|
||||
%+ verb |
|
||||
^- agent:gall
|
||||
=<
|
||||
|_ =bowl:gall
|
||||
|
||||
@ -51,7 +51,7 @@
|
||||
[%all ~] (give %permission-initial !>(permissions))
|
||||
[%updates ~] ~
|
||||
[%permission @ *]
|
||||
=/ =vase !>([%create path (~(got by permissions) path)])
|
||||
=/ =vase !>([%create t.path (~(got by permissions) t.path)])
|
||||
(give %permission-update vase)
|
||||
==
|
||||
[cards this]
|
||||
@ -71,6 +71,7 @@
|
||||
[%x %permission *]
|
||||
?~ t.t.path ~
|
||||
``noun+!>((~(get by permissions) t.t.path))
|
||||
::
|
||||
[%x %permitted @ *]
|
||||
?~ t.t.t.path ~
|
||||
=/ pem (~(get by permissions) t.t.t.path)
|
||||
|
||||
@ -118,25 +118,6 @@
|
||||
[%config (conf config.mailbox)]
|
||||
==
|
||||
::
|
||||
++ two-update-to-json
|
||||
|= upd=chat-two-update
|
||||
=, enjs:format
|
||||
^- json
|
||||
%+ frond %chat-update
|
||||
%- pairs
|
||||
:~
|
||||
?: =(%messages -.upd)
|
||||
?> ?=(%messages -.upd)
|
||||
:- %messages
|
||||
%- pairs
|
||||
:~ [%path (path path.upd)]
|
||||
[%start (numb start.upd)]
|
||||
[%end (numb end.upd)]
|
||||
[%envelopes [%a (turn envelopes.upd enve)]]
|
||||
==
|
||||
[*@t *^json]
|
||||
==
|
||||
::
|
||||
++ update-to-json
|
||||
|= upd=chat-update
|
||||
=, enjs:format
|
||||
@ -144,28 +125,31 @@
|
||||
%+ frond %chat-update
|
||||
%- pairs
|
||||
:~
|
||||
?: =(%message -.upd)
|
||||
?> ?=(%message -.upd)
|
||||
?: ?=(%message -.upd)
|
||||
:- %message
|
||||
%- pairs
|
||||
:~ [%path (path path.upd)]
|
||||
[%envelope (enve envelope.upd)]
|
||||
==
|
||||
?: =(%read -.upd)
|
||||
?> ?=(%read -.upd)
|
||||
?: ?=(%messages -.upd)
|
||||
:- %messages
|
||||
%- pairs
|
||||
:~ [%path (path path.upd)]
|
||||
[%start (numb start.upd)]
|
||||
[%end (numb end.upd)]
|
||||
[%envelopes [%a (turn envelopes.upd enve)]]
|
||||
==
|
||||
?: ?=(%read -.upd)
|
||||
[%read (pairs [%path (path path.upd)]~)]
|
||||
?: =(%create -.upd)
|
||||
?> ?=(%create -.upd)
|
||||
?: ?=(%create -.upd)
|
||||
:- %create
|
||||
%- pairs
|
||||
:~ [%ship (ship ship.upd)]
|
||||
[%path (path path.upd)]
|
||||
==
|
||||
?: =(%delete -.upd)
|
||||
?> ?=(%delete -.upd)
|
||||
?: ?=(%delete -.upd)
|
||||
[%delete (pairs [%path (path path.upd)]~)]
|
||||
?: =(%config -.upd)
|
||||
?> ?=(%config -.upd)
|
||||
?: ?=(%config -.upd)
|
||||
:- %config
|
||||
%- pairs
|
||||
:~ [%path (path path.upd)]
|
||||
@ -270,4 +254,3 @@
|
||||
(su (perk %channel %village %journal %mailbox ~))
|
||||
--
|
||||
--
|
||||
|
||||
|
||||
@ -47,9 +47,7 @@
|
||||
+$ chat-update
|
||||
$% [%keys keys=(set path)]
|
||||
[%config =path =config]
|
||||
[%messages =path start=@ud end=@ud envelopes=(list envelope)]
|
||||
chat-base
|
||||
==
|
||||
::
|
||||
+$ chat-two-update
|
||||
[%messages =path start=@ud end=@ud envelopes=(list envelope)]
|
||||
--
|
||||
|
||||
Loading…
Reference in New Issue
Block a user