shrub/pkg/arvo/app/chat.hoon

642 lines
16 KiB
Plaintext

/- hall
/+ *server, chat, hall-json
/= 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/
::
=, chat
::
|%
::
+$ state
$% [%0 str=streams]
==
::
+$ move [bone card]
::
+$ card
$% [%http-response =http-event:http]
[%connect wire binding:eyre term]
[%peer wire dock path]
[%quit ~]
[%poke wire dock poke]
[%peer wire dock path]
[%pull wire dock ~]
[%diff diff]
==
::
--
::
|_ [bol=bowl:gall state]
::
++ this .
::
:: +prep: set up the app, migrate the state
::
++ prep
|= old=(unit state)
^- (quip move _this)
=/ launcha (launch-poke [/chattile '/~chat/js/tile.js'])
?~ old
=/ peer-inbox
%+ hall-peer
/circle/[(scot %p our.bol)]/inbox/config/group
/circle/inbox/config/group
=/ circlespat /circles/[(scot %p our.bol)]
=/ sourceannounce (hall-source [~marzod %announcements])
::
=/ hall-actions=(list move)
?: =((clan:title our.bol) %czar)
~
?: =(our.bol ~marzod)
:- (hall-create %announcements 'Announcements from Tlon' %journal)
[sourceannounce]~
?: =(our.bol ~dopzod)
:- (hall-create %urbit-dev 'Chat about developing on Urbit' %channel)
[(hall-create %urbit-help 'Help about Urbit' %channel)]~
:~ (hall-create %hall-internal-announcements '' %village)
(hall-source [our.bol %hall-internal-announcements])
sourceannounce
==
::
=/ actions=(list move)
:~ [ost.bol %connect / [~ /'~chat'] %chat]
launcha
peer-inbox
(hall-peer circlespat circlespat)
(hall-source [our.bol %i])
==
:_ this
(weld actions hall-actions)
::
:_ this(+<+ u.old)
[launcha]~
::
++ peer-chattile
|= wir=wire
^- (quip move _this)
:_ this
[ost.bol %diff %json (construct-tile-json str)]~
::
:: +peer-messages: subscribe to subset of messages and updates
::
::
++ peer-primary
|= wir=wire
^- (quip move _this)
=* messages messages.str
=/ lismov=(list move)
%+ murn ~(tap by messages)
|= [cir=circle:hall lis=(list envelope:hall)]
^- (unit move)
=/ envs=(unit (list envelope:hall)) (~(get by messages) cir)
?~ envs
~
=/ length/@ (lent u.envs)
=/ start/@
?: (gte length 100)
(sub length 100)
0
=/ end/@ length
=/ offset/@ (sub end start)
:- ~
:* ost.bol
%diff
%chat-update
[%messages cir start end (swag [start offset] u.envs)]
==
:_ this
[[ost.bol %diff %chat-config str] lismov]
::
:: +poke-chat: send us an action
::
++ poke-chat-action
|= act=action:chat
^- (quip move _this)
:_ this
%+ turn lis.act
|= hac=action:hall
^- move
:* ost.bol
%poke
/p/[(scot %da now.bol)]
[our.bol %hall]
[%hall-action hac]
==
::
::
:: +hall arms
::
::
:: +diff-hall-prize: handle full state initially handed to us by hall
::
++ diff-hall-prize
|= [wir=wire piz=prize:hall]
^- (quip move _this)
?~ wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
?+ i.wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
::
:: %circles wire
::
%circles
?> ?=(%circles -.piz)
:_ this(circles.str cis.piz)
(send-chat-update [[%circles cis.piz] sta])
::
:: %circle wire
::
%circle
?> ?=(%circle -.piz)
=/ circle/circle:hall [our.bol &3:wir]
::
:: fill inbox config and remote configs with prize data
::
?: =(circle [our.bol %inbox])
=/ configs
%- ~(uni in configs.str)
^- (map circle:hall (unit config:hall))
(~(run by rem.cos.piz) |=(a=config:hall `a))
::
=/ circles=(list circle:hall)
(turn ~(tap in src.loc.cos.piz) head)
::
=/ meslis=(list [circle:hall (list envelope:hall)])
%+ turn circles
|= cir=circle:hall
^- [circle:hall (list envelope:hall)]
[cir ~]
::
=/ localpeers=(set @p)
(silt (turn ~(tap by loc.pes.piz) head))
::
=/ peers=(map circle:hall (set @p))
%- ~(rep by rem.pes.piz)
|= [[cir=circle:hall grp=group:hall] acc=(map circle:hall (set @p))]
^- (map circle:hall (set @p))
(~(put by acc) cir (silt (turn ~(tap by grp) head)))
::
:-
%+ turn ~(tap in (~(del in (silt circles)) [our.bol %inbox]))
|= cir=circle:hall
^- move
=/ wir/wire /circle/[(scot %p our.bol)]/[nom.cir]/config/group
=/ pat/path /circle/[nom.cir]/config/group
[ost.bol %peer wir [our.bol %hall] pat]
%= this
inbox.str loc.cos.piz
configs.str configs
messages.str (molt meslis)
peers.str (~(put by peers) [our.bol %inbox] localpeers)
==
::
:: fill remote configs with message data
::
=* messages messages.str
=/ circle=circle:hall [`@p`(slav %p &2:wir) &3:wir]
=/ localpeers=(set @p) (silt (turn ~(tap by loc.pes.piz) head))
::
=/ peers=(map circle:hall (set @p))
%- ~(rep by rem.pes.piz)
|= [[cir=circle:hall grp=group:hall] acc=(map circle:hall (set @p))]
^- (map circle:hall (set @p))
(~(put by acc) cir (silt (turn ~(tap by grp) head)))
=/ sta
%= str
messages (~(put by messages) circle nes.piz)
peers (~(uni by peers.str) (~(put by peers) circle localpeers))
==
=/ messageupdate=update [%messages circle 0 (lent messages) nes.piz]
:- (send-chat-update [messageupdate sta])
this(str sta)
==
::
:: +diff-hall-rumor: handle updates to hall state
::
++ diff-hall-rumor
|= [wir=wire rum=rumor:hall]
^- (quip move _this)
?~ wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
?+ i.wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
::
:: %circles
::
%circles
?> ?=(%circles -.rum)
=/ cis
?: add.rum
(~(put in circles.str) cir.rum)
(~(del in circles.str) cir.rum)
=/ sta
%= str
circles cis
peers
?: add.rum
(~(put by peers.str) [our.bol cir.rum] ~)
(~(del by peers.str) [our.bol cir.rum])
==
:_ this(str sta)
(send-chat-update [[%circles cis] sta])
::
::
:: %circle: fill remote configs with message data
::
%circle
?> ?=(%circle -.rum)
=* sto rum.rum
?+ -.sto
[~ this]
::
:: %gram:
::
%gram
?> ?=(%gram -.sto)
=* messages messages.str
=/ circle=circle:hall [`@p`(slav %p &2:wir) &3:wir]
=/ nes=(unit (list envelope:hall)) (~(get by messages) circle)
?~ nes
[~ this]
=/ sta
%= str
messages (~(put by messages) circle (snoc u.nes nev.sto))
==
:_ this(str sta)
(send-chat-update [[%message circle nev.sto] sta])
::
:: status:
::
%status
?> ?=(%status -.sto)
=/ upeers=(unit (set @p)) (~(get by peers.str) cir.sto)
?~ upeers
[~ this]
=/ peers=(set @p)
?: =(%remove -.dif.sto)
(~(del in u.upeers) who.sto)
(~(put in u.upeers) who.sto)
=/ sta
%= str
peers (~(put by peers.str) cir.sto peers)
==
:_ this(str sta)
(send-chat-update [[%peers cir.sto peers] sta])
::
:: %config: config has changed
::
%config
=* circ cir.sto
::
?+ -.dif.sto
[~ this]
::
:: %full: set all of config without side effects
::
%full
=* conf cof.dif.sto
=/ sta
%= str
configs (~(put by configs.str) circ `conf)
==
:_ this(str sta)
(send-chat-update [[%config circ conf] sta])
::
:: %read: the read count of one of our configs has changed
::
%read
?: =(circ [our.bol %inbox])
:: ignore when circ is inbox
[~ this]
=/ uconf/(unit config:hall) (~(got by configs.str) circ)
?~ uconf
[~ this]
=/ conf/config:hall
%= u.uconf
red red.dif.sto
==
=/ sta
%= str
configs (~(put by configs.str) circ `conf)
==
:_ this(str sta)
(send-chat-update [[%config circ conf] sta])
::
:: %source: the sources of our inbox have changed
::
%source
?. =(circ [our.bol %inbox])
:: ignore when circ is not inbox
[~ this]
=* affectedcir cir.src.dif.sto
=/ newwir/wire
/circle/(scot %p hos.affectedcir)/[nom.affectedcir]/grams/0/config/group
=/ pat/path /circle/[nom.affectedcir]/grams/0/config/group
:: we've added a source to our inbox
::
?: add.dif.sto
=/ newinbox %= inbox.str
src (~(put in src.inbox.str) src.dif.sto)
==
=/ sta
%= str
inbox newinbox
::
configs
?: (~(has by configs.str) affectedcir)
configs.str
(~(put by configs.str) affectedcir ~)
==
::
:_ this(str sta)
%+ weld
[ost.bol %peer newwir [hos.affectedcir %hall] pat]~
(send-chat-update [[%inbox newinbox] sta])
::
=/ newinbox %= inbox.str
src (~(del in src.inbox.str) src.dif.sto)
==
:: we've removed a source from our inbox
::
=/ sta
%= str
inbox newinbox
::
configs (~(del by configs.str) affectedcir)
messages (~(del by messages.str) affectedcir)
peers (~(del by peers.str) affectedcir)
==
=/ fakecir=circle:hall
:- our.bol
(crip (weld (trip 'hall-internal-') (trip nom.affectedcir)))
::
?~ (~(get by configs.str) fakecir)
:: just forward the delete to our clients
::
:_ this(str sta)
:- [ost.bol %pull newwir [hos.affectedcir %hall] ~]
%+ weld
(send-chat-update [[%inbox newinbox] sta])
(send-chat-update [[%delete affectedcir] sta])
:: if we get a delete from another ship, delete our fake circle copy
::
=/ deletefake [%hall-action [%delete nom.fakecir ~]]
:_ this(str sta)
:- [ost.bol %pull newwir [hos.affectedcir %hall] ~]
:- [ost.bol %poke /fake [our.bol %hall] deletefake]
%+ weld
(send-chat-update [[%inbox newinbox] sta])
(send-chat-update [[%delete affectedcir] sta])
::
:: %remove: remove a circle
::
%remove
=/ sta
%= str
configs (~(del by configs.str) circ)
messages (~(del by messages.str) circ)
peers (~(del by peers.str) circ)
==
:- (send-chat-update [[%delete circ] sta])
this(str sta)
::
==
:: end of branching on dif.sto type
==
:: end of branching on sto type
==
:: end of i.wir branching
::
:: +lient arms
::
::
:: +bound: lient tells us we successfully bound our server to the ~chat url
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
:: +poke-handle-http-request: serve pages from file system based on URl path
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
::
=+ request-line=(parse-request-line url.request.inbound-request)
=/ name=@t
=+ back-path=(flop site.request-line)
?~ back-path
''
i.back-path
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
?+ site.request-line
:_ this
[ost.bol %http-response not-found:app]~
::
:: styling
::
[%'~chat' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~chat' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
:: images
::
[%'~chat' %img *]
=/ img (as-octs:mimes:html (~(got by chat-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
::
:: paginated message data
::
[%'~chat' %scroll @t @t @t @t ~]
=/ cir=circle:hall [(slav %p &3:site.request-line) &4:site.request-line]
=/ start=@ud (need (rush &5:site.request-line dem))
=/ parsedend=@ud (need (rush &6:site.request-line dem))
=* messages messages.str
=/ envs/(unit (list envelope:hall)) (~(get by messages) cir)
?~ envs
[~ this]
?: (gte start (lent u.envs))
[~ this]
=/ end=@
?: (gte parsedend (lent u.envs))
(dec (lent u.envs))
parsedend
=/ offset (sub end start)
=/ jon=json %- msg-to-json
:* %messages
cir
start
end
(swag [start offset] u.envs)
==
:_ this
[ost.bol %http-response (json-response:app (json-to-octs jon))]~
::
::
:: inbox page
::
[%'~chat' *]
:_ this
[ost.bol %http-response (html-response:app index)]~
==
::
::
:: +subscription-retry arms
::
::
:: +reap: recieve acknowledgement for peer, retry on failure
::
++ reap
|= [wir=wire err=(unit tang)]
^- (quip move _this)
?~ err
[~ this]
?~ wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
?+ i.wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
::
%circle
=/ shp=@p (slav %p &2:wir)
=/ pat /circle/[&3:wir]/config/group
?: =(&3:wir 'inbox')
:_ this
[ost.bol %peer wir [shp %hall] pat]~
?: (~(has in src.inbox.str) [[shp &3:wir] ~])
:_ this
[ost.bol %peer wir [shp %hall] pat]~
[~ this]
::
%circles
:_ this
[ost.bol %peer wir [our.bol %hall] wir]~
==
::
:: +quit: subscription failed/quit at some point, retry
::
++ quit
|= wir=wire
^- (quip move _this)
?~ wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
?+ i.wir
(mean [leaf+"invalid wire for diff: {(spud wir)}"]~)
::
%circle
=/ shp=@p (slav %p &2:wir)
=/ pat /circle/[&3:wir]/config/group
?: =(&3:wir 'inbox')
:_ this
[ost.bol %peer wir [shp %hall] pat]~
?: (~(has in src.inbox.str) [[shp &3:wir] ~])
:_ this
[ost.bol %peer wir [shp %hall] pat]~
[~ this]
::
%circles
:_ this
[ost.bol %peer wir [our.bol %hall] wir]~
==
::
:: +utilities
::
::
:: +send-chat-update: utility func for sending updates to all our subscribers
::
++ send-chat-update
|= [upd=update str=streams]
^- (list move)
=/ updates=(list move)
%+ turn (prey:pubsub:userlib /primary bol)
|= [=bone *]
[bone %diff %chat-update upd]
::
=/ jon (construct-tile-json str)
=/ tile-updates=(list move)
%+ turn (prey:pubsub:userlib /chattile bol)
|= [=bone *]
[bone %diff %json jon]
::
(weld updates tile-updates)
::
++ construct-tile-json
|= str=streams
^- json
=/ numbers/(list [circle:hall @ud])
%+ turn ~(tap by messages.str)
|= [cir=circle:hall lis=(list envelope:hall)]
^- [circle:hall @ud]
?~ lis
[cir 0]
=/ last (snag (dec (lent lis)) `(list envelope:hall)`lis)
[cir (add num.last 1)]
=/ maptjson=(map @t json)
%- my
:~ ['config' (config-to-json str)]
['numbers' (numbers-to-json numbers)]
==
[%o maptjson]
::
++ launch-poke
|= [=path =cord]
^- move
[ost.bol %poke /chat [our.bol %launch] [%launch-action %chat path cord]]
::
++ hall-peer
|= [wir=wire pat=path]
^- move
[ost.bol %peer wir [our.bol %hall] pat]
::
++ hall-create
|= [name=@tas description=@t =security:hall]
^- move
=/ poke [%hall-action [%create name description security]]
[ost.bol %poke /chat [our.bol %hall] poke]
::
++ hall-source
|= cir=circle:hall
^- move
=/ poke [%hall-action [%source %inbox %.y (silt [cir ~]~)]]
[ost.bol %poke /chat [our.bol %hall] poke]
::
--