1
1
mirror of https://github.com/urbit/shrub.git synced 2024-12-27 06:02:27 +03:00
shrub/pkg/arvo/app/chat-cli.hoon
2020-12-11 11:05:13 +10:00

1238 lines
34 KiB
Plaintext

:: chat-cli: cli chat client using chat-store and friends
::
:: pulls all known messages into a single stream.
:: type ;help for usage instructions.
::
:: note that while the chat-store only cares about paths,
:: we mostly deal with [ship path] (aka target) here.
:: when sending messages (through the chat hook),
:: we concat the ship onto the head of the path,
:: and trust it to take care of the rest.
::
/- *resource, post, store=chat-store
/+ shoe, default-agent, verb, dbug, graph=graph-store, libgraph=graph
::
|%
+$ card card:shoe
::
+$ versioned-state
$% state-3
state-2
state-1
state-0
==
::
+$ state-3
$: %3
::TODO support multiple sessions
sessions=(map sole-id session) :: sole sessions
bound=(map resource glyph) :: bound resource glyphs
binds=(jug glyph resource) :: resource glyph lookup
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
==
::
+$ sole-id @ta
+$ session
$: viewing=(set resource) :: connected graphs
history=(list uid:post) :: scrollback pointers
count=@ud :: (lent history)
audience=target :: active target
==
::
::TODO remove for breach
+$ target-2 [in-group=? =ship =path]
+$ mail [source=target-2 envelope:store]
+$ state-2
$: %2
grams=(list mail) :: all messages
known=(set [target-2 serial:store]) :: known message lookup
count=@ud :: (lent grams)
bound=(map target-2 glyph) :: bound circle glyphs
binds=(jug glyph target-2) :: circle glyph lookup
audience=(set target-2) :: active targets
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
==
::
+$ state-1
$: %1
grams=(list mail) :: all messages
known=(set [target-2 serial:store]) :: known message lookup
count=@ud :: (lent grams)
bound=(map target-2 glyph) :: bound circle glyphs
binds=(jug glyph target-2) :: circle glyph lookup
audience=(set target-2) :: active targets
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
cli=state=sole-share:shoe :: console state
eny=@uvJ :: entropy
==
::
+$ state-0
$: grams=(list [[=ship =path] envelope:store]) :: all messages
known=(set [[=ship =path] serial:store]) :: known message lookup
count=@ud :: (lent grams)
bound=(map [=ship =path] glyph) :: bound circle glyphs
binds=(jug glyph [=ship =path]) :: circle glyph lookup
audience=(set [=ship =path]) :: active targets
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
cli=state=sole-share:shoe :: console state
eny=@uvJ :: entropy
==
::
+$ target resource
::
+$ glyph char
++ glyphs "!@#$%^&()-=_+[]\{}'\\:\",.<>?"
::
+$ command
$% [%target target] :: set messaging target
[%say content:post] :: send message
[%eval cord hoon] :: send #-message
:: ::
[%view $?(~ target)] :: notice chat
[%flee target] :: ignore chat
:: ::
[%bind glyph target] :: bind glyph
[%unbind glyph (unit target)] :: unbind glyph
[%what (unit $@(char target))] :: glyph lookup
:: ::
[%settings ~] :: show active settings
[%set term] :: set settings flag
[%unset term] :: unset settings flag
[%width @ud] :: adjust display width
[%timezone ? @ud] :: adjust time printing
:: ::
[%select $@(rel=@ud [zeros=@u abs=@ud])] :: rel/abs msg selection
[%chats ~] :: list available chats
[%help ~] :: print usage info
== ::
::
--
=| state-3
=* state -
::
%- agent:dbug
%+ verb |
%- (agent:shoe command)
^- (shoe:shoe command)
=<
|_ =bowl:gall
+* this .
talk-core +>
tc ~(. talk-core bowl)
def ~(. (default-agent this %|) bowl)
des ~(. (default:shoe this command) bowl)
::
++ on-init
^- (quip card _this)
=^ cards state (prep:tc ~)
[cards this]
::
++ on-save !>(state)
::
++ on-load
|= old-state=vase
^- (quip card _this)
=/ old !<(versioned-state old-state)
=^ cards state (prep:tc `old)
[cards this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%noun (poke-noun:tc !<(* vase))
==
[cards this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ cards state
?- -.sign
%poke-ack [- state]:(on-agent:def wire sign)
%watch-ack [- state]:(on-agent:def wire sign)
::
%kick
:_ state
?+ wire ~
[%graph-store ~] ~[connect:tc]
==
::
%fact
?+ p.cage.sign ~|([dap.bowl %bad-sub-mark wire p.cage.sign] !!)
%graph-update
%- on-graph-update:tc
!<(update:graph q.cage.sign)
==
==
[cards this]
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
::
++ command-parser
|= =sole-id
parser:(make:sh:tc sole-id)
::
++ tab-list
|= =sole-id
tab-list:sh:tc
::
++ on-command
|= [=sole-id =command]
=^ cards state
(work:(make:sh:tc sole-id) command)
[cards this]
::
++ on-connect
|= =sole-id
^- (quip card _this)
[[prompt:(make:sh-out:tc sole-id)]~ this]
::
++ can-connect can-connect:des
++ on-disconnect on-disconnect:des
--
::
|_ =bowl:gall
+* libgraph ~(. ^libgraph bowl)
:: +prep: setup & state adapter
::
++ prep
|= old=(unit versioned-state)
^- (quip card _state)
?~ old
[~[connect] state(width 80)]
::
=? u.old ?=(?(~ ^) -.u.old)
^- state-1
:- %1
%= u.old
grams ~ ::NOTE this only impacts historic message lookup in chat-cli
::
known
^- (set [target-2 serial:store])
%- ~(run in known.u.old)
|= [t=[ship path] s=serial:store]
[`target-2`[| t] s]
::
bound
^- (map target-2 glyph)
%- ~(gas by *(map target-2 glyph))
%+ turn ~(tap by bound.u.old)
|= [t=[ship path] g=glyph]
[`target-2`[| t] g]
::
binds
^- (jug glyph target-2)
%- ~(run by binds.u.old)
|= s=(set [ship path])
%- ~(run in s)
|= t=[ship path]
`target-2`[| t]
::
audience
^- (set target-2)
%- ~(run in audience.u.old)
|= t=[ship path]
`target-2`[| t]
==
::
=? u.old ?=(%1 -.u.old)
^- state-2
=, u.old
:* %2
grams known count
bound binds audience
settings width timez
==
::
=^ cards u.old
?. ?=(%2 -.u.old) [~ u.old]
:- :~ [%pass /chat-store %agent [our-self %chat-store] %leave ~]
[%pass /invites %agent [our.bowl %invite-store] %leave ~]
==
^- state-3
:- %3
:* %+ ~(put in *(map sole-id session))
(cat 3 'drum_' (scot %p our.bowl))
:* ~ ~ 0
::
?~ audience.u.old *target
[ship ?~(path %$ i.path)]:n.audience.u.old
==
::
%- ~(gas by *(map resource glyph))
%+ turn ~(tap in bound.u.old)
|= [t=target-2 g=glyph]
[[ship.t ?~(path.t %$ i.path.t)] g]
::
^- (jug glyph resource)
%- ~(run by binds.u.old)
|= s=(set target-2)
%- ~(run in s)
|= t=target-2
[ship.t ?~(path.t %$ i.path.t)]
::
settings.u.old
width.u.old
timez.u.old
==
::
?> ?=(%3 -.u.old)
:_ u.old
%+ welp
cards
?: %- ~(has by wex.bowl)
[/graph-store our-self %graph-store]
~
~[connect]
:: +connect: connect to the graph-store
::
++ connect
^- card
[%pass /graph-store %agent [our-self %graph-store] %watch /updates]
::
::TODO better moon support. (name:title our.bowl)
++ our-self our.bowl
::
++ get-session
|= =sole-id
^- session
(~(gut by sessions) sole-id %*(. *session audience [our-self %$]))
:: +tor: term ordering for targets
::
++ tor
|= [[* a=term] [* b=term]]
(aor a b)
:: +ior: index ordering for nodes
::
++ ior
|= [[a=index:post *] [b=index:post *]]
(aor a b)
:: +safe-get-graph: virtualized +get-graph
::
++ safe-get-graph
|= =resource
^- (unit update:graph)
=/ res=(each update:graph tang)
::TODO doesn't actually contain the crash?
%- mule |.
(get-graph:libgraph resource)
?- -.res
%& `p.res
%| ~
==
:: +is-chat-graph: check whether graph contains chat-style data
::
++ is-chat-graph
|= =resource
^- ?
=/ update=(unit update:graph)
(safe-get-graph resource)
?~ update |
?> ?=(%add-graph -.q.u.update)
=(`%graph-validator-chat mark.q.u.update)
:: +poke-noun: debug helpers
::
++ poke-noun
|= a=*
^- (quip card _state)
?: ?=(%connect a)
[[connect ~] state]
[~ state]
:: +handle-graph-update: get new mailboxes & messages
::
++ on-graph-update
|= upd=update:graph
^- (quip card _state)
?. ?=(?(%remove-graph %add-nodes) -.q.upd)
[~ state]
=/ sez=(list [=sole-id =session])
~(tap by sessions)
=| cards=(list card)
|-
?~ sez [cards state]
=^ caz session.i.sez
?- -.q.upd
%remove-graph (~(notice-remove se i.sez) +.q.upd)
::
%add-nodes
?. (~(has in viewing.session.i.sez) resource.q.upd)
[~ session.i.sez]
%+ ~(read-posts se i.sez)
resource.q.upd
(sort ~(tap by nodes.q.upd) ior)
==
=. sessions (~(put by sessions) i.sez)
$(sez t.sez, cards (weld cards caz))
:: +se: session event handling
::
++ se
|_ [=sole-id =session]
+* sh-out ~(. ^sh-out sole-id session)
::
++ read-posts
|= [=target nodes=(list [=index:post =node:graph])]
^- (quip card _session)
=^ cards nodes
^- (quip card _nodes)
=+ count=(lent nodes)
?. (gth count 10) [~ nodes]
:_ (swag [(sub count 10) 10] nodes)
[(print:sh-out "skipping {(scow %ud (sub count 10))} messages...")]~
|-
?~ nodes [cards session]
=^ caz session
(read-post target [index post.node]:i.nodes)
$(cards (weld cards caz), nodes t.nodes)
::
:: +read-post: add envelope to state and show it to user
::
++ read-post
|= [=target =index:post =post:post]
^- (quip card _session)
:- (show-post:sh-out target post)
%_ session
history [[target index] history.session]
count +(count.session)
==
::
++ notice-remove
|= =target
^- (quip card _session)
?. (~(has in viewing.session) target)
[~ session]
:- [(show-delete:sh-out target) ~]
session(viewing (~(del in viewing.session) target))
--
::
:: +bind-default-glyph: bind to default, or random available
::
++ bind-default-glyph
|= =target
^- (quip card _state)
=; =glyph (bind-glyph glyph target)
|^ =/ g=glyph (choose glyphs)
?. (~(has by binds) g) g
=/ available=(list glyph)
%~ tap in
(~(dif in `(set glyph)`(sy glyphs)) ~(key by binds))
?~ available g
(choose available)
++ choose
|= =(list glyph)
=; i=@ud (snag i list)
(mod (mug target) (lent list))
--
:: +bind-glyph: add binding for glyph
::
++ bind-glyph
|= [=glyph =target]
^- (quip card _state)
::TODO should send these to settings store eventually
:: if the target was already bound to another glyph, un-bind that
::
=? binds (~(has by bound) target)
(~(del ju binds) (~(got by bound) target) target)
=. bound (~(put by bound) target glyph)
=. binds (~(put ju binds) glyph target)
[(show-glyph:sh-out glyph `target) state]
:: +unbind-glyph: remove all binding for glyph
::
++ unbind-glyph
|= [=glyph targ=(unit target)]
^- (quip card _state)
?^ targ
=. binds (~(del ju binds) glyph u.targ)
=. bound (~(del by bound) u.targ)
[(show-glyph:sh-out glyph ~) state]
=/ ole=(set target)
(~(get ju binds) glyph)
=. binds (~(del by binds) glyph)
=. bound
|-
?~ ole bound
=. bound $(ole l.ole)
=. bound $(ole r.ole)
(~(del by bound) n.ole)
[(show-glyph:sh-out glyph ~) state]
:: +decode-glyph: find the target that matches a glyph, if any
::
++ decode-glyph
|= [=session =glyph]
^- (unit target)
=+ lax=(~(get ju binds) glyph)
:: no target
?: =(~ lax) ~
%- some
:: single target
?: ?=([* ~ ~] lax) n.lax
:: in case of multiple matches, pick one we're viewing
=. lax (~(uni in lax) viewing.session)
?: ?=([* ~ ~] lax) n.lax
:: in case of multiple audiences, pick the most recently active one
|- ^- target
?~ history.session -:~(tap in lax)
=* resource resource.i.history.session
?: (~(has in lax) resource)
resource
$(history.session t.history.session)
::
:: +sh: shoe handling
::
++ sh
|_ [=sole-id session]
+* session +<+
sh-out ~(. ^sh-out sole-id session)
put-ses state(sessions (~(put by sessions) sole-id session))
::
++ make
|= =^sole-id
%_ ..make
sole-id sole-id
+<+ (get-session sole-id)
==
:: +read: command parser
::
:: parses the command line buffer.
:: produces commands which can be executed by +work.
::
++ parser
|^
%+ stag |
%+ knee *command |. ~+
=- ;~(pose ;~(pfix mic -) message)
;~ pose
(stag %target targ)
::
;~((glue ace) (tag %view) targ)
;~((glue ace) (tag %flee) targ)
;~(plug (tag %view) (easy ~))
::
;~((glue ace) (tag %bind) glyph targ)
;~((glue ace) (tag %unbind) ;~(plug glyph (punt ;~(pfix ace targ))))
;~(plug (perk %what ~) (punt ;~(pfix ace ;~(pose glyph targ))))
::
;~(plug (tag %settings) (easy ~))
;~((glue ace) (tag %set) flag)
;~((glue ace) (tag %unset) flag)
;~(plug (cold %width (jest 'set width ')) dem:ag)
::
;~ plug
(cold %timezone (jest 'set timezone '))
;~ pose
(cold %| (just '-'))
(cold %& (just '+'))
==
%+ sear
|= a=@ud
^- (unit @ud)
?:(&((gte a 0) (lte a 14)) `a ~)
dem:ag
==
::
;~(plug (tag %chats) (easy ~))
;~(plug (tag %help) (easy ~))
::
(stag %select nump)
==
::
::TODO
:: ++ cmd
:: |* [cmd=term req=(list rule) opt=(list rule)]
:: |^ ;~ plug
:: (tag cmd)
:: ::
:: ::TODO this feels slightly too dumb
:: ?~ req
:: ?~ opt (easy ~)
:: (opt-rules opt)
:: ?~ opt (req-rules req)
:: ;~(plug (req-rules req) (opt-rules opt)) ::TODO rest-loop
:: ==
:: ++ req-rules
:: |* req=(lest rule)
:: =- ;~(pfix ace -)
:: ?~ t.req i.req
:: ;~(plug i.req $(req t.req))
:: ++ opt-rules
:: |* opt=(lest rule)
:: =- (punt ;~(pfix ace -))
:: ?~ t.opt ;~(pfix ace i.opt)
:: ;~(pfix ace ;~(plug i.opt $(opt t.opt)))
:: --
::
++ group ;~((glue fas) ship sym)
++ tag |*(a=@tas (cold a (jest a))) ::TODO into stdlib
++ ship ;~(pfix sig fed:ag)
++ name ;~(pfix fas urs:ab)
:: +tarl: local target, as /path
::
++ tarl (stag our-self name)
:: +targ: any target, as tarl, tarp, ~ship/path or glyph
::
++ targ
;~ pose
tarl
;~(plug ship name)
(sear (cury decode-glyph session) glyph)
==
:: +tars: set of comma-separated targs
::
++ tars
%+ cook ~(gas in *(set target))
(most ;~(plug com (star ace)) targ)
:: +ships: set of comma-separated ships
::
++ ships
%+ cook ~(gas in *(set ^ship))
(most ;~(plug com (star ace)) ship)
:: +glyph: shorthand character
::
++ glyph (mask glyphs)
:: +flag: valid flag
::
++ flag
%- perk :~
%notify
%showtime
==
:: +nump: message number reference
::
++ nump
;~ pose
;~(pfix hep dem:ag)
;~ plug
(cook lent (plus (just '0')))
;~(pose dem:ag (easy 0))
==
(stag 0 dem:ag)
(cook lent (star mic))
==
:: +message: all messages
::
++ message
;~ pose
;~(plug (cold %eval hax) expr)
(stag %say content)
==
:: +content: simple messages
::TODO mentions
::
++ content
;~ pose
(stag %url turl)
(stag %text ;~(less mic hax text))
==
:: +turl: url parser
::
++ turl
=- (sear - text)
|= t=cord
^- (unit cord)
?~((rush t aurf:de-purl:html) ~ `t)
:: +text: text message body
::
++ text
%+ cook crip
(plus next)
:: +expr: parse expression into [cord hoon]
::
++ expr
|= tub=nail
%. tub
%+ stag (crip q.tub)
wide:(vang & [&1:% &2:% (scot %da now.bowl) |3:%])
--
:: +tab-list: command descriptions
::
++ tab-list
^- (list [@t tank])
:~
[';view' leaf+";view ~ship/chat-name (glyph)"]
[';flee' leaf+";flee ~ship/chat-name"]
::
[';bind' leaf+";bind [glyph] ~ship/chat-name"]
[';unbind' leaf+";unbind [glyph]"]
[';what' leaf+";what (~ship/chat-name) (glyph)"]
::
[';settings' leaf+";settings"]
[';set' leaf+";set key (value)"]
[';unset' leaf+";unset key"]
::
[';chats' leaf+";chats"]
[';help' leaf+";help"]
==
:: +work: run user command
::
++ work
|= job=command
^- (quip card _state)
|^ ?- -.job
%target (set-target +.job)
%say (say +.job)
%eval (eval +.job)
::
%view (view +.job)
%flee (flee +.job)
::
%bind (bind-glyph +.job)
%unbind (unbind-glyph +.job)
%what (lookup-glyph +.job)
::
%settings show-settings
%set (set-setting +.job)
%unset (unset-setting +.job)
%width (set-width +.job)
%timezone (set-timezone +.job)
::
%select (select +.job)
%chats chats
%help help
==
:: +act: build action card
::
++ act
|= [what=term app=term =cage]
^- card
:* %pass
/cli-command/[what]
%agent
[our-self app]
%poke
cage
==
:: +set-target: set audience, update prompt
::
++ set-target
|= =target
^- (quip card _state)
=. audience target
[[prompt:sh-out ~] put-ses]
:: +view: start printing messages from a resource
::
++ view
|= target=$?(~ target)
^- (quip card _state)
:: without argument, print all we're viewing
::
?~ target
[[(show-chats:sh-out ~(tap in viewing))]~ state]
:: only view existing chat-type graphs
::
?. (is-chat-graph target)
[[(note:sh-out "no such chat")]~ put-ses]
=. viewing (~(put in viewing) target)
=^ cards state
?: (~(has by bound) target)
[~ state]
(bind-default-glyph target)
[[prompt:sh-out cards] put-ses]
:: +flee: stop printing messages from a resource
::
++ flee
|= =target
^- (quip card _state)
=. viewing (~(del in viewing) target)
[~ put-ses]
:: +say: send messages
::
++ say
|= msg=content:post
^- (quip card _state)
=/ =serial:store (shaf %msg-uid eny.bowl)
:_ state
:_ ~
::TODO move creation into lib?
%^ act %out-message
%graph-push-hook
:- %graph-update
!> ^- update:graph
:+ %0 now.bowl
:+ %add-nodes audience
%- ~(put by *(map index:post node:graph))
:- ~[now.bowl]
:_ *internal-graph:graph
^- post:post
[our-self ~[now.bowl] now.bowl [msg]~ ~ ~]
:: +eval: run hoon, send code and result as message
::
:: this double-virtualizes and clams to disable .^ for security reasons
::
++ eval
|= [txt=cord exe=hoon]
~& %eval-tmp-disabled
[~ state]
::TODO why -find.eval??
:: (say %code txt (eval:store bowl exe))
:: +lookup-glyph: print glyph info for all, glyph or target
::
++ lookup-glyph
|= qur=(unit $@(glyph target))
^- (quip card _state)
=- [[- ~] state]
?^ qur
?^ u.qur
=+ gyf=(~(get by bound) u.qur)
(print:sh-out ?~(gyf "none" [u.gyf]~))
=+ pan=~(tap in (~(get ju binds) `@t`u.qur))
?: =(~ pan) (print:sh-out "~")
=< (effect:sh-out %mor (turn pan .))
|=(t=target [%txt ~(phat tr t)])
%- print-more:sh-out
%- ~(rep by binds)
|= $: [=glyph tars=(set target)]
lis=(list tape)
==
%+ weld lis
^- (list tape)
%- ~(rep in tars)
|= [t=target l=(list tape)]
%+ weld l
^- (list tape)
[glyph ' ' ~(phat tr t)]~
:: +show-settings: print enabled flags, timezone and width settings
::
++ show-settings
^- (quip card _state)
:_ state
:~ %- print:sh-out
%- zing
^- (list tape)
:- "flags: "
%+ join ", "
(turn `(list @t)`~(tap in settings) trip)
::
%- print:sh-out
%+ weld "timezone: "
^- tape
:- ?:(p.timez '+' '-')
(scow %ud q.timez)
::
(print:sh-out "width: {(scow %ud width)}")
==
:: +set-setting: enable settings flag
::
++ set-setting
|= =term
^- (quip card _state)
[~ state(settings (~(put in settings) term))]
:: +unset-setting: disable settings flag
::
++ unset-setting
|= =term
^- (quip card _state)
[~ state(settings (~(del in settings) term))]
:: +set-width: configure cli printing width
::
++ set-width
|= w=@ud
[~ state(width (max 40 w))]
:: +set-timezone: configure timestamp printing adjustment
::
++ set-timezone
|= tz=[? @ud]
[~ state(timez tz)]
:: +select: expand message from number reference
::
++ select
::NOTE rel is the nth most recent message,
:: abs is the last message whose numbers ends in n
:: (with leading zeros used for precision)
::
|= num=$@(rel=@ud [zeros=@u abs=@ud])
^- (quip card _state)
|^ ?@ num
=+ tum=(scow %s (new:si | +(num)))
?: (gte rel.num count)
%- just-print
"{tum}: no such telegram"
(activate tum rel.num)
?. (gte abs.num count)
?: =(count 0)
(just-print "0: no messages")
=+ msg=(index (dec count) num)
(activate (scow %ud msg) (sub count +(msg)))
%- just-print
"…{(reap zeros.num '0')}{(scow %ud abs.num)}: no such telegram"
:: +just-print: full [cards state] output with a single print card
::
++ just-print
|= txt=tape
[[(print:sh-out txt) ~] state]
:: +index: get message index from absolute reference
::
++ index
|= [max=@ud nul=@u fin=@ud]
^- @ud
=+ dog=|-(?:(=(0 fin) 1 (mul 10 $(fin (div fin 10)))))
=. dog (mul dog (pow 10 nul))
=- ?:((lte - max) - (sub - dog))
(add fin (sub max (mod max dog)))
:: +activate: echo message selector and print details
::
++ activate
|= [number=tape index=@ud]
^- (quip card _state)
::NOTE graph store allows node deletion, so can this crash?
=/ =uid:post (snag index history)
=/ =node:graph (got-node:libgraph uid)
=. audience resource.uid
:_ put-ses
^- (list card)
:~ (print:sh-out ['?' ' ' number])
(effect:sh-out ~(render-activate mr resource.uid post.node))
prompt:sh-out
==
--
:: +chats: display list of joined chats
::
++ chats
^- (quip card _state)
:_ state
:_ ~
%- show-chats:sh-out
(skim ~(tap in get-keys:libgraph) is-chat-graph)
:: +help: print (link to) usage instructions
::
++ help
^- (quip card _state)
:_ state
=- (turn - print:sh-out)
:~ ";view ~host/chat to print messages for a chat you've already jonied."
";flee ~host/chat to stop printing messages for a chat."
"For more details:"
"https://urbit.org/using/operations/using-your-ship/#messaging"
==
--
--
::
:: +sh-out: ouput to session
::
++ sh-out
|_ [=sole-id session]
++ make
|= =^sole-id
%_ ..make
sole-id sole-id
+<+ (get-session sole-id)
==
:: +effex: emit shoe effect card
::
++ effex
|= effect=shoe-effect:shoe
^- card
[%shoe ~[sole-id] effect]
:: +effect: emit console effect card
::
++ effect
|= effect=sole-effect:shoe
^- card
(effex %sole effect)
:: +print: puts some text into the cli as-is
::
++ print
|= txt=tape
^- card
(effect %txt txt)
:: +print-more: puts lines of text into the cli
::
++ print-more
|= txs=(list tape)
^- card
%+ effect %mor
(turn txs |=(t=tape [%txt t]))
:: +note: prints left-padded ---| txt
::
++ note
|= txt=tape
^- card
=+ lis=(simple-wrap txt (sub width 16))
%- print-more
=+ ?:((gth (lent lis) 0) (snag 0 lis) "")
:- (runt [14 '-'] '|' ' ' -)
%+ turn (slag 1 lis)
|=(a=tape (runt [14 ' '] '|' ' ' a))
:: +prompt: update prompt to display current audience
::
++ prompt
^- card
%+ effect %pro
:+ & %talk-line
=+ ~(show tr audience)
?:(=(1 (lent -)) "{-} " "[{-}] ")
:: +show-post: print incoming message
::
:: every five messages, prints the message number also.
:: if the message mentions the user's (shortened) ship name,
:: and the %notify flag is set, emit a bell.
::
++ show-post
|= [=target =post:post]
^- (list card)
%+ weld
^- (list card)
?. =(0 (mod count 5)) ~
:_ ~
=+ num=(scow %ud count)
%- print
(runt [(sub 13 (lent num)) '-'] "[{num}]")
^- (list card)
:- (effex ~(render-inline mr target post))
=; mentioned=?
?. mentioned ~
[(effect %bel ~)]~
%+ lien contents.post
(cury test %mention our.bowl)
:: +show-create: print mailbox creation notification
::
++ show-create
|= =target
^- card
(note "new: {~(phat tr target)}")
:: +show-delete: print mailbox deletion notification
::
++ show-delete
|= =target
^- card
(note "del: {~(phat tr target)}")
:: +show-glyph: print glyph un/bind notification
::
++ show-glyph
|= [=glyph target=(unit target)]
^- (list card)
:_ [prompt ~]
%- note
%+ weld "set: {[glyph ~]} "
?~ target "unbound"
~(phat tr u.target)
:: +show-chats: print list of targets
::
++ show-chats
|= chats=(list target)
^- card
%- print-more
%+ turn (sort chats tor)
|= resource
"{(nome:mr entity)}/{(trip name)}"
--
::
:: +tr: render targets (resource identifiers)
::
++ tr
|_ tr=target
:: +full: render target fully, always (as ~ship/path)
::
++ full
^- tape
"{(scow %p entity.tr)}/{(trip name.tr)}"
:: +phat: render target with local shorthand
::
:: renders as ~ship/path.
:: for local mailboxes, renders just /path.
::
++ phat
^- tape
%+ weld
?: =(our-self entity.tr) ~
(scow %p entity.tr)
"/{(trip name.tr)}"
:: +show: render as tape, as glyph if we can
::
++ show
^- tape
=+ cha=(~(get by bound) tr)
?~(cha phat [u.cha ~])
:: +glyph: tape for glyph of target, defaulting to *
::
++ glyph
^- tape
[(~(gut by bound) tr '*') ~]
--
::
:: +mr: render messages
::
++ mr
|_ $: source=target
post:post
==
+* showtime (~(has in settings) %showtime)
notify (~(has in settings) %notify)
::
++ content-width
:: termwidth, minus author, timestamp, and padding
%+ sub width
%+ add 15
?:(showtime 11 0)
::
++ render-inline
^- shoe-effect:shoe
:+ %row
:- 15
?. showtime
~[(sub width 16)]
~[(sub width 26) 9]
:+ t+(crip (weld (nome author) ~(glyph tr source)))
t+(crip line)
?. showtime ~
:_ ~
:- %t
=. time-sent
%- ?:(p.timez add sub)
[time-sent (mul q.timez ~h1)]
=+ dat=(yore time-sent)
=* t (d-co:co 2)
=, t.dat
%- crip
:(weld "~" (t h) "." (t m) "." (t s))
::
++ line
^- tape
%- zing
%+ join "\0a"
%- turn
:_ |=(ls=(list tape) `tape`(zing (join " " ls)))
%+ roll contents
|= [=content:post out=(list (list tape))]
?- -.content
%text (append-inline out (trip text.content))
%mention (append-inline out (scow %p ship.content))
%reference (append-inline out "^")
::
%code
%+ snoc out
^- (list tape)
:- (trip expression.content)
?: =(~ output.content) ~
:- "\0a"
~(ram re (snag 0 output.content))^~
::
%url
%+ append-inline out
=+ wyd=content-width
=+ ful=(trip url.content)
:: if the full url fits, just render it.
?: (gte wyd (lent ful)) ful
:: if it doesn't, prefix with _ and truncate domain with ellipses
=. wyd (sub wyd 2)
:- '_'
=- (weld - "_")
=+ prl=(rust ful aurf:de-purl:html)
?~ prl (scag wyd ful)
=+ hok=r.p.p.u.prl
=; domain=tape
%+ swag
[(sub (max wyd (lent domain)) wyd) wyd]
domain
?. ?=(%& -.hok)
+:(scow %if p.hok)
%+ reel p.hok
|= [a=knot b=tape]
?~ b (trip a)
(welp b '.' (trip a))
==
::
++ append-newline
|= [content=(list (list tape)) newline=tape]
^- (list (list tape))
(snoc content ~[newline])
::
++ append-inline
|= [content=(list (list tape)) inline=tape]
^- (list (list tape))
?: =(~ content)
~[~[inline]]
=/ last
(dec (lent content))
=/ old=(list tape)
(snag last content)
=/ new=(list tape)
(snoc old inline)
(snap content last new)
:: +activate: produce sole-effect for printing message details
::
++ render-activate
^- sole-effect:shoe
~[%mor [%tan meta] body]
:: +meta: render message metadata (serial, timestamp, author, target)
::
++ meta
^- tang
=+ hed=leaf+"{(scow %uv (fall hash 0))} at {(scow %da time-sent)}"
=/ src=tape ~(phat tr source)
[%rose [" " ~ ~] [hed >author< [%rose [", " "to " ~] [leaf+src]~] ~]]~
:: +body: long-form render of message contents
::
++ body
|- ^- sole-effect:shoe
:- %mor
%+ turn contents
|= =content:post
^- sole-effect:shoe
?- -.content
%text txt+(trip text.content)
%url url+url.content
%reference txt+"[reference to msg in {~(phat tr resource.uid.content)}]"
::
%mention
?. =(ship.content our-self) txt+(scow %p ship.content)
:- %mor
:- klr+[[`%br ~ ~]^(scow %p ship.content)]~ ::TODO inline
?.(notify ~ [%bel ~]~)
::
%code
:- %txt
%+ weld (trip expression.content)
?: =(~ output.content) ~
:- '\0a'
~(ram re (snag 0 output.content))
==
:: +nome: prints a ship name in 14 characters, left-padding with spaces
::
++ nome
|= =ship
^- tape
=+ raw=(cite:title ship)
(runt [(sub 14 (lent raw)) ' '] raw)
--
::
++ simple-wrap
|= [txt=tape wid=@ud]
^- (list tape)
?~ txt ~
=/ [end=@ud nex=?]
=+ ret=(find "\0a" (scag +(wid) `tape`txt))
?^ ret [u.ret &]
?: (lte (lent txt) wid) [(lent txt) &]
=+ ace=(find " " (flop (scag +(wid) `tape`txt)))
?~ ace [wid |]
[(sub wid u.ace) &]
:- (tufa (scag end `(list @)`txt))
$(txt (slag ?:(nex +(end) end) `tape`txt))
::
::NOTE anything that uses this breaks moons support, because moons don't sync
:: full app state rn
++ scry-for
|* [=mold app=term =path]
.^ mold
%gx
(scot %p our.bowl)
app
(scot %da now.bowl)
(snoc `^path`path %noun)
==
--