ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-09-20 06:58:16 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/release/next-userspace' into lf/graph-permissioning

Browse Source
This commit is contained in:
Liam Fitzgerald 2021-02-02 10:40:40 +10:00
commit c16f2365bf
No known key found for this signature in database
GPG Key ID: D390E12C61D1CFFB
147 changed files with 3680 additions and 2816 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.github/ISSUE_TEMPLATE/config.yml vendored
View File

@ -1,11 +1,8 @@
blank_issues_enabled: true
contact_links:
- name: Landscape design issue
url: https://github.com/urbit/landscape/issues/new?assignees=&labels=design+issue&template=report-a-design-issue.md&title=
about: Submit non-functionality, design-specific issues to the Landscape team here.
- name: Landscape feature request
url: https://github.com/urbit/landscape/issues/new?assignees=&labels=feature+request&template=feature_request.md&title=
about: Landscape is comprised of Tlon's user applications and client for Urbit. Submit Landscape feature requests here.
- name: Submit a Landscape issue
url: https://github.com/urbit/landscape/issues/new/choose
about: Issues with Landscape (Tlon's flagship client) should be filed at urbit/landscape. This includes groups, chats, collections, notebooks, and more.
- name: urbit-dev mailing list
url: https://groups.google.com/a/urbit.org/g/dev
about: Developer questions and discussions also take place on the urbit-dev mailing list.

39
.github/ISSUE_TEMPLATE/os1-bug-report.md vendored
View File

@ -1,39 +0,0 @@
---
name: Landscape bug report
about: 'Use this template to file a bug for any Landscape app: Chat, Publish, Links, Groups,
Weather or Clock'
title: ''
labels: landscape
assignees: ''
---
**Describe the bug**
A clear and concise description of what the bug is.
**To Reproduce**
Steps to reproduce the behavior:
1. Go to '...'
2. Click on '....'
3. Scroll down to '....'
4. See error
**Expected behavior**
A clear and concise description of what you expected to happen.
**Screenshots**
If applicable, add screenshots to help explain your problem. If possible, please also screenshot your browser's dev console. Here are [Chrome's docs](https://developers.google.com/web/tools/chrome-devtools/open) for using this feature.
**Desktop (please complete the following information):**
- OS: [e.g. MacOS 10.15.3]
- Browser [e.g. chrome, safari]
- Base hash of your urbit ship. Run `+trouble` in Dojo to see this.
**Smartphone (please complete the following information):**
- Device: [e.g. iPhone6]
- OS: [e.g. iOS8.1]
- Browser [e.g. stock browser, safari]
- Base hash of your urbit ship. Run `+trouble` in Dojo to see this.
**Additional context**
Add any other context about the problem here.

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:271d575a87373f4ed73b195780973ed41cb72be21b428a645c42a49ab5f786ee
size 8873583
oid sha256:6b4b198b552066fdee2a694a3134bf641b20591bebda21aa90920f4107f04f20
size 9065500

3
default.nix
View File

@ -155,8 +155,7 @@ let
contents = {
"${name}/urbit" = "${urbit}/bin/urbit";
"${name}/urbit-worker" = "${urbit}/bin/urbit-worker";
# temporarily removed for compatibility reasons
# "${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
"${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
};
};

580
pkg/arvo/app/contact-hook.hoon
View File

@ -1,571 +1,27 @@
:: contact-hook [landscape]
:: contact-hook [landscape]: deprecated
::
::
/- *contact-hook,
*contact-view,
inv=invite-store,
*metadata-hook,
*metadata-store,
*group
/+ *contact-json,
default-agent,
dbug,
group-store,
verb,
resource,
grpl=group,
*migrate
~% %contact-hook-top ..part ~
/+ default-agent
|%
+$ card card:agent:gall
::
+$ versioned-state
$% state-zero
state-one
state-two
state-three
==
::
+$ state-zero [%0 state-base]
+$ state-one [%1 state-base]
+$ state-two [%2 state-base]
+$ state-three [%3 state-base]
+$ state-base
$: =synced
invite-created=_|
==
--
=| state-three
=* state -
%- agent:dbug
%+ verb |
::
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
contact-core +>
cc ~(. contact-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
^- (quip card _this)
:_ this(invite-created %.y)
:~ (invite-poke:cc [%create %contacts])
[%pass /inv %agent [our.bol %invite-store] %watch /invitatory/contacts]
[%pass /group %agent [our.bol %group-store] %watch /groups]
==
++ on-save !>(state)
++ on-load
|= old-vase=vase
^- (quip card _this)
=/ old !<(versioned-state old-vase)
=| cards=(list card)
|^
|- ^- (quip card _this)
?: ?=(%3 -.old)
[cards this(state old)]
?: ?=(%2 -.old)
%_ $
old [%3 +.old]
::
cards
%+ welp
cards
%- zing
%+ turn
~(tap by synced.old)
|= [=path =ship]
^- (list card)
?. =(ship our.bol)
~
?> ?=([%ship *] path)
:~ (pass-store contacts+t.path %leave ~)
(pass-store contacts+path %watch contacts+path)
==
==
?: ?=(%1 -.old)
%_ $
-.old %2
::
synced.old
%- malt
%+ turn
~(tap by synced.old)
|= [=path =ship]
[ship+path ship]
::
cards
^- (list card)
;: welp
:~ [%pass /group %agent [our.bol %group-store] %leave ~]
[%pass /group %agent [our.bol %group-store] %watch /groups]
==
kick-old-subs
cards
==
==
%_ $
-.old %1
::
cards
:_ cards
[%pass /group %agent [our.bol %group-store] %watch /updates]
==
++ kick-old-subs
=/ paths
%+ turn
~(val by sup.bol)
|=([=ship =path] path)
?~ paths ~
[%give %kick paths ~]~
::
++ pass-store
|= [=wire =task:agent:gall]
^- card
[%pass wire %agent [our.bol %contact-store] task]
--
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json
(poke-json:cc !<(json vase))
::
%contact-action
(poke-contact-action:cc !<(contact-action vase))
::
%contact-hook-action
(poke-hook-action:cc !<(contact-hook-action vase))
::
%import
?> (team:title our.bol src.bol)
(poke-import:cc q.vase)
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?+ path (on-watch:def path)
[%contacts *] [(watch-contacts:cc t.path) this]
[%synced *] [(watch-synced:cc t.path) this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%kick [(kick:cc wire) this]
%watch-ack
=^ cards state
(watch-ack:cc wire p.sign)
[cards this]
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%contact-update
=^ cards state
(fact-contact-update:cc wire !<(contact-update q.cage.sign))
[cards this]
::
%group-update
=^ cards state
(fact-group-update:cc wire !<(update:group-store q.cage.sign))
[cards this]
::
%invite-update [~ this]
==
==
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %export ~]
``noun+!>(state)
[%x %synced ~]
``noun+!>(~(key by synced))
==
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=([%try-rejoin @ @ *] wire)
(on-arvo:def wire sign-arvo)
=/ nack-count=@ud (slav %ud i.t.wire)
=/ who=@p (slav %p i.t.t.wire)
=/ pax t.t.t.wire
?> ?=([%behn %wake *] sign-arvo)
~? ?=(^ error.sign-arvo)
"behn errored in backoff timers, continuing anyway"
:_ this
[(try-rejoin:cc who pax +(nack-count))]~
::
++ on-fail on-fail:def
--
::
|_ bol=bowl:gall
++ grp ~(. grpl bol)
+* this .
def ~(. (default-agent this %|) bol)
::
++ poke-json
|= jon=json
^- (quip card _state)
(poke-contact-action (json-to-action jon))
++ on-init on-init:def
++ on-poke on-poke:def
++ on-watch on-watch:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-save !>(~)
++ on-load
|= old-vase=vase
^- (quip card _this)
[~ this]
::
++ poke-contact-action
|= act=contact-action
^- (quip card _state)
:_ state
?+ -.act !!
%edit (handle-contact-action path.act ship.act act)
%add (handle-contact-action path.act ship.act act)
%remove (handle-contact-action path.act ship.act act)
==
::
++ handle-contact-action
|= [=path =ship act=contact-action]
^- (list card)
:: local
?: (team:title our.bol src.bol)
?. |(=(path /~/default) (~(has by synced) path)) ~
=/ shp ?:(=(path /~/default) our.bol (~(got by synced) path))
=/ appl ?:(=(shp our.bol) %contact-store %contact-hook)
[%pass / %agent [shp appl] %poke %contact-action !>(act)]~
:: foreign
=/ shp (~(got by synced) path)
?. |(=(shp our.bol) =(src.bol ship)) ~
:: scry group to check if ship is a member
=/ =group (need (group-scry path))
?. (~(has in members.group) shp) ~
[%pass / %agent [our.bol %contact-store] %poke %contact-action !>(act)]~
::
++ poke-hook-action
|= act=contact-hook-action
^- (quip card _state)
?- -.act
%add-owned
?> (team:title our.bol src.bol)
=/ contact-path [%contacts path.act]
?: (~(has by synced) path.act)
[~ state]
=. synced (~(put by synced) path.act our.bol)
:_ state
:~ [%pass contact-path %agent [our.bol %contact-store] %watch contact-path]
[%give %fact [/synced]~ %contact-hook-update !>([%initial synced])]
==
::
%add-synced
?> (team:title our.bol src.bol)
?: (~(has by synced) path.act) [~ state]
=. synced (~(put by synced) path.act ship.act)
=/ contact-path [%contacts path.act]
:_ state
:~ [%pass contact-path %agent [ship.act %contact-hook] %watch contact-path]
[%give %fact [/synced]~ %contact-hook-update !>([%initial synced])]
==
::
%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 [%contacts path.act])
[%give %kick ~[[%contacts path.act]] ~]~
[%give %fact [/synced]~ %contact-hook-update !>([%initial synced])]~
==
?. |(=(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
=/ cards
(handle-contact-action path.act our.bol [%remove path.act our.bol])
:_ state(synced (~(del by synced) path.act))
%- zing
:~ (pull-wire [%contacts path.act])
[%give %fact [/synced]~ %contact-hook-update !>([%initial synced])]~
cards
==
==
::
++ poke-import
|= arc=*
^- (quip card _state)
=/ sty=state-three
[%3 (remake-map ;;((tree [path ship]) +<.arc)) ;;(? +>.arc)]
:_ sty
%+ turn ~(tap by synced.sty)
|= [=path =ship]
^- card
=/ contact-path [%contacts path]
?: =(our.bol ship)
[%pass contact-path %agent [our.bol %contact-store] %watch contact-path]
(try-rejoin ship contact-path 0)
::
++ try-rejoin
|= [who=@p pax=path nack-count=@ud]
^- card
=/ =wire
[%try-rejoin (scot %ud nack-count) (scot %p who) pax]
[%pass wire %agent [who %contact-hook] %watch pax]
::
++ watch-contacts
|= pax=path
^- (list card)
?> ?=(^ pax)
?> (~(has by synced) pax)
:: scry groups to check if ship is a member
=/ =group (need (group-scry pax))
?> (~(has in members.group) src.bol)
=/ contacts (need (contacts-scry pax))
[%give %fact ~ %contact-update !>([%contacts pax contacts])]~
::
++ watch-synced
|= pax=path
^- (list card)
?> (team:title our.bol src.bol)
[%give %fact ~ %contact-hook-update !>([%initial synced])]~
::
++ watch-ack
|= [wir=wire saw=(unit tang)]
^- (quip card _state)
?~ saw
[~ state]
?: ?=([%try-rejoin @ *] wir)
=/ nack-count=@ud (slav %ud i.t.wir)
=/ wakeup=@da
(add now.bol (mul ~s1 (bex (min 19 nack-count))))
:_ state
[%pass wir %arvo %b %wait wakeup]~
::
?> ?=(^ wir)
[~ state(synced (~(del by synced) t.wir))]
::
++ migrate
|= wir=wire
^- wire
?> ?=([%contacts @ @ *] wir)
[%contacts %ship t.wir]
::
++ kick
|= wir=wire
^- (list card)
?+ wir !!
[%try-rejoin @ @ *]
$(wir t.t.t.wir)
::
[%inv ~]
[%pass /inv %agent [our.bol %invite-store] %watch /invitatory/contacts]~
::
[%group ~]
[%pass /group %agent [our.bol %group-store] %watch /groups]~
::
[%contacts @ *]
=/ wir
?: =(%ship i.t.wir)
wir
(migrate wir)
?> ?=([%contacts @ @ *] wir)
?. (~(has by synced) t.wir) ~
=/ =ship (~(got by synced) t.wir)
?: =(ship our.bol)
[%pass wir %agent [our.bol %contact-store] %watch wir]~
[%pass wir %agent [ship %contact-hook] %watch wir]~
==
::
++ fact-contact-update
|= [wir=wire fact=contact-update]
^- (quip card _state)
|^
?: (team:title our.bol src.bol)
(local fact)
:_ state
(foreign fact)
::
++ give-fact
|= [=path update=contact-update]
^- (list card)
[%give %fact ~[[%contacts path]] %contact-update !>(update)]~
::
++ local
|= fact=contact-update
^- (quip card _state)
?+ -.fact [~ state]
%add
:_ state
(give-fact path.fact [%add path.fact ship.fact contact.fact])
::
%edit
:_ state
(give-fact path.fact [%edit path.fact ship.fact edit-field.fact])
::
%delete
=. synced (~(del by synced) path.fact)
`state
==
::
++ foreign
|= fact=contact-update
^- (list card)
?+ -.fact ~
%contacts
=/ owner (~(got by synced) path.fact)
?> =(owner src.bol)
=/ have-contacts=(unit contacts)
(contacts-scry path.fact)
?~ have-contacts
:: if we don't have any contacts yet,
:: create the entry, and %add every contact
::
:- (contact-poke [%create path.fact])
%+ turn ~(tap by contacts.fact)
|= [=ship =contact]
(contact-poke [%add path.fact ship contact])
:: if we already have some, decide between %add, %remove and recreate
:: on a per-contact basis
::
%- zing
%+ turn
%~ tap in
%- ~(uni in ~(key by contacts.fact))
~(key by u.have-contacts)
|= =ship
^- (list card)
=/ have=(unit contact) (~(get by u.have-contacts) ship)
=/ want=(unit contact) (~(get by contacts.fact) ship)
?~ have
[(contact-poke %add path.fact ship (need want))]~
?~ want
[(contact-poke %remove path.fact ship)]~
?: =(u.want u.have) ~
::TODO probably want an %all edit-field that resolves to more granular
:: updates within the contact-store?
:~ (contact-poke %remove path.fact ship)
(contact-poke %add path.fact ship u.want)
==
::
%add
=/ owner (~(get by synced) path.fact)
?~ owner ~
?> |(=(u.owner src.bol) =(src.bol ship.fact))
~[(contact-poke [%add path.fact ship.fact contact.fact])]
::
%remove
=/ owner (~(get by synced) path.fact)
?~ owner ~
?> |(=(u.owner src.bol) =(src.bol ship.fact))
~[(contact-poke [%remove path.fact ship.fact])]
::
%edit
=/ owner (~(got by synced) path.fact)
?> |(=(owner src.bol) =(src.bol ship.fact))
~[(contact-poke [%edit path.fact ship.fact edit-field.fact])]
==
--
::
++ fact-group-update
|= [wir=wire fact=update:group-store]
^- (quip card _state)
?: ?=(%initial -.fact)
[~ state]
=/ group=(unit group)
(scry-group:grp resource.fact)
|^
?+ -.fact [~ state]
%initial-group (initial-group +.fact)
%remove-members (remove +.fact)
%remove-group (unbundle +.fact)
==
::
++ initial-group
|= [rid=resource =^group]
^- (quip card _state)
?: hidden.group [~ state]
=/ =path
(en-path:resource rid)
?: (~(has by synced) path)
[~ state]
(poke-hook-action %add-synced entity.rid path)
::
++ unbundle
|= [rid=resource ~]
^- (quip card _state)
=/ =path
(en-path:resource rid)
?. (~(has by synced) path)
?~ (contacts-scry path)
[~ state]
:_ state
[(contact-poke [%delete path])]~
:_ state(synced (~(del by synced) path))
:~ [%pass [%contacts path] %agent [our.bol %contact-store] %leave ~]
[(contact-poke [%delete path])]
==
::
++ remove
|= [rid=resource ships=(set ship)]
^- (quip card _state)
:: if pax is synced, remove member from contacts and kick their sub
?~ group
[~ state]
?: hidden.u.group [~ state]
=/ =path
(en-path:resource rid)
=/ owner=(unit ship) (~(get by synced) path)
?~ owner
:_ state
%+ turn ~(tap in ships)
|= =ship
(contact-poke [%remove path ship])
:_ state
%- zing
%+ turn ~(tap in ships)
|= =ship
:~ [%give %kick ~[[%contacts path]] `ship]
?: =(ship our.bol)
(contact-poke [%delete path])
(contact-poke [%remove path ship])
==
--
::
++ invite-poke
|= act=action:inv
^- card
[%pass / %agent [our.bol %invite-store] %poke %invite-action !>(act)]
::
++ contact-poke
|= act=contact-action
^- card
[%pass / %agent [our.bol %contact-store] %poke %contact-action !>(act)]
::
++ contacts-scry
|= pax=path
^- (unit contacts)
=. pax
;: weld
/(scot %p our.bol)/contact-store/(scot %da now.bol)/contacts
pax
/noun
==
.^((unit contacts) %gx pax)
::
++ group-scry
|= pax=path
.^ (unit group)
%gx
;:(weld /(scot %p our.bol)/group-store/(scot %da now.bol) /groups 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 %contact-store] %leave ~]~
[%pass pax %agent [u.shp %contact-hook] %leave ~]~
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
--

45
pkg/arvo/app/contact-pull-hook.hoon Normal file
View File

