1
1
mirror of https://github.com/urbit/shrub.git synced 2024-12-28 22:54:15 +03:00
shrub/pkg/arvo/app/chat-store.hoon
Fang ae8a57ca25
gall: (list path) in %fact and %kick
Instead of providing a (unit path), allows for (list path), which better
supports the "update to path and subpath cases".

For example, if /things wants updates about everything, and
/things/specific wants updates about the specific thing, they'll both
need to receive a %fact when the specific thing changes.
Previously, these would have been two separate moves. Now, gall handles
the multi-targeting for you.
2019-12-23 13:37:32 +01:00

265 lines
6.6 KiB
Plaintext

:: chat-store: data store that holds linear sequences of chat messages
::
/+ *chat-json, *chat-eval, default-agent
|%
+$ card card:agent:gall
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: %0
=inbox
==
::
+$ diff
$% [%chat-initial inbox]
[%chat-configs chat-configs]
[%chat-update chat-update]
==
--
::
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(chat-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%keys ~] (give %chat-update !>([%keys ~(key by inbox)]))
[%all ~] (give %chat-initial !>(inbox))
[%configs ~] (give %chat-configs !>((inbox-to-configs inbox)))
[%updates ~] ~
[%mailbox @ *]
?> (~(has by inbox) t.path)
=/ =ship (slav %p i.t.path)
(give %chat-update !>([%create ship t.t.path]))
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] ``noun+!>(inbox)
[%x %configs ~] ``noun+!>((inbox-to-configs inbox))
[%x %keys ~] ``noun+!>(~(key by inbox))
[%x %envelopes *] (peek-x-envelopes:cc t.t.path)
[%x %mailbox *]
?~ t.t.path
~
``noun+!>((~(get by inbox) t.t.path))
::
[%x %config *]
?~ t.t.path
~
=/ mailbox (~(get by inbox) t.t.path)
?~ mailbox
~
``noun+!>(config.u.mailbox)
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
::
|_ bol=bowl:gall
::
++ peek-x-envelopes
|= pax=path
^- (unit (unit [%noun vase]))
?+ pax ~
[@ @ *]
=/ mail-path t.t.pax
=/ mailbox (~(get by inbox) mail-path)
?~ mailbox
[~ ~ %noun !>(~)]
=* envelopes envelopes.u.mailbox
=/ sign-test=[?(%neg %pos) @]
%- need
%+ rush i.pax
;~ pose
%+ cook
|= n=@
[%neg n]
;~(pfix hep dem:ag)
::
%+ cook
|= n=@
[%pos n]
dem:ag
==
=* length length.config.u.mailbox
=* start +.sign-test
?: =(-.sign-test %neg)
?: (gth start length)
[~ ~ %noun !>(envelopes)]
[~ ~ %noun !>((swag [(sub length start) start] envelopes))]
::
=/ end (slav %ud i.t.pax)
?. (lte start end)
~
=. end ?:((lth end length) end length)
[~ ~ %noun !>((swag [start (sub end start)] envelopes))]
==
::
++ poke-json
|= jon=json
^- (quip card _state)
(poke-chat-action (json-to-action jon))
::
++ poke-chat-action
|= action=chat-action
^- (quip card _state)
?- -.action
%create (handle-create action)
%delete (handle-delete action)
%message (handle-message action)
%messages (handle-messages action)
%read (handle-read action)
==
::
++ handle-create
|= act=chat-action
^- (quip card _state)
?> ?=(%create -.act)
=/ pax [(scot %p ship.act) path.act]
?: (~(has by inbox) pax)
[~ state]
:- (send-diff pax act)
state(inbox (~(put by inbox) pax *mailbox))
::
++ handle-delete
|= act=chat-action
^- (quip card _state)
?> ?=(%delete -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ state]
:- (send-diff path.act act)
state(inbox (~(del by inbox) path.act))
::
++ handle-message
|= act=chat-action
^- (quip card _state)
?> ?=(%message -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ state]
=. letter.envelope.act (evaluate-letter [author letter]:envelope.act)
=. u.mailbox (append-envelope u.mailbox envelope.act)
:- (send-diff path.act act)
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ handle-messages
|= act=chat-action
^- (quip card _state)
?> ?=(%messages -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ state]
=/ evaluated-envelopes=(list envelope) ~
|- ^- (quip card _state)
?~ envelopes.act
:_ state(inbox (~(put by inbox) path.act u.mailbox))
%+ send-diff path.act
:* %messages
path.act
(sub length.config.u.mailbox (lent evaluated-envelopes))
length.config.u.mailbox
evaluated-envelopes
==
=. letter.i.envelopes.act (evaluate-letter [author letter]:i.envelopes.act)
=. evaluated-envelopes (snoc evaluated-envelopes i.envelopes.act)
=. u.mailbox (append-envelope u.mailbox i.envelopes.act)
$(envelopes.act t.envelopes.act)
::
++ handle-read
|= act=chat-action
^- (quip card _state)
?> ?=(%read -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ state]
=. read.config.u.mailbox length.config.u.mailbox
:- (send-diff path.act act)
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ evaluate-letter
|= [author=ship =letter]
^- ^letter
=? letter
?& ?=(%code -.letter)
?=(~ output.letter)
(team:title our.bol author)
==
=/ =hoon (ream expression.letter)
letter(output (eval bol hoon))
letter
::
++ append-envelope
|= [=mailbox =envelope]
^- ^mailbox
=. number.envelope +(length.config.mailbox)
=: length.config.mailbox +(length.config.mailbox)
envelopes.mailbox (snoc envelopes.mailbox envelope)
==
mailbox
::
++ update-subscribers
|= [pax=path update=chat-update]
^- (list card)
[%give %fact ~[pax] %chat-update !>(update)]~
::
++ send-diff
|= [pax=path upd=chat-update]
^- (list card)
%- zing
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%mailbox pax] upd)
?. |(|(=(%read -.upd) =(%message -.upd)) =(%messages -.upd))
~
(update-subscribers /configs upd)
?. |(=(%create -.upd) =(%delete -.upd))
~
(update-subscribers /keys upd)
==
--