@ -0,0 +1,45 @@
/- *resource
/+ store=contact-store, contact, default-agent, verb, dbug, pull-hook
~% %contact-pull-hook-top ..part ~
|%
+$ card card:agent:gall
++ config
^- config:pull-hook
:* %contact-store
update:store
%contact-update
%contact-push-hook
==
--
::
%- agent:dbug
^- agent:gall
%- (agent:pull-hook config)
^- (pull-hook:pull-hook config)
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
dep ~(. (default:pull-hook this config) bowl)
con ~(. contact bowl)
::
++ on-init on-init:def
++ on-save !>(~)
++ on-load on-load:def
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
++ on-agent on-agent:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-pull-nack
|= [=resource =tang]
^- (quip card _this)
:_ this
?~ (get-contact:con entity.resource) ~
=- [%pass /pl-nack %agent [our.bowl %contact-store] %poke %contact-update -]~
!> ^- update:store
[%remove entity.resource]
::
++ on-pull-kick |=(=resource `/)
--

69
pkg/arvo/app/contact-push-hook.hoon Normal file
View File

@ -0,0 +1,69 @@
/+ store=contact-store, res=resource, contact, default-agent, dbug, push-hook
~% %contact-push-hook-top ..part ~
|%
+$ card card:agent:gall
++ config
^- config:push-hook
:* %contact-store
/updates
update:store
%contact-update
%contact-pull-hook
==
::
+$ agent (push-hook:push-hook config)
--
::
%- agent:dbug
^- agent:gall
%- (agent:push-hook config)
^- agent
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
con ~(. contact bowl)
::
++ on-init on-init:def
++ on-save !>(~)
++ on-load on-load:def
++ on-poke on-poke:def
++ on-agent on-agent:def
++ 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
::
++ should-proxy-update
|= =vase
^- ?
=/ =update:store !<(update:store vase)
?- -.update
%initial %.n
%add %.y
%remove %.y
%edit %.y
%allow %.n
%disallow %.n
%set-public %.n
==
::
++ initial-watch
|= [=path =resource:res]
^- vase
?> (is-allowed:con src.bowl)
!> ^- update:store
=/ contact=(unit contact:store) (get-contact:con our.bowl)
:+ %add
our.bowl
?^ contact u.contact
*contact:store
::
++ take-update
|= =vase
^- [(list card) agent]
=/ =update:store !<(update:store vase)
?. ?=(%disallow -.update) [~ this]
:_ this
[%give %kick ~[resource+(en-path:res [our.bowl %our])] ~]~
--

455
pkg/arvo/app/contact-store.hoon
View File

@ -1,279 +1,220 @@
:: contact-store [landscape]:
::
:: data store that holds group-based contact data
:: data store that holds individual contact data
::
/+ *contact-json, default-agent, dbug, *migrate
/- store=contact-store, *resource
/+ default-agent, dbug, *migrate
|%
+$ card card:agent:gall
+$ state-4
$: %4
=rolodex:store
allowed-groups=(set resource)
allowed-ships=(set ship)
is-public=_|
==
+$ versioned-state
$% state-zero
state-one
state-two
state-three
==
::
+$ rolodex-0 (map path contacts-0)
+$ contacts-0 (map ship contact-0)
+$ avatar-0 [content-type=@t octs=[p=@ud q=@t]]
+$ contact-0
$: nickname=@t
email=@t
phone=@t
website=@t
notes=@t
color=@ux
avatar=(unit avatar-0)
==
::
+$ state-zero
$: %0
rolodex=rolodex-0
==
+$ state-one
$: %1
=rolodex
==
+$ state-two
$: %2
=rolodex
==
+$ state-three
$: %3
=rolodex
$% [%0 *]
[%1 *]
[%2 *]
[%3 *]
state-4
==
--
::
=| state-three
=| state-4
=* state -
%- agent:dbug
^- agent:gall
=<
|_ =bowl:gall
+* this .
contact-core +>
cc ~(. contact-core bowl)
def ~(. (default-agent this %|) bowl)
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init
=. rolodex (~(put by rolodex) our.bowl *contact:store)
[~ this(state state)]
::
++ on-save !>(state)
++ on-load
|= old-vase=vase
^- (quip card _this)
=/ old !<(versioned-state old-vase)
?+ -.old
=. rolodex (~(put by rolodex) our.bowl *contact:store)
[~ this(state state)]
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old-vase=vase
=/ old !<(versioned-state old-vase)
=| cards=(list card)
|-
?: ?=(%3 -.old)
[cards this(state old)]
?: ?=(%2 -.old)
%_ $
-.old %3
::
rolodex.old
=/ def
(~(get by rolodex.old) /ship/~/default)
?~ def
rolodex.old
=. rolodex.old
(~(del by rolodex.old) /ship/~/default)
=. rolodex.old
(~(put by rolodex.old) /~/default u.def)
rolodex.old
==
?: ?=(%1 -.old)
=/ new-rolodex=^rolodex
%- malt
%+ turn
~(tap by rolodex.old)
|= [=path =contacts]
[ship+path contacts]
%_ $
old [%2 new-rolodex]
::
cards
=/ paths
%+ turn
~(val by sup.bol)
|=([=ship =path] path)
?~ paths cards
:_ cards
[%give %kick paths ~]
==
=/ new-rolodex=^rolodex
%- ~(run by rolodex.old)
|= cons=contacts-0
^- contacts
%- ~(run by cons)
|= con=contact-0
^- contact
:* nickname.con
email.con
phone.con
website.con
notes.con
color.con
~
==
$(old [%1 new-rolodex])
::
++ 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))
%contact-action
(poke-contact-action:cc !<(contact-action vase))
::
%import
(poke-import:cc q.vase)
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] (give %contact-update !>([%initial rolodex]))
[%updates ~] ~
[%contacts @ *]
%+ give %contact-update
!>([%contacts t.path (~(got by rolodex) t.path)])
==
[cards this]
%4 [~ this(state old)]
==
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] (give [%initial rolodex is-public])
[%updates ~] ~
::
++ 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+!>(rolodex)
[%x %contacts *]
?~ t.t.path
~
``noun+!>((~(get by rolodex) t.t.path))
::
[%x %contact *]
:: /:path/:ship
=/ pax `^path`(flop t.t.path)
?~ pax ~
=/ =ship (slav %p i.pax)
?~ t.pax ~
=> .(pax `(list @ta)`(flop t.pax))
=/ contacts=(unit contacts) (~(get by rolodex) pax)
?~ contacts
~
``noun+!>((~(get by u.contacts) ship))
::
[%x %export ~]
``noun+!>(state)
[%our ~]
%- give
:+ %add
our.bowl
=/ contact=(unit contact:store) (~(get by rolodex) our.bowl)
?~ contact *contact:store
u.contact
==
[cards this]
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
++ give
|= =update:store
^- (list card)
[%give %fact ~ [%contact-update !>(update)]]~
--
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=^ cards state
?+ mark (on-poke:def mark vase)
%contact-update (update !<(update:store vase))
%import (import q.vase)
==
[cards this]
::
++ update
|= =update:store
^- (quip card _state)
|^
?- -.update
%initial (handle-initial +.update)
%add (handle-add +.update)
%remove (handle-remove +.update)
%edit (handle-edit +.update)
%allow (handle-allow +.update)
%disallow (handle-disallow +.update)
%set-public (handle-set-public +.update)
==
::
++ handle-initial
|= [rolo=rolodex:store is-public=?]
^- (quip card _state)
=. rolodex (~(uni by rolodex) rolo)
:_ state(rolodex rolodex, is-public is-public)
(send-diff [%initial rolodex is-public] %.n)
::
++ handle-add
|= [=ship =contact:store]
^- (quip card _state)
=. last-updated.contact now.bowl
:- (send-diff [%add ship contact] =(ship our.bowl))
state(rolodex (~(put by rolodex) ship contact))
::
++ handle-remove
|= =ship
^- (quip card _state)
?> (~(has by rolodex) ship)
:- (send-diff [%remove ship] =(ship our.bowl))
?: =(ship our.bowl)
state(rolodex (~(put by rolodex) our.bowl *contact:store))
state(rolodex (~(del by rolodex) ship))
::
++ handle-edit
|= [=ship =edit-field:store]
|^
^- (quip card _state)
=/ contact (~(got by rolodex) ship)
=. contact (edit-contact contact edit-field)
=. last-updated.contact now.bowl
:- (send-diff [%edit ship edit-field] =(ship our.bowl))
state(rolodex (~(put by rolodex) ship contact))
::
++ edit-contact
|= [=contact:store edit=edit-field:store]
^- contact:store
?- -.edit
%nickname contact(nickname nickname.edit)
%bio contact(bio bio.edit)
%status contact(status status.edit)
%color contact(color color.edit)
%avatar contact(avatar avatar.edit)
%cover contact(cover cover.edit)
::
%add-group
contact(groups (~(put in groups.contact) resource.edit))
::
%remove-group
contact(groups (~(del in groups.contact) resource.edit))
==
--
::
++ handle-allow
|= =beings:store
^- (quip card _state)
:- (send-diff [%allow beings] %.n)
?- -.beings
%group state(allowed-groups (~(put in allowed-groups) resource.beings))
%ships state(allowed-ships (~(uni in allowed-ships) ships.beings))
==
::
++ handle-disallow
|= =beings:store
^- (quip card _state)
:- (send-diff [%disallow beings] %.y)
?- -.beings
%group state(allowed-groups (~(del in allowed-groups) resource.beings))
%ships state(allowed-ships (~(dif in allowed-ships) ships.beings))
==
::
++ handle-set-public
|= public=?
^- (quip card _state)
:_ state(is-public public)
(send-diff [%set-public public] %.n)
::
++ send-diff
|= [=update:store our=?]
^- (list card)
=/ paths=(list path)
?: our
[/updates /our /all ~]
[/updates /all ~]
[%give %fact paths %contact-update !>(update)]~
--
::
++ import
|= arc=*
^- (quip card _state)
:: note: we are purposefully wiping all state before state-4
[~ *state-4]
--
::
|_ bol=bowl:gall
::
::++ poke-json
:: |= =json
:: ^- (quip move _this)
:: ?> (team:title our.bol src.bol)
:: (poke-contact-action (json-to-action json))
::
++ poke-contact-action
|= action=contact-action
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%create (handle-create +.action)
%delete (handle-delete +.action)
%add (handle-add +.action)
%remove (handle-remove +.action)
%edit (handle-edit +.action)
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] ``noun+!>(rolodex)
::
[%x %contact @ ~]
=/ =ship (slav %p i.t.t.path)
=/ contact=(unit contact:store) (~(get by rolodex) ship)
?~ contact [~ ~]
:- ~ :- ~ :- %contact-update
!> ^- update:store
[%add ship u.contact]
::
[%x %allowed-ship @ ~]
=/ =ship (slav %p i.t.t.path)
``noun+!>((~(has in allowed-ships) ship))
::
[%x %allowed-groups ~]
``noun+!>(allowed-groups)
==
::
++ poke-import
|= arc=*
^- (quip card _state)
=/ sty=state-three
:- %3
%- remake-map-of-map
;;((tree [path (tree [ship contact])]) +.arc)
[~ sty]
::
++ handle-create
|= =path
^- (quip card _state)
?< (~(has by rolodex) path)
:- (send-diff path [%create path])
state(rolodex (~(put by rolodex) path *contacts))
::
++ handle-delete
|= =path
^- (quip card _state)
?. (~(has by rolodex) path) [~ state]
:- (send-diff path [%delete path])
state(rolodex (~(del by rolodex) path))
::
++ handle-add
|= [=path =ship =contact]
^- (quip card _state)
=/ contacts (~(got by rolodex) path)
?< (~(has by contacts) ship)
=. contacts (~(put by contacts) ship contact)
:- (send-diff path [%add path ship contact])
state(rolodex (~(put by rolodex) path contacts))
::
++ handle-remove
|= [=path =ship]
^- (quip card _state)
=/ contacts (~(got by rolodex) path)
?. (~(has by contacts) ship) [~ state]
=. contacts (~(del by contacts) ship)
:- (send-diff path [%remove path ship])
state(rolodex (~(put by rolodex) path contacts))
::
++ handle-edit
|= [=path =ship =edit-field]
^- (quip card _state)
=/ contacts (~(got by rolodex) path)
=/ contact (~(got by contacts) ship)
=. contact (edit-contact contact edit-field)
=. contacts (~(put by contacts) ship contact)
:- (send-diff path [%edit path ship edit-field])
state(rolodex (~(put by rolodex) path contacts))
::
++ edit-contact
|= [con=contact edit=edit-field]
^- contact
?- -.edit
%nickname con(nickname nickname.edit)
%email con(email email.edit)
%phone con(phone phone.edit)
%website con(website website.edit)
%notes con(notes notes.edit)
%color con(color color.edit)
%avatar con(avatar avatar.edit)
==
::
++ send-diff
|= [pax=path upd=contact-update]
^- (list card)
:~ :*
%give %fact
~[/all /updates [%contacts pax]]
%contact-update !>(upd)
== ==
++ on-leave on-leave:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

350
pkg/arvo/app/contact-view.hoon
View File

@ -1,343 +1,27 @@
:: contact-view [landscape]:
::
:: sets up contact JS client and combines commands
:: into semantic actions for the UI
::
/-
inv=invite-store,
*contact-hook,
metadata=metadata-store,
pull-hook,
push-hook
/+ *server, *contact-json, default-agent, dbug, verb,
grpl=group, mdl=metadata, resource,
group-store
:: contact-view [landscape]: deprecated
::
/+ default-agent
|%
+$ versioned-state
$% state-0
==
::
+$ state-0
$: %0
~
==
::
+$ card card:agent:gall
--
=| state-0
=* state -
::
%- agent:dbug
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
contact-core +>
cc ~(. contact-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
:_ this
:~ [%pass /updates %agent [our.bowl %contact-store] %watch /updates]
(contact-poke:cc [%create /~/default])
(contact-poke:cc [%add /~/default our.bowl *contact])
:* %pass /srv %agent [our.bol %file-server]
%poke %file-server-action
!>([%serve-dir /'~groups' /app/landscape %.n %.y])
==
==
::
++ on-save !>(state)
++ on-load
|= old-vase=vase
^- (quip card _this)
=/ old ((soft state-0) q.old-vase)
?^ old [~ this]
:_ this(state [%0 ~])
:~ [%pass / %arvo %e %disconnect [~ /'~groups']]
[%pass / %arvo %e %connect [~ /'contact-view'] %contact-view]
:* %pass /srv %agent [our.bol %file-server]
%poke %file-server-action
!>([%serve-dir /'~groups' /app/landscape %.n %.y])
==
==
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
?+ mark (on-poke:def mark vase)
%json [(poke-json:cc !<(json vase)) this]
%contact-view-action
[(poke-contact-view-action:cc !<(contact-view-action vase)) this]
::
%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
==
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
?: ?=([%http-response *] path) [~ this]
?. =(/primary path) (on-watch:def path)
[[%give %fact ~ %json !>((update-to-json [%initial all-scry:cc]))]~ this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%poke-ack
?. ?=([%join-group %ship @ @ ~] wire)
(on-agent:def wire sign)
?^ p.sign
(on-agent:def wire sign)
:_ this
(joined-group:cc t.wire)
::
%kick
[[%pass / %agent [our.bol %contact-store] %watch /updates]~ this]
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%contact-update
=/ update=json (update-to-json !<(contact-update q.cage.sign))
[[%give %fact ~[/primary] %json !>(update)]~ this]
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
--
::
|_ bol=bowl:gall
++ grp ~(. grpl bol)
++ md ~(. mdl bol)
++ poke-json
|= jon=json
^- (list card)
?> (team:title our.bol src.bol)
(poke-contact-view-action (json-to-view-action jon))
+* this .
def ~(. (default-agent this %|) bol)
::
++ poke-contact-view-action
|= act=contact-view-action
^- (list card)
?> (team:title our.bol src.bol)
?- -.act
%create
=/ rid=resource
[our.bol name.act]
=/ =path
(en-path:resource rid)
;: weld
:~ (group-poke [%add-group rid policy.act %.n])
(group-poke [%add-members rid (sy our.bol ~)])
(group-push-poke %add rid)
(contact-poke [%create path])
(contact-hook-poke [%add-owned path])
==
(create-metadata rid title.act description.act)
?. ?=(%invite -.policy.act)
~
%+ turn
~(tap in pending.policy.act)
|= =ship
(send-invite our.bol %contacts rid ship '')
==
::
%join
=/ =cage
:- %group-update
!> ^- update:group-store
[%add-members resource.act (sy our.bol ~)]
=/ =wire
[%join-group (en-path:resource resource.act)]
[%pass wire %agent [entity.resource.act %group-push-hook] %poke cage]~
::
%invite
=* rid resource.act
=/ =group (need (scry-group:grp rid))
:- (send-invite entity.rid %contacts rid ship.act text.act)
?. ?=(%invite -.policy.group) ~
~[(add-pending rid ship.act)]
::
%delete
~
::
%remove
=/ rid=resource
(de-path:resource path.act)
:~ (group-poke %remove-members rid (sy ship.act ~))
(contact-poke [%remove path.act ship.act])
==
::
%share
:: determine whether to send to our contact-hook or foreign
:: send contact-action to contact-hook with %add action
[(share-poke recipient.act [%add path.act ship.act contact.act])]~
::
%groupify
=/ =path
(en-path:resource resource.act)
%+ weld
:~ (group-poke %expose resource.act ~)
(contact-poke [%create path])
(contact-hook-poke [%add-owned path])
==
(create-metadata resource.act title.act description.act)
==
++ poke-handle-http-request
|= =inbound-request:eyre
^- simple-payload:http
=+ url=(parse-request-line url.request.inbound-request)
=/ name=@t
=+ back-path=(flop site.url)
?~ back-path
''
i.back-path
?+ site.url not-found:gen
[%'contact-view' @ *]
=/ =path (flop t.t.site.url)
?~ path not-found:gen
=/ contact (contact-scry `^path`(snoc (flop t.path) name))
?~ contact not-found:gen
?~ avatar.u.contact not-found:gen
?- -.u.avatar.u.contact
%url [[307 ['location' url.u.avatar.u.contact]~] ~]
%octt
=/ max-3-days ['cache-control' 'max-age=259200']
=/ content-type ['content-type' content-type.u.avatar.u.contact]
[[200 [content-type max-3-days ~]] `octs.u.avatar.u.contact]
==
==
++ on-init on-init:def
++ on-poke on-poke:def
++ on-watch on-watch:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-save !>(~)
++ on-load
|= old-vase=vase
^- (quip card _this)
[~ this]
::
++ joined-group
|= =path
^- (list card)
=/ rid=resource
(de-path:resource path)
:~ (group-pull-poke [%add entity.rid rid])
(contact-hook-poke [%add-synced entity.rid path])
(pull-metadata rid)
==
::
:: +utilities
::
++ add-pending
|= [rid=resource =ship]
^- card
=/ app=term
?: =(our.bol entity.rid)
%group-store
%group-push-hook
=/ =cage
:- %group-update
!> ^- action:group-store
[%change-policy rid %invite %add-invites (sy ship ~)]
[%pass / %agent [entity.rid app] %poke cage]
::
++ send-invite
|= =invite:inv
^- card
=/ =cage
:- %invite-action
!> ^- action:inv
[%invite %contacts (shaf %invite-uid eny.bol) invite]
[%pass / %agent [recipient.invite %invite-hook] %poke cage]
::
++ contact-poke
|= act=contact-action
^- card
[%pass / %agent [our.bol %contact-store] %poke %contact-action !>(act)]
::
++ contact-hook-poke
|= act=contact-hook-action
^- card
[%pass / %agent [our.bol %contact-hook] %poke %contact-hook-action !>(act)]
::
++ share-poke
|= [=ship act=contact-action]
^- card
[%pass / %agent [ship %contact-hook] %poke %contact-action !>(act)]
::
++ group-poke
|= act=action:group-store
^- card
[%pass / %agent [our.bol %group-store] %poke %group-action !>(act)]
::
++ group-push-poke
|= act=action:push-hook
^- card
[%pass / %agent [our.bol %group-push-hook] %poke %push-hook-action !>(act)]
::
++ group-proxy-poke
|= act=action:group-store
^- card
[%pass / %agent [entity.resource.act %group-push-hook] %poke %group-update !>(act)]
::
++ group-pull-poke
|= act=action:pull-hook
^- card
[%pass / %agent [our.bol %group-pull-hook] %poke %pull-hook-action !>(act)]
::
++ metadata-poke
|= =action:metadata
^- card
[%pass / %agent [our.bol %metadata-store] %poke metadata-action+!>(action)]
::
++ create-metadata
|= [rid=resource title=@t description=@t]
^- (list card)
=/ =metadatum:metadata
%* . *metadatum:metadata
title title
description description
date-created now.bol
creator our.bol
==
:~ (metadata-poke [%add rid [%contacts rid] metadatum])
(push-metadata rid)
==
::
++ push-metadata
|= rid=resource
^- card
=- [%pass / %agent [our.bol %metadata-push-hook] %poke -]
push-hook-action+!>([%add rid])
::
++ pull-metadata
|= rid=resource
^- card
=- [%pass / %agent [our.bol %metadata-pull-hook] %poke -]
pull-hook-action+!>([%add [entity .]:rid])
::
++ all-scry
^- rolodex
.^(rolodex %gx /(scot %p our.bol)/contact-store/(scot %da now.bol)/all/noun)
::
++ contact-scry
|= pax=path
^- (unit contact)
=. pax
;: weld
/(scot %p our.bol)/contact-store/(scot %da now.bol)/contact
pax
/noun
==
.^((unit contact) %gx pax)
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
--

2
pkg/arvo/app/glob.hoon
View File

@ -5,7 +5,7 @@
/- glob
/+ default-agent, verb, dbug
|%
++ hash 0v7.ttn7o.50403.rf6oh.63hnc.hgpc9
++ hash 0v1.39us5.oj5a9.9as9u.od9db.0dipj
+$ state-0 [%0 hash=@uv glob=(unit (each glob:glob tid=@ta))]
+$ all-states
$% state-0

11
pkg/arvo/app/graph-store.hoon
View File

@ -726,7 +726,8 @@
$: %0
p=time
$= q
$% [%add-nodes =resource:store nodes=(tree [index:store tree-node])]
$% [%add-graph =resource:store =tree-graph mark=(unit ^mark) ow=?]
[%add-nodes =resource:store nodes=(tree [index:store tree-node])]
[%remove-nodes =resource:store indices=(tree index:store)]
[%add-signatures =uid:store signatures=tree-signatures]
[%remove-signatures =uid:store signatures=tree-signatures]
@ -806,6 +807,14 @@
^- logged-update:store
:+ %0 p.t
?- -.q.t
%add-graph
:* %add-graph
resource.q.t
(remake-graph tree-graph.q.t)
mark.q.t
ow.q.t
==
::
%add-nodes
:- %add-nodes
:- resource.q.t

14
pkg/arvo/app/group-store.hoon
View File

@ -29,7 +29,7 @@
:: Modify the group. Further documented in /sur/group-store.hoon
::
::
/- *group, *contact-view
/- *group
/+ store=group-store, default-agent, verb, dbug, resource, *migrate
|%
+$ card card:agent:gall
@ -229,11 +229,8 @@
|= [recipient=@p out=(list card)]
?: =(recipient our.bol)
out
:_ out
%- poke-contact
:* %invite rid recipient
(crip "Rejoin disconnected group {<entity.rid>}/{<name.rid>}")
==
:: TODO: figure out contacts integration
out
:_ out
(try-rejoin rid 0)
::
@ -555,11 +552,6 @@
|= =action:store
^- card
[%pass / %agent [our.bol %group-store] %poke %group-action !>(action)]
::
++ poke-contact
|= act=contact-view-action
^- card
[%pass / %agent [our.bol %contact-view] %poke %contact-view-action !>(act)]
:: +send-diff: update subscribers of new state
::
:: We only allow subscriptions on /groups

227
pkg/arvo/app/group-view.hoon Normal file
View File

@ -0,0 +1,227 @@
/- view-sur=group-view, group-store, *group, metadata=metadata-store
/+ default-agent, agentio, mdl=metadata, resource, dbug, grpl=group, verb
|%
++ card card:agent:gall
+$ state-zero
$: %0
joining=(map rid=resource [=ship =progress:view])
==
++ view view-sur
--
=| state-zero
=* state -
::
%- agent:dbug
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
gc ~(. +> bowl)
io ~(. agentio bowl)
++ on-init
`this
++ on-save
!>(state)
::
++ on-load
|= =vase
=+ !<(old=state-zero vase)
`this(state old)
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?. ?=(?(%group-view-action %noun) mark)
(on-poke:def mark vase)
=+ !<(=action:view vase)
?> ?=(%join -.action)
=^ cards state
jn-abet:(jn-start:join:gc +.action)
[cards this]
::
++ on-watch
|= =path
?+ path (on-watch:def path)
[%all ~]
:_ this
:_ ~
%+ fact:io
:- %group-view-update
!> ^- update:view
[%initial (~(run by joining) |=([=ship =progress:view] progress))]
~
==
::
++ on-peek on-peek:def
::
++ on-agent
|= [=wire =sign:agent:gall]
=^ cards state
?+ wire `state
[%join %ship @ @ *]
=/ rid
(de-path:resource t.wire)
?. (~(has by joining) rid) `state
jn-abet:(jn-agent:(jn-abed:join:gc rid) t.t.t.t.wire sign)
==
[cards this]
::
++ on-arvo on-arvo:def
::
++ on-leave on-leave:def
::
++ on-fail on-fail:def
--
|_ =bowl:gall
++ met ~(. mdl bowl)
++ grp ~(. grpl bowl)
++ io ~(. agentio bowl)
::
::
++ join
|_ [rid=resource =ship cards=(list card)]
++ jn-core .
++ emit-many
|= crds=(list card)
jn-core(cards (weld (flop crds) cards))
++ emit
|= =card
jn-core(cards [card cards])
::
++ tx-progress
|= =progress:view
=. joining
(~(put by joining) rid [ship progress])
=; =cage
(emit (fact:io cage /all tx+(en-path:resource rid) ~))
group-view-update+!>([%progress rid progress])
::
++ watch-md
(emit (watch-our:(jn-pass-io /md) %metadata-store /updates))
::
++ watch-groups
(emit (watch-our:(jn-pass-io /groups) %group-store /groups))
::
++ jn-pass-io
|= pax=path
~(. pass:io (welp join+(en-path:resource rid) pax))
::
++ jn-abed
|= r=resource
=/ [s=^ship =progress:view]
(~(got by joining) r)
jn-core(rid r, ship s)
::
++ jn-abet
^- (quip card _state)
[(flop cards) state]
::
++ jn-start
|= [rid=resource =^ship]
^+ jn-core
?< (~(has by joining) rid)
=. joining
(~(put by joining) rid [ship %start])
=. jn-core
(jn-abed rid)
=/ maybe-group
(peek-group:met %groups rid)
?^ maybe-group
~|("already joined group {<rid>}" !!)
=. jn-core
%- emit
%+ poke:(jn-pass-io /add)
[ship %group-push-hook]
group-update+!>([%add-members rid (silt our.bowl ~)])
=. jn-core (tx-progress %start)
=> watch-md
watch-groups
::
++ jn-agent
|= [=wire =sign:agent:gall]
^+ jn-core
|^
?+ -.wire ~|("bad %join wire" !!)
%add :: join group
?> ?=(%poke-ack -.sign)
?^ p.sign
(cleanup %no-perms)
=> %- emit
%+ poke-our:(jn-pass-io /pull-groups) %group-pull-hook
pull-hook-action+!>([%add ship rid])
(tx-progress %added)
::
%pull-groups
?> ?=(%poke-ack -.sign)
(ack +.sign)
::
%groups
?+ -.sign !!
%fact (groups-fact +.sign)
%watch-ack (ack +.sign)
%kick watch-groups
==
::
%pull-md
?> ?=(%poke-ack -.sign)
(ack +.sign)
::
%md
?+ -.sign !!
%fact (md-fact +.sign)
%watch-ack (ack +.sign)
%kick watch-md
==
::
%pull-graphs
?> ?=(%poke-ack -.sign)
%- cleanup
?^(p.sign %strange %done)
==
++ groups-fact
|= =cage
?. ?=(%group-update p.cage) jn-core
=+ !<(=update:group-store q.cage)
?. ?=(%initial-group -.update) jn-core
?. =(rid resource.update) jn-core
%- emit
%+ poke-our:(jn-pass-io /pull-md) %metadata-pull-hook
pull-hook-action+!>([%add [entity .]:rid])
::
++ md-fact
|= [=mark =vase]
?. ?=(%metadata-update mark) jn-core
=+ !<(=update:metadata vase)
?. ?=(%initial-group -.update) jn-core
?. =(group.update rid) jn-core
=. jn-core (cleanup %done)
?. hidden:(need (scry-group:grp rid)) jn-core
%- emit-many
%+ murn ~(tap by associations.update)
|= [=md-resource:metadata =association:metadata]
^- (unit card)
?. =(app-name.md-resource %graph) ~
=* rid resource.md-resource
:- ~
%+ poke-our:(jn-pass-io /pull-graph) %graph-pull-hook
pull-hook-action+!>([%add [entity .]:rid])
::
++ ack
|= err=(unit tang)
?~ err jn-core
%- (slog u.err)
(cleanup %strange)
::
++ cleanup
|= =progress:view
=. jn-core
(tx-progress progress)
=. joining (~(del by joining) rid)
=. jn-core
(emit (leave-our:(jn-pass-io /groups) %group-store))
(emit (leave-our:(jn-pass-io /md) %metadata-store))
--
--
--

3
pkg/arvo/app/hood.hoon
View File

@ -2,7 +2,7 @@
/+ drum=hood-drum, helm=hood-helm, kiln=hood-kiln
|%
+$ state
$: %11
$: %12
drum=state:drum
helm=state:helm
kiln=state:kiln
@ -14,6 +14,7 @@
[%8 drum=state:drum helm=state:helm kiln=state:kiln]
[%9 drum=state:drum helm=state:helm kiln=state:kiln]
[%10 drum=state:drum helm=state:helm kiln=state:kiln]
[%11 drum=state:drum helm=state:helm kiln=state:kiln]
==
+$ any-state-tuple
$: drum=any-state:drum

63
pkg/arvo/app/invite-store.hoon
View File

@ -6,6 +6,7 @@
+$ versioned-state
$% state-0
state-1
state-2
==
::
+$ invitatory-0 (map serial:store invite-0)
@ -19,9 +20,10 @@
::
+$ state-0 [%0 invites=(map path invitatory-0)]
+$ state-1 [%1 =invites:store]
+$ state-2 [%2 =invites:store]
--
::
=| state-1
=| state-2
=* state -
%- agent:dbug
^- agent:gall
@ -43,37 +45,22 @@
++ on-load
|= old-vase=vase
=/ old !<(versioned-state old-vase)
=| cards=(list card)
|-
?: ?=(%2 -.old)
[cards this(state old)]
?: ?=(%1 -.old)
`this(state old)
:- =- [%pass / %agent [our.bowl %invite-store] %poke %invite-action -]~
!> ^- action:store
[%create %graph]
%= this
state
:- %1
%- ~(gas by *invites:store)
%+ murn ~(tap by invites.old)
|= [=path =invitatory-0]
^- (unit [term invitatory:store])
?. ?=([@ ~] path) ~
:- ~
:- i.path
%- ~(gas by *invitatory:store)
%+ murn ~(tap by invitatory-0)
|= [=serial:store =invite-0]
^- (unit [serial:store invite:store])
=/ resource=(unit resource:res) (de-path-soft:res path.invite-0)
?~ resource ~
:- ~
:- serial
^- invite:store
:* ship.invite-0
app.invite-0
u.resource
recipient.invite-0
text.invite-0
==
==
=. cards
:~ =- [%pass / %agent [our.bowl %invite-store] %poke %invite-action -]
!> ^- action:store
[%create %groups]
::
=- [%pass / %agent [our.bowl %invite-store] %poke %invite-action -]
!> ^- action:store
[%delete %contacts]
==
$(-.old %2)
$(old [%1 (~(gas by *invites:store) [%graph *invitatory:store]~)])
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
@ -109,11 +96,19 @@
++ poke-import
|= arc=*
^- (quip card _state)
=/ sty=state-1
:- %1
=/ sty=state-2
:- %2
%- remake-map-of-map
;;((tree [term (tree [serial:store invite:store])]) +.arc)
[~ sty]
:_ sty
:~ =- [%pass / %agent [our.bowl %invite-store] %poke %invite-action -]
!> ^- action:store
[%create %groups]
::
=- [%pass / %agent [our.bowl %invite-store] %poke %invite-action -]
!> ^- action:store
[%delete %contacts]
==
::
++ poke-invite-action
|= =action:store

2
pkg/arvo/app/landscape/index.html
View File

@ -24,6 +24,6 @@
<div id="portal-root"></div>
<script src="/~landscape/js/channel.js"></script>
<script src="/~landscape/js/session.js"></script>
<script src="/~landscape/js/bundle/index.7d4248944fe1255cb74b.js"></script>
<script src="/~landscape/js/bundle/index.5fdbe84c6b57646a6a6b.js"></script>
</body>
</html>

2
pkg/arvo/app/lens.hoon
View File

@ -28,8 +28,6 @@
%contact-store
%contact-hook
%invite-store
%chat-store
%chat-hook
%graph-store
==
|= app=@tas

1
pkg/arvo/app/metadata-pull-hook.hoon
View File

@ -55,7 +55,6 @@
=+ !<(=update:invite-store q.cage.sign)
:_ state
?. ?=(%invite -.update) ~
?. =(%contacts term.update) ~
(get-preview resource.invite.update)^~
::
%kick [watch-invites^~ state]

4
pkg/arvo/app/metadata-push-hook.hoon
View File

@ -49,7 +49,9 @@
=/ members
~(wyt in (members:grp rid))
=/ =metadatum:store
(need (peek-metadatum:met %contacts rid))
%- need
%+ mate (peek-metadatum:met %groups rid)
(peek-metadatum:met %graph rid)
:_ this
=; =cage
[%pass / %agent [src.bowl %metadata-pull-hook] %poke cage]~

15
pkg/arvo/app/metadata-store.hoon
View File

@ -353,7 +353,7 @@
++ handle-add
|= [group=resource =md-resource:store =metadatum:store]
^- (quip card _state)
:- %+ send-diff app-name.md-resource
:- %- send-diff
[%add group md-resource metadatum]
%= state
associations
@ -374,7 +374,7 @@
++ handle-remove
|= [group=resource =md-resource:store]
^- (quip card _state)
:- (send-diff app-name.md-resource [%remove group md-resource])
:- (send-diff [%remove group md-resource])
%= state
associations
(~(del by associations) md-resource)
@ -395,15 +395,15 @@
|= [group=resource =associations:store]
=/ assocs=(list [=md-resource:store grp=resource =metadatum:store])
~(tap by associations)
=| cards=(list card)
:- (send-diff %initial-group group associations)
|-
?~ assocs
[cards state]
state
=, assocs
?> =(group grp.i)
=^ new-cards state
=^ cards state
(handle-add group [md-resource metadatum]:i)
$(cards (weld cards new-cards), assocs t)
$(assocs t)
::
++ metadata-for-app
|= =app-name:store
@ -428,13 +428,12 @@
(~(put by out) md-resource [group metadatum])
::
++ send-diff
|= [=app-name:store =update:store]
|= =update:store
^- (list card)
|^
%- zing
:~ (update-subscribers /all update)
(update-subscribers /updates update)
(update-subscribers [%app-name app-name ~] update)
==
::
++ update-subscribers

103
pkg/arvo/lib/agentio.hoon Normal file
View File

@ -0,0 +1,103 @@
=>
|%
++ card card:agent:gall
--
::
|_ =bowl:gall
++ scry
|* [desk=@tas =path]
?> ?=(^ path)
?> ?=(^ t.path)
%+ weld
/(scot %p our.bowl)/[desk]/(scot %da now.bowl)
t.t.path
::
++ pass
|_ =wire
++ poke
|= [=dock =cage]
[%pass wire %agent dock %poke cage]
::
++ poke-our
|= [app=term =cage]
^- card
(poke [our.bowl app] cage)
::
++ arvo
|= =note-arvo
^- card
[%pass wire %arvo note-arvo]
::
++ watch
|= [=dock =path]
[%pass (watch-wire path) %agent dock %watch path]
::
++ watch-our
|= [app=term =path]
(watch [our.bowl app] path)
::
++ watch-wire
|= =path
^+ wire
?. ?=(~ wire)
wire
agentio-watch+path
::
++ leave
|= =dock
[%pass wire %agent dock %leave ~]
::
++ leave-our
|= app=term
(leave our.bowl app)
::
++ leave-path
|= [=dock =path]
=. wire
(watch-wire path)
(leave dock)
::
++ wait
|= p=@da
(arvo %b %wait p)
::
++ rest
|= p=@da
(arvo %b %wait p)
::
++ warp
|= [wer=ship =riff:clay]
(arvo %c %warp wer riff)
::
++ warp-our
|= =riff:clay
(warp our.bowl riff)
::
:: right here, right now
++ warp-slim
|= [genre=?(%sing %next) =care:clay =path]
=/ =mood:clay
[care r.byk.bowl path]
=/ =rave:clay
?:(?=(%sing genre) [genre mood] [genre mood])
(warp-our q.byk.bowl `rave)
--
::
++ fact-curry
|* [=mark =mold]
|= [paths=(list path) fac=mold]
(fact mark^!>(fac) paths)
::
++ fact
|= [=cage paths=(list path)]
^- card
[%give %fact paths cage]
::
++ kick
|= paths=(list path)
[%give %kick paths ~]
::
++ kick-only
|= [=ship paths=(list path)]
[%give %kick paths `ship]
--

265
pkg/arvo/lib/contact-json.hoon
View File

@ -1,265 +0,0 @@
/- *contact-view, *contact-hook
/+ group-store, resource
|%
++ nu :: parse number as hex
|= jon=json
?> ?=([%s *] jon)
(rash p.jon hex)
::
++ hook-update-to-json
|= upd=contact-hook-update
=, enjs:format
^- json
%+ frond %contact-hook-update
%- pairs
%+ turn ~(tap by synced.upd)
|= [pax=^path shp=^ship]
^- [cord json]
[(spat pax) s+(scot %p shp)]
::
++ rolodex-to-json
|= rolo=rolodex
=, enjs:format
^- json
%- pairs
%+ turn ~(tap by rolo)
|= [pax=^path =contacts]
^- [cord json]
:- (spat pax)
(contacts-to-json pax contacts)
::
++ contacts-to-json
|= [=path con=contacts]
^- json
%- pairs:enjs:format
%+ turn ~(tap by con)
|= [=ship =contact]
^- [cord json]
[(crip (slag 1 (scow %p ship))) (contact-to-json path ship contact)]
::
++ contact-to-json
|= [=path =ship con=contact]
^- json
%- pairs:enjs:format
:~ [%nickname s+nickname.con]
[%email s+email.con]
[%phone s+phone.con]
[%website s+website.con]
[%notes s+notes.con]
[%color s+(scot %ux color.con)]
[%avatar (avatar-to-json path ship avatar.con)]
==
::
++ edit-to-json
|= [=path =ship edit=edit-field]
^- json
%+ frond:enjs:format -.edit
?- -.edit
%nickname s+nickname.edit
%email s+email.edit
%phone s+phone.edit
%website s+website.edit
%notes s+notes.edit
%color s+(scot %ux color.edit)
%avatar (avatar-to-json path ship avatar.edit)
==
::
++ avatar-to-json
|= [=path =ship avat=(unit avatar)]
^- json
?~ avat ~
?- -.u.avat
%octt
:- %s
%- crip
%- zing
:~ "/contact-view"
(trip (spat path))
"/"
(trip (scot %p ship))
==
::
%url s+url.u.avat
==
::
++ update-to-json
|= upd=contact-update
=, enjs:format
^- json
%+ frond %contact-update
%- pairs
:~
?: ?=(%initial -.upd)
[%initial (rolodex-to-json rolodex.upd)]
?: ?=(%create -.upd)
[%create (pairs [%path (path path.upd)]~)]
?: ?=(%delete -.upd)
[%delete (pairs [%path (path path.upd)]~)]
?: ?=(%add -.upd)
:- %add
%- pairs
:~ [%path (path path.upd)]
[%ship (ship ship.upd)]
[%contact (contact-to-json path.upd ship.upd contact.upd)]
==
?: ?=(%remove -.upd)
:- %remove
%- pairs
:~ [%path (path path.upd)]
[%ship (ship ship.upd)]
==
?: ?=(%edit -.upd)
:- %edit
%- pairs
:~ [%path (path path.upd)]
[%ship (ship ship.upd)]
[%edit-field (edit-to-json path.upd ship.upd edit-field.upd)]
==
[*@t *^json]
==
::
++ json-to-view-action
|= jon=json
^- contact-view-action
=, dejs:format
=< (parse-json jon)
|%
++ parse-json
%- of
:~ [%create create]
[%delete delete]
[%join dejs:resource]
[%invite invite]
[%remove remove]
[%share share]
==
::
++ create
%- ot
:~ [%name so]
[%policy policy:dejs:group-store]
[%title so]
[%description so]
==
::
++ invite
%- ot
:~ [%resource dejs:resource]
[%ship (su ;~(pfix sig fed:ag))]
[%text so]
==
::
++ delete (ot [%path pa]~)
::
++ remove
%- ot
:~ [%path pa]
[%ship (su ;~(pfix sig fed:ag))]
==
::
++ share
%- ot
:~ [%recipient (su ;~(pfix sig fed:ag))]
[%path pa]
[%ship (su ;~(pfix sig fed:ag))]
[%contact cont]
==
--
::
++ json-to-action
|= jon=json
^- contact-action
=, dejs:format
=< (parse-json jon)
|%
++ parse-json
%- of
:~ [%create create]
[%delete delete]
[%add add]
[%remove remove]
[%edit edit]
==
::
++ create
(ot [%path pa]~)
::
++ delete
(ot [%path pa]~)
::
++ add
%- ot
:~ [%path pa]
[%ship (su ;~(pfix sig fed:ag))]
[%contact cont]
==
::
++ remove
%- ot
:~ [%path pa]
[%ship (su ;~(pfix sig fed:ag))]
==
::
++ edit
%- ot
:~ [%path pa]
[%ship (su ;~(pfix sig fed:ag))]
[%edit-field edit-fi]
==
--
::
++ octet
%- ot:dejs:format
:~ [%p ni:dejs:format]
[%q so:dejs:format]
==
::
++ avat
|= jon=json
^- avatar
|^
=/ =avatar (parse-json jon)
?- -.avatar
%url avatar
%octt
=. octs.avatar (need (de:base64:mimes:html q.octs.avatar))
avatar
==
::
++ parse-json
%- of:dejs:format
:~ [%octt octt]
[%url url]
==
::
++ octt
%- ot:dejs:format
:~ [%content-type so:dejs:format]
[%octs octet]
==
::
++ url so:dejs:format
--
::
++ cont
%- ot:dejs:format
:~ [%nickname so:dejs:format]
[%email so:dejs:format]
[%phone so:dejs:format]
[%website so:dejs:format]
[%notes so:dejs:format]
[%color nu]
[%avatar (mu:dejs:format avat)]
==
::
++ edit-fi
%- of:dejs:format
:~ [%nickname so:dejs:format]
[%email so:dejs:format]
[%phone so:dejs:format]
[%website so:dejs:format]
[%notes so:dejs:format]
[%color nu]
[%avatar (mu:dejs:format avat)]
==
--

176
pkg/arvo/lib/contact-store.hoon Normal file
View File

@ -0,0 +1,176 @@
/- sur=contact-store
/+ res=resource
=< [sur .]
=, sur
|%
++ nu :: parse number as hex
|= jon=json
?> ?=([%s *] jon)
(rash p.jon hex)
::
++ enjs
=, enjs:format
|%
++ update
|= upd=^update
^- json
%+ frond %contact-update
%- pairs
:_ ~
^- [cord json]
?- -.upd
%initial
:- %initial
%- pairs
:~ [%rolodex (rolo rolodex.upd)]
[%is-public b+is-public.upd]
==
::
%add
:- %add
%- pairs
:~ [%ship (ship ship.upd)]
[%contact (cont contact.upd)]
==
::
%remove
:- %remove
(pairs [%ship (ship ship.upd)]~)
::
%edit
:- %edit
%- pairs
:~ [%ship (ship ship.upd)]
[%edit-field (edit edit-field.upd)]
==
::
%allow
:- %allow
(pairs [%beings (beng beings.upd)]~)
::
%disallow
:- %disallow
(pairs [%beings (beng beings.upd)]~)
::
%set-public
[%set-public b+public.upd]
==
::
++ rolo
|= =rolodex
^- json
%- pairs
%+ turn ~(tap by rolodex)
|= [=^ship =contact]
^- [cord json]
[(scot %p ship) (cont contact)]
::
++ cont
|= =contact
^- json
%- pairs
:~ [%nickname s+nickname.contact]
[%bio s+bio.contact]
[%status s+status.contact]
[%color s+(scot %ux color.contact)]
[%avatar ?~(avatar.contact ~ s+u.avatar.contact)]
[%cover ?~(cover.contact ~ s+u.cover.contact)]
[%groups a+(turn ~(tap in groups.contact) |=(r=resource (enjs:res r)))]
[%last-updated (time last-updated.contact)]
==
::
++ edit
|= field=edit-field
^- json
%+ frond -.field
?- -.field
%nickname s+nickname.field
%bio s+bio.field
%status s+status.field
%color s+(scot %ux color.field)
%avatar ?~(avatar.field ~ s+u.avatar.field)
%cover ?~(cover.field ~ s+u.cover.field)
%add-group (enjs:res resource.field)
%remove-group (enjs:res resource.field)
==
::
++ beng
|= =beings
^- json
?- -.beings
%ships [%a (turn ~(tap in ships.beings) |=(s=^ship s+(scot %p s)))]
%group (enjs:res resource.beings)
==
--
::
++ dejs
=, dejs:format
|%
++ update
|= jon=json
^- ^update
=< (decode jon)
|%
++ decode
%- of
:~ [%initial initial]
[%add add-contact]
[%remove remove-contact]
[%edit edit-contact]
[%allow beings]
[%disallow beings]
[%set-public bo]
==
::
++ initial
%- ot
:~ [%rolodex (op ;~(pfix sig fed:ag) cont)]
[%is-public bo]
==
::
++ add-contact
%- ot
:~ [%ship (su ;~(pfix sig fed:ag))]
[%contact cont]
==
::
++ remove-contact (ot [%ship (su ;~(pfix sig fed:ag))]~)
::
++ edit-contact
%- ot
:~ [%ship (su ;~(pfix sig fed:ag))]
[%edit-field edit]
==
::
++ beings
%- of
:~ [%ships (as (su ;~(pfix sig fed:ag)))]
[%group dejs:res]
==
::
++ cont
%- ot
:~ [%nickname so]
[%bio so]
[%status so]
[%color nu]
[%avatar (mu so)]
[%cover (mu so)]
[%groups (as dejs:res)]
[%last-updated di]
==
::
++ edit
%- of
:~ [%nickname so]
[%bio so]
[%status so]
[%color nu]
[%avatar (mu so)]
[%cover (mu so)]
[%add-group dejs:res]
[%remove-group dejs:res]
==
--
--
--

34
pkg/arvo/lib/contact.hoon Normal file
View File

@ -0,0 +1,34 @@
/- store=contact-store, *resource
/+ group
|_ =bowl:gall
++ scry-for
|* [=mold =path]
.^ mold
%gx
(scot %p our.bowl)
%contact-store
(scot %da now.bowl)
(snoc `^path`path %noun)
==
::
++ get-contact
|= =ship
^- (unit contact:store)
=/ upd (scry-for (unit update:store) /contact/(scot %p ship))
?~ upd ~
?> ?=(%add -.u.upd)
`contact.u.upd
::
++ is-allowed
|= =ship
^- ?
=/ shp (scry-for ? /allowed-ship/(scot %p ship))
?: shp %.y
=/ allowed-groups ~(tap in (scry-for (set resource) /allowed-groups))
=/ grp ~(. group bowl)
|-
?~ allowed-groups %.n
?: (~(has in (members:grp i.allowed-groups)) ship)
%.y
$(allowed-groups t.allowed-groups)
--

84
pkg/arvo/lib/group-view.hoon Normal file
View File

@ -0,0 +1,84 @@
/- sur=group-view, spider
/+ resource, strandio, metadata=metadata-store, store=group-store
^?
=< [. sur]
=, sur
|%
++ dejs
=, dejs:format
|%
++ action
^- $-(json ^action)
%- of
:~ create+create
remove+remove
join+join
leave+leave
==
::
++ create
%- ot
:~ name+so
policy+policy:dejs:store
title+so
description+so
==
::
++ remove dejs:resource
::
++ leave dejs:resource
::
++ join
%- ot
:~ resource+dejs:resource
ship+(su ;~(pfix sig fed:ag))
==
--
::
++ enjs
=, enjs:format
|%
++ update
|= upd=^update
%+ frond %group-view-update
%+ frond -.upd
?- -.upd
%initial (initial +.upd)
%progress (progress +.upd)
==
::
++ progress
|= [rid=resource prog=^progress]
%- pairs
:~ resource+s+(enjs-path:resource rid)
progress+s+prog
==
::
++ initial
|= init=(map resource ^progress)
%- pairs
%+ turn ~(tap by init)
|= [rid=resource prog=^progress]
:_ s+prog
(enjs-path:resource rid)
--
++ cleanup-md
|= rid=resource
=/ m (strand:spider ,~)
^- form:m
;< =associations:metadata bind:m
%+ scry:strandio associations:metadata
%+ weld /gx/metadata-store/group
(snoc (en-path:resource rid) %noun)
~& associations
=/ assocs=(list [=md-resource:metadata association:metadata])
~(tap by associations)
|-
=* loop $
?~ assocs
(pure:m ~)
;< ~ bind:m
%+ poke-our:strandio %metadata-store
metadata-action+!>([%remove rid md-resource.i.assocs])
loop(assocs t.assocs)
--

7
pkg/arvo/lib/hood/drum.hoon
View File

@ -91,6 +91,8 @@
%herm
%contact-store
%contact-hook
%contact-push-hook
%contact-pull-hook
%contact-view
%metadata-store
%s3-store
@ -106,6 +108,7 @@
%observe-hook
%metadata-push-hook
%metadata-pull-hook
%group-view
==
::
++ deft-fish :: default connects
@ -251,6 +254,10 @@
=> (se-born | %home %metadata-pull-hook)
=> (se-born | %home %metadata-push-hook)
(se-born | %home %herm)
=? ..on-load (lte hood-version %12)
=> (se-born | %home %contact-push-hook)
=> (se-born | %home %contact-pull-hook)
(se-born | %home %group-view)
..on-load
::
++ reap-phat :: ack connect

15
pkg/arvo/lib/metadata-store.hoon
View File

@ -7,6 +7,14 @@
++ enjs
=, enjs:format
|%
::
++ initial-group
|= [group=resource assocs=^associations]
%- pairs
:~ group+s+(enjs-path:resource group)
associations+(associations assocs)
==
::
++ associations
|= =^associations
=, enjs:format
@ -49,7 +57,7 @@
^- json
%+ frond %metadata-update
%- pairs
:~ ?+ -.upd *[cord json]
:~ ?- -.upd
%add
:- %add
%- pairs
@ -77,6 +85,9 @@
::
%associations
[%associations (associations associations.upd)]
::
%initial-group
[%initial-group (initial-group +.upd)]
::
== ==
::
@ -110,7 +121,7 @@
::
++ initial-group
|= json
[%initial-group *resource *associations]
[*resource *associations]
::
++ add
%- ot

27
pkg/arvo/lib/push-hook.hoon
View File

@ -386,18 +386,17 @@
[%give %fact paths update-mark.config vase]~
::
++ forward-update
|= =vase
|= update=vase
^- (list card:agent:gall)
=/ rid=(unit resource)
(resource-for-update vase)
?~ rid ~
=/ rid=resource
(need (resource-for-update update))
=/ =path
resource+(en-path:resource u.rid)
resource+(en-path:resource rid)
=/ =wire
(make-wire resource+(en-path:resource u.rid))
(make-wire resource+(en-path:resource rid))
=/ dap=term
?:(=(our.bowl entity.u.rid) store-name.config dap.bowl)
[%pass wire %agent [entity.u.rid dap] %poke update-mark.config vase]~
?:(=(our.bowl entity.rid) store-name.config dap.bowl)
[%pass wire %agent [entity.rid dap] %poke update-mark.config update]~
::
++ get-conversion
.^ tube:clay
@ -407,11 +406,13 @@
::
++ resource-for-update
|= update=vase
=/ =tube:clay
get-conversion
%+ bind
(mole |.((tube update)))
|=(=vase !<(resource vase))
^- (unit resource)
=/ converted=(each vase (list tank))
(mule |.((get-conversion update)))
?: ?=(%| -.converted)
%- (slog p.converted)
~
[~ !<(resource p.converted)]
::
++ build-mark
|= rav=?(%sing %next)

10
pkg/arvo/mar/contact-hook-action.hoon
View File

@ -1,10 +0,0 @@
/- *contact-hook
|_ act=contact-hook-action
++ grab |%
++ noun contact-hook-action
--
++ grow |%
++ noun act
--
++ grad %noun
--

15
pkg/arvo/mar/contact/action.hoon
View File

@ -1,15 +0,0 @@
/+ *contact-json
|_ act=contact-action
++ grad %noun
++ grow
|%
++ noun act
--
++ grab
|%
++ noun contact-action
++ json
|= jon=^json
(json-to-action jon)
--
--

15
pkg/arvo/mar/contact/hook-update.hoon
View File

@ -1,15 +0,0 @@
/+ *contact-json
|_ upd=contact-hook-update
++ grad %noun
++ grow
|%
++ noun upd
++ json (hook-update-to-json upd)
--
::
++ grab
|%
++ noun contact-hook-update
--
::
--

16
pkg/arvo/mar/contact/initial.hoon
View File

@ -1,16 +0,0 @@
/+ *contact-json
|_ rolo=rolodex
::
++ grad %noun
++ grow
|%
++ noun +<.grow
++ json (rolodex-to-json rolo)
--
::
++ grab
|%
++ noun rolodex
--
::
--

27
pkg/arvo/mar/contact/update.hoon
View File

@ -1,15 +1,32 @@
/+ *contact-json
|_ upd=contact-update
/+ *contact-store
::
|_ upd=update
++ grad %noun
++ grow
|%
++ noun upd
++ json (update-to-json upd)
++ json (update:enjs upd)
++ resource
|^
?- -.upd
%initial [nobody %contacts]
%add [nobody %contacts]
%remove [nobody %contacts]
%edit [nobody %contacts]
%allow !!
%disallow !!
%set-public !!
==
::
++ nobody
^- @p
(bex 128)
--
--
::
++ grab
|%
++ noun contact-update
++ noun update
++ json update:dejs
--
::
--

12
pkg/arvo/mar/contact/view-action.hoon
View File

@ -1,12 +0,0 @@
/- *contact-view
|_ act=contact-view-action
++ grad %noun
++ grow
|%
++ noun act
--
++ grab
|%
++ noun contact-view-action
--
--

13
pkg/arvo/mar/group/view-action.hoon Normal file
View File

@ -0,0 +1,13 @@
/+ view=group-view
|_ =action:view
++ grad %noun
++ grow
|%
++ noun action
--
++ grab
|%
++ noun action:view
++ json action:dejs:view
--
--

13
pkg/arvo/mar/group/view-update.hoon Normal file
View File

@ -0,0 +1,13 @@
/+ view=group-view
|_ =update:view
++ grad %noun
++ grow
|%
++ noun update
++ json (update:enjs:view update)
--
++ grab
|%
++ noun update:view
--
--

18
pkg/arvo/sur/contact-hook.hoon
View File

@ -1,18 +0,0 @@
|%
+$ contact-hook-action
$% :: %add-owned: make a contacts list accessible to foreign ships
:: who are members of that list
::
[%add-owned =path]
:: %add-synced: mirror a foreign contacts list to our contact-store
::
[%add-synced =ship =path]
:: %remove: stop mirroring a foreign contacts list or stop allowing
:: a local contacts list to be mirrored
::
[%remove =path]
==
::
+$ synced (map path ship)
+$ contact-hook-update [%initial =synced]
--

53
pkg/arvo/sur/contact-store.hoon
View File

@ -1,43 +1,40 @@
/- *identity
/- *resource
|%
+$ rolodex (map path contacts)
+$ contacts (map ship contact)
+$ avatar
$% [%octt content-type=@t octs=[p=@ud q=@t]]
[%url url=@t]
==
::
+$ rolodex (map ship contact)
+$ contact
$: nickname=@t
email=@t
phone=@t
website=@t
notes=@t
bio=@t
status=@t
color=@ux
avatar=(unit avatar)
avatar=(unit @t)
cover=(unit @t)
groups=(set resource)
last-updated=@da
==
::
+$ edit-field
$% [%nickname nickname=@t]
[%email email=@t]
[%phone phone=@t]
[%website website=@t]
[%notes notes=@t]
[%bio bio=@t]
[%status status=@t]
[%color color=@ux]
[%avatar avatar=(unit avatar)]
[%avatar avatar=(unit @t)]
[%add-group =resource]
[%remove-group =resource]
[%cover cover=(unit @t)]
==
::
+$ contact-action
$% [%create =path]
[%delete =path]
[%add =path =ship =contact]
[%remove =path =ship]
[%edit =path =ship =edit-field]
+$ beings
$% [%ships ships=(set ship)]
[%group =resource]
==
::
+$ contact-update
$% [%initial =rolodex]
[%contacts =path =contacts]
contact-action
+$ update
$% [%initial =rolodex is-public=?]
[%add =ship =contact]
[%remove =ship]
[%edit =ship =edit-field]
[%allow =beings]
[%disallow =beings]
[%set-public public=?]
==
--

27
pkg/arvo/sur/contact-view.hoon
View File

@ -1,27 +0,0 @@
/- *contact-store, *group, *resource
::
|%
+$ contact-view-action
$% :: %create: create in both groups and contacts
::
[%create name=term =policy title=@t description=@t]
:: %join: join open group in both groups and contacts
::
[%join =resource]
:: %invite: invite to invite-only group and contacts
::
[%invite =resource =ship text=cord]
:: %remove: remove from both groups and contacts
::
[%remove =path =ship]
:: %delete: delete in both groups and contacts
::
[%delete =path]
:: %share: send %add contact-action to to recipient's contact-hook
::
[%share recipient=ship =path =ship =contact]
:: %groupify: create contacts object for a preexisting group
::
[%groupify =resource title=@t description=@t]
==
--

25
pkg/arvo/sur/group-view.hoon Normal file
View File

@ -0,0 +1,25 @@
/- *resource, *group
^?
|%
::
+$ action
$% :: host side
[%create name=term =policy title=@t description=@t]
[%remove =resource]
:: client side
[%join =resource =ship]
[%leave =resource]
==
::
+$ progress
?(%start %added final)
::
+$ final
?(%no-perms %strange %done)
::
+$ update
$% [%initial initial=(map resource progress)]
[%progress =resource =progress]
==
--

40
pkg/arvo/ted/graph/create.hoon
View File

@ -1,9 +1,10 @@
/- spider,
graph=graph-store,
*metadata-store,
met=metadata-store,
*group,
group-store,
inv=invite-store
inv=invite-store,
push-hook
/+ strandio, resource, graph-view
=>
|%
@ -16,13 +17,22 @@
=/ m (strand ,resource)
?: ?=(%group -.associated)
(pure:m rid.associated)
=/ =action:group-store
[%add-group rid policy.associated %&]
;< ~ bind:m (poke-our %group-store %group-action !>(action))
;< =bowl:spider bind:m get-bowl:strandio
;< ~ bind:m (poke-our %group-store %group-action !>([%add-members rid (sy our.bowl ~)]))
=/ push-hook-act=cage
:- %push-hook-action
!> ^- action:push-hook
[%add rid]
;< ~ bind:m
(poke-our %metadata-push-hook push-hook-act)
;< ~ bind:m
(poke-our %group-push-hook %push-hook-action !>([%add rid]))
%+ poke-our %group-store
:- %group-update
!> ^- update:group-store
[%add-group rid policy.associated %.y]
;< =bowl:spider bind:m get-bowl:strandio
;< ~ bind:m
(poke-our %group-store group-update+!>([%add-members rid (sy our.bowl ~)]))
;< ~ bind:m
(poke-our %group-push-hook push-hook-act)
(pure:m rid)
--
::
@ -52,13 +62,11 @@
::
;< group=resource bind:m
(handle-group rid.action associated.action)
=/ group-path=path
(en-path:resource group)
::
:: Setup metadata
::
=/ =metadata
%* . *metadata
=/ =metadatum:met
%* . *metadatum:met
title title.action
description description.action
date-created now.bowl
@ -66,12 +74,10 @@
module module.action
preview %.n
==
=/ =metadata-action
[%add group graph+rid.action metadata]
=/ met-action=action:met
[%add group graph+rid.action metadatum]
;< ~ bind:m
(poke-our %metadata-push-hook %metadata-update !>(metadata-action))
;< ~ bind:m
(poke-our %metadata-push-hook %push-hook-action !>([%add group]))
(poke-our %metadata-push-hook metadata-update+!>(met-action))
::
:: Send invites
::

46
pkg/arvo/ted/graph/delete.hoon
View File

@ -1,4 +1,4 @@
/- spider, graph-view, graph=graph-store, *metadata-store, *group, group-store
/- spider, graph-view, graph=graph-store, metadata=metadata-store, *group, group-store
/+ strandio, resource
=>
|%
@ -8,17 +8,15 @@
::
++ scry-metadata
|= rid=resource
=/ m (strand ,(unit resource))
;< paxs=(unit (set path)) bind:m
%+ scry:strandio ,(unit (set path))
=/ m (strand ,resource)
;< group=(unit resource) bind:m
%+ scry:strandio ,(unit resource)
;: weld
/gx/metadata-store/resource/graph
(en-path:resource rid)
/noun
==
?~ paxs (pure:m ~)
?~ u.paxs (pure:m ~)
(pure:m `(de-path:resource n.u.paxs))
(pure:m (need group))
::
++ scry-group
|= rid=resource
@ -42,11 +40,10 @@
;< ~ bind:m
(poke-our %graph-push-hook %push-hook-action !>([%remove rid]))
;< ~ bind:m
%+ poke-our %metadata-hook
:- %metadata-action
!> :+ %remove
(en-path:resource group-rid)
[%graph (en-path:resource rid)]
%+ poke-our %metadata-push-hook
:- %metadata-update
!> ^- action:metadata
[%remove group-rid [%graph rid]]
(pure:m ~)
::
++ delete-tags
@ -54,8 +51,7 @@
=/ m (strand ,~)
^- form:m
=/ tags=(list [=tag tagged=(set ship)])
%+ skim ~(tap by tags.group)
|= [=tag tagged=(set ship)]
%+ skim ~(tap by tags.group) |= [=tag tagged=(set ship)]
?@ tag %.n
?& =(app.tag %graph)
=(resource.tag graph)
@ -81,23 +77,17 @@
;< =bowl:spider bind:m get-bowl:strandio
?. =(our.bowl entity.rid.action)
(strand-fail:strandio %bad-request ~)
;< ugroup-rid=(unit resource) bind:m
;< group-rid=resource bind:m
(scry-metadata rid.action)
?~ ugroup-rid !!
;< =group bind:m
(scry-group u.ugroup-rid)
(scry-group group-rid)
;< ~ bind:m
(delete-tags rid.action u.ugroup-rid group)
(delete-tags rid.action group-rid group)
;< ~ bind:m
(delete-graph group-rid rid.action)
?. hidden.group
;< ~ bind:m
(delete-graph u.ugroup-rid rid.action)
(pure:m !>(~))
;< ~ bind:m
(poke-our %group-store %group-action !>([%remove-group rid.action ~]))
;< ~ bind:m
(poke-our %group-push-hook %push-hook-action !>([%remove rid.action]))
;< ~ bind:m (delete-graph u.ugroup-rid rid.action)
;< ~ bind:m
%+ poke-our %metadata-hook
metadata-hook-action+!>([%remove (en-path:resource u.ugroup-rid)])
;< =thread-result:strandio bind:m
(await-thread:strandio %group-delete !>(`[%remove rid.action]))
(pure:m !>(~))

66
pkg/arvo/ted/graph/join.hoon
View File

@ -19,42 +19,6 @@
/noun
==
(pure:m res)
::
++ wait-for-group-join
|= rid=resource
=/ m (strand ,~)
^- form:m
=/ pax
(en-path:resource rid)
=/ hold=@dr ~s0..8000
|- ^- form:m
?> (lte hold ~m5)
=* loop $
;< u-group=(unit group) bind:m
(scry:strandio ,(unit group) (weld /gx/group-store/groups (snoc pax %noun)))
?^ u-group
(pure:m ~)
;< ~ bind:m (sleep:strandio hold)
=. hold (mul hold 2)
loop
::
++ wait-for-md
|= rid=resource
=/ m (strand ,~)
^- form:m
=/ pax
(en-path:resource rid)
=/ hold=@dr ~s0..8000
|- ^- form:m
?> (lte hold ~m5)
=* loop $
;< groups=(jug path md-resource) bind:m
(scry:strandio ,(jug path md-resource) /gy/metadata-store/group-indices)
?: (~(has by groups) pax)
(pure:m ~)
;< ~ bind:m (sleep:strandio hold)
=. hold (mul hold 2)
loop
--
::
^- thread:spider
@ -67,30 +31,10 @@
?: =(our.bowl entity.rid.action)
(fail %bad-request ~)
;< group=(unit resource) bind:m (scry-metadata rid.action)
?^ group
:: We have group, graph is managed
;< ~ bind:m
%+ poke-our %graph-pull-hook
pull-hook-action+!>([%add ship.action rid.action])
(pure:m !>(~))
:: Else, add group then join
?> ?=(^ group)
:: We have group, graph is managed
;< ~ bind:m
%+ (map-err:strandio ,~) |=(* [%forbidden ~])
%+ poke
[ship.action %group-push-hook]
group-update+!>([%add-members rid.action (sy our.bowl ~)])
::
;< ~ bind:m
%+ poke-our %group-pull-hook
pull-hook-action+!>([%add ship.action rid.action])
;< ~ bind:m (wait-for-group-join rid.action)
::
;< ~ bind:m
%+ poke-our %metadata-pull-hook
pull-hook-action+!>([%add ship.action rid.action])::
;< ~ bind:m (wait-for-md rid.action)
::
;< ~ bind:m
%+ poke-our %graph-pull-hook
pull-hook-action+!>([%add ship.action rid.action])
%+ poke-our %graph-pull-hook
pull-hook-action+!>([%add ship.action rid.action])
(pure:m !>(~))

28
pkg/arvo/ted/graph/leave.hoon
View File

@ -10,16 +10,14 @@
|= rid=resource
=/ m (strand ,resource)
^- form:m
;< pax=(unit (set path)) bind:m
%+ scry:strandio ,(unit (set path))
;< group=(unit resource) bind:m
%+ scry:strandio ,(unit resource)
;: weld
/gx/metadata-store/resource/graph
(en-path:resource rid)
/noun
==
?> ?=(^ pax)
?> ?=(^ u.pax)
(pure:m (de-path:resource n.u.pax))
(pure:m (need group))
::
++ scry-group
|= rid=resource
@ -56,21 +54,9 @@
(strand-fail:strandio %bad-request ~)
;< group-rid=resource bind:m (scry-metadata rid.action)
;< g=group bind:m (scry-group group-rid)
?. hidden.g
;< ~ bind:m (delete-graph now.bowl rid.action)
(pure:m !>(~))
;< ~ bind:m
%+ poke-our %metadata-hook
metadata-hook-action+!>([%remove (en-path:resource rid.action)])
;< ~ bind:m
%+ poke-our %metadata-store
:- %metadata-action
!> :+ %remove
(en-path:resource rid.action)
[%graph (en-path:resource rid.action)]
;< ~ bind:m
(poke-our %group-store %group-action !>([%remove-group rid.action ~]))
;< ~ bind:m
(poke-our %group-pull-hook %pull-hook-action !>([%remove rid.action]))
;< ~ bind:m (delete-graph now.bowl rid.action)
?. hidden.g
(pure:m !>(~))
;< =thread-result:strandio bind:m
(await-thread:strandio %group-leave !>([~ [%leave rid.action]]))
(pure:m !>(~))

50
pkg/arvo/ted/group/create.hoon Normal file
View File

@ -0,0 +1,50 @@
/- spider,
metadata=metadata-store,
*group,
inv=invite-store,
store=group-store,
push-hook
/+ strandio, resource, view=group-view
=>
|%
++ strand strand:spider
++ poke poke:strandio
++ poke-our poke-our:strandio
--
^- thread:spider
|= arg=vase
=/ m (strand ,vase)
^- form:m
=+ !<([~ =action:view] arg)
?> ?=(%create -.action)
?> ((sane %tas) name.action)
;< =bowl:spider bind:m get-bowl:strandio
:: Add graph to graph-store
::
=/ rid=resource
[our.bowl name.action]
=/ group-act=action:store
[%add-group rid policy.action %.n]
;< ~ bind:m (poke-our %group-store %group-action !>(group-act))
;< =bowl:spider bind:m get-bowl:strandio
;< ~ bind:m (poke-our %group-store %group-action !>([%add-members rid (sy our.bowl ~)]))
=/ push-hook-act=cage
:- %push-hook-action
!> ^- action:push-hook
[%add rid]
;< ~ bind:m
(poke-our %group-push-hook push-hook-act)
=/ =metadatum:metadata
%* . *metadatum:metadata
title title.action
description description.action
date-created now.bowl
creator our.bowl
==
=/ met-action=action:metadata
[%add rid groups+rid metadatum]
;< ~ bind:m (poke-our %metadata-store %metadata-action !>(met-action))
;< ~ bind:m (poke-our %metadata-push-hook push-hook-act)
(pure:m !>(~))

30
pkg/arvo/ted/group/delete.hoon Normal file
View File

@ -0,0 +1,30 @@
/- spider,
metadata=metadata-store,
*group,
inv=invite-store,
store=group-store,
push-hook
/+ strandio, resource, view=group-view
=>
|%
++ strand strand:spider
++ poke poke:strandio
++ poke-our poke-our:strandio
--
^- thread:spider
|= arg=vase
=/ m (strand ,vase)
=+ !<([~ =action:view] arg)
?> ?=(%remove -.action)
=* rid resource.action
;< =bowl:spider bind:m get-bowl:strandio
?> =(our.bowl entity.rid)
=/ push-hook-act=cage
:- %push-hook-action
!> ^- action:push-hook
[%remove resource.action]
;< ~ bind:m (cleanup-md:view rid)
;< ~ bind:m (poke-our %group-store %group-update !>([%remove-group rid ~]))
;< ~ bind:m (poke-our %metadata-push-hook push-hook-act)
;< ~ bind:m (poke-our %group-push-hook push-hook-act)
(pure:m !>(~))

29
pkg/arvo/ted/group/leave.hoon Normal file
View File

@ -0,0 +1,29 @@
/- spider,
metadata=metadata-store,
*group,
inv=invite-store,
store=group-store,
pull-hook
/+ strandio, resource, view=group-view
=>
|%
++ strand strand:spider
++ poke poke:strandio
++ poke-our poke-our:strandio
--
^- thread:spider
|= arg=vase
=/ m (strand ,vase)
=+ !<([~ =action:view] arg)
?> ?=(%leave -.action)
;< =bowl:spider bind:m get-bowl:strandio
=* rid resource.action
=/ pull-hook-act=cage
:- %pull-hook-action
!> ^- action:pull-hook
[%remove rid]
;< ~ bind:m (poke-our %metadata-pull-hook pull-hook-act)
;< ~ bind:m (poke-our %group-pull-hook pull-hook-act)
;< ~ bind:m (poke-our %group-store %group-update !>([%remove-group rid ~]))
;< ~ bind:m (cleanup-md:view rid)
(pure:m !>(~))

21
pkg/arvo/ted/group/on-leave.hoon
View File

@ -1,4 +1,4 @@
/- spider, grp=group-store, gra=graph-store, met=metadata-store, con=contact-store
/- spider, grp=group-store, gra=graph-store, met=metadata-store
/+ strandio, res=resource
::
=* strand strand:spider
@ -34,21 +34,6 @@
[our.bowl %group-pull-hook]
:- %pull-hook-action
!>([%remove resource.update])
:: stop serving or syncing contacts associated with group
::
;< ~ bind:m
%+ raw-poke
[our.bowl %contact-hook]
:- %contact-hook-action
!>([%remove (en-path:res resource.update)])
:: remove contact data associated with group
::
;< ~ bind:m
%+ raw-poke
[our.bowl %contact-store]
:- %contact-action
!> ^- contact-action:con
[%delete (en-path:res resource.update)]
:: stop serving or syncing metadata associated with group
::
;< ~ bind:m
@ -65,7 +50,7 @@
(en-path:res resource.update)
/noun
==
=/ entries=(list [m=md-resource:met g=resource:res =metadata:met])
=/ entries=(list [m=md-resource:met g=resource:res *])
~(tap by associations)
|- ^- form:m
=* loop $
@ -77,7 +62,7 @@
%+ raw-poke
[our.bowl %metadata-store]
:- %metadata-action
!> ^- metadata-action:met
!> ^- action:met
[%remove g.i.entries m.i.entries]
:: archive graph associated with group
::

34
pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs
View File

@ -12,6 +12,7 @@
-}
module Urbit.Arvo.Common
( KingId(..), ServId(..)
, Vere(..), Wynn(..)
, Json, JsonNode(..)
, Desk(..), Mime(..)
, Port(..), Turf(..)
@ -21,9 +22,10 @@ module Urbit.Arvo.Common
, AmesDest, Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
) where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Control.Monad.Fail (fail)
import Data.Bits
import qualified Network.HTTP.Types.Method as H
import qualified Urbit.Ob as Ob
@ -45,6 +47,25 @@ newtype KingId = KingId { unKingId :: UV }
newtype ServId = ServId { unServId :: UV }
deriving newtype (Eq, Ord, Show, Num, Enum, Integral, Real, FromNoun, ToNoun)
-- Arvo Version Negotiation ----------------------------------------------------
-- Information about the king runtime passed to Arvo.
data Vere = Vere { vereName :: Term,
vereRev :: [Cord],
vereWynn :: Wynn }
deriving (Eq, Ord, Show)
instance ToNoun Vere where
toNoun Vere{..} = toNoun ((vereName, vereRev), vereWynn)
instance FromNoun Vere where
parseNoun n = named "Vere" $ do
((vereName, vereRev), vereWynn) <- parseNoun n
pure $ Vere {..}
-- A list of names and their kelvin numbers, used in version negotiations.
newtype Wynn = Wynn { unWynn :: [(Term, Word)] }
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
-- Http Common -----------------------------------------------------------------
@ -112,7 +133,7 @@ deriveNoun ''HttpServerConf
-- Desk and Mime ---------------------------------------------------------------
newtype Desk = Desk { unDesk :: Cord }
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun, IsString)
data Mime = Mime Path File
deriving (Eq, Ord, Show)
@ -146,7 +167,14 @@ newtype Port = Port { unPort :: Word16 }
-- @if
newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
instance Show Ipv4 where
show (Ipv4 i) =
show ((shiftL i 24) .&. 0xff) ++ "." ++
show ((shiftL i 16) .&. 0xff) ++ "." ++
show ((shiftL i 8) .&. 0xff) ++ "." ++
show (i .&. 0xff)
-- @is
newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }

18
pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs
View File

@ -18,7 +18,7 @@ import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
import Urbit.Arvo.Common (AmesDest, Turf)
import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
import Urbit.Arvo.Common (Desk)
import Urbit.Arvo.Common (Desk, Wynn)
-- Newt Effects ----------------------------------------------------------------
@ -259,20 +259,32 @@ data Ef
= EfVane VaneEf
| EfVega Cord EvilPath -- second path component, rest of path
| EfExit Cord EvilPath -- second path component, rest of path
| EfWend Wynn
deriving (Eq, Ord, Show)
-- XX HACK
clip :: Noun -> Noun
clip (C (C _ x) y) = C x y
clip _ = error "misclip"
tack :: Noun -> Noun
tack (C x y) = C (C (A 0) x) y
tack _ = error "mistack"
instance ToNoun Ef where
toNoun = \case
toNoun = clip . \case
EfVane v -> toNoun $ reorgThroughNoun ("", v)
EfExit s p -> toNoun $ ReOrg "" s "exit" p (A 0)
EfVega s p -> toNoun $ ReOrg "" s "vega" p (A 0)
EfWend w -> toNoun $ reorgThroughNoun ("", w)
instance FromNoun Ef where
parseNoun = parseNoun >=> \case
parseNoun = tack >>> parseNoun >=> \case
ReOrg "" s "exit" p (A 0) -> pure (EfExit s p)
ReOrg "" s "exit" p _ -> fail "%exit effect expects nil value"
ReOrg "" s "vega" p (A 0) -> pure (EfVega s p)
ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value"
ReOrg "" s "wend" p val -> EfWend <$> parseNoun val
ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
ReOrg _ _ _ _ _ -> fail "Non-empty first path-element"

59
pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
View File

@ -9,10 +9,10 @@
-}
module Urbit.Arvo.Event where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Control.Monad.Fail (fail)
import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (KingId(..), ServId(..), Vere(..))
import Urbit.Arvo.Common (Desk, Mime)
import Urbit.Arvo.Common (Header(..), HttpEvent)
import Urbit.Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
@ -218,9 +218,12 @@ instance Show Entropy where
data ArvoEv
= ArvoEvWhom () Ship
| ArvoEvWack () Entropy
| ArvoEvWarn Path Noun
| ArvoEvWyrd () Vere
| ArvoEvCrud Path Noun
| ArvoEvVeer Atom Noun
| ArvoEvTrim UD
| ArvoEvWhat [Noun]
| ArvoEvWhey ()
| ArvoEvVerb (Maybe Bool)
deriving (Eq, Ord, Show)
deriveNoun ''ArvoEv
@ -318,50 +321,29 @@ data BlipEv
deriveNoun ''BlipEv
-- Boot Events -----------------------------------------------------------------
data Vane
= VaneVane VaneEv
| VaneZuse ZuseEv
deriving (Eq, Ord, Show)
data VaneName
= Ames | Behn | Clay | Dill | Eyre | Ford | Gall | Iris | Jael
deriving (Eq, Ord, Show, Enum, Bounded)
data ZuseEv
= ZEVeer () Cord Path BigCord
| ZEVoid Void
deriving (Eq, Ord, Show)
data VaneEv
= VEVeer (VaneName, ()) Cord Path BigCord
| VEVoid Void
deriving (Eq, Ord, Show)
deriveNoun ''Vane
deriveNoun ''VaneName
deriveNoun ''VaneEv
deriveNoun ''ZuseEv
-- The Main Event Type ---------------------------------------------------------
data Ev
= EvBlip BlipEv
| EvVane Vane
deriving (Eq, Show)
instance ToNoun Ev where
toNoun = \case
EvBlip v -> toNoun $ reorgThroughNoun (Cord "", v)
EvVane v -> toNoun $ reorgThroughNoun (Cord "vane", v)
toNoun = toNoun . \case
EvBlip v@BlipEvAmes{} -> reorgThroughNoun ("ames", v)
EvBlip v@BlipEvArvo{} -> reorgThroughNoun ("", v)
EvBlip v@BlipEvBehn{} -> reorgThroughNoun ("behn", v)
EvBlip v@BlipEvBoat{} -> reorgThroughNoun ("clay", v)
EvBlip v@BlipEvHttpClient{} -> reorgThroughNoun ("iris", v)
EvBlip v@BlipEvHttpServer{} -> reorgThroughNoun ("eyre", v)
EvBlip v@BlipEvNewt{} -> reorgThroughNoun ("ames", v)
EvBlip v@BlipEvSync{} -> reorgThroughNoun ("clay", v)
EvBlip v@BlipEvTerm{} -> reorgThroughNoun ("dill", v)
-- XX We really should check the first path element, but since this is used only
-- in the event browser, which otherwise is broken, I don't care right now.
instance FromNoun Ev where
parseNoun = parseNoun >=> \case
ReOrg "" s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
ReOrg _ s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
-- Short Event Names -----------------------------------------------------------
@ -373,7 +355,6 @@ instance FromNoun Ev where
-}
getSpinnerNameForEvent :: Ev -> Maybe Text
getSpinnerNameForEvent = \case
EvVane _ -> Nothing
EvBlip b -> case b of
BlipEvAmes _ -> Just "ames"
BlipEvArvo _ -> Just "arvo"

21
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -4,6 +4,7 @@
module Urbit.King.App
( KingEnv
, runKingEnvStderr
, runKingEnvStderrRaw
, runKingEnvLogFile
, runKingEnvNoLog
, kingEnvKillSignal
@ -29,6 +30,7 @@ where
import Urbit.King.Config
import Urbit.Prelude
import RIO (logGeneric)
import System.Directory ( createDirectoryIfMissing
, getXdgDirectory
, XdgDirectory(XdgCache)
@ -90,6 +92,22 @@ runKingEnvStderr verb lvl inner = do
<&> setLogMinLevel lvl
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
runKingEnvStderrRaw :: Bool -> LogLevel -> RIO KingEnv a -> IO a
runKingEnvStderrRaw verb lvl inner = do
logOptions <-
logOptionsHandle stderr verb
<&> setLogUseTime True
<&> setLogUseLoc False
<&> setLogMinLevel lvl
withLogFunc logOptions $ \logFunc ->
let lf = wrapCarriage logFunc
in runKingEnv lf lf inner
-- XX loses callstack
wrapCarriage :: LogFunc -> LogFunc
wrapCarriage lf = mkLogFunc $ \_ ls ll bldr ->
runRIO lf $ logGeneric ls ll (bldr <> "\r")
runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a
runKingEnvLogFile verb lvl fileM inner = do
logFile <- case fileM of
@ -119,7 +137,8 @@ defaultLogFile :: IO FilePath
defaultLogFile = do
logDir <- getXdgDirectory XdgCache "urbit"
createDirectoryIfMissing True logDir
pure (logDir </> "king.log")
logId :: Word32 <- randomIO
pure (logDir </> "king-" <> show logId <> ".log")
runKingEnvNoLog :: RIO KingEnv a -> IO a
runKingEnvNoLog act = runKingEnv mempty mempty act

7
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -382,7 +382,7 @@ replayPartEvs top last = do
{-|
Interesting
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill :: HasKingEnv e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
logInfo "Reading pill file."
pillBytes <- readFile pax
@ -678,10 +678,13 @@ main = do
runKingEnv args log =
let
verb = verboseLogging args
runStderr = case args of
CLI.CmdRun {} -> runKingEnvStderrRaw
_ -> runKingEnvStderr
CLI.Log {..} = log
in case logTarget lTarget args of
CLI.LogFile f -> runKingEnvLogFile verb lLevel f
CLI.LogStderr -> runKingEnvStderr verb lLevel
CLI.LogStderr -> runStderr verb lLevel
CLI.LogOff -> runKingEnvNoLog
setupSignalHandlers = do

36
pkg/hs/urbit-king/lib/Urbit/King/Scry.hs
View File

@ -2,30 +2,32 @@
Scry helpers
-}
module Urbit.King.Scry (scryNow) where
module Urbit.King.Scry
( scryNow
, module Urbit.Vere.Pier.Types
)
where
import Urbit.Prelude
import Urbit.Vere.Serf.Types
import qualified Urbit.Noun.Time as Time
import Urbit.Arvo.Common (Desk)
import Urbit.Vere.Pier.Types (ScryFunc)
scryNow :: forall e n
. (HasLogFunc e, FromNoun n)
=> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> Text -- ^ vane + care as two-letter string
-> Ship -- ^ ship in scry path, usually the local ship
-> Text -- ^ desk in scry path
=> ScryFunc
-> Term -- ^ vane + care as two-letter string
-> Desk -- ^ desk in scry path
-> [Text] -- ^ resource path to scry for
-> RIO e (Maybe n)
scryNow scry vare ship desk path = do
env <- ask
wen <- io Time.now
let wan = tshow $ Time.MkDate wen
let pax = Path $ fmap MkKnot $ vare : (tshow ship) : desk : wan : path
io (scry wen Nothing pax) >>= \case
Just (_, fromNoun @n -> Just v) -> pure $ Just v
Just (_, n) -> do
logError $ displayShow ("uncanny scry result", vare, pax, n)
pure Nothing
Nothing -> pure Nothing
scryNow scry vare desk path =
io (scry Nothing (EachNo $ DemiOnce vare desk (Path $ MkKnot <$> path)))
>>= \case
Just ("omen", fromNoun @(Path, Term, n) -> Just (_,_,v)) -> pure $ Just v
Just (_, fromNoun @n -> Just v) -> pure $ Just v
Just (_, n) -> do
logError $ displayShow ("uncanny scry result", vare, path, n)
pure Nothing
Nothing -> pure Nothing

6
pkg/hs/urbit-king/lib/Urbit/Prelude.hs
View File

@ -16,6 +16,7 @@ module Urbit.Prelude
, io, rio
, logTrace
, acquireWorker, acquireWorkerBound
, hark
) where
import ClassyPrelude
@ -38,6 +39,8 @@ import RIO (HasLogFunc, LogFunc, LogLevel(..), logDebug, logError, logFuncL,
logInfo, logOptionsHandle, logOther, logWarn, mkLogFunc,
setLogMinLevel, setLogUseLoc, setLogUseTime, withLogFunc)
import qualified RIO
io :: MonadIO m => IO a -> m a
io = liftIO
@ -47,6 +50,9 @@ rio = liftRIO
logTrace :: HasLogFunc e => Utf8Builder -> RIO e ()
logTrace = logOther "trace"
-- | Composes a log message out of textual components.
hark :: [Text] -> Utf8Builder
hark = RIO.displayBytesUtf8 . foldMap encodeUtf8
-- Utils for Spawning Worker Threads -------------------------------------------

86
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs
View File

@ -24,8 +24,7 @@ import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
import qualified Urbit.Noun.Time as Time
import Urbit.Vere.Stat (AmesStat(..), bump, bump')
-- Constants -------------------------------------------------------------------
@ -47,7 +46,6 @@ type Version = Word8
data AmesDrv = AmesDrv
{ aTurfs :: TVar (Maybe [Turf])
, aDropped :: TVar Word
, aVersion :: TVar (Maybe Version)
, aUdpServ :: UdpServ
, aResolvr :: ResolvServ
@ -125,13 +123,14 @@ udpPort isFake who = do
udpServ :: (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e)
=> Bool
-> Ship
-> AmesStat
-> RIO e UdpServ
udpServ isFake who = do
udpServ isFake who stat = do
mode <- netMode isFake
port <- udpPort isFake who
case modeAddress mode of
Nothing -> fakeUdpServ
Just host -> realUdpServ port host
Just host -> realUdpServ port host stat
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
@ -141,10 +140,11 @@ ames'
:: HasPierEnv e
=> Ship
-> Bool
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> AmesStat
-> ScryFunc
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
ames' who isFake scry stderr = do
ames' who isFake stat scry stderr = do
-- Unfortunately, we cannot use TBQueue because the only behavior
-- provided for when full is to block the writer. The implementation
-- below uses materially the same data structures as TBQueue, however.
@ -164,11 +164,11 @@ ames' who isFake scry stderr = do
pure Ouster
dequeuePacket = do
pM <- tryReadTQueue ventQ
when (isJust pM) $ modifyTVar avail (+ 1)
when (isJust pM) $ modifyTVar' avail (+ 1)
pure pM
env <- ask
let (bornEvs, startDriver) = ames env who isFake scry enqueuePacket stderr
let (bornEvs, startDriver) = ames env who isFake stat scry enqueuePacket stderr
let runDriver = do
diOnEffect <- startDriver
@ -195,11 +195,12 @@ ames
=> e
-> Ship
-> Bool
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> AmesStat
-> ScryFunc
-> (EvErr -> STM PacketOutcome)
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (NewtEf -> IO ()))
ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
where
king = fromIntegral (env ^. kingIdL)
@ -218,21 +219,28 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
cachedScryLane <- cache scryLane
aTurfs <- newTVarIO Nothing
aDropped <- newTVarIO 0
aVersion <- newTVarIO Nothing
aVersTid <- trackVersionThread aVersion
aUdpServ <- udpServ isFake who
aUdpServ <- udpServ isFake who stat
aResolvr <- resolvServ aTurfs (usSend aUdpServ) stderr
aRecvTid <- queuePacketsThread
aDropped
aVersion
cachedScryLane
(send aUdpServ aResolvr mode)
aUdpServ
stat
pure (AmesDrv { .. })
hearFailed _ = pure ()
hearFailed AmesStat {..} = runRIO env . \case
RunSwap{} -> bump asSwp
RunBail gs -> do
for gs \(t, es) ->
for es \e ->
logWarn $ hark
["ames: goof: ", unTerm t, ": ", tankToText e]
bump asBal
RunOkay{} -> bump asOky
trackVersionThread :: HasLogFunc e => TVar (Maybe Version) -> RIO e (Async ())
trackVersionThread versSlot = async $ forever do
@ -249,34 +257,43 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
threadDelay (10 * 60 * 1_000_000) -- 10m
queuePacketsThread :: HasLogFunc e
=> TVar Word
-> TVar (Maybe Version)
=> TVar (Maybe Version)
-> (Ship -> RIO e (Maybe [AmesDest]))
-> (AmesDest -> ByteString -> RIO e ())
-> UdpServ
-> AmesStat
-> RIO e (Async ())
queuePacketsThread dropCtr vers lan forward UdpServ{..} = async $ forever $ do
queuePacketsThread vers lan forward UdpServ{..} s@(AmesStat{..}) = async $ forever $ do
-- port number, host address, bytestring
(p, a, b) <- atomically usRecv
(p, a, b) <- atomically (bump' asRcv >> usRecv)
ver <- readTVarIO vers
case decode b of
Right (pkt@Packet {..}) | ver == Nothing || ver == Just pktVersion -> do
logDebug $ displayShow ("ames: bon packet", pkt, showUD $ bytesAtom b)
if pktRcvr == who
then serfsUp p a b
then do
bump asSup
serfsUp p a b
else lan pktRcvr >>= \case
Just ls
| dest:_ <- filter notSelf ls
-> forward dest $ encode pkt
{ pktOrigin = pktOrigin <|> Just (ipDest p a) }
-> do
bump asFwd
forward dest $ encode pkt
{ pktOrigin = pktOrigin
<|> Just (AAIpv4 (Ipv4 a) (fromIntegral p)) }
where
notSelf (EachYes g) = who /= Ship (fromIntegral g)
notSelf (EachNo _) = True
_ -> logInfo $ displayShow ("ames: dropping unroutable", pkt)
Right pkt -> logInfo $ displayShow ("ames: dropping ill-versed", pkt, ver)
_ -> do
bump asDrt
logInfo $ displayShow ("ames: dropping unroutable", pkt)
Right pkt -> do
bump asDvr
logInfo $ displayShow ("ames: dropping ill-versed", pkt, ver)
-- XX better handle misversioned or illegible packets.
-- Remarks from 67f06ce5, pkg/urbit/vere/io/ames.c, L1010:
@ -293,18 +310,19 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
-- trigger printfs suggesting upgrade.
-- they cannot be filtered, as we do not know their semantics
--
Left e -> logInfo $ displayShow ("ames: dropping malformed", e)
Left e -> do
bump asDml
logInfo $ displayShow ("ames: dropping malformed", e)
where
serfsUp p a b =
atomically (enqueueEv (EvErr (hearEv p a b) hearFailed)) >>= \case
Intake -> pure ()
atomically (enqueueEv (EvErr (hearEv p a b) (hearFailed s))) >>= \case
Intake -> bump asSrf
Ouster -> do
d <- atomically $ do
d <- readTVar dropCtr
writeTVar dropCtr (d + 1)
pure d
when (d `rem` packetsDroppedPerComplaint == 0) $
bump' asQuf
readTVar asQuf
when (d `rem` packetsDroppedPerComplaint == 1) $
logWarn "ames: queue full; dropping inbound packets"
stop :: forall e. AmesDrv -> RIO e ()
@ -342,12 +360,12 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
EachNo addr -> to (ipv4Addr addr)
scryVersion :: HasLogFunc e => RIO e (Maybe Version)
scryVersion = scryNow scry "ax" who "" ["protocol", "version"]
scryVersion = scryNow scry "ax" "" ["protocol", "version"]
scryLane :: HasLogFunc e
=> Ship
-> RIO e (Maybe [AmesDest])
scryLane ship = scryNow scry "ax" who "" ["peers", tshow ship, "forward-lane"]
scryLane ship = scryNow scry "ax" "" ["peers", tshow ship, "forward-lane"]
ipv4Addr (Jammed (AAVoid v )) = absurd v
ipv4Addr (Jammed (AAIpv4 a p)) = SockAddrInet (fromIntegral p) (unIpv4 a)

170
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/Packet.hs
View File

@ -9,18 +9,19 @@ import Urbit.Prelude
import Control.Monad.Fail
import Data.Bits
import Data.LargeWord
import Data.List (genericIndex)
import Data.Serialize
import Urbit.Arvo (AmesDest)
import Urbit.Arvo (AmesAddress(..), Ipv4(..), Port(..))
data Packet = Packet
{ pktVersion :: Word8
, pktEncrypted :: Bool
--
, pktSndr :: Ship
, pktRcvr :: Ship
, pktOrigin :: Maybe AmesDest
, pktContent :: Bytes
{ pktVersion :: Word3
, pktSndr :: Ship
, pktRcvr :: Ship
, pktSndrTick :: Word4
, pktRcvrTick :: Word4
, pktOrigin :: Maybe AmesAddress
, pktContent :: ByteString
}
deriving Eq
@ -28,73 +29,140 @@ instance Show Packet where
show Packet {..}
= "Packet {pktVersion = "
<> show pktVersion
<> ", pktEncrypted = "
<> show pktEncrypted
<> ", pktSndr = "
<> show pktSndr
<> ", pktRcvr = "
<> show pktRcvr
<> ", pktSndrTick = "
<> show pktSndrTick
<> ", pktRcvrTick = "
<> show pktRcvrTick
<> ", pktOrigin = "
<> show pktOrigin
<> ", pktContent = "
<> showUD (bytesAtom $ unBytes pktContent)
<> showUD (bytesAtom pktContent)
<> "}"
{-
-- Wire format
data PacketHeader = PacketHeader
{ pktIsAmes :: Bool -- sim_o
, pktVersion :: Word3 -- ver_y
, pktSndrClass :: ShipClass -- sac_y
, pktRcvrClass :: ShipClass -- rac_y
, pktChecksum :: Word20 -- mug_l
, pktIsRelayed :: Bool -- rel_o
}
deriving Eq
data PacketBody = PacketBody
{ pktSndr :: Ship -- sen_d
, pktRcvr :: Ship -- rec_d
, pktSndrTick :: Word4 -- sic_y
, pktRcvrTick :: Word4 -- ric_y
, pktContent :: ByteString -- (con_s, con_y)
, pktOrigin :: Maybe AmesAddress -- rog_d
}
deriving Eq
-}
type Word3 = Word8
type Word4 = Word8
type Word20 = Word32
data ShipClass
= Lord
| Planet
| Moon
| Comet
deriving (Eq, Show)
muk :: ByteString -> Word20
muk bs = mugBS bs .&. (2 ^ 20 - 1)
-- XX check this
getAmesAddress :: Get AmesAddress
getAmesAddress = AAIpv4 <$> (Ipv4 <$> getWord32le) <*> (Port <$> getWord16le)
putAmesAddress :: Putter AmesAddress
putAmesAddress = \case
AAIpv4 (Ipv4 ip) (Port port) -> putWord32le ip >> putWord16le port
instance Serialize Packet where
get = do
-- header
head <- getWord32le
let pktVersion = head .&. 0b111 & fromIntegral
let checksum = shiftR head 3 .&. (2 ^ 20 - 1)
let sndrRank = shiftR head 23 .&. 0b11
let rcvrRank = shiftR head 25 .&. 0b11
let pktEncrypted = testBit head 27 & not -- loobean
-- verify checksum
-- skip first three bits
let isAmes = testBit head 3 & not
let pktVersion = shiftR head 4 .&. 0b111 & fromIntegral
let sndrRank = shiftR head 7 .&. 0b11
let rcvrRank = shiftR head 9 .&. 0b11
let checksum = shiftR head 11 .&. (2 ^ 20 - 1)
let isRelayed = testBit head 31 & not -- loobean
let sndrClass = genericIndex [Lord, Planet, Moon, Comet] sndrRank
let rcvrClass = genericIndex [Lord, Planet, Moon, Comet] rcvrRank
guard isAmes
pktOrigin <- if isRelayed
then Just <$> getAmesAddress
else pure Nothing
-- body
lookAhead $ do
len <- remaining
len <- remaining
body <- getBytes len
let chk = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
let chk = muk body
when (checksum /= chk) $
fail ("checksum mismatch: expected " <> show checksum
<> "; got " <> show chk)
-- body
pktSndr <- getShip sndrRank
pktRcvr <- getShip rcvrRank
len <- remaining
payload <- getBytes len
-- data ("payload")
(pktOrigin, pktContent) <- case cueBS payload of
Left e -> fail (show e)
Right n -> case fromNounErr n of
Left e -> fail (show e)
Right c -> pure c
pure Packet {..}
tick <- getWord8
let pktSndrTick = tick .&. 0b1111
let pktRcvrTick = shiftR tick 4
pktSndr <- getShip sndrClass
pktRcvr <- getShip rcvrClass
len <- remaining
pktContent <- getBytes len
pure Packet{..}
where
getShip = fmap Ship . \case
0 -> fromIntegral <$> getWord16le -- galaxy / star
1 -> fromIntegral <$> getWord32le -- planet
2 -> fromIntegral <$> getWord64le -- moon
3 -> LargeKey <$> getWord64le <*> getWord64le -- comet
_ -> fail "impossibiru"
Lord -> fromIntegral <$> getWord16le
Planet -> fromIntegral <$> getWord32le
Moon -> fromIntegral <$> getWord64le
Comet -> LargeKey <$> getWord64le <*> getWord64le
put Packet {..} = do
let load = jamBS $ toNoun (pktOrigin, pktContent)
put Packet{..} = do
let (sndR, putSndr) = putShipGetRank pktSndr
let (rcvR, putRcvr) = putShipGetRank pktRcvr
let body = runPut (putSndr <> putRcvr <> putByteString load)
let chek = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
let encr = pktEncrypted
let body = runPut $ do
putWord8 $ (pktSndrTick .&. 0b1111)
.|. shiftL (pktRcvrTick .&. 0b1111) 4
putSndr
putRcvr
putByteString pktContent
let vers = fromIntegral pktVersion .&. 0b111
let head = vers
.|. shiftL chek 3
.|. shiftL sndR 23
.|. shiftL rcvR 25
.|. if encr then 0 else bit 27
let chek = muk body
-- skip first 3 bytes, set 4th to yes (0) for "is ames"
let head = shiftL vers 4
.|. shiftL sndR 7
.|. shiftL rcvR 9
.|. shiftL chek 11
.|. if isJust pktOrigin then 0 else bit 31
putWord32le head
putByteString body -- XX can we avoid copy?
case pktOrigin of
Just o -> putAmesAddress o
Nothing -> pure ()
putByteString body
where
putShipGetRank s@(Ship (LargeKey p q)) = case () of
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- gar
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- pan
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- mon
| otherwise -> (3, putWord64le p >> putWord64le q) -- com
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- lord
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- planet
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- moon
| otherwise -> (3, putWord64le p >> putWord64le q) -- comet

9
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs
View File

@ -39,7 +39,7 @@ import Network.Socket
import Control.Monad.STM (retry)
import Network.Socket.ByteString (recvFrom, sendTo)
import Urbit.Vere.Stat (AmesStat(..), bump)
-- Types -----------------------------------------------------------------------
@ -156,8 +156,9 @@ realUdpServ
. (HasLogFunc e, HasPortControlApi e)
=> PortNumber
-> HostAddress
-> AmesStat
-> RIO e UdpServ
realUdpServ por hos = do
realUdpServ por hos sat = do
logInfo $ displayShow ("AMES", "UDP", "Starting real UDP server.")
env <- ask
@ -192,6 +193,7 @@ realUdpServ por hos = do
enqueueRecvPacket p a b = do
did <- atomically (tryWriteTBQueue qRecv (p, a, b))
when (did == False) $ do
bump (asUqf sat)
logWarn $ displayShow $ ("AMES", "UDP",)
"Dropping inbound packet because queue is full."
@ -232,13 +234,16 @@ realUdpServ por hos = do
Just sk -> do
recvPacket sk >>= \case
Left exn -> do
bump (asUdf sat)
logError "AMES: UDP: Failed to receive packet"
signalBrokenSocket sk
Right Nothing -> do
bump (asUi6 sat)
logError "AMES: UDP: Dropping non-ipv4 packet"
pure ()
Right (Just (b, p, a)) -> do
logDebug "AMES: UDP: Received packet."
bump (asUdp sat)
enqueueRecvPacket p a b
let shutdown = do

2
pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs
View File

@ -10,7 +10,7 @@ module Urbit.Vere.Behn (behn, DriverApi(..), behn') where
import Data.Time.Clock.System (SystemTime)
import Urbit.Arvo hiding (Behn)
import Urbit.Arvo
import Urbit.Prelude
import Urbit.Vere.Pier.Types

34
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/KingSubsite.hs
View File

@ -13,16 +13,15 @@ import Urbit.Prelude hiding (Builder)
import Data.ByteString.Builder
import Urbit.King.Scry
import Urbit.Vere.Serf.Types
import Data.Conduit (ConduitT, Flush(..), yield)
import Data.Text.Encoding (encodeUtf8Builder)
import Urbit.Vere.Stat (RenderedStat)
import qualified Data.Text.Encoding as E
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import qualified Network.Wai.Conduit as W
import qualified Urbit.Noun.Time as Time
newtype KingSubsite = KS { runKingSubsite :: W.Application }
@ -43,10 +42,11 @@ streamSlog a = do
kingSubsite :: HasLogFunc e
=> Ship
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> IO RenderedStat
-> TVar ((Atom, Tank) -> IO ())
-> RAcquire e KingSubsite
kingSubsite who scry func = do
kingSubsite who scry stat func = do
clients <- newTVarIO (mempty :: Map Word (SlogAction -> IO ()))
nextId <- newTVarIO (0 :: Word)
baton <- newTMVarIO ()
@ -77,15 +77,29 @@ kingSubsite who scry func = do
else
let loop = yield Flush
>> forever (atomically (readTQueue q) >>= streamSlog)
in respond $ W.responseSource (H.mkStatus 200 "OK") heads loop)
in respond $ W.responseSource (H.mkStatus 200 "OK") slogHeads loop)
["~_~", "stat"] -> do
authed <- authenticated env req
if not authed
then respond $ emptyResponse 403 "Permission Denied"
else do
lines <- stat
let msg = mconcat ((<> "\n") . encodeUtf8Builder <$> lines)
<> "\nRefresh for more current data."
respond $ W.responseBuilder (H.mkStatus 200 "OK") statHeads msg
_ -> respond $ emptyResponse 404 "Not Found"
where
heads = [ ("Content-Type" , "text/event-stream")
, ("Cache-Control", "no-cache")
, ("Connection" , "keep-alive")
]
slogHeads = [ ("Content-Type", "text/event-stream")
, ("Cache-Control", "no-cache")
, ("Connection", "keep-alive")
]
statHeads = [ ("Content-Type", "text/plain")
, ("Cache-Control", "no-cache")
]
emptyResponse cod mes = W.responseLBS (H.mkStatus cod mes) [] ""
@ -102,7 +116,7 @@ kingSubsite who scry func = do
=> Text
-> RIO e (Maybe Bool)
scryAuth cookie =
scryNow scry "ex" who "" ["authenticated", "cookie", textAsTa cookie]
scryNow scry "ex" "" ["authenticated", "cookie", textAsTa cookie]
fourOhFourSubsite :: Ship -> KingSubsite
fourOhFourSubsite who = KS $ \req respond ->

119
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -23,6 +23,7 @@ import RIO.Directory
import Urbit.Arvo
import Urbit.King.App
import Urbit.Vere.Pier.Types
import Urbit.Vere.Stat
import Control.Monad.STM (retry)
import System.Environment (getExecutablePath)
@ -31,11 +32,11 @@ import System.Posix.Files (ownerModes, setFileMode)
import Urbit.EventLog.LMDB (EventLog)
import Urbit.EventLog.Event (buildLogEvent)
import Urbit.King.API (TermConn)
import Urbit.Noun.Time (Wen)
import Urbit.TermSize (TermSize(..), termSize)
import Urbit.Vere.Serf (Serf)
import qualified Data.Text as T
import qualified Data.List as L
import qualified System.Entropy as Ent
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.King.API as King
@ -71,16 +72,22 @@ setupPierDirectory shipPath = do
-- Load pill into boot sequence. -----------------------------------------------
data CannotBootFromIvoryPill = CannotBootFromIvoryPill
deriving (Show, Exception)
genEntropy :: MonadIO m => m Entropy
genEntropy = Entropy . fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
genBootSeq :: MonadIO m => Ship -> Pill -> Bool -> LegacyBootEvent -> m BootSeq
genBootSeq ship Pill {..} lite boot = io $ do
ent <- genEntropy
let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
pure $ BootSeq ident pBootFormulas ovums
genBootSeq :: HasKingEnv e
=> Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
genBootSeq _ PillIvory {} _ _ = throwIO CannotBootFromIvoryPill
genBootSeq ship PillPill {..} lite boot = do
ent <- io genEntropy
wyr <- wyrd
let ova = preKern ent <> [wyr] <> pKernelOva <> postKern <> pUserspaceOva
pure $ BootSeq ident pBootFormulae ova
where
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulae)
preKern ent =
[ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
@ -295,14 +302,18 @@ pier (serf, log) vSlog startedSig injected = do
let execute = writeTQueue executeQ
let persist = writeTQueue persistQ
let sigint = Serf.sendSIGINT serf
let scry = \w b g -> do
let scry = \g r -> do
res <- newEmptyMVar
atomically $ writeTQueue scryQ (w, b, g, putMVar res)
atomically $ writeTQueue scryQ (g, r, putMVar res)
takeMVar res
-- Set up the runtime stat counters.
stat <- newStat
-- Set up the runtime subsite server and its capability to slog
-- and display stats.
siteSlog <- newTVarIO (const $ pure ())
runtimeSubsite <- Site.kingSubsite ship scry siteSlog
runtimeSubsite <- Site.kingSubsite ship scry (renderStat stat) siteSlog
-- Slogs go to stderr, to the runtime subsite, and to the terminal.
env <- ask
@ -311,12 +322,12 @@ pier (serf, log) vSlog startedSig injected = do
io $ readTVarIO siteSlog >>= ($ s)
logOther "serf" (display $ T.strip $ tankToText tank)
let err = atomically . Term.trace muxed . (<> "\r\n")
(bootEvents, startDrivers) <- do
env <- ask
let err = atomically . Term.trace muxed . (<> "\r\n")
siz <- atomically $ Term.curDemuxSize demux
let fak = isFake logId
drivers env ship fak compute scry (siz, muxed) err sigint runtimeSubsite
drivers env ship fak compute scry (siz, muxed) err sigint stat runtimeSubsite
let computeConfig = ComputeConfig { ccOnWork = takeTMVar computeQ
, ccOnKill = onKill
@ -330,6 +341,8 @@ pier (serf, log) vSlog startedSig injected = do
tSerf <- acquireWorker "Serf" (runCompute serf computeConfig)
doVersionNegotiation compute err
-- Run all born events and retry them until they succeed.
wackEv <- EvBlip . BlipEvArvo . ArvoEvWack () <$> genEntropy
rio $ for_ (wackEv : bootEvents) $ \ev -> do
@ -341,7 +354,7 @@ pier (serf, log) vSlog startedSig injected = do
cb :: Int -> WorkError -> IO ()
cb n | n >= 3 = error ("boot event failed: " <> show ev)
cb n = \case
RunOkay _ -> putMVar okaySig ()
RunOkay _ _ -> putMVar okaySig ()
RunSwap _ _ _ _ _ -> putMVar okaySig ()
RunBail _ -> inject (n + 1)
@ -368,7 +381,7 @@ pier (serf, log) vSlog startedSig injected = do
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
cb :: WorkError -> IO ()
cb = \case
RunOkay _ -> putMVar okaySig (Right ())
RunOkay _ _ -> putMVar okaySig (Right ())
RunSwap _ _ _ _ _ -> putMVar okaySig (Right ())
RunBail goofs -> putMVar okaySig (Left goofs)
@ -409,6 +422,68 @@ death tag tid = do
Left exn -> Left (tag, exn)
Right () -> Right tag
-- %wyrd version negotiation ---------------------------------------------------
data PierVersionNegotiationFailed = PierVersionNegotiationFailed
deriving (Show, Exception)
zuseVersion :: Word
zuseVersion = 420
wyrd :: HasKingEnv e => RIO e Ev
wyrd = do
king <- tshow <$> view kingIdL
let k = Wynn [("zuse", zuseVersion),
("lull", 330),
("arvo", 240),
("hoon", 140),
("nock", 4)]
sen = MkTerm king
v = Vere sen [Cord "king-haskell", Cord "1.0"] k
pure $ EvBlip $ BlipEvArvo $ ArvoEvWyrd () v
doVersionNegotiation
:: HasPierEnv e
=> (RunReq -> STM ())
-> (Text -> RIO e ())
-> RAcquire e ()
doVersionNegotiation compute stderr = do
ev <- rio wyrd
okaySig :: MVar (Either [Goof] FX) <- newEmptyMVar
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
cb :: WorkError -> IO ()
cb = \case
RunOkay _ fx -> putMVar okaySig (Right fx)
RunSwap _ _ _ _ fx -> putMVar okaySig (Right fx)
RunBail goofs -> putMVar okaySig (Left goofs)
rio $ stderr "vere: checking version compatibility"
io inject
takeMVar okaySig >>= \case
Left goof -> do
rio $ stderr "pier: version negotation failed"
logError $ display @Text ("Goof in wyrd event: " <> tshow goof)
throwIO PierVersionNegotiationFailed
Right fx -> do
-- Walk through the returned fx looking for a wend effect. If we find
-- one, check the zuse versions.
rio $ for_ fx $ \case
GoodParse (EfWend (Wynn xs)) -> case L.lookup "zuse" xs of
Nothing -> pure ()
Just zuseVerInWynn ->
if zuseVerInWynn /= zuseVersion
then do
rio $ stderr "pier: pier: version negotiation failed; downgrade"
throwIO PierVersionNegotiationFailed
else
pure ()
_ -> pure ()
-- Start All Drivers -----------------------------------------------------------
@ -427,16 +502,19 @@ drivers
-> Ship
-> Bool
-> (RunReq -> STM ())
-> (Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> (TermSize, Term.Client)
-> (Text -> RIO e ())
-> IO ()
-> Stat
-> Site.KingSubsite
-> RAcquire e ([Ev], RAcquire e Drivers)
drivers env who isFake plan scry termSys stderr serfSIGINT sub = do
drivers env who isFake plan scry termSys stderr serfSIGINT stat sub = do
let Stat{..} = stat
(behnBorn, runBehn) <- rio Behn.behn'
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake scry stderr)
(termBorn, runTerm) <- rio (Term.term' termSys (renderStat stat) serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake statAmes scry stderr)
(httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr sub)
(clayBorn, runClay) <- rio Clay.clay'
(irisBorn, runIris) <- rio Iris.client'
@ -494,6 +572,7 @@ router slog waitFx Drivers {..} = do
case ef of
GoodParse (EfVega _ _ ) -> vega
GoodParse (EfExit _ _ ) -> exit
GoodParse (EfWend _ ) -> pure ()
GoodParse (EfVane (VEBehn ef)) -> io (dBehn ef)
GoodParse (EfVane (VEBoat ef)) -> io (dSync ef)
GoodParse (EfVane (VEClay ef)) -> io (dSync ef)
@ -529,7 +608,7 @@ data ComputeConfig = ComputeConfig
{ ccOnWork :: STM RunReq
, ccOnKill :: STM ()
, ccOnSave :: STM ()
, ccOnScry :: STM (Wen, Gang, Path, Maybe (Term, Noun) -> IO ())
, ccOnScry :: STM (Gang, ScryReq, Maybe (Term, Noun) -> IO ())
, ccPutResult :: (Fact, FX) -> STM ()
, ccShowSpinner :: Maybe Text -> STM ()
, ccHideSpinner :: STM ()
@ -543,7 +622,7 @@ runCompute serf ComputeConfig {..} = do
let onRR = asum [ ccOnKill <&> Serf.RRKill
, ccOnSave <&> Serf.RRSave
, ccOnWork
, ccOnScry <&> \(w,g,p,k) -> Serf.RRScry w g p k
, ccOnScry <&> \(g,r,k) -> Serf.RRScry g r k
]
vEvProcessing :: TMVar Ev <- newEmptyTMVarIO

20
pkg/hs/urbit-king/lib/Urbit/Vere/Pier/Types.hs
View File

@ -14,10 +14,11 @@ module Urbit.Vere.Pier.Types
, jobId
, jobMug
, DriverApi(..)
, ScryFunc
)
where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Urbit.Arvo
import Urbit.Noun.Time
@ -44,11 +45,14 @@ instance Show Nock where
--------------------------------------------------------------------------------
data Pill = Pill
{ pBootFormulas :: ![Nock]
, pKernelOvums :: ![Ev]
, pUserspaceOvums :: ![Ev]
}
data Pill
= PillIvory [Noun]
| PillPill
{ pName :: Noun
, pBootFormulae :: ![Nock] -- XX not actually nock, semantically
, pKernelOva :: ![Ev]
, pUserspaceOva :: ![Ev]
}
deriving (Eq, Show)
data BootSeq = BootSeq !LogIdentity ![Nock] ![Ev]
@ -87,6 +91,10 @@ data DriverApi ef = DriverApi
}
-- Scrying --------------------------------------------------------------------
type ScryFunc = Gang -> ScryReq -> IO (Maybe (Term, Noun))
-- Instances -------------------------------------------------------------------
instance ToNoun Work where

42
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs
View File

@ -16,15 +16,16 @@
|%
:: +writ: from king to serf
::
+$ gang (unit (set ship))
+$ writ
$% $: %live
$% [%cram eve=@]
[%exit cod=@]
[%save eve=@]
[%meld ~]
[%pack ~]
== ==
[%peek mil=@ now=@da lyc=gang pat=path]
:: sam=[gang (each path $%([%once @tas @tas path] [beam @tas beam]))]
[%peek mil=@ sam=*]
[%play eve=@ lit=(list ?((pair @da ovum) *))]
[%work mil=@ job=(pair @da ovum)]
==
@ -33,7 +34,8 @@
+$ plea
$% [%live ~]
[%ripe [pro=%1 hon=@ nok=@] eve=@ mug=@]
[%slog pri=@ ?(cord tank)]
[%slog pri=@ tank]
[%flog cord]
$: %peek
$% [%done dat=(unit (cask))]
[%bail dud=goof]
@ -48,6 +50,7 @@
[%bail lud=(list goof)]
== ==
==
--
```
-}
@ -84,7 +87,8 @@ import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import RIO.Prelude (decodeUtf8Lenient)
import System.Posix.Signals (sigINT, sigKILL, signalProcess)
import Urbit.Arvo (Ev, FX)
import Urbit.Arvo (FX)
import Urbit.Arvo.Event
import Urbit.Noun.Time (Wen)
import qualified Data.ByteString as BS
@ -171,9 +175,9 @@ recvPleaHandlingSlog :: Serf -> IO Plea
recvPleaHandlingSlog serf = loop
where
loop = recvPlea serf >>= \case
PSlog info -> serfSlog serf info >> loop
other -> pure other
PSlog info -> serfSlog serf info >> loop
PFlog (Cord ofni) -> serfSlog serf (0, Tank $ Leaf $ Tape $ ofni) >> loop
other -> pure other
-- Higher-Level IPC Functions --------------------------------------------------
@ -219,9 +223,9 @@ sendCompactionRequest serf = do
sendWrit serf (WLive $ LPack ())
recvLive serf
sendScryRequest :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
sendScryRequest serf w g p = do
sendWrit serf (WPeek 0 w g p)
sendScryRequest :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
sendScryRequest serf g r = do
sendWrit serf (WPeek 0 g r)
recvPeek serf
sendShutdownRequest :: Serf -> Atom -> IO ()
@ -370,10 +374,9 @@ compact serf = withSerfLockIO serf $ \ss -> do
{-|
Peek into the serf state.
-}
scry :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
scry serf w g p = withSerfLockIO serf $ \ss -> do
(ss,) <$> sendScryRequest serf w g p
scry :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
scry serf g r = withSerfLockIO serf $ \ss -> do
(ss,) <$> sendScryRequest serf g r
{-|
Given a list of boot events, send them to to the serf in a single
@ -493,7 +496,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
RRSave () -> doSave
RRKill () -> doKill
RRPack () -> doPack
RRScry w g p k -> doScry w g p k
RRScry g r k -> doScry g r k
doPack :: IO ()
doPack = compact serf >> topLoop
@ -511,8 +514,8 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
doKill :: IO ()
doKill = waitForLog >> snapshot serf >> pure ()
doScry :: Wen -> Gang -> Path -> (Maybe (Term, Noun) -> IO ()) -> IO ()
doScry w g p k = (scry serf w g p >>= k) >> topLoop
doScry :: Gang -> ScryReq -> (Maybe (Term, Noun) -> IO ()) -> IO ()
doScry g r k = (scry serf g r >>= k) >> topLoop
doWork :: EvErr -> IO ()
doWork firstWorkErr = do
@ -529,13 +532,13 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
RRKill () -> atomically (closeTBMQueue que) >> pure doKill
RRSave () -> atomically (closeTBMQueue que) >> pure doSave
RRPack () -> atomically (closeTBMQueue que) >> pure doPack
RRScry w g p k -> atomically (closeTBMQueue que) >> pure (doScry w g p k)
RRScry g r k -> atomically (closeTBMQueue que) >> pure (doScry g r k)
RRWork workErr -> atomically (writeTBMQueue que workErr) >> workLoop que
onWorkResp :: Wen -> EvErr -> Work -> IO ()
onWorkResp wen (EvErr evn err) = \case
WDone eid hash fx -> do
io $ err (RunOkay eid)
io $ err (RunOkay eid fx)
atomically $ sendOn ((Fact eid hash wen (toNoun evn)), fx)
WSwap eid hash (wen, noun) fx -> do
io $ err (RunSwap eid hash wen noun fx)
@ -543,6 +546,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
WBail goofs -> do
io $ err (RunBail goofs)
{-|
Given:

3
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC/Types.hs
View File

@ -35,7 +35,7 @@ data Work
data Writ
= WLive Live
| WPeek Atom Wen Gang Path
| WPeek Atom Gang ScryReq
| WPlay EventId [Noun]
| WWork Atom Wen Ev
deriving (Show)
@ -44,6 +44,7 @@ data Plea
= PLive ()
| PRipe SerfInfo
| PSlog Slog
| PFlog Cord
| PPeek Scry
| PPlay Play
| PWork Work

20
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/Types.hs
View File

@ -2,7 +2,7 @@ module Urbit.Vere.Serf.Types where
import Urbit.Prelude
import Urbit.Arvo (Ev, FX)
import Urbit.Arvo (Desk, Ev, FX)
import Urbit.Noun.Time (Wen)
@ -82,7 +82,7 @@ data EvErr = EvErr Ev (WorkError -> IO ())
data WorkError -- TODO Rename type and constructors
= RunSwap EventId Mug Wen Noun FX -- TODO Maybe provide less info here?
| RunBail [Goof]
| RunOkay EventId
| RunOkay EventId FX
{-
- RRWork: Ask the serf to do work, will output (Fact, FX) if work
@ -94,7 +94,19 @@ data RunReq
| RRSave ()
| RRKill ()
| RRPack ()
| RRScry Wen Gang Path (Maybe (Term, Noun) -> IO ())
| RRScry Gang ScryReq (Maybe (Term, Noun) -> IO ())
type ScryReq = (Each Path Demi)
data Demi
= DemiOnce Term Desk Path
| DemiBeam Term Beam
deriving (Show)
-- TODO
type Beam = Void
deriveNoun ''Demi
-- Exceptions ------------------------------------------------------------------
@ -111,6 +123,8 @@ data SerfExn
| SerfNotRunning
| MissingBootEventsInEventLog Word Word
| SnapshotAheadOfLog EventId EventId
| BailDuringWyrd [Goof]
| SwapDuringWyrd Mug (Wen, Noun) FX
deriving (Show, Exception)

75
pkg/hs/urbit-king/lib/Urbit/Vere/Stat.hs Normal file
View File

@ -0,0 +1,75 @@
module Urbit.Vere.Stat where
import Urbit.Prelude
data Stat = Stat
{ statAmes :: AmesStat
}
data AmesStat = AmesStat
{ asUdp :: TVar Word
, asUqf :: TVar Word
, asUdf :: TVar Word
, asUi6 :: TVar Word
, asRcv :: TVar Word
, asSup :: TVar Word
, asSrf :: TVar Word
, asQuf :: TVar Word
, asFwd :: TVar Word
, asDrt :: TVar Word
, asDvr :: TVar Word
, asDml :: TVar Word
, asSwp :: TVar Word
, asBal :: TVar Word
, asOky :: TVar Word
}
newStat :: MonadIO m => m Stat
newStat = do
asUdp <- newTVarIO 0
asUqf <- newTVarIO 0
asUdf <- newTVarIO 0
asUi6 <- newTVarIO 0
asRcv <- newTVarIO 0
asSup <- newTVarIO 0
asSrf <- newTVarIO 0
asQuf <- newTVarIO 0
asFwd <- newTVarIO 0
asDrt <- newTVarIO 0
asDvr <- newTVarIO 0
asDml <- newTVarIO 0
asSwp <- newTVarIO 0
asBal <- newTVarIO 0
asOky <- newTVarIO 0
pure Stat{statAmes = AmesStat{..}}
bump :: MonadIO m => TVar Word -> m ()
bump s = atomically $ bump' s
bump' :: TVar Word -> STM ()
bump' s = modifyTVar' s (+ 1)
type RenderedStat = [Text]
renderStat :: MonadIO m => Stat -> m RenderedStat
renderStat Stat{statAmes = AmesStat{..}} =
sequence
[ pure "stat:"
, pure " ames:"
, (" udp ingress: " <>) <$> tshow <$> readTVarIO asUdp
, (" udp queue evict: " <>) <$> tshow <$> readTVarIO asUqf
, (" udp recv fail: " <>) <$> tshow <$> readTVarIO asUdf
, (" udp dropped non-ipv4: " <>) <$> tshow <$> readTVarIO asUi6
, (" driver ingress: " <>) <$> tshow <$> readTVarIO asRcv
, (" enqueued for serf: " <>) <$> tshow <$> readTVarIO asSup
, (" sent to serf: " <>) <$> tshow <$> readTVarIO asSrf
, (" serf queue evict: " <>) <$> tshow <$> readTVarIO asQuf
, (" forwarded: " <>) <$> tshow <$> readTVarIO asFwd
, (" dropped (unroutable): " <>) <$> tshow <$> readTVarIO asDrt
, (" dropped (wrong version): " <>) <$> tshow <$> readTVarIO asDvr
, (" dropped (malformed): " <>) <$> tshow <$> readTVarIO asDml
, (" serf swapped: " <>) <$> tshow <$> readTVarIO asSwp
, (" serf bailed: " <>) <$> tshow <$> readTVarIO asBal
, (" serf okay: " <>) <$> tshow <$> readTVarIO asOky
]

11
pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
View File

@ -27,6 +27,7 @@ import Urbit.Vere.Pier.Types
import Data.List ((!!))
import RIO.Directory (createDirectoryIfMissing)
import Urbit.King.API (readPortsFile)
import Urbit.Vere.Stat (RenderedStat)
import Urbit.TermSize (TermSize(TermSize))
import Urbit.Vere.Term.API (Client(Client), ClientTake(..))
@ -558,7 +559,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
loop rd
else if w == 3 then do
-- ETX (^C)
logInfo $ displayShow "Ctrl-c interrupt"
logInfo $ "Ctrl-c interrupt"
atomically $ do
writeTQueue wq [Term.Trace "interrupt\r\n"]
writeTQueue rq $ Ctl $ Cord "c"
@ -599,9 +600,10 @@ localClient doneSignal = fst <$> mkRAcquire start stop
term'
:: HasPierEnv e
=> (TermSize, Client)
-> IO RenderedStat
-> IO ()
-> RIO e ([Ev], RAcquire e (DriverApi TermEf))
term' (tsize, client) serfSIGINT = do
term' (tsize, client) stat serfSIGINT = do
let TermSize wi hi = tsize
initEv = [blewEvent wi hi, initialHail]
@ -610,7 +612,7 @@ term' (tsize, client) serfSIGINT = do
runDriver = do
env <- ask
ventQ :: TQueue EvErr <- newTQueueIO
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) serfSIGINT
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) stat serfSIGINT
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
@ -623,9 +625,10 @@ term :: forall e. (HasPierEnv e)
=> e
-> (TermSize, Client)
-> (EvErr -> STM ())
-> IO RenderedStat
-> IO ()
-> RAcquire e (TermEf -> IO ())
term env (tsize, Client{..}) plan serfSIGINT = runTerm
term env (tsize, Client{..}) plan stat serfSIGINT = runTerm
where
runTerm :: RAcquire e (TermEf -> IO ())
runTerm = do

2
pkg/hs/urbit-king/package.yaml
View File

@ -1,5 +1,5 @@
name: urbit-king
version: 0.10.8
version: 1.1
license: MIT
license-file: LICENSE
data-files:

3
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -108,9 +108,10 @@ instance Arbitrary LogIdentity where
instance Arbitrary Packet where
arbitrary = do
pktVersion <- suchThat arb (< 8)
pktEncrypted <- arb
pktSndr <- arb
pktRcvr <- arb
pktSndrTick <- suchThat arb (< 16)
pktRcvrTick <- suchThat arb (< 16)
pktOrigin <- arb
pktContent <- arb
pure Packet {..}

30
pkg/hs/urbit-king/test/ArvoTests.hs
View File

@ -31,18 +31,6 @@ roundTrip x = Just x == fromNoun (toNoun x)
nounEq :: (ToNoun a, ToNoun b) => a -> b -> Bool
nounEq x y = toNoun x == toNoun y
data EvExample = EvEx Ev Noun
deriving (Eq, Show)
eventSanity :: [EvExample] -> Bool
eventSanity = all $ \(EvEx e n) -> toNoun e == n
instance Arbitrary EvExample where
arbitrary = oneof $ fmap pure $
[ EvEx (EvVane $ VaneVane $ VEVeer (Jael, ()) "" (Path []) "")
(toNoun (Path ["vane", "vane", "jael"], Cord "veer", (), (), ()))
]
--------------------------------------------------------------------------------
tests :: TestTree
@ -51,7 +39,6 @@ tests =
[ testProperty "Round Trip Effect" (roundTrip @Ef)
, testProperty "Round Trip Event" (roundTrip @Ev)
, testProperty "Round Trip AmesDest" (roundTrip @AmesDest)
, testProperty "Basic Event Sanity" eventSanity
]
@ -131,24 +118,9 @@ instance Arbitrary BlipEv where
]
instance Arbitrary Ev where
arbitrary = oneof [ EvVane <$> arb
, EvBlip <$> arb
arbitrary = oneof [ EvBlip <$> arb
]
instance Arbitrary Vane where
arbitrary = oneof [ VaneVane <$> arb
, VaneZuse <$> arb
]
instance Arbitrary VaneName where
arbitrary = oneof $ pure <$> [minBound .. maxBound]
instance Arbitrary VaneEv where
arbitrary = VEVeer <$> arb <*> arb <*> arb <*> arb
instance Arbitrary ZuseEv where
arbitrary = ZEVeer () <$> arb <*> arb <*> arb
instance Arbitrary StdMethod where
arbitrary = oneof $ pure <$> [ minBound .. maxBound ]

2
pkg/hs/urbit-king/test/Options.hs
View File

@ -35,7 +35,7 @@ instance KnownSymbol name => Options.IsOption (Pill name) where
)
defaultValue =
Pill ( "../../../bin"
Pill ( "../../../bin/"
++ TypeLits.symbolVal (Proxy @name)
++ ".pill"
)

2
pkg/hs/urbit-king/test/gold/hoontree.gold
View File

@ -1 +1 @@
2082167031
233234490

24
pkg/hs/urbit-noun-core/lib/Urbit/Noun/Mug.hs
View File

@ -5,6 +5,7 @@ module Urbit.Noun.Mug where
import ClassyPrelude
import Data.Bits
import Data.ByteString.Builder
import Urbit.Atom
import Data.Hash.Murmur (murmur3)
@ -13,14 +14,7 @@ type Mug = Word32
{-# INLINE mugBS #-}
mugBS :: ByteString -> Word32
mugBS = go 0xcafebabe
where
go seed buf =
let haz = murmur3 seed buf
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
in if ham == 0
then go (seed + 1) buf
else ham
mugBS = mum 0xcafe_babe 0x7fff
-- XX is there a way to do this without copy?
{-# INLINE mugAtom #-}
@ -29,4 +23,16 @@ mugAtom = mugBS . atomBytes
{-# INLINE mugBoth #-}
mugBoth :: Word32 -> Word32 -> Word32
mugBoth m n = mugAtom $ fromIntegral $ m `xor` 0x7fff_ffff `xor` n
mugBoth m n = mum 0xdead_beef 0xfffe
$ toStrict $ toLazyByteString (word32LE m <> word32LE n)
mum :: Word32 -> Word32 -> ByteString -> Word32
mum syd fal key = go syd 0
where
go syd 8 = fal
go syd i =
let haz = murmur3 syd key
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
in if ham /= 0
then ham
else go (syd + 1) (i + 1)

7
pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
View File

@ -147,7 +147,9 @@ enumFromAtom :: [(String, Name)] -> Exp
enumFromAtom cons = LamE [VarP x] body
where
(x, c) = (mkName "x", mkName "c")
getTag = BindS (VarP c) $ AppE (VarE 'parseNounUtf8Atom) (VarE x)
getTag = BindS (VarP c)
$ AppE (AppE (VarE 'named) matchFail)
$ AppE (VarE 'parseNounUtf8Atom) (VarE x)
examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback])
matches = mkMatch <$> cons
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
@ -194,6 +196,7 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
$ AppE (VarE 'parseNoun) (VarE n)
getTag = BindS (SigP (VarP c) (ConT ''Text))
$ AppE (AppE (VarE 'named) tagFail)
$ AppE (VarE 'parseNounUtf8Atom) (VarE h)
examine = NoBindS
@ -208,6 +211,8 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
matchFail = unexpectedTag (fst <$> cons) (VarE c)
tagFail = LitE $ StringL (intercalate " " (('%':) <$> (fst <$> cons)))
--------------------------------------------------------------------------------
tagString :: Int -> Name -> String

BIN
pkg/interface/package-lock.json generated
View File

Binary file not shown.

2
pkg/interface/package.json
View File

@ -18,7 +18,7 @@
"codemirror": "^5.59.2",
"css-loader": "^3.6.0",
"file-saver": "^2.0.5",
"formik": "^2.2.6",
"formik": "^2.1.5",
"immer": "^8.0.1",
"lodash": "^4.17.20",
"markdown-to-jsx": "^6.11.4",

62
pkg/interface/src/logic/api/contacts.ts
View File

@ -5,74 +5,50 @@ import { Contact, ContactEdit } from '~/types/contact-update';
import { GroupPolicy, Resource } from '~/types/group-update';
export default class ContactsApi extends BaseApi<StoreState> {
create(
name: string,
policy: Enc<GroupPolicy>,
title: string,
description: string
) {
return this.viewAction({
create: {
name,
policy,
title,
description,
},
});
add(ship: Patp, contact: any) {
return this.storeAction({ add: { ship, contact } });
}
share(recipient: Patp, path: Patp, ship: Patp, contact: Contact) {
return this.viewAction({
share: {
recipient,
path,
ship,
contact,
},
});
remove(ship: Patp) {
return this.storeAction({ remove: { ship } });
}
remove(path: Path, ship: Patp) {
return this.viewAction({ remove: { path, ship } });
}
edit(path: Path, ship: Patp, editField: ContactEdit) {
edit(ship: Patp, editField: ContactEdit) {
/* editField can be...
{nickname: ''}
{email: ''}
{phone: ''}
{website: ''}
{notes: ''}
{color: 'fff'} // with no 0x prefix
{avatar: null}
{avatar: {url: ''}}
{avatar: ''}
{add-group: {ship, name}}
{remove-group: {ship, name}}
*/
return this.hookAction({
console.log(ship, editField);
return this.storeAction({
edit: {
path,
ship,
'edit-field': editField,
},
});
}
invite(resource: Resource, ship: Patp, text = '') {
return this.viewAction({
invite: { resource, ship, text },
setPublic(setPublic: any) {
return this.storeAction({
'set-public': setPublic
});
}
join(resource: Resource) {
return this.viewAction({
join: resource,
});
private storeAction(action: any): Promise<any> {
return this.action('contact-store', 'contact-update', action)
}
private hookAction(data) {
return this.action('contact-hook', 'contact-action', data);
private viewAction(threadName: string, action: any) {
return this.spider('contact-view-action', 'json', threadName, action);
}
private viewAction(data) {
return this.action('contact-view', 'json', data);
private hookAction(ship: Patp, action: any): Promise<any> {
return this.action('contact-push-hook', 'contact-update', action);
}
}

43
pkg/interface/src/logic/api/groups.ts
View File

@ -8,6 +8,7 @@ import {
Tag,
GroupPolicyDiff,
} from '~/types/group-update';
import {makeResource} from '../lib/group';
export default class GroupsApi extends BaseApi<StoreState> {
remove(resource: Resource, ships: Patp[]) {
@ -34,12 +35,52 @@ export default class GroupsApi extends BaseApi<StoreState> {
return this.proxyAction({ changePolicy: { resource, diff } });
}
join(ship: string, name: string) {
const resource = makeResource(ship, name);
return this.viewAction({ join: { resource, ship }});
}
create(name: string, policy: Enc<GroupPolicy>, title: string, description: string) {
return this.viewThread('group-create', {
create: {
name,
policy,
title,
description
}
});
}
deleteGroup(ship: string, name: string) {
const resource = makeResource(ship, name);
return this.viewThread('group-delete', {
remove: resource
});
}
leaveGroup(ship: string, name: string) {
const resource = makeResource(ship, name);
return this.viewThread('group-leave', {
leave: resource
});
}
private proxyAction(action: GroupAction) {
return this.action('group-push-hook', 'group-update', action);
}
private storeAction(action: GroupAction) {
console.log(action);
return this.action('group-store', 'group-update', action);
}
private viewThread(thread: string, action: any) {
return this.spider('group-view-action', 'json', thread, action);
}
private viewAction(action: any) {
return this.action('group-view', 'group-view-action', action);
}
}

5
pkg/interface/src/logic/api/hark.ts
View File

@ -196,10 +196,11 @@ export class HarkApi extends BaseApi<StoreState> {
});
}
getMore() {
async getMore(): Promise<boolean> {
const offset = this.store.state['notifications']?.size || 0;
const count = 3;
return this.getSubset(offset, count, false);
await this.getSubset(offset, count, false);
return offset === (this.store.state.notifications?.size || 0);
}
async getSubset(offset:number, count:number, isArchive: boolean) {

2
pkg/interface/src/logic/api/metadata.ts
View File

@ -70,7 +70,7 @@ export default class MetadataApi extends BaseApi<StoreState> {
done = true;
tempChannel.delete();
reject(new Error("offline"))
}, 30000);
}, 15000);
tempChannel.subscribe(window.ship, "metadata-pull-hook", `/preview${group}`,
(err) => {

14
pkg/interface/src/logic/lib/omnibox.js
View File

@ -1,6 +1,7 @@
import { cite } from '~/logic/lib/util';
const indexes = new Map([
['ships', []],
['commands', []],
['subscriptions', []],
['groups', []],
@ -18,6 +19,14 @@ const result = function(title, link, app, host) {
};
};
const shipIndex = function(contacts) {
const ships = [];
Object.keys(contacts).map((e) => {
return ships.push(result(e, `/~profile/${e}`, 'profile', contacts[e]?.status));
});
return ships;
};
const commandIndex = function (currentGroup) {
// commands are special cased for default suite
const commands = [];
@ -62,7 +71,8 @@ const otherIndex = function() {
return other;
};
export default function index(associations, apps, currentGroup, groups) {
export default function index(contacts, associations, apps, currentGroup, groups) {
indexes.set('ships', shipIndex(contacts));
// all metadata from all apps is indexed
// into subscriptions and landscape
const subscriptions = [];
@ -106,7 +116,7 @@ export default function index(associations, apps, currentGroup, groups) {
title,
`/~landscape${group}/join/${app}${each.resource}`,
app.charAt(0).toUpperCase() + app.slice(1),
(associations?.contacts?.[each.group]?.metadata?.title || null)
(associations?.groups?.[each.group]?.metadata?.title || null)
);
subscriptions.push(obj);
}

51
pkg/interface/src/logic/lib/useLazyScroll.ts Normal file
View File

@ -0,0 +1,51 @@
import { useEffect, RefObject, useRef, useState } from "react";
import _ from "lodash";
export function distanceToBottom(el: HTMLElement) {
const { scrollTop, scrollHeight, clientHeight } = el;
const scrolledPercent =
(scrollHeight - scrollTop - clientHeight) / scrollHeight;
return _.isNaN(scrolledPercent) ? 0 : scrolledPercent;
}
export function useLazyScroll(
ref: RefObject<HTMLElement>,
margin: number,
loadMore: () => Promise<boolean>
) {
const [isDone, setIsDone] = useState(false);
useEffect(() => {
if (!ref.current) {
return;
}
setIsDone(false);
const scroll = ref.current;
const loadUntil = (el: HTMLElement) => {
if (!isDone && distanceToBottom(el) < margin) {
return loadMore().then((done) => {
if (done) {
setIsDone(true);
return Promise.resolve();
}
return loadUntil(el);
});
}
return Promise.resolve();
};
loadUntil(scroll);
const onScroll = (e: Event) => {
const el = e.currentTarget! as HTMLElement;
loadUntil(el);
};
ref.current.addEventListener("scroll", onScroll);
return () => {
ref.current?.removeEventListener("scroll", onScroll);
};
}, [ref?.current]);
return isDone;
}

14
pkg/interface/src/logic/lib/util.ts
View File

@ -376,11 +376,19 @@ export function useShowNickname(contact: Contact | null, hide?: boolean): boolea
return !!(contact && contact.nickname && !hideNicknames);
}
export function useHovering() {
interface useHoveringInterface {
hovering: boolean;
bind: {
onMouseOver: () => void,
onMouseLeave: () => void
}
}
export const useHovering = (): useHoveringInterface => {
const [hovering, setHovering] = useState(false);
const bind = {
onMouseEnter: () => setHovering(true),
onMouseOver: () => setHovering(true),
onMouseLeave: () => setHovering(false)
};
return { hovering, bind };
}
};

2
pkg/interface/src/logic/lib/workspace.ts
View File

@ -8,7 +8,7 @@ export function getTitleFromWorkspace(
case "home":
return "DMs + Drafts";
case "group":
const association = associations.contacts[workspace.group];
const association = associations.groups[workspace.group];
return association?.metadata?.title || "";
}
}

104
pkg/interface/src/logic/reducers/contact-update.ts
View File

@ -5,74 +5,60 @@ import { ContactUpdate } from '~/types/contact-update';
type ContactState = Pick<StoreState, 'contacts'>;
export default class ContactReducer<S extends ContactState> {
reduce(json: Cage, state: S) {
const data = _.get(json, 'contact-update', false);
if (data) {
this.initial(data, state);
this.create(data, state);
this.delete(data, state);
this.add(data, state);
this.remove(data, state);
this.edit(data, state);
}
export const ContactReducer = (json, state) => {
const data = _.get(json, 'contact-update', false);
if (data) {
initial(data, state);
add(data, state);
remove(data, state);
edit(data, state);
setPublic(data, state);
}
};
initial(json: ContactUpdate, state: S) {
const data = _.get(json, 'initial', false);
if (data) {
state.contacts = data;
}
const initial = (json: ContactUpdate, state: S) => {
const data = _.get(json, 'initial', false);
if (data) {
state.contacts = data.rolodex;
state.isContactPublic = data['is-public'];
}
};
create(json: ContactUpdate, state: S) {
const data = _.get(json, 'create', false);
if (data) {
state.contacts[data.path] = {};
}
const add = (json: ContactUpdate, state: S) => {
const data = _.get(json, 'add', false);
if (data) {
state.contacts[data.ship] = data.contact;
}
};
delete(json: ContactUpdate, state: S) {
const data = _.get(json, 'delete', false);
if (data) {
delete state.contacts[data.path];
}
const remove = (json: ContactUpdate, state: S) => {
const data = _.get(json, 'remove', false);
if (
data &&
(data.ship in state.contacts)
) {
delete state.contacts[data.ship];
}
};
add(json: ContactUpdate, state: S) {
const data = _.get(json, 'add', false);
if (
data &&
(data.path in state.contacts)
) {
state.contacts[data.path][data.ship] = data.contact;
const edit = (json: ContactUpdate, state: S) => {
const data = _.get(json, 'edit', false);
const ship = `~${data.ship}`;
if (
data &&
(ship in state.contacts)
) {
const edit = Object.keys(data['edit-field']);
if (edit.length !== 1) {
return;
}
state.contacts[ship][edit[0]] = data['edit-field'][edit[0]];
}
};
const setPublic = (json: ContactUpdate, state: S) => {
const data = _.get(json, 'set-public', state.isContactPublic);
state.isContactPublic = data;
};
remove(json: ContactUpdate, state: S) {
const data = _.get(json, 'remove', false);
if (
data &&
(data.path in state.contacts) &&
(data.ship in state.contacts[data.path])
) {
delete state.contacts[data.path][data.ship];
}
}
edit(json: ContactUpdate, state: S) {
const data = _.get(json, 'edit', false);
if (
data &&
(data.path in state.contacts) &&
(data.ship in state.contacts[data.path])
) {
const edit = Object.keys(data['edit-field']);
if (edit.length !== 1) {
return;
}
state.contacts[data.path][data.ship][edit[0]] =
data['edit-field'][edit[0]];
}
}
}

30
pkg/interface/src/logic/reducers/group-view.ts Normal file
View File

@ -0,0 +1,30 @@
import { resourceAsPath } from "~/logic/lib/util";
const initial = (json: any, state: any) => {
const data = json.initial;
if(data) {
state.pendingJoin = data;
}
}
const progress = (json: any, state: any) => {
const data = json.progress;
if(data) {
const { progress, resource } = data;
state.pendingJoin = {...state.pendingJoin, [resource]: progress };
if(progress === 'done') {
setTimeout(() => {
delete state.pendingJoin[resource];
}, 10000);
}
}
}
export const GroupViewReducer = (json: any, state: any) => {
const data = json['group-view-update'];
if(data) {
progress(data, state);
initial(data, state);
}
}

9
pkg/interface/src/logic/reducers/metadata-update.ts
View File

@ -16,6 +16,15 @@ export default class MetadataReducer<S extends MetadataState> {
this.add(data, state);
this.update(data, state);
this.remove(data, state);
this.groupInitial(data, state);
}
}
groupInitial(json: MetadataUpdate, state: S) {
const data = _.get(json, 'initial-group', false);
console.log(data);
if(data) {
this.associations(data, state);
}
}

5
pkg/interface/src/logic/state/local.tsx
View File

@ -40,7 +40,8 @@ const useLocalState = create<LocalState>(persist((set, get) => ({
}
})),
set: fn => set(produce(fn))
}), {
}), {
blacklist: ['suspendedFocus', 'toggleOmnibox', 'omniboxShown'],
name: 'localReducer'
}));
@ -55,4 +56,4 @@ function withLocalState<P, S extends keyof LocalState>(Component: any, stateMemb
});
}
export { useLocalState as default, withLocalState };
export { useLocalState as default, withLocalState };

32
pkg/interface/src/logic/store/store.ts
View File

@ -1,3 +1,5 @@
import _ from 'lodash';
import BaseStore from './base';
import InviteReducer from '../reducers/invite-update';
import MetadataReducer from '../reducers/metadata-update';
@ -6,29 +8,41 @@ import LocalReducer from '../reducers/local';
import { StoreState } from './type';
import { Timebox } from '~/types';
import { Cage } from '~/types/cage';
import ContactReducer from '../reducers/contact-update';
import S3Reducer from '../reducers/s3-update';
import { GraphReducer } from '../reducers/graph-update';
import { HarkReducer } from '../reducers/hark-update';
import { ContactReducer } from '../reducers/contact-update';
import GroupReducer from '../reducers/group-update';
import LaunchReducer from '../reducers/launch-update';
import ConnectionReducer from '../reducers/connection';
import SettingsReducer from '../reducers/settings-update';
import {OrderedMap} from '../lib/OrderedMap';
import { BigIntOrderedMap } from '../lib/BigIntOrderedMap';
import {GroupViewReducer} from '../reducers/group-view';
export default class GlobalStore extends BaseStore<StoreState> {
inviteReducer = new InviteReducer();
metadataReducer = new MetadataReducer();
localReducer = new LocalReducer();
contactReducer = new ContactReducer();
s3Reducer = new S3Reducer();
groupReducer = new GroupReducer();
launchReducer = new LaunchReducer();
connReducer = new ConnectionReducer();
settingsReducer = new SettingsReducer();
pastActions: Record<string, any> = {}
constructor() {
super();
(window as any).debugStore = this.debugStore.bind(this);
}
debugStore(tag: string, ...stateKeys: string[]) {
console.log(this.pastActions[tag]);
console.log(_.pick(this.state, stateKeys));
}
rehydrate() {
this.localReducer.rehydrate(this.state);
}
@ -43,7 +57,7 @@ export default class GlobalStore extends BaseStore<StoreState> {
baseHash: null,
invites: {},
associations: {
contacts: {},
groups: {},
graph: {},
},
groups: {},
@ -64,6 +78,7 @@ export default class GlobalStore extends BaseStore<StoreState> {
},
credentials: null
},
isContactPublic: false,
contacts: {},
notifications: new BigIntOrderedMap<Timebox>(),
archivedNotifications: new BigIntOrderedMap<Timebox>(),
@ -79,21 +94,28 @@ export default class GlobalStore extends BaseStore<StoreState> {
group: {}
},
notificationsCount: 0,
settings: {}
settings: {},
pendingJoin: {},
};
}
reduce(data: Cage, state: StoreState) {
// debug shim
const tag = Object.keys(data)[0];
const oldActions = this.pastActions[tag] || [];
this.pastActions[tag] = [data[tag], ...oldActions.slice(0,14)];
this.inviteReducer.reduce(data, this.state);
this.metadataReducer.reduce(data, this.state);
this.localReducer.reduce(data, this.state);
this.contactReducer.reduce(data, this.state);
this.s3Reducer.reduce(data, this.state);
this.groupReducer.reduce(data, this.state);
this.launchReducer.reduce(data, this.state);
this.connReducer.reduce(data, this.state);
GraphReducer(data, this.state);
HarkReducer(data, this.state);
ContactReducer(data, this.state);
this.settingsReducer.reduce(data, this.state);
GroupViewReducer(data, this.state);
}
}

5
pkg/interface/src/logic/store/type.ts
View File

@ -11,7 +11,8 @@ import {
Notifications,
NotificationGraphConfig,
GroupNotificationsConfig,
Unreads
Unreads,
JoinRequests
} from "~/types";
export interface StoreState {
@ -46,5 +47,5 @@ export interface StoreState {
notificationsCount: number,
unreads: Unreads;
doNotDisturb: boolean;
unreads: Unreads;
pendingJoin: JoinRequests;
}

6
pkg/interface/src/logic/subscription/global.ts
View File

@ -10,7 +10,6 @@ import _ from 'lodash';
type AppSubscription = [Path, string];
const groupSubscriptions: AppSubscription[] = [
['/synced', 'contact-hook']
];
const graphSubscriptions: AppSubscription[] = [
@ -37,14 +36,15 @@ export default class GlobalSubscription extends BaseSubscription<StoreState> {
this.subscribe('/groups', 'group-store');
this.clearQueue();
this.subscribe('/primary', 'contact-view');
// TODO: update to get /updates
this.subscribe('/all', 'contact-store');
this.subscribe('/all', 's3-store');
this.subscribe('/keys', 'graph-store');
this.subscribe('/updates', 'hark-store');
this.subscribe('/updates', 'hark-graph-hook');
this.subscribe('/updates', 'hark-group-hook');
this.subscribe('/all', 'settings-store');
this.subscribe('/all', 'group-view');
}
restart() {

11
pkg/interface/src/types/group-view.ts Normal file
View File

@ -0,0 +1,11 @@
export const joinError = ['no-perms', 'strange'] as const;
export type JoinError = typeof joinError[number];
export const joinResult = ['done', ...joinError] as const;
export type JoinResult = typeof joinResult[number];
export const joinProgress = ['start', 'added', ...joinResult] as const;
export type JoinProgress = typeof joinProgress[number];
export interface JoinRequests {
[rid: string]: JoinProgress;
}

3
pkg/interface/src/types/index.ts
View File

@ -1,10 +1,9 @@
export * from './cage';
export * from './chat-hook-update';
export * from './chat-update';
export * from './connection';
export * from './contact-update';
export * from './global';
export * from './group-update';
export * from './group-view';
export * from './graph-update';
export * from './hark-update';
export * from './invite-update';

5
pkg/interface/src/types/invite-update.ts
View File

@ -1,4 +1,5 @@
import { Serial, PatpNoSig, Path } from './noun';
import {Resource} from './group-update';
export type InviteUpdate =
InviteUpdateInitial
@ -60,8 +61,8 @@ export type AppInvites = {
export interface Invite {
app: string;
path: Path;
recipeint: PatpNoSig;
recipient: PatpNoSig;
resource: Resource;
ship: PatpNoSig;
text: string;
}

2
pkg/interface/src/types/noun.ts
View File

@ -18,7 +18,7 @@ export type Serial = string;
export type Jug<K,V> = Map<K,Set<V>>;
// name of app
export type AppName = 'chat' | 'link' | 'contacts' | 'publish' | 'graph';
export type AppName = 'contacts' | 'groups' | 'graph';
export function getTagFromFrond<O>(frond: O): keyof O {
const tags = Object.keys(frond) as Array<keyof O>;

6
pkg/interface/src/views/App.js
View File

@ -138,9 +138,7 @@ class App extends React.Component {
const notificationsCount = state.notificationsCount || 0;
const doNotDisturb = state.doNotDisturb || false;
const showBanner = localStorage.getItem("2020BreachBanner") || "flex";
let banner = null;
const ourContact = this.state.contacts[`~${this.ship}`] || null;
return (
<ThemeProvider theme={theme}>
@ -156,6 +154,7 @@ class App extends React.Component {
props={this.props}
associations={associations}
invites={this.state.invites}
ourContact={ourContact}
api={this.api}
connection={this.state.connection}
subscription={this.subscription}
@ -169,6 +168,7 @@ class App extends React.Component {
associations={state.associations}
apps={state.launch}
api={this.api}
contacts={state.contacts}
notifications={state.notificationsCount}
invites={state.invites}
groups={state.groups}

6
pkg/interface/src/views/apps/chat/ChatResource.tsx
View File

@ -9,6 +9,7 @@ import { useFileDrag } from '~/logic/lib/useDrag';
import ChatWindow from './components/ChatWindow';
import ChatInput from './components/ChatInput';
import GlobalApi from '~/logic/api/global';
import { ShareProfile } from '~/views/apps/chat/components/ShareProfile';
import SubmitDragger from '~/views/components/SubmitDragger';
import { useLocalStorageState } from '~/logic/lib/useLocalStorageState';
import { Loading } from '~/views/components/Loading';
@ -25,7 +26,7 @@ export function ChatResource(props: ChatResourceProps) {
const station = props.association.resource;
const groupPath = props.association.group;
const group = props.groups[groupPath];
const contacts = props.contacts[groupPath] || {};
const contacts = props.contacts;
const graph = props.graphs[station.slice(7)];
@ -34,7 +35,7 @@ export function ChatResource(props: ChatResourceProps) {
const unreadCount = props.unreads.graph?.[station]?.['/']?.unreads || 0;
const [,, owner, name] = station.split('/');
const ourContact = contacts?.[window.ship];
const ourContact = contacts?.[`~${window.ship}`];
const chatInput = useRef<ChatInput>();
@ -88,6 +89,7 @@ export function ChatResource(props: ChatResourceProps) {
return (
<Col {...bind} height="100%" overflow="hidden" position="relative">
<ShareProfile our={ourContact} />
{dragging && <SubmitDragger />}
<ChatWindow
mailboxSize={5}

75
pkg/interface/src/views/apps/chat/components/ChatMessage.tsx
View File

@ -4,7 +4,7 @@ import _ from "lodash";
import { Box, Row, Text, Rule } from "@tlon/indigo-react";
import OverlaySigil from '~/views/components/OverlaySigil';
import { uxToHex, cite, writeText, useShowNickname } from '~/logic/lib/util';
import { uxToHex, cite, writeText, useShowNickname, useHovering } from '~/logic/lib/util';
import { Group, Association, Contacts, Post } from "~/types";
import TextContent from './content/text';
import CodeContent from './content/code';
@ -134,6 +134,7 @@ export default class ChatMessage extends Component<ChatMessageProps> {
className={containerClass}
style={style}
mb={1}
position="relative"
>
{dayBreak && !isLastRead ? <DayBreak when={msg['time-sent']} /> : null}
{renderSigil
@ -177,7 +178,7 @@ export const MessageWithSigil = (props) => {
const dark = useLocalState(state => state.dark);
const datestamp = moment.unix(msg['time-sent'] / 1000).format(DATESTAMP_FORMAT);
const contact = msg.author in contacts ? contacts[msg.author] : false;
const contact = `~${msg.author}` in contacts ? contacts[`~${msg.author}`] : false;
const showNickname = useShowNickname(contact);
const name = showNickname ? contact.nickname : cite(msg.author);
const color = contact ? `#${uxToHex(contact.color)}` : dark ? '#000000' :'#FFFFFF'
@ -194,6 +195,8 @@ export const MessageWithSigil = (props) => {
}
};
const { hovering, bind } = useHovering();
return (
<>
<OverlaySigil
@ -206,9 +209,11 @@ export const MessageWithSigil = (props) => {
history={history}
api={api}
bg="white"
className="fl pr3 v-top pt1"
className="fl v-top pt1"
pr={3}
pl={2}
/>
<Box flexGrow={1} display='block' className="clamp-message">
<Box flexGrow={1} display='block' className="clamp-message" {...bind}>
<Box
flexShrink={0}
className="hide-child"
@ -231,8 +236,15 @@ export const MessageWithSigil = (props) => {
}}
title={`~${msg.author}`}
>{name}</Text>
<Text flexShrink='0' fontSize='0' gray mono className="v-mid">{timestamp}</Text>
<Text flexShrink={0} gray mono ml={2} className="v-mid child dn-s">{datestamp}</Text>
<Text flexShrink={0} fontSize={0} gray mono>{timestamp}</Text>
<Text
flexShrink={0}
fontSize={0}
gray
mono
ml={2}
display={['none', hovering ? 'block' : 'none']}
>{datestamp}</Text>
</Box>
<ContentBox flexShrink={0} fontSize={fontSize ? fontSize : '14px'}>
{msg.contents.map(c =>
@ -257,20 +269,40 @@ const ContentBox = styled(Box)`
`;
export const MessageWithoutSigil = ({ timestamp, contacts, msg, measure, group }) => (
<>
<Text flexShrink={0} mono gray display='inline-block' pt='2px' lineHeight='tall' className="child" fontSize='0'>{timestamp}</Text>
<ContentBox flexShrink={0} fontSize='14px' className="clamp-message" style={{ flexGrow: 1 }}>
{msg.contents.map((c, i) => (
<MessageContent
key={i}
contacts={contacts}
content={c}
group={group}
measure={measure}/>))}
</ContentBox>
</>
);
export const MessageWithoutSigil = ({ timestamp, contacts, msg, measure, group }) => {
const { hovering, bind } = useHovering();
return (
<>
<Text
flexShrink={0}
mono
gray
display={hovering ? 'block': 'none'}
pt='2px'
lineHeight='tall'
fontSize={0}
position="absolute"
left={1}
>{timestamp}</Text>
<ContentBox
flexShrink={0}
fontSize='14px'
className="clamp-message"
style={{ flexGrow: 1 }}
{...bind}
pl={6}
>
{msg.contents.map((c, i) => (
<MessageContent
key={i}
contacts={contacts}
content={c}
group={group}
measure={measure}/>))}
</ContentBox>
</>
)
};
export const MessageContent = ({ content, contacts, measure, fontSize, group }) => {
if ('code' in content) {
@ -292,7 +324,8 @@ export const MessageContent = ({ content, contacts, measure, fontSize, group })
}}
textProps={{style: {
fontSize: 'inherit',
textDecoration: 'underline'
borderBottom: '1px solid',
textDecoration: 'none'
}}}
/>
</Box>

30
pkg/interface/src/views/apps/chat/components/ShareProfile.js Normal file
View File

@ -0,0 +1,30 @@
import React from 'react';
import { Box, Row, Text, BaseImage } from '@tlon/indigo-react';
import { uxToHex } from '~/logic/lib/util';
import { Sigil } from '~/logic/lib/sigil';
export const ShareProfile = (props) => {
const image = (props?.our?.avatar)
? <BaseImage src={props.our.avatar} width='24px' height='24px' borderRadius={2} style={{ objectFit: 'cover' }} />
: <Row p={1} alignItems="center" borderRadius={2} backgroundColor={`#${uxToHex(props?.our?.color)}` || "#000000"}>
<Sigil ship={window.ship} size={16} icon color={`#${uxToHex(props?.our?.color)}` || "#000000"} />
</Row>;
return (
<Row
height="48px"
alignItems="center"
justifyContent="space-between"
borderBottom={1}
borderColor="washedGray"
>
<Row pl={3} alignItems="center">
{image}
<Text verticalAlign="middle" pl={2}>Share private profile?</Text>
</Row>
<Box pr={2}>
<Text color="blue" bold cursor="pointer">Share</Text>
</Box>
</Row>
);
};

9
pkg/interface/src/views/apps/chat/components/content/text.js
View File

@ -53,6 +53,9 @@ const MessageMarkdown = React.memo(props => (
{...props}
unwrapDisallowed={true}
renderers={renderers}
// shim until we uncover why RemarkBreaks and
// RemarkDisableTokenizers can't be loaded simultaneously
disallowedTypes={['heading', 'list', 'listItem', 'link']}
allowNode={(node, index, parent) => {
if (
node.type === 'blockquote'
@ -67,11 +70,7 @@ const MessageMarkdown = React.memo(props => (
return true;
}}
plugins={[[
RemarkBreaks,
RemarkDisableTokenizers,
{ block: DISABLED_BLOCK_TOKENS, inline: DISABLED_INLINE_TOKENS }
]]} />
plugins={[RemarkBreaks]} />
));

Some files were not shown because too many files have changed in this diff Show More