ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-11-23 18:18:23 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'king-haskell' of github.com:urbit/urbit into king-haskell

Browse Source
This commit is contained in:
pilfer-pandex 2019-12-16 15:03:50 -08:00
commit c5b0834bca
399 changed files with 53326 additions and 31145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -1,2 +1,4 @@
bin/* filter=lfs diff=lfs merge=lfs -text
bin/*/* filter=lfs diff=lfs merge=lfs -text
pkg/arvo/**/*.js binary
pkg/arvo/**/*.css binary

2
.gitignore vendored
View File

@ -12,7 +12,6 @@ release/
.stack-work
\#*\#
s/*
=======
**/.DS_Store
**/dist
**/node_modules
@ -21,3 +20,4 @@ s/*
**/*.swo
**/*-min.js
.stack-work
pkg/interface/link-webext/web-ext-artifacts

54
.travis.yml
View File

@ -1,20 +1,50 @@
language: nix
nix: 2.1.3
# TODO Only do release builds on the `pull` branch?
install:
- nix-env -iA cachix -f https://cachix.org/api/v1/install
jobs:
include:
- os: linux
language: nix
nix: 2.1.3
before_install:
- git lfs pull
- sh/travis-install-stack
before_install:
- git lfs pull
install:
- nix-env -iA cachix -f https://cachix.org/api/v1/install
- stack --no-terminal --install-ghc build king --only-dependencies
script:
- cachix use urbit2
- ./sh/cachix || true
script:
- cachix use urbit2
- ./sh/cachix
- make build-fast
- make release
- sh/ci-tests
- make
- make release
- os: osx
language: generic
sudo: required
- sh/ci-tests
before_install:
- sh/travis-install-stack
install:
- stack --no-terminal --install-ghc build king --only-dependencies
script:
- ver="$(git rev-parse HEAD)"
- if [ -n "${TRAVIS_COMMIT-}" ]; then ver="$TRAVIS_COMMIT"; fi
- if [ -n "${TRAVIS_TAG-}" ]; then ver="$TRAVIS_TAG"; fi
- stack clean
- stack install king --local-bin-path ./release
- mv release/king release/king-darwin-$ver
- otool -L release/king-darwin-$ver
cache:
directories:
- $HOME/.ghc
- $HOME/.cabal
- $HOME/.stack
- $TRAVIS_BUILD_DIR/.stack-work
deploy:
- skip_cleanup: true

34
CONTRIBUTING.md
View File

@ -81,9 +81,12 @@ aqua, ph" -- but note that this may be a warning that too many changes are
being packed into a single commit. The 'component' and 'short description'
combined should be no more than 50 characters.
A lengthier description is encouraged, where useful, but is not required.
A lengthier description is encouraged, where useful, but is not always strictly
required. You should use the longer description to give any useful background
on or motivation for the commit, provide a summary of what it does, link to
relevant issues, proposals, or other commits, and so on.
Here's an example of our commit format, applied to a hypothetical commit:
Here is an example of our commit format, taken from a commit in the history:
> zuse: remove superfluous 'scup' and 'culm' types.
>
@ -95,6 +98,23 @@ Here's an example of our commit format, applied to a hypothetical commit:
> This commit deletes 'scup' and 'culm' and refactors what little code
> made use of them.
Note that the short description is prefixed by `zuse:`, which is what the
commit touches. Otherwise it just includes a summary of the change.
Here's another example:
> build: give arvo a high priority
>
> 0bdced981e4 introduced the 'arvo-ropsten' derivation. Attempting to
> install both 'arvo' and 'arvo-ropsten' via nix-env will result in a
> priority error; this assigns a higher priority to 'arvo' to resolve the
> conflict.
>
> Fixes #1912.
Note that it cites a previous relevant commit, `0bdced981e4`, in its summary,
and also points at the issue that it resolves.
If you're in doubt about how to format your commit descriptions, take a look at
the recent history and try to mimic the style that you can see others broadly
follow there.
@ -128,9 +148,13 @@ via:
sh/update-solid-pill
```
and include it along with your contribution. You can either include it in the
same commit as your change, or, if you prefer, in a standalone commit (you will
see plenty of "pills: update solid" commits if you look through the history).
and include it along with your contribution.
Historically, we've sometimes included these updated pills in separate,
standalone commits (you will see plenty of "pills: update solid" and similar
commits if you look through the history), but this practice is considered to be
deprecated -- you should usually just include the updated pill in the same
commit that updates the source.
## Releases

10
Makefile
View File

@ -1,7 +1,12 @@
.PHONY: build build-all install cross release test pills clean
.PHONY: build build-all install cross release test pills ropsten-pills clean
build:
nix-build -A urbit -A herb --no-out-link
stack build king
build-fast:
nix-build -A urbit -A herb --no-out-link
stack build king --fast
build-all:
nix-build --no-out-link
@ -23,6 +28,9 @@ pills:
sh/update-brass-pill
sh/update-ivory-pill
ropsten-pills:
sh/create-ropsten-pills
interface:
sh/build-interface

4
bin/brass.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:7c86406f2d43d58e1da8ed1a048d6cba38112b6abb5f633bd8faa317b10285f1
size 14537034
oid sha256:18d492d912068e7fefef48006105d39c1c8f56aa756b7aeae48387c2254c1b91
size 7153239

4
bin/ivory.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:49b12bf8c0f9a436cc3e9178e327bbe07548cee061a0873f8eebca7f67446c78
size 9540091
oid sha256:f900509c3277b9eb194299605ce588f25dea6f92622748ced15554b7bb5914ce
size 1214375

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:a038ac924ebd1d68b415facbc75edf7af543a7ec8e9fe3382b1b343977c33296
size 17384333
oid sha256:04735cc4764f9a3e6c4fb5b046a6b9590664fe9f644578c58f3bc6acc911b723
size 9606039

30
nix/deps/ivory-header/builder.sh
View File

@ -1,13 +1,6 @@
source $stdenv/setup
set -ex
cleanup () {
echo "done"
}
trap cleanup EXIT
set -e
if ! [ -f "$IVORY" ]; then
echo "$IVORY doesn't exist"
@ -18,16 +11,19 @@ fi
# heuristics to confirm the ivory pill is valid
#
# greater than 10KB
#
if [ $(du -k $IVORY | cut -f1) -gt 10 ]; then
echo "$IVORY is less than 10KB"
fi
# first 7 bytes != "version" (start of an lfs pointer)
#
if [ "$(cat $(IVORY) | head -c 7)" = "version" ]; then
echo "$IVORY starts with 'version'; it's an LFS pointer"
if [ "$(head -c 7 "$IVORY")" = "version" ]; then
echo "$IVORY is an LFS pointer (it starts with 'version')"
echo "to fix, run: git lfs install"
exit 1
fi
# greater than 10KB
#
if ! [ $(du -k "$IVORY" | cut -f1) -gt 10 ]; then
echo "$IVORY is less than 10KB"
exit 1
fi
cat $IVORY > u3_Ivory.pill
@ -37,5 +33,3 @@ mkdir -p $out/include
mv ivory.h $out/include
rm u3_Ivory.pill
set +x

28
nix/ops/default.nix
View File

@ -2,10 +2,11 @@
let
tlon = import ../pkgs { inherit pkgs; };
arvo = tlon.arvo;
herb = tlon.herb;
urbit = if debug then tlon.urbit-debug else tlon.urbit;
tlon = import ../pkgs { inherit pkgs; };
arvo = tlon.arvo;
arvo-ropsten = tlon.arvo-ropsten;
herb = tlon.herb;
urbit = if debug then tlon.urbit-debug else tlon.urbit;
bootbrass = ../../bin/brass.pill;
bootsolid = ../../bin/solid.pill;
@ -17,6 +18,13 @@ let
arvo = null;
};
ropzod = import ./fakeship {
inherit pkgs herb urbit;
pill = bootsolid;
ship = "zod";
arvo = arvo-ropsten;
};
zod = import ./fakeship {
inherit pkgs herb urbit arvo;
pill = bootsolid;
@ -48,11 +56,23 @@ rec {
pier = zod;
};
brass-ropsten = import ./brass {
inherit pkgs herb urbit;
arvo = arvo-ropsten;
pier = ropzod;
};
ivory = import ./ivory {
inherit pkgs herb urbit arvo;
pier = zod;
};
ivory-ropsten = import ./ivory {
inherit pkgs herb urbit;
arvo = arvo-ropsten;
pier = ropzod;
};
image = import ./image {
inherit pkgs urbit;
pill = bootsolid;

39
nix/ops/image/default.nix
View File

@ -1,34 +1,7 @@
{ pkgs, urbit, pill }:
let
name = urbit.meta.name;
debug = urbit.meta.debug;
exe = ''${urbit.meta.exe} "$@"'';
coredump = ''
ulimit -c unlimited
${exe} || \
${pkgs.gdb}/bin/gdb -ex "thread apply all bt" -ex "set pagination 0" -batch \
${urbit.meta.bin} \
/tmp/cores/core*
'';
entrypoint = pkgs.writeScript "entrypoint.sh" ''
#!${pkgs.stdenv.shell}
set -euo pipefail
${pkgs.coreutils}/bin/ln -sf ${pill} /data/urbit.pill
${if debug then coredump else exe}
'';
in
pkgs.dockerTools.buildImage {
inherit name;
name = urbit.meta.name;
runAsRoot = ''
#!${pkgs.stdenv.shell}
@ -39,17 +12,21 @@ pkgs.dockerTools.buildImage {
${pkgs.dockerTools.shadowSetup}
mkdir -p /data /tmp/cores
mkdir -p /bin /share /data /tmp
${pkgs.coreutils}/bin/ln -sf ${pill} /share/urbit.pill
${pkgs.coreutils}/bin/ln -sf ${entrypoint} /bin/urbit
'';
config = {
Entrypoint = entrypoint;
Entrypoint = [ "urbit" ];
WorkingDir = "/data";
Env = [ "PATH=/bin" ];
Volumes = {
"/data" = {};
"/tmp" = {};
};
ExposedPorts = {

2
nix/ops/solid/builder.sh
View File

@ -34,6 +34,8 @@ cp $ARVO/app/dojo.hoon ./pier/home/app/ 2>/dev/null || true
cp $ARVO/lib/base64.hoon ./pier/home/lib/ 2>/dev/null || true
cp $ARVO/lib/server.hoon ./pier/home/lib/ 2>/dev/null || true
cp $ARVO/lib/sole.hoon ./pier/home/lib/ 2>/dev/null || true
cp $ARVO/lib/xray.hoon ./pier/home/lib/ 2>/dev/null || true
cp $ARVO/lib/pprint.hoon ./pier/home/lib/ 2>/dev/null || true
mkdir -p ./pier/home/mar/lens/
cp $ARVO/mar/lens/* ./pier/home/mar/lens/ 2>/dev/null || true

4
nix/ops/test/builder.sh
View File

@ -43,6 +43,10 @@ herb ./ship -d '+test, =seed `@uvI`(shaz %reproducible)' |
herb ./ship -p hood -d '+hood/mass'
herb ./ship -d '~& ~ ~& %start-pack ~'
herb ./ship -p hood -d '+hood/pack'
herb ./ship -d '~& ~ ~& %finish-pack ~'
shutdown
# Collect output

26
nix/pkgs/arvo-ropsten/builder.sh Normal file
View File

@ -0,0 +1,26 @@
source $stdenv/setup
cp -r $src tmp
chmod -R u+w tmp
ZUSE=tmp/sys/zuse.hoon
AMES=tmp/sys/vane/ames.hoon
ACME=tmp/app/acme.hoon
# replace the mainnet azimuth contract with the ropsten contract
sed --in-place \
's/\(\+\+ contracts \)mainnet\-contracts/\1ropsten-contracts/' \
$ZUSE
# increment the %ames protocol version
sed -r --in-place \
's_^(=/ protocol\-version=\?\(.*\) %)([0-7])_echo "\1$(echo "(\2+1) % 8" | bc)"_e' \
$AMES
# use the staging API in :acme
sed --in-place \
's_https://acme-v02.api.letsencrypt.org/directory_https://acme-staging-v02.api.letsencrypt.org/directory_' \
$ACME
cp -r tmp $out
chmod -R u+w $out

8
nix/pkgs/arvo-ropsten/default.nix Normal file
View File

@ -0,0 +1,8 @@
{ pkgs }:
pkgs.stdenv.mkDerivation {
name = "arvo-ropsten";
buildInputs = [ pkgs.bc ];
builder = ./builder.sh;
src = pkgs.buildRustCrateHelpers.exclude [ ".git" ] ../../../pkg/arvo;
}

3
nix/pkgs/arvo/default.nix
View File

@ -4,4 +4,7 @@ pkgs.stdenv.mkDerivation {
name = "arvo";
builder = ./builder.sh;
src = pkgs.buildRustCrateHelpers.exclude [ ".git" ] ../../../pkg/arvo;
meta = {
priority = 0;
};
}

3
nix/pkgs/default.nix
View File

@ -6,6 +6,7 @@ let
ent = import ./ent { inherit pkgs; };
arvo = import ./arvo { inherit pkgs; };
arvo-ropsten = import ./arvo-ropsten { inherit pkgs; };
herb = import ../../pkg/herb { inherit pkgs; };
ge-additions = import ./ge-additions {
@ -25,4 +26,4 @@ let
in
{ inherit ent ge-additions arvo herb urbit urbit-debug; }
{ inherit ent ge-additions arvo arvo-ropsten herb urbit urbit-debug; }

6
nix/pkgs/urbit/default.nix
View File

@ -12,8 +12,8 @@ let
meta = rec {
inherit debug;
bin = "${urbit}/bin/${name}";
flags = if debug then "-g" else "";
exe = "${meta.bin} ${meta.flags}";
flags = if debug then [ "-g" ] else [];
exe = ''${meta.bin} ${pkgs.lib.strings.concatStringsSep " " meta.flags}'';
};
deps =
@ -33,7 +33,7 @@ let
# See https://github.com/NixOS/nixpkgs/issues/18995
hardeningDisable = if debug then [ "all" ] else [];
CFLAGS = if debug then "-O3 -g -Werror" else "-O3 -Werror";
CFLAGS = "-O3 -g -Werror";
MEMORY_DEBUG = debug;
CPU_DEBUG = debug;
EVENT_TIME_DEBUG = false;

5
nix/pkgs/urbit/release.nix
View File

@ -20,8 +20,9 @@ let
in
env.make_derivation {
CFLAGS = if debug then "-O0 -g" else "-O3";
LDFLAGS = if debug then "" else "-s";
CFLAGS = if debug then "-O0 -g" else "-O3 -g";
# binary stripping disabled
# LDFLAGS = if debug then "" else "-s";
MEMORY_DEBUG = debug;
CPU_DEBUG = debug;
EVENT_TIME_DEBUG = false;

13
nix/release.nix
View File

@ -19,9 +19,13 @@ let
ge-additions = env:
import ./pkgs/ge-additions/cross.nix env;
urbit = env:
import ./pkgs/urbit/release.nix env
{ ent = ent env; ge-additions = ge-additions env; debug = false; name = "urbit"; };
urbit = { env, debug }:
import ./pkgs/urbit/release.nix env {
inherit debug;
name = if debug then "urbit-debug" else "urbit";
ent = ent env;
ge-additions = ge-additions env;
};
builds-for-platform = plat:
plat.deps // {
@ -29,7 +33,8 @@ let
inherit (plat.env) cmake_toolchain;
ent = ent plat;
ge-additions = ge-additions plat;
urbit = urbit plat;
urbit = urbit { env = plat; debug = false; };
urbit-debug = urbit { env = plat; debug = true; };
};
darwin_extra = {

221
pkg/arvo/app/acme.hoon
View File

@ -1,5 +1,5 @@
/- asn1, hall
/+ base64, der, primitive-rsa, *pkcs, *jose
/+ base64, der, primitive-rsa, *pkcs, *jose, default-agent, verb
=, eyre
=* rsa primitive-rsa
::
@ -141,24 +141,9 @@
:::: acme state
::
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%serve wire =binding:eyre =generator:eyre]
[%http-response =http-event:http]
[%poke wire dock poke]
[%request wire request:http outbound-config:iris]
[%rule wire %cert (unit [wain wain])]
[%wait wire @da]
==
:: +poke: outgoing app pokes
::
+$ poke
$% [%hall-action %phrase audience:hall (list speech:hall)]
==
+$ card card:agent:gall
:: +nonce-next: next effect to emit upon receiving nonce
::
+$ nonce-next
@ -337,6 +322,69 @@
challenges=(set @t)
==
--
=| acme
=* state -
=<
%+ verb |
|_ =bowl:gall
+* this .
acme-core +>
ac ~(. acme-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
=/ =binding:eyre
[~ /'.well-known'/acme-challenge]
=/ =generator:eyre
[q.byk.bowl /gen/acme/domain-validation/hoon ~]
=/ =card
[%pass /acme %arvo %e %serve binding generator]
[[card ~] this]
::
++ on-save !>(state)
++ on-load |=(old=vase `this(state !<(acme old)))
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%acme-order (poke-acme-order:ac !<((set turf) vase))
%noun (poke-noun:ac !<(* vase))
%path (poke-path:ac !<(path vase))
==
[cards this]
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit [%noun vase]))
?+ path ~
[%x %domain-validation @t ~]
=* token i.t.t.path
:^ ~ ~ %noun !>
?. (~(has in challenges) token)
~
(some (rap 3 [token '.' (pass:thumb:jwk key.act) ~]))
==
::
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%acme *]
?+ +<.sign-arvo (on-arvo:def wire sign-arvo)
%http-response (http-response:ac wire +>.sign-arvo)
%wake (wake:ac wire +>.sign-arvo)
%bound (bound:ac wire +>.sign-arvo)
==
==
[cards this]
::
++ on-fail on-fail:def
--
::
:::: acme app
::
@ -345,26 +393,33 @@
=/ directory-base=purl
=- (need (de-purl:html -))
'https://acme-v02.api.letsencrypt.org/directory'
:: mov: list of outgoing moves for the current transaction
:: cards: list of outgoing moves for the current transaction
::
=| mov=(list move)
=| cards=(list card)
::
|_ [bow=bowl:gall acme]
|_ bow=bowl:gall
:: +this: self
::
:: XX Should be a +* core alias, see urbit/arvo#712
::
++ this .
:: +emit: emit a move
:: +emit: emit a card
::
++ emit
|= car=card
this(mov [[ost.bow car] mov])
this(cards [car cards])
:: +emil: emit a list of cards
::
++ emil
|= rac=(list card)
|- ^+ this
?~ rac
this
=. cards [i.rac cards]
$(rac t.rac)
:: +abet: finalize transaction
::
++ abet
^- (quip move _this)
[(flop mov) this(mov ~)]
^- (quip card _state)
[(flop cards) state]
:: +backoff: calculate exponential backoff
::
++ backoff
@ -380,24 +435,21 @@
|= [try=@ud act=@tas =wire]
^- ^wire
(weld /acme/try/(scot %ud try)/[act] wire)
:: +notify: send :hall notification
:: +notify: send notification message
::
++ notify
|= [=cord =tang]
^- card
=/ msg=speech:hall
:+ %app dap.bow
=/ line [%lin & cord]
?~(tang line [%fat [%tank tang] line])
=/ act
[%phrase (sy [our.bow %inbox] ~) [msg ~]]
[%poke / [our.bow %hall] %hall-action act]
^- (list card)
:- [%pass / %arvo %d %flog %text :(weld (trip dap.bow) ": " (trip cord))]
%+ turn
`wall`(zing (turn (flop tang) (cury wash [0 80])))
|=(=tape [%pass / %arvo %d %flog %text tape])
:: +request: unauthenticated http request
::
++ request
|= [wir=wire req=hiss]
^- card
[%request wir (hiss-to-request:html req) *outbound-config:iris]
[%pass wir %arvo %i %request (hiss-to-request:html req) *outbound-config:iris]
:: +signed-request: JWS JSON POST
::
++ signed-request
@ -460,7 +512,7 @@
:: too many certificates for these domains
::
?: ?=(^ (find "already issued for exact" detail))
=. ..this (retry:effect try act spur ~d7)
=. ..emit (retry:effect try act spur ~d7)
=/ msg=cord
%+ rap 3
:~ 'rate limit exceeded: '
@ -472,11 +524,11 @@
(join-turf ~(tap in dom.u.rod))
'. retrying in ~d7.'
==
(emit (notify msg ~))
(emil (notify msg ~))
:: too many certificates for top-level-domain
::
?: ?=(^ (find "too many certificates already" detail))
=. ..this (retry:effect try act spur ~d7)
=. ..emit (retry:effect try act spur ~d7)
=/ lul=@dr
(add ~d7 (mul ~m1 (~(rad og eny.bow) (bex 10))))
=/ msg=cord
@ -489,7 +541,7 @@
'. retrying in '
(scot %dr lul) '.'
==
(emit (notify msg ~))
(emil (notify msg ~))
:: XX match more rate-limit conditions
:: or backoff by wire
::
@ -616,11 +668,11 @@
::
=/ msg=cord
(cat 3 'retrying certificate request in ' (scot %dr lul))
=. ..this (emit (notify msg ~))
=. ..this (retry:effect try %new-order / lul)
=. ..emit (emil (notify msg ~))
=. ..emit (retry:effect try %new-order / lul)
:: domains might already be validated
::
=. ..this (queue-next-order +(try.order) & dom.order)
=. ..emit (queue-next-order +(try.order) & dom.order)
cancel-current-order
:: +finalize-order: finalize completed order
::
@ -672,7 +724,7 @@
~| %install-effect-fail
?> ?=(^ liv)
=/ key=wain (ring:en:pem:pkcs8 key.u.liv)
(emit %rule /install %cert `[key `wain`cer.u.liv])
(emit %pass /install %arvo %e %rule %cert `[key `wain`cer.u.liv])
:: +get-authz: get next ACME service domain authorization object
::
++ get-authz
@ -736,7 +788,7 @@
|= [try=@ud act=@tas =wire lull=@dr]
:: XX validate wire
::
(emit %wait (acme-wire +(try) act wire) (add now.bow lull))
(emit %pass (acme-wire +(try) act wire) %arvo %b %wait (add now.bow lull))
--
:: |event: accept event, emit next effect(s)
::
@ -774,7 +826,7 @@
:~ 'unable to reach ' (scot %p our.bow)
' via http at ' (en-turf:html turf.i.item) ':80'
==
(emit(next-order ~) (notify msg [(sell !>(rep)) ~]))
(emil(next-order ~) (notify msg [(sell !>(rep)) ~]))
?: ?=(~ (skip ~(val by dom.u.next-order) |=([@ud valid=?] valid)))
new-order:effect
(validate-domain:effect +(idx))
@ -786,7 +838,7 @@
?. =(200 p.rep)
?: (lth try 10)
(retry:effect try %directory / (min ~m30 (backoff try)))
(emit (notify (failure-message directory-base) [(sell !>(rep)) ~]))
(emil (notify (failure-message directory-base) [(sell !>(rep)) ~]))
=. dir (directory:grab (need (de-json:html q:(need r.rep))))
?~(reg.act register:effect this)
:: +nonce: accept new nonce and trigger next effect
@ -805,7 +857,7 @@
?. =(204 p.rep)
?: (lth try 10)
(retry:effect try %nonce t.wire (min ~m30 (backoff try)))
(emit (notify (failure-message nonce.dir) [(sell !>(rep)) ~]))
(emil (notify (failure-message nonce.dir) [(sell !>(rep)) ~]))
?- nex
%register register:effect
%new-order new-order:effect
@ -822,7 +874,7 @@
::
?: (lth try 10)
(retry:effect try %register / (min ~h1 (backoff try)))
(emit (notify (failure-message register.dir) [(sell !>(rep)) ~]))
(emil (notify (failure-message register.dir) [(sell !>(rep)) ~]))
=/ loc=@t
q:(head (skim q.rep |=((pair @t @t) ?=(%location p))))
:: XX @da once parser is fixed
@ -852,7 +904,7 @@
(retry:effect try %new-order / (min ~h1 (backoff try)))
:: XX next steps, retrying in ??
::
(emit (notify (failure-message register.dir) [(sell !>(rep)) ~]))
(emil (notify (failure-message register.dir) [(sell !>(rep)) ~]))
?> ?=(^ next-order)
=/ loc=@t
q:(head (skim q.rep |=((pair @t @t) ?=(%location p))))
@ -902,7 +954,7 @@
(retry:effect try %check-order / (min ~m10 (backoff try)))
:: XX next steps, retrying in, delete order ??
::
(emit (notify (failure-message ego.u.rod) [(sell !>(rep)) ~]))
(emil (notify (failure-message ego.u.rod) [(sell !>(rep)) ~]))
=/ bod=order:body
(order:grab (need (de-json:html q:(need r.rep))))
?+ sas.bod
@ -916,7 +968,7 @@
:: XX possible to retry any reasons?
::
=< cancel-order:effect
(emit (notify 'certificate order failed' [(sell !>(rep)) ~]))
(emil (notify 'certificate order failed' [(sell !>(rep)) ~]))
:: initial order state
::
%pending
@ -958,7 +1010,7 @@
:~ 'unable to download certificate. '
'please confirm that your urbit has network connectivity.'
==
(emit (notify msg [(sell !>(rep)) ~]))
(emil (notify msg [(sell !>(rep)) ~]))
=/ cer=wain (to-wain:format q:(need r.rep))
=/ fig=config
:: XX expiration date
@ -978,7 +1030,7 @@
:~ 'received https certificate for '
(join-turf ~(tap in dom.u.liv))
==
(emit (notify msg ~))
(emil (notify msg ~))
:: set renewal timer, install certificate in %eyre
::
:: Certificates expire after ~d90. We want time for retries and
@ -1009,7 +1061,7 @@
(retry:effect try %get-authz / (min ~m10 (backoff try)))
:: XX next steps, retrying in ??
::
(emit (notify (failure-message i.pending.aut.u.rod) [(sell !>(rep)) ~]))
(emil (notify (failure-message i.pending.aut.u.rod) [(sell !>(rep)) ~]))
=/ bod=auth:body
(auth:grab (need (de-json:html q:(need r.rep))))
=/ cal=trial
@ -1054,7 +1106,7 @@
'via ' (en-turf:html dom.aut) '. '
'please confirm your urbit has network connectivity.'
==
(emit (notify msg [(sell !>(rep)) ~]))
(emil (notify msg [(sell !>(rep)) ~]))
=/ bod
%- as-octs:mimes:html
(rap 3 [tok.cal.aut '.' (pass:thumb:jwk key.act) ~])
@ -1069,7 +1121,7 @@
(sell !>((some bod)))
leaf+"expected:"
==
(emit (notify 'domain validation value is wrong' tang))
(emil (notify 'domain validation value is wrong' tang))
finalize-trial:effect
:: +finalize-trial:
::
@ -1091,7 +1143,7 @@
(retry:effect try %finalize-trial / (min ~m10 (backoff try)))
:: XX next steps, check connectivity, etc. ??
::
(emit (notify (failure-message ego.cal.aut) [(sell !>(rep)) ~]))
(emil (notify (failure-message ego.cal.aut) [(sell !>(rep)) ~]))
:: XX get challenge, confirm urn:ietf:params:acme:error:connection
::
:: =/ err=error:body
@ -1101,7 +1153,7 @@
=< cancel-order:effect
=/ msg=cord
'unable to finalize domain validation challenge'
(emit (notify msg [(sell !>(rep)) ~]))
(emil (notify msg [(sell !>(rep)) ~]))
=/ bod=challenge:body
(challenge:grab (need (de-json:html q:(need r.rep))))
:: XX check for other possible values in 200 response
@ -1146,11 +1198,11 @@
--
++ http-response
|= [=wire response=client-response:iris]
^- (quip move _this)
^- (quip card _state)
:: ignore progress reports
::
?: ?=(%progress -.response)
[~ this]
[~ state]
::
?> ?=([%acme ^] wire)
=< abet
@ -1202,26 +1254,11 @@
:: XX delete-trial?
::
==
:: +peek: read from app state
::
++ peek
|= =path
^- (unit (unit [%noun (unit @t)]))
?+ path
~
::
[%x %domain-validation @t ~]
=* token i.t.t.path
:^ ~ ~ %noun
?. (~(has in challenges) token)
~
(some (rap 3 [token '.' (pass:thumb:jwk key.act) ~]))
==
:: +wake: timer wakeup event
::
++ wake
|= [wir=wire error=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?^ error
%- (slog u.error)
abet
@ -1236,7 +1273,7 @@
::
++ poke-noun
|= a=*
^- (quip move _this)
^- (quip card _state)
=< abet
?+ a
this
@ -1270,7 +1307,7 @@
=/ bas=path /(scot %p our.bow)/home/(scot %da now.bow)/acme
=/ key=wain .^(wain %cx (weld bas /privkey/pem))
=/ cer=wain .^(wain %cx (weld bas /cert/pem))
(emit %rule /install %cert `[key cer])
(emit %pass /install %arvo %e %rule %cert `[key cer])
::
%init
init
@ -1288,30 +1325,16 @@
::
++ poke-path
|=(a=path abet:(add-order (sy a ~)))
:: +prep: initialize and adapt state
::
++ prep
|= old=(unit acme)
^- (quip move _this)
?~ old
=/ =binding:eyre
[~ /'.well-known'/acme-challenge]
=/ =generator:eyre
[q.byk.bow /gen/acme/domain-validation/hoon ~]
=/ =move
[ost.bow %serve /acme binding generator]
[[move ~] this]
[~ this(+<+ u.old)]
:: +bound: response to %serve binding request
::
++ bound
|= [=wire accepted=? =binding:eyre]
?: accepted
[~ this]
[~ state]
:: XX better error message
::
~& [%acme-http-path-binding-failed +<]
[~ this]
[~ state]
:: +rekey: create new 2.048 bit RSA key
::
:: XX do something about this iteration
@ -1373,17 +1396,17 @@
~|(%acme-empty-certificate-order !!)
?: ?=(?(%earl %pawn) (clan:title our.bow))
this
=. ..this (queue-next-order 1 | dom)
=. ..this cancel-current-order
=. ..emit (queue-next-order 1 | dom)
=. ..emit cancel-current-order
:: notify :hall
::
=. ..this
=. ..emit
=/ msg=cord
%+ rap 3
:~ 'requesting an https certificate for '
(join-turf ~(tap in dom))
==
(emit (notify msg ~))
(emil (notify msg ~))
:: if registered, create order
::
?^ reg.act

83
pkg/arvo/app/aqua-ames.hoon
View File

@ -1,83 +0,0 @@
:: This needs a better SDN solution. Every ship should have an IP
:: address, and we should eventually test changing those IP
:: addresses.
::
:: For now, we broadcast every packet to every ship and rely on them
:: to drop them.
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
==
::
+$ state
$: %0
subscribed=_|
==
--
=, gall
=| moves=(list move)
=| aqua-event-list=(list aqua-event)
=| ships=(list ship)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~, aqua-event-list ~, ships ~)
++ abet
=? this !=(~ aqua-event-list)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aqua-event-list]~
:: ~? !?=(~ moves) [%aqua-ames-moves (lent moves)]
[moves this]
::
++ emit-moves
|= ms=(list move)
%_(this moves (weld moves ms))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%_(this aqua-event-list (weld aqua-event-list aes))
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
:: Handle effects from ships. We only react to %send effects.
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%restore (handle-restore who.afs)
%send (handle-send i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
++ handle-restore
|= who=@p
%- emit-aqua-events
[%event who [//newt/0v1n.2m9vh %barn ~]]~
::
++ handle-send
|= [way=wire %send lan=lane:ames pac=@]
^+ this
=/ hear [//newt/0v1n.2m9vh %hear lan pac]
=? ships =(~ ships)
.^((list ship) %gx /(scot %p our)/aqua/(scot %da now)/ships/noun)
%- emit-aqua-events
%+ turn ships
|= who=ship
[%event who hear]
--

131
pkg/arvo/app/aqua-behn.hoon
View File

@ -1,131 +0,0 @@
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
[%wait wire p=@da]
[%rest wire p=@da]
==
::
+$ state
$: %0
subscribed=_|
piers=(map ship pier)
==
::
+$ pier next-timer=(unit @da)
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%sleep abet-pe:handle-sleep:(pe who.afs)
%restore abet-pe:handle-restore:(pe who.afs)
%doze abet-pe:(handle-doze:(pe who.afs) i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
:: Received timer wake
::
++ wake
|= [way=wire error=(unit tang)]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
abet-pe:(take-wake:(pe who) t.way error)
::
++ pe
|= who=ship
=+ (~(gut by piers) who *pier)
=* pier-data -
|%
++ abet-pe
^+ this
=. piers (~(put by piers) who pier-data)
this
::
++ handle-sleep
^+ ..abet-pe
=< ..abet-pe(pier-data *pier)
?~ next-timer
..abet-pe
cancel-timer
::
++ handle-restore
^+ ..abet-pe
=. this
%- emit-aqua-events
[%event who [//behn/0v1n.2m9vh %born ~]]~
..abet-pe
::
++ handle-doze
|= [way=wire %doze tim=(unit @da)]
^+ ..abet-pe
?~ tim
?~ next-timer
..abet-pe
cancel-timer
?~ next-timer
(set-timer u.tim)
(set-timer:cancel-timer u.tim)
::
++ set-timer
|= tim=@da
~? debug=| [who=who %setting-timer tim]
=. next-timer `tim
=. this (emit-moves [ost %wait /(scot %p who) tim]~)
..abet-pe
::
++ cancel-timer
~? debug=| [who=who %cancell-timer (need next-timer)]
=. this (emit-moves [ost %rest /(scot %p who) (need next-timer)]~)
=. next-timer ~
..abet-pe
::
++ take-wake
|= [way=wire error=(unit tang)]
~? debug=| [who=who %aqua-behn-wake now error=error]
=. next-timer ~
=. this
%- emit-aqua-events
:_ ~
^- aqua-event
:+ %event who
:- //behn/0v1n.2m9vh
?~ error
[%wake ~]
[%crud %fail u.error]
..abet-pe
--
--

78
pkg/arvo/app/aqua-dill.hoon
View File

@ -1,78 +0,0 @@
:: Would love to see a proper stateful terminal handler. Ideally,
:: you'd be able to ^X into the virtual ship, like the old ^W.
::
:: However, that's probably not the primary way of interacting with
:: it. In practice, most of the time you'll be running from a file
:: (eg for automated testing) or fanning the same command to multiple
:: ships or otherwise making use of the fact that we can
:: programmatically send events.
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
==
::
+$ state
$: %0
subscribed=_|
==
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%blit (handle-blit who.afs i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
++ handle-blit
|= [who=@p way=wire %blit blits=(list blit:dill)]
^+ this
=/ last-line
%+ roll blits
|= [b=blit:dill line=tape]
?- -.b
%lin (tape p.b)
%mor ~& "{<who>}: {line}" ""
%hop line
%bel line
%clr ""
%sag ~& [%save-jamfile-to p.b] line
%sav ~& [%save-file-to p.b] line
%url ~& [%activate-url p.b] line
==
~? !=(~ last-line) last-line
this
--

157
pkg/arvo/app/aqua-eyre.hoon
View File

@ -1,157 +0,0 @@
:: Pass-through Eyre driver
::
/- aquarium
=, aquarium
=> |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock %aqua-events (list aqua-event)]
[%peer wire dock path]
[%pull wire dock ~]
[%hiss wire p=(unit user:eyre) q=mark r=(cask hiss:eyre)]
==
::
+$ state
$: %0
subscribed=_|
piers=(map ship pier)
==
::
+$ pier http-requests=(set @ud)
--
=, gall
=| moves=(list move)
|_ $: bowl
state
==
++ this .
++ apex %_(this moves ~)
++ abet [(flop moves) this]
++ emit-moves
|= ms=(list move)
%_(this moves (weld ms moves))
::
++ emit-aqua-events
|= aes=(list aqua-event)
%- emit-moves
[ost %poke /aqua-events [our %aqua] %aqua-events aes]~
::
++ poke-aqua-vane-control
|= command=?(%subscribe %unsubscribe)
:_ this(subscribed =(command %subscribe))
(aqua-vane-control-handler our ost subscribed command)
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
=. this apex =< abet
|- ^+ this
?~ ufs.afs
this
=. this
?+ -.q.i.ufs.afs this
%sleep abet-pe:handle-sleep:(pe who.afs)
%restore abet-pe:handle-restore:(pe who.afs)
%thus abet-pe:(handle-thus:(pe who.afs) i.ufs.afs)
==
$(ufs.afs t.ufs.afs)
::
:: Received inbound HTTP response
::
++ sigh-httr
|= [way=wire res=httr:eyre]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
~& [%received-httr who]
abet-pe:(take-sigh-httr:(pe who) t.way res)
::
:: Received inbound HTTP response error
::
++ sigh-tang
|= [way=wire tan=tang]
^- (quip move _this)
=. this apex =< abet
?> ?=([@ *] way)
=/ who (,@p (slav %p i.way))
~& [%received-httr who]
abet-pe:(take-sigh-tang:(pe who) t.way tan)
::
++ pe
|= who=ship
=+ (~(gut by piers) who *pier)
=* pier-data -
|%
++ abet-pe
^+ this
=. piers (~(put by piers) who pier-data)
this
::
++ handle-sleep
^+ ..abet-pe
..abet-pe(pier-data *pier)
::
++ handle-restore
^+ ..abet-pe
=. this
%- emit-aqua-events
[%event who [//http/0v1n.2m9vh %born ~]]~
..abet-pe
::
++ handle-thus
|= [way=wire %thus num=@ud req=(unit hiss:eyre)]
^+ ..abet-pe
?~ req
?. (~(has in http-requests) num)
..abet-pe
:: Eyre doesn't support cancelling HTTP requests from userspace,
:: so we remove it from our state so we won't pass along the
:: response.
::
~& [who=who %aqua-eyre-cant-cancel-thus num=num]
=. http-requests (~(del in http-requests) num)
..abet-pe
~& [who=who %aqua-eyre-requesting u.req]
=. http-requests (~(put in http-requests) num)
=. this
%- emit-moves :_ ~
:* ost
%hiss
/(scot %p who)/(scot %ud num)
~
%httr
[%hiss u.req]
==
..abet-pe
::
:: Pass HTTP response back to virtual ship
::
++ take-sigh-httr
|= [way=wire res=httr:eyre]
^+ ..abet-pe
?> ?=([@ ~] way)
=/ num (slav %ud i.way)
?. (~(has in http-requests) num)
~& [who=who %ignoring-httr num=num]
..abet-pe
=. http-requests (~(del in http-requests) num)
=. this
(emit-aqua-events [%event who [//http/0v1n.2m9vh %receive num [%start [p.res q.res] r.res &]]]~)
..abet-pe
::
:: Got error in HTTP response
::
++ take-sigh-tang
|= [way=wire tan=tang]
^+ ..abet-pe
?> ?=([@ ~] way)
=/ num (slav %ud i.way)
?. (~(has in http-requests) num)
~& [who=who %ignoring-httr num=num]
..abet-pe
=. http-requests (~(del in http-requests) num)
%- (slog tan)
..abet-pe
--
--

311
pkg/arvo/app/aqua.hoon
View File

@ -21,23 +21,10 @@
:: We get ++unix-event and ++pill from /-aquarium
::
/- aquarium
/+ pill
/+ pill, default-agent
=, pill-lib=pill
=, aquarium
=> $~ |%
+$ move (pair bone card)
+$ card
$% [%diff diff-type]
==
::
:: Outgoing subscription updates
::
+$ diff-type
$% [%aqua-effects aqua-effects]
[%aqua-events aqua-events]
[%aqua-boths aqua-boths]
==
::
+$ state
$: %0
pil=pill
@ -54,7 +41,60 @@
processing-events=?
==
--
=, gall
::
=| state
=* all-state -
=<
^- agent:gall
|_ =bowl:gall
+* this .
aqua-core +>
ac ~(. aqua-core bowl)
def ~(. (default-agent this %|) bowl)
++ on-init `this
++ on-save !>(all-state)
++ on-load
|= old-state=vase
^- step:agent:gall
~& prep=%aqua
=+ new=((soft state) !<(* old-state))
?~ new
`this
`this(all-state u.new)
::
++ on-poke
|= [=mark =vase]
^- step:agent:gall
=^ cards all-state
?+ mark ~|([%aqua-bad-mark mark] !!)
%aqua-events (poke-aqua-events:ac !<((list aqua-event) vase))
%pill (poke-pill:ac !<(pill vase))
%noun (poke-noun:ac !<(* vase))
==
[cards this]
::
++ on-watch
|= =path
^- step:agent:gall
?: ?=([?(%effects %effect) ~] path)
`this
?: ?=([%effect @ ~] path)
`this
?. ?=([?(%effects %effect %evens %boths) @ ~] path)
~| [%aqua-bad-subscribe-path path]
!!
?~ (slaw %p i.t.path)
~| [%aqua-bad-subscribe-path-ship path]
!!
`this
::
++ on-leave on-leave:def
++ on-peek peek:ac
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
:: unix-{effects,events,boths}: collect jar of effects and events to
:: brodcast all at once to avoid gall backpressure
@ -63,10 +103,8 @@
=| unix-effects=(jar ship unix-effect)
=| unix-events=(jar ship unix-timed-event)
=| unix-boths=(jar ship unix-both)
=| moves=(list move)
|_ $: hid=bowl
state
==
=| cards=(list card:agent:gall)
|_ hid=bowl:gall
::
:: Represents a single ship's state.
::
@ -99,11 +137,11 @@
=. next-events (~(gas to next-events) ues)
..abet-pe
::
:: Send moves to host arvo
:: Send cards to host arvo
::
++ emit-moves
|= ms=(list move)
=. this (^emit-moves ms)
++ emit-cards
|= ms=(list card:agent:gall)
=. this (^emit-cards ms)
..abet-pe
::
:: Process the events in our queue.
@ -200,7 +238,7 @@
::
++ apex-aqua
^+ this
=: moves ~
=: cards ~
unix-effects ~
unix-events ~
unix-boths ~
@ -208,46 +246,63 @@
this
::
++ abet-aqua
^- (quip move _this)
^- (quip card:agent:gall state)
=. this
%- emit-moves
%- zing ^- (list (list move))
%+ turn ~(tap by sup.hid)
|= [b=bone her=ship pax=path]
^- (list move)
?+ pax ~
[%effects @ ~]
=/ who (slav %p i.t.pax)
=/ ufs (~(get ja unix-effects) who)
?~ ufs
~
[b %diff %aqua-effects who (flop ufs)]~
::
[%effects ~]
%+ turn
~(tap by unix-effects)
|= [who=ship ufs=(list unix-effect)]
[b %diff %aqua-effects who (flop ufs)]
::
[%events @ ~]
=/ who (slav %p i.t.pax)
=/ ve (~(get ja unix-events) who)
?~ ve
~
[b %diff %aqua-events who (flop ve)]~
::
[%boths @ ~]
=/ who (slav %p i.t.pax)
=/ bo (~(get ja unix-boths) who)
?~ bo
~
[b %diff %aqua-boths who (flop bo)]~
=/ =path /effect
%- emit-cards
%- zing
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
%- zing
%+ turn ufs
|= uf=unix-effect
:~ [%give %fact `/effect %aqua-effect !>(`aqua-effect`[ship uf])]
[%give %fact `/effect/[-.q.uf] %aqua-effect !>(`aqua-effect`[ship uf])]
==
[(flop moves) this]
::
=. this
=/ =path /effects
%- emit-cards
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
[%give %fact `path %aqua-effects !>(`aqua-effects`[ship (flop ufs)])]
::
=. this
%- emit-cards
%- zing
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
=/ =path /effect/(scot %p ship)
%+ turn ufs
|= uf=unix-effect
[%give %fact `path %aqua-effect !>(`aqua-effect`[ship uf])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-effects)
|= [=ship ufs=(list unix-effect)]
=/ =path /effects/(scot %p ship)
[%give %fact `path %aqua-effects !>(`aqua-effects`[ship (flop ufs)])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-events)
|= [=ship ve=(list unix-timed-event)]
=/ =path /events/(scot %p ship)
[%give %fact `path %aqua-events !>(`aqua-events`[ship (flop ve)])]
::
=. this
%- emit-cards
%+ turn ~(tap by unix-boths)
|= [=ship bo=(list unix-both)]
=/ =path /boths/(scot %p ship)
[%give %fact `path %aqua-boths !>(`aqua-boths`[ship (flop bo)])]
::
[(flop cards) all-state]
::
++ emit-moves
|= ms=(list move)
=. moves (weld ms moves)
++ emit-cards
|= ms=(list card:agent:gall)
=. cards (weld ms cards)
this
::
::
@ -269,51 +324,12 @@
=. this abet-pe:plow:(pe u.who)
$
::
:: Subscribe to effects from a ship
::
++ peer-effects
|= pax=path
^- (quip move _this)
?. ?=([@ *] pax)
~& [%aqua-bad-peer-effects pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-effects-ship pax]
!!
`this
::
:: Subscribe to events to a ship
::
++ peer-events
|= pax=path
^- (quip move _this)
?. ?=([@ ~] pax)
~& [%aqua-bad-peer-events pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-events-ship pax]
!!
`this
::
:: Subscribe to both events and effects of a ship
::
++ peer-boths
|= pax=path
^- (quip move _this)
?. ?=([@ ~] pax)
~& [%aqua-bad-peer-boths pax]
`this
?~ (slaw %p i.pax)
~& [%aqua-bad-peer-boths-ship pax]
!!
`this
::
:: Load a pill and assemble arvo. Doesn't send any of the initial
:: events.
::
++ poke-pill
|= p=pill
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
=. pil p
~& lent=(met 3 (jam boot-ova.pil))
@ -344,7 +360,7 @@
::
++ poke-noun
|= val=*
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
^+ this
:: Could potentially factor out the three lines of turn-ships
@ -355,8 +371,8 @@
?> ?=([[%7 * %1 installed=*] ~] boot-ova.pil)
=. installed.boot-ova.pil
%+ roll (,(list term) vs.val)
|= [v=term _installed.boot-ova.pil]
%^ slum installed.boot-ova.pil now.hid
|= [v=term =_installed.boot-ova.pil]
%^ slum installed now.hid
=/ vane
?+ v ~|([%unknown-vane v] !!)
%a %ames
@ -367,25 +383,26 @@
%f %ford
%g %gall
%j %jael
%g %gall
==
=/ pax
/(scot %p our.hid)/home/(scot %da now.hid)/sys/vane/[vane]
=/ txt .^(@ %cx (weld pax /hoon))
[/vane/[vane] [%veer v pax txt]]
=> .(this ^+(this this))
=^ ms this (poke-pill pil)
(emit-moves ms)
=^ ms all-state (poke-pill pil)
(emit-cards ms)
::
[%swap-files ~]
=. userspace-ova.pil
=/ slim-dirs
`(list path)`~[/app /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
=/ slim-dirs=(list path)
~[/app /ted /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
:_ ~
%- unix-event
%- %*(. file-ovum:pill-lib directories slim-dirs)
/(scot %p our.hid)/home/(scot %da now.hid)
=^ ms this (poke-pill pil)
(emit-moves ms)
=^ ms all-state (poke-pill pil)
(emit-cards ms)
::
[%wish hers=* p=@t]
%+ turn-ships ((list ship) hers.val)
@ -414,7 +431,7 @@
::
++ poke-aqua-events
|= events=(list aqua-event)
^- (quip move _this)
^- (quip card:agent:gall state)
=. this apex-aqua =< abet-aqua
%+ turn-events events
|= [ae=aqua-event thus=_this]
@ -428,7 +445,7 @@
^- (list unix-event)
:~ [/ %wack 0] :: eny
[/ %whom who.ae] :: eny
[//newt/0v1n.2m9vh %barn ~]
[//newt/0v1n.2m9vh %born ~]
[//behn/0v1n.2m9vh %born ~]
:^ //term/1 %boot &
?~ keys.ae
@ -514,63 +531,23 @@
::
:: Check whether we have a snapshot
::
++ peek-x-fleet-snap
|= pax=path
^- (unit (unit [%noun noun]))
?. ?=([@ ~] pax)
~
:^ ~ ~ %noun
(~(has by fleet-snaps) i.pax)
::
:: Pass scry into child ship
::
++ peek-x-i
|= pax=path
^- (unit (unit [%noun noun]))
?. ?=([@ @ @ @ @ *] pax)
~
=/ who (slav %p i.pax)
=/ pier (~(get by piers) who)
?~ pier
~
:^ ~ ~ %noun
(peek:(pe who) t.pax)
::
:: Get all created ships
::
++ peek-x-ships
|= pax=path
^- (unit (unit [%noun (list ship)]))
?. ?=(~ pax)
~
:^ ~ ~ %noun
`(list ship)`(turn ~(tap by piers) head)
::
::
::
++ peek-x-pill
|= pax=path
^- (unit (unit [%pill pill]))
=/ pill-size (met 3 (jam pil))
?: (lth pill-size 100)
~& [%no-pill size=pill-size]
[~ ~]
``pill+pil
++ peek
|= =path
^- (unit (unit cage))
?+ path ~
[%x %fleet-snap @ ~] ``noun+!>((~(has by fleet-snaps) i.t.t.path))
[%x %ships ~] ``noun+!>((turn ~(tap by piers) head))
[%x %pill ~] ``pill+!>(pil)
[%x %i @ @ @ @ @ *]
=/ who (slav %p i.t.t.path)
=/ pier (~(get by piers) who)
?~ pier
~
:^ ~ ~ %noun !>
(peek:(pe who) t.t.t.path)
==
::
:: Trivial scry for mock
::
++ scry |=([* *] ~)
::
:: Throw away old state if it doesn't soft to new state.
::
++ prep
|= old/(unit noun)
^- [(list move) _+>.$]
~& prep=%aqua
?~ old
`+>.$
=+ new=((soft state) u.old)
?~ new
`+>.$
`+>.$(+<+ u.new)
--

563
pkg/arvo/app/azimuth-tracker.hoon
View File

@ -1,426 +1,165 @@
/+ tapp, stdio
/- eth-watcher
/+ default-agent, verb
=, able:jael
=> |%
+$ pending-udiffs (map number:block udiffs:point)
+$ app-state
$: %2
url=@ta
=number:block
=pending-udiffs
blocks=(list block)
whos=(set ship)
|%
++ app-state
$: %0
url=@ta
whos=(set ship)
==
+$ poke-data
$% :: %listen
::
[%listen whos=(list ship) =source:jael]
:: %watch: configure node url
::
[%watch url=@ta]
==
--
::
|%
++ topics
|= ships=(set ship)
^- (list ?(@ux (list @ux)))
:: The first topic should be one of these event types
::
:- => azimuth-events:azimuth
:~ broke-continuity
changed-keys
lost-sponsor
escape-accepted
==
+$ peek-data ~
+$ in-poke-data
$: %azimuth-tracker-poke
$% [%listen whos=(list ship) =source:jael]
[%watch url=@ta]
==
==
+$ out-poke-data ~
+$ in-peer-data ~
+$ out-peer-data
[%azimuth-udiff =ship =udiff:point]
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
--
:: If we're looking for a specific set of ships, specify them as
:: the second topic. Otherwise don't specify the second topic so
:: we will match all ships.
::
?: =(~ ships)
~
[(turn ~(tap in ships) ,@) ~]
::
:: Async helpers
++ event-logs-to-udiffs
|= event-logs=(list =event-log:rpc:ethereum)
^- =udiffs:point
%+ murn event-logs
|= =event-log:rpc:ethereum
^- (unit [=ship =udiff:point])
?~ mined.event-log
~
?: removed.u.mined.event-log
~& [%removed-log event-log]
~
=/ =id:block [block-hash block-number]:u.mined.event-log
=, azimuth-events:azimuth
=, abi:ethereum
?: =(broke-continuity i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=/ num=@ (decode-results data.event-log ~[%uint])
`[who id %rift num]
?: =(changed-keys i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=+ ^- [enc=octs aut=octs sut=@ud rev=@ud]
%+ decode-results data.event-log
~[[%bytes-n 32] [%bytes-n 32] %uint %uint]
`[who id %keys rev sut (pass-from-eth:azimuth enc aut sut)]
?: =(lost-sponsor i.topics.event-log)
=+ ^- [who=@ pos=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon ~]
?: =(escape-accepted i.topics.event-log)
=+ ^- [who=@ wer=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon `wer]
~& [%bad-topic event-log]
~
::
=> |%
++ topics
|= ships=(set ship)
^- (list ?(@ux (list @ux)))
:: The first topic should be one of these event types
::
:- => azimuth-events:azimuth
:~ broke-continuity
changed-keys
lost-sponsor
escape-accepted
==
:: If we're looking for a specific set of ships, specify them as
:: the second topic. Otherwise don't specify the second topic so
:: we will match all ships.
::
?: =(~ ships)
~
[(turn ~(tap in ships) ,@) ~]
::
++ request-rpc
|= [url=@ta id=(unit @t) req=request:rpc:ethereum]
=/ m (async:stdio ,json)
^- form:m
%+ (retry json) `10
=/ m (async:stdio ,(unit json))
^- form:m
|^
=/ =request:http
:* method=%'POST'
url=url
header-list=['Content-Type'^'application/json' ~]
^= body
%- some %- as-octt:mimes:html
%- en-json:html
(request-to-json:rpc:ethereum id req)
==
;< ~ bind:m (send-request:stdio request)
;< rep=(unit client-response:iris) bind:m
take-maybe-response:stdio
?~ rep
(pure:m ~)
(parse-response u.rep)
::
++ parse-response
|= =client-response:iris
=/ m (async:stdio ,(unit json))
^- form:m
?> ?=(%finished -.client-response)
?~ full-file.client-response
(pure:m ~)
=/ body=@t q.data.u.full-file.client-response
=/ jon=(unit json) (de-json:html body)
?~ jon
(pure:m ~)
=, dejs-soft:format
=/ array=(unit (list response:rpc:jstd))
((ar parse-one-response) u.jon)
?~ array
=/ res=(unit response:rpc:jstd) (parse-one-response u.jon)
?~ res
(async-fail:stdio %request-rpc-parse-error >id< ~)
?: ?=(%error -.u.res)
(async-fail:stdio %request-rpc-error >id< >+.res< ~)
?. ?=(%result -.u.res)
(async-fail:stdio %request-rpc-fail >u.res< ~)
(pure:m `res.u.res)
(async-fail:stdio %request-rpc-batch >%not-implemented< ~)
:: (pure:m `[%batch u.array])
::
++ parse-one-response
|= =json
^- (unit response:rpc:jstd)
=/ res=(unit [@t ^json])
%. json
=, dejs-soft:format
(ot id+so result+some ~)
?^ res `[%result u.res]
~| parse-one-response=json
:+ ~ %error %- need
%. json
=, dejs-soft:format
(ot id+so error+(ot code+no message+so ~) ~)
--
::
++ retry
|* result=mold
|= [crash-after=(unit @ud) computation=_*form:(async:stdio (unit result))]
=/ m (async:stdio ,result)
=| try=@ud
|^
|- ^- form:m
=* loop $
?: =(crash-after `try)
(async-fail:stdio %retry-too-many ~)
;< ~ bind:m (backoff try ~m1)
;< res=(unit result) bind:m computation
?^ res
(pure:m u.res)
loop(try +(try))
::
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
--
::
++ get-latest-block
|= url=@ta
=/ m (async:stdio ,block)
^- form:m
;< =json bind:m (request-rpc url `'block number' %eth-block-number ~)
(get-block-by-number url (parse-eth-block-number:rpc:ethereum json))
::
++ get-block-by-number
|= [url=@ta =number:block]
=/ m (async:stdio ,block)
^- form:m
|^
;< =json bind:m
(request-rpc url `'block by number' %eth-get-block-by-number number |)
=/ =block (parse-block json)
?. =(number number.id.block)
(async-fail:stdio %reorg-detected >number< >block< ~)
(pure:m block)
::
++ parse-block
|= =json
^- block
=< [[&1 &2] |2]
^- [@ @ @]
~| json
%. json
=, dejs:format
%- ot
:~ hash+parse-hex-result:rpc:ethereum
number+parse-hex-result:rpc:ethereum
'parentHash'^parse-hex-result:rpc:ethereum
==
--
::
++ get-logs-by-hash
|= [url=@ta whos=(set ship) =hash:block]
=/ m (async:stdio udiffs:point)
^- form:m
;< =json bind:m
%+ request-rpc url
:* `'logs by hash'
%eth-get-logs-by-hash
hash
~[azimuth:contracts:azimuth]
(topics whos)
==
=/ event-logs=(list event-log:rpc:ethereum)
(parse-event-logs:rpc:ethereum json)
=/ =udiffs:point (event-logs-to-udiffs event-logs)
(pure:m udiffs)
::
++ get-logs-by-range
|= [url=@ta whos=(set ship) =from=number:block =to=number:block]
=/ m (async:stdio udiffs:point)
^- form:m
;< =json bind:m
%+ request-rpc url
:* `'logs by range'
%eth-get-logs
`number+from-number
`number+to-number
~[azimuth:contracts:azimuth]
(topics whos)
==
=/ event-logs=(list event-log:rpc:ethereum)
(parse-event-logs:rpc:ethereum json)
=/ =udiffs:point (event-logs-to-udiffs event-logs)
(pure:m udiffs)
::
++ event-logs-to-udiffs
|= event-logs=(list =event-log:rpc:ethereum)
^- =udiffs:point
%+ murn event-logs
|= =event-log:rpc:ethereum
^- (unit [=ship =udiff:point])
?~ mined.event-log
~
?: removed.u.mined.event-log
~& [%removed-log event-log]
~
=/ =id:block [block-hash block-number]:u.mined.event-log
=, azimuth-events:azimuth
=, abi:ethereum
?: =(broke-continuity i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=/ num=@ (decode-results data.event-log ~[%uint])
`[who id %rift num]
?: =(changed-keys i.topics.event-log)
=/ who=@ (decode-topics t.topics.event-log ~[%uint])
=+ ^- [enc=octs aut=octs sut=@ud rev=@ud]
%+ decode-results data.event-log
~[[%bytes-n 32] [%bytes-n 32] %uint %uint]
`[who id %keys rev sut (pass-from-eth:azimuth enc aut sut)]
?: =(lost-sponsor i.topics.event-log)
=+ ^- [who=@ pos=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon ~]
?: =(escape-accepted i.topics.event-log)
=+ ^- [who=@ wer=@]
(decode-topics t.topics.event-log ~[%uint %uint])
`[who id %spon `wer]
~& [%bad-topic event-log]
~
::
++ jael-update
|= =udiffs:point
=/ m (async:stdio ,~)
|- ^- form:m
=* loop $
?~ udiffs
(pure:m ~)
=/ =path /(scot %p ship.i.udiffs)
;< ~ bind:m (give-result:stdio / %azimuth-udiff i.udiffs)
;< ~ bind:m (give-result:stdio path %azimuth-udiff i.udiffs)
loop(udiffs t.udiffs)
--
::
:: Main loop
::
=> |%
::
:: Send %listen to jael
::
++ listen
|= [state=app-state whos=(list ship) =source:jael]
=/ m (async:stdio ,app-state)
^- form:m
;< ~ bind:m (send-effect:stdio %listen /lo (silt whos) source)
(pure:m state)
::
:: Start watching a node
::
++ start
|= state=app-state
=/ m (async:stdio ,app-state)
^- form:m
=: number.state 0
pending-udiffs.state *pending-udiffs
blocks.state *(list block)
==
(get-updates state)
::
:: Get updates since last checked
::
++ get-updates
|= state=app-state
=/ m (async:stdio ,app-state)
^- form:m
;< =latest=block bind:m (get-latest-block url.state)
;< state=app-state bind:m (zoom state number.id.latest-block)
|- ^- form:m
=* walk-loop $
?: (gth number.state number.id.latest-block)
;< now=@da bind:m get-time:stdio
;< ~ bind:m (wait-effect:stdio (add now ~m5))
(pure:m state)
;< =block bind:m (get-block-by-number url.state number.state)
;< [=new=pending-udiffs new-blocks=(lest ^block)] bind:m
%- take-block
[url.state whos.state pending-udiffs.state block blocks.state]
=: pending-udiffs.state new-pending-udiffs
blocks.state new-blocks
number.state +(number.id.i.new-blocks)
==
walk-loop
::
:: Process a block, detecting and handling reorgs
::
++ take-block
|= [url=@ta whos=(set ship) =a=pending-udiffs =block blocks=(list block)]
=/ m (async:stdio ,[pending-udiffs (lest ^block)])
^- form:m
?: &(?=(^ blocks) !=(parent-hash.block hash.id.i.blocks))
(rewind url a-pending-udiffs block blocks)
;< =b=pending-udiffs bind:m
(release-old-events a-pending-udiffs number.id.block)
;< =new=udiffs:point bind:m (get-logs-by-hash url whos hash.id.block)
=. b-pending-udiffs (~(put by b-pending-udiffs) number.id.block new-udiffs)
(pure:m b-pending-udiffs block blocks)
::
:: Release events if they're more than 30 blocks ago
::
++ release-old-events
|= [=pending-udiffs =number:block]
=/ m (async:stdio ,^pending-udiffs)
^- form:m
=/ rel-number (sub number 30)
=/ =udiffs:point (~(get ja pending-udiffs) rel-number)
;< ~ bind:m (jael-update udiffs)
(pure:m (~(del by pending-udiffs) rel-number))
::
:: Reorg detected, so rewind until we're back in sync
::
++ rewind
|= [url=@ta =pending-udiffs =block blocks=(list block)]
=/ m (async:stdio ,[^pending-udiffs (lest ^block)])
|- ^- form:m
=* loop $
?~ blocks
(pure:m pending-udiffs block blocks)
?: =(parent-hash.block hash.id.i.blocks)
(pure:m pending-udiffs block blocks)
;< =next=^block bind:m (get-block-by-number url number.id.i.blocks)
?: =(~ pending-udiffs)
;< ~ bind:m (disavow block)
loop(block next-block, blocks t.blocks)
=. pending-udiffs (~(del by pending-udiffs) number.id.block)
loop(block next-block, blocks t.blocks)
::
:: Tell subscribers there was a deep reorg
::
++ disavow
|= =block
=/ m (async:stdio ,~)
^- form:m
(jael-update [*ship id.block %disavow ~]~)
::
:: Zoom forward to near a given block number.
::
:: Zooming doesn't go forward one block at a time. As a
:: consequence, it cannot detect and handle reorgs. Only use it
:: at a safe distance -- 500 blocks ago is probably sufficient.
::
++ zoom
|= [state=app-state =latest=number:block]
=/ m (async:stdio ,app-state)
^- form:m
=/ zoom-margin=number:block 100
?: (lth latest-number (add number.state zoom-margin))
(pure:m state)
=/ to-number=number:block (sub latest-number zoom-margin)
;< =udiffs:point bind:m
(get-logs-by-range url.state whos.state number.state to-number)
;< ~ bind:m (jael-update udiffs)
=. number.state +(to-number)
=. blocks.state ~
(pure:m state)
--
::
:: Main
::
=* default-tapp default-tapp:tapp
%- create-tapp-poke-peer-take:tapp
|_ [=bowl:gall state=app-state]
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?- +<.in-poke-data
%listen (listen state +>.in-poke-data)
%watch (pure:m state(url url.in-poke-data))
++ jael-update
|= =udiffs:point
^- (list card:agent:gall)
?~ udiffs
~
=/ =path /(scot %p ship.i.udiffs)
:* [%give %fact `/ %azimuth-udiff !>(i.udiffs)]
[%give %fact `path %azimuth-udiff !>(i.udiffs)]
$(udiffs t.udiffs)
==
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?+ -.sign ~|([%strange-sign -.sign] !!)
%wake (get-updates state)
++ start
|= [state=app-state our=ship dap=term]
^- card:agent:gall
=/ args=vase !>
:* %watch /[dap]
url.state ~m5 launch:contracts:azimuth
~[azimuth:contracts:azimuth]
(topics whos.state)
==
[%pass /wa %agent [our %eth-watcher] %poke %eth-watcher-poke args]
--
::
=| state=app-state
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card:agent:gall agent:gall)
:_ this :_ ~
^- card:agent:gall
[%pass /eth-watcher %agent [our.bowl %eth-watcher] %watch /logs/[dap.bowl]]
::
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(app-state old))
::
++ on-poke
|= [=mark =vase]
?. ?=(%azimuth-tracker-poke mark)
(on-poke:def mark vase)
=+ !<(poke=poke-data vase)
?- -.poke
%listen [[%pass /lo %arvo %j %listen (silt whos.poke) source.poke]~ this]
%watch
=. url.state url.poke
[[(start state [our dap]:bowl) ~] this]
==
::
++ handle-peer
++ on-watch
|= =path
=/ m tapp-async
^- form:m
=/ who=(unit ship) ?~(path ~ `(slav %p i.path))
^- (quip card:agent:gall _this)
?< =(/sole/drum path)
?> ?=(?(~ [@ ~]) path)
=/ who=(unit ship)
?~ path ~
`(slav %p i.path)
=. whos.state
?~ who
~
(~(put in whos.state) u.who)
(start state)
:_ this :_ ~
(start state [our dap]:bowl)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
?. ?=([%eth-watcher ~] wire)
(on-agent:def wire sign)
?. ?=(%fact -.sign)
(on-agent:def wire sign)
?. ?=(%eth-watcher-diff p.cage.sign)
(on-agent:def wire sign)
=+ !<(diff=diff:eth-watcher q.cage.sign)
:_ this
^- (list card:agent:gall)
%- jael-update
?- -.diff
%history (event-logs-to-udiffs loglist.diff)
%log (event-logs-to-udiffs event-log.diff ~)
%disavow [*ship id.diff %disavow ~]~
==
::
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

505
pkg/arvo/app/chat-cli.hoon
View File

@ -10,11 +10,13 @@
:: and trust it to take care of the rest.
::
/- *chat-store, *chat-view, *chat-hook,
*permission-store, *group-store,
*permission-store, *group-store, *invite-store,
sole-sur=sole
/+ sole-lib=sole, chat-eval
/+ sole-lib=sole, chat-eval, default-agent, verb,
auto=language-server-complete
::
|%
+$ card card:agent:gall
+$ state
$: grams=(list mail) :: all messages
known=(set [target serial]) :: known message lookup
@ -25,7 +27,8 @@
settings=(set term) :: frontend flags
width=@ud :: display width
timez=(pair ? @ud) :: timezone adjustment
cli=[=bone state=sole-share:sole-sur] :: console id & state
cli=state=sole-share:sole-sur :: console state
eny=@uvJ :: entropy
==
::
+$ mail [source=target envelope]
@ -39,12 +42,14 @@
[%say letter] :: send message
[%eval cord hoon] :: send #-message
::
[%create chat-security path (unit glyph)] :: create chat
::
:: create chat
[%create rw-security path (unit glyph) (unit ?)]
[%delete path] :: delete chat
[%invite ?(%r %w %rw) path (set ship)] :: allow
[%banish ?(%r %w %rw) path (set ship)] :: disallow
::
[%join target (unit glyph)] :: join target
[%join target (unit glyph) (unit ?)] :: join target
[%leave target] :: nuke target
::
[%bind glyph target] :: bind glyph
@ -62,40 +67,92 @@
[%help ~] :: print usage info
== ::
::
+$ move [bone card]
+$ card
$% [%diff %sole-effect sole-effect:sole-sur]
[%poke wire dock out-action]
[%peer wire dock path]
==
::
+$ out-action
$% [%chat-action chat-action]
[%chat-view-action chat-view-action]
[%chat-hook-action chat-hook-action]
[%group-action group-action]
==
--
=| state
=* all-state -
=<
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
talk-core +>
tc ~(. talk-core(eny eny.bowl) bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
:- [connect:tc]~
%_ this
audience [[our-self:tc /] ~ ~]
settings (sy %showtime %notify ~)
width 80
==
::
++ on-save !>(all-state)
::
++ on-load
|= old-state=vase
^- (quip card _this)
=/ old !<(state old-state)
=^ cards all-state (prep:tc `old)
[cards this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards all-state
?+ mark (on-poke:def mark vase)
%noun (poke-noun:tc mark !<(* vase))
%sole-action (poke-sole-action:tc !<(sole-action:sole-sur vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=^ cards all-state (peer:tc path)
[cards this]
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ cards all-state
?- -.sign
%poke-ack [- all-state]:(on-agent:def wire sign)
%watch-ack [- all-state]:(on-agent:def wire sign)
%kick ~& %chat-cli-kicked `all-state
%fact
?+ p.cage.sign ~|([%chat-cli-bad-sub-mark wire p.cage.sign] !!)
%chat-update (diff-chat-update:tc wire !<(chat-update q.cage.sign))
==
==
[cards this]
::
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ [=bowl:gall state]
++ this .
|_ =bowl:gall
:: +prep: setup & state adapter
::
++ prep
|= old=(unit state)
^- (quip card state)
?^ old
[~ this(+<+ u.old)]
=^ moves this
[~ u.old]
=^ cards all-state
%_ catch-up
audience [[our-self /] ~ ~]
settings (sy %showtime %notify ~)
width 80
==
[[connect moves] this]
[[connect cards] all-state]
:: +catch-up: process all chat-store state
::
++ catch-up
^- (quip move _this)
^- (quip card state)
=/ =inbox
.^ inbox
%gx
@ -104,28 +161,22 @@
(scot %da now.bowl)
/all/noun
==
|- ^- (quip move _this)
?~ inbox [~ this]
|- ^- (quip card state)
?~ inbox [~ all-state]
=* path p.n.inbox
=* mailbox q.n.inbox
=/ =target (path-to-target path)
=^ moves-n this (read-envelopes target envelopes.mailbox)
=^ moves-l this $(inbox l.inbox)
=^ moves-r this $(inbox r.inbox)
[:(weld moves-n moves-l moves-r) this]
=^ cards-n all-state (read-envelopes target envelopes.mailbox)
=^ cards-l all-state $(inbox l.inbox)
=^ cards-r all-state $(inbox r.inbox)
[:(weld cards-n cards-l cards-r) all-state]
:: +connect: connect to the chat-store
::
++ connect
^- move
[ost.bowl %peer /chat-store [our-self %chat-store] /updates]
:: +true-self: moons to planets
^- card
[%pass /chat-store %agent [our-self %chat-store] %watch /updates]
::
++ true-self
|= who=ship
^- ship
?. ?=(%earl (clan:title who)) who
(sein:title our.bowl now.bowl who)
++ our-self (true-self our.bowl)
++ our-self (name:title our.bowl)
:: +target-to-path: prepend ship to the path
::
++ target-to-path
@ -147,68 +198,67 @@
::
++ poke-noun
|= a=*
^- (quip move _this)
^- (quip card state)
?: ?=(%connect a)
[[connect ~] this]
[[connect ~] all-state]
?: ?=(%catch-up a)
catch-up
[~ this]
[~ all-state]
:: +poke-sole-action: handle cli input
::
++ poke-sole-action
|= act=sole-action:sole-sur
^- (quip move _this)
?. =(bone.cli ost.bowl)
~|(%strange-sole !!)
::TODO use id.act to support multiple separate sessions
|= [act=sole-action:sole-sur]
^- (quip card state)
(sole:sh-in act)
:: +peer: accept only cli subscriptions from ourselves
::
++ peer
|= =path
^- (quip move _this)
^- (quip card state)
?. (team:title our-self src.bowl)
~| [%peer-talk-stranger src.bowl]
!!
?. ?=([%sole *] path)
~| [%peer-talk-strange path]
!!
=. bone.cli ost.bowl
:: display a fresh prompt
:- [prompt:sh-out ~]
:: start with fresh sole state
this(state.cli *sole-share:sole-sur)
all-state(state.cli *sole-share:sole-sur)
:: +diff-chat-update: get new mailboxes & messages
::
++ diff-chat-update
|= [=wire upd=chat-update]
^- (quip move _this)
?+ -.upd [~ this]
%create (notice-create +.upd)
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] this]
%message (read-envelope (path-to-target path.upd) envelope.upd)
^- (quip card state)
?+ -.upd [~ all-state]
%create (notice-create +.upd)
%delete [[(show-delete:sh-out (path-to-target path.upd)) ~] all-state]
%message (read-envelope (path-to-target path.upd) envelope.upd)
%messages (read-envelopes (path-to-target path.upd) envelopes.upd)
==
::
++ read-envelopes
|= [=target envs=(list envelope)]
^- (quip move _this)
?~ envs [~ this]
=^ moves-i this (read-envelope target i.envs)
=^ moves-t this $(envs t.envs)
[(weld moves-i moves-t) this]
^- (quip card state)
?~ envs [~ all-state]
=^ cards-i all-state (read-envelope target i.envs)
=^ cards-t all-state $(envs t.envs)
[(weld cards-i cards-t) all-state]
::
++ notice-create
|= =target
^- (quip move _this)
=^ moves this
^- (quip card state)
=^ cards all-state
?: (~(has by bound) target)
[~ this]
[~ all-state]
(bind-default-glyph target)
[[(show-create:sh-out target) moves] this]
[[(show-create:sh-out target) cards] all-state]
:: +bind-default-glyph: bind to default, or random available
::
++ bind-default-glyph
|= =target
^- (quip move _this)
^- (quip card state)
=; =glyph (bind-glyph glyph target)
|^ =/ g=glyph (choose glyphs)
?. (~(has by binds) g) g
@ -226,7 +276,7 @@
::
++ bind-glyph
|= [=glyph =target]
^- (quip move _this)
^- (quip card state)
::TODO should send these to settings store eventually
:: if the target was already bound to another glyph, un-bind that
::
@ -234,16 +284,16 @@
(~(del ju binds) (~(got by bound) target) target)
=. bound (~(put by bound) target glyph)
=. binds (~(put ju binds) glyph target)
[(show-glyph:sh-out glyph `target) this]
[(show-glyph:sh-out glyph `target) all-state]
:: +unbind-glyph: remove all binding for glyph
::
++ unbind-glyph
|= [=glyph targ=(unit target)]
^- (quip move _this)
^- (quip card state)
?^ targ
=. binds (~(del ju binds) glyph u.targ)
=. bound (~(del by bound) u.targ)
[(show-glyph:sh-out glyph ~) this]
[(show-glyph:sh-out glyph ~) all-state]
=/ ole=(set target)
(~(get ju binds) glyph)
=. binds (~(del by binds) glyph)
@ -253,7 +303,7 @@
=. bound $(ole l.ole)
=. bound $(ole r.ole)
(~(del by bound) n.ole)
[(show-glyph:sh-out glyph ~) this]
[(show-glyph:sh-out glyph ~) all-state]
:: +decode-glyph: find the target that matches a glyph, if any
::
++ decode-glyph
@ -276,12 +326,12 @@
::
++ read-envelope
|= [=target =envelope]
^- (quip move _this)
^- (quip card state)
?: (~(has in known) [target uid.envelope])
::NOTE we no-op only because edits aren't possible
[~ this]
[~ all-state]
:- (show-envelope:sh-out target envelope)
%_ this
%_ all-state
known (~(put in known) [target uid.envelope])
grams [[target envelope] grams]
count +(count)
@ -296,11 +346,71 @@
::
++ sole
|= act=sole-action:sole-sur
^- (quip move _this)
?- -.act
$det (edit +.act)
$clr [~ this]
$ret obey
^- (quip card state)
?- -.dat.act
%det (edit +.dat.act)
%clr [~ all-state]
%ret obey
%tab (tab +.dat.act)
==
:: +tab-list: static list of autocomplete entries
++ tab-list
^- (list (option:auto tank))
:~
[%join leaf+";join ~ship/chat-name (glyph)"]
[%leave leaf+";leave ~ship/chat-name"]
::
[%create leaf+";create [type] /chat-name (glyph)"]
[%delete leaf+";delete /chat-name"]
[%invite leaf+";invite [rw | r | w] /chat-name ~ships"]
[%banish leaf+";banish [rw | r | w] /chat-name ~ships"]
::
[%bind leaf+";bind [glyph] ~ship/chat-name"]
[%unbind leaf+";unbind [glyph]"]
[%what leaf+";what (~ship/chat-name) (glyph)"]
::
[%settings leaf+";settings"]
[%set leaf+";set key (value)"]
[%unset leaf+";unset key"]
::
[%chats leaf+";chats"]
[%help leaf+";help"]
==
++ tab
|= pos=@ud
^- (quip card state)
?: ?| =(~ buf.state.cli)
!=(';' -.buf.state.cli)
==
:_ all-state
[(effect:sh-out [%bel ~]) ~]
::
=+ (get-id:auto pos (tufa buf.state.cli))
=/ needle=term
(fall id '')
?: &(!=(pos 1) =(0 (met 3 needle)))
[~ all-state] :: autocomplete empty command iff user at start of command
=/ options=(list (option:auto tank))
(search-prefix:auto needle tab-list)
=/ advance=term
(longest-match:auto options)
=/ to-send=tape
(trip (rsh 3 (met 3 needle) advance))
=/ send-pos
(add pos (met 3 (fall forward '')))
=| moves=(list card)
=? moves ?=(^ options)
[(tab:sh-out options) moves]
=| fxs=(list sole-effect:sole-sur)
|- ^- (quip card state)
?~ to-send
[(flop moves) all-state]
=^ char state.cli
(~(transmit sole-lib state.cli) [%ins send-pos `@c`i.to-send])
%_ $
moves [(effect:sh-out %det char) moves]
send-pos +(send-pos)
to-send t.to-send
==
:: +edit: apply sole edit
::
@ -309,17 +419,17 @@
::
++ edit
|= cal=sole-change:sole-sur
^- (quip move _this)
^- (quip card state)
=^ inv state.cli (~(transceive sole-lib state.cli) cal)
=+ fix=(sanity inv buf.state.cli)
?~ lit.fix
[~ this]
[~ all-state]
:: just capital correction
?~ err.fix
(slug fix)
:: allow interior edits and deletes
?. &(?=($del -.inv) =(+(p.inv) (lent buf.state.cli)))
[~ this]
[~ all-state]
(slug fix)
:: +sanity: check input sanity
::
@ -336,13 +446,13 @@
::
++ slug
|= [lit=(list sole-edit:sole-sur) err=(unit @u)]
^- (quip move _this)
?~ lit [~ this]
^- (quip card state)
?~ lit [~ all-state]
=^ lic state.cli
%- ~(transmit sole-lib state.cli)
^- sole-edit:sole-sur
?~(t.lit i.lit [%mor lit])
:_ this
:_ all-state
:_ ~
%+ effect:sh-out %mor
:- [%det lic]
@ -362,13 +472,24 @@
;~ (glue ace)
(tag %create)
security
;~(plug path (punt ;~(pfix ace glyph)))
;~ plug
path
(punt ;~(pfix ace glyph))
(punt ;~(pfix ace (fuss 'y' 'n')))
==
==
;~((glue ace) (tag %delete) path)
;~((glue ace) (tag %invite) rw path ships)
;~((glue ace) (tag %banish) rw path ships)
::
;~((glue ace) (tag %join) ;~(plug targ (punt ;~(pfix ace glyph))))
;~ (glue ace)
(tag %join)
;~ plug
targ
(punt ;~(pfix ace glyph))
(punt ;~(pfix ace (fuss 'y' 'n')))
==
==
;~((glue ace) (tag %leave) targ)
::
;~((glue ace) (tag %bind) glyph targ)
@ -497,8 +618,8 @@
++ letter
;~ pose
(stag %url turl)
:(stag %me ;~(pfix vat text))
:(stag %text ;~(less mic hax text))
(stag %me ;~(pfix vat text))
(stag %text ;~(less mic hax text))
==
:: +turl: url parser
::
@ -528,22 +649,22 @@
:: the command (if any) gets echoed to the user.
::
++ obey
^- (quip move _this)
^- (quip card state)
=+ buf=buf.state.cli
=+ fix=(sanity [%nop ~] buf)
?^ lit.fix
(slug fix)
=+ jub=(rust (tufa buf) read)
?~ jub [[(effect:sh-out %bel ~) ~] this]
?~ jub [[(effect:sh-out %bel ~) ~] all-state]
=^ cal state.cli (~(transmit sole-lib state.cli) [%set ~])
=^ moves this (work u.jub)
:_ this
=^ cards all-state (work u.jub)
:_ all-state
%+ weld
^- (list move)
^- (list card)
:: echo commands into scrollback
?. =(`0 (find ";" buf)) ~
[(note:sh-out (tufa `(list @)`buf)) ~]
:_ moves
:_ cards
%+ effect:sh-out %mor
:~ [%nex ~]
[%det cal]
@ -552,7 +673,7 @@
::
++ work
|= job=command
^- (quip move _this)
^- (quip card state)
|^ ?- -.job
%target (set-target +.job)
%say (say +.job)
@ -580,66 +701,102 @@
%chats chats
%help help
==
:: +act: build action move
:: +act: build action card
::
++ act
|= [what=term app=term =out-action]
^- move
:* ost.bowl
%poke
|= [what=term app=term =cage]
^- card
:* %pass
/cli-command/[what]
%agent
[our-self app]
out-action
%poke
cage
==
:: +invite-card: build invite card
::
++ invite-card
|= [where=path who=ship]
^- card
:* %pass
/cli-command/invite
%agent
[who %invite-hook] ::NOTE only place chat-cli pokes others
%poke
%invite-action
::
!>
^- invite-action
:^ %invite /chat
(shax (jam [our-self where] who))
^- invite
=; desc=cord
[our-self %chat-hook where who desc]
%- crip
%+ weld
"You have been invited to chat at "
~(full tr [our-self where])
==
:: +set-target: set audience, update prompt
::
++ set-target
|= tars=(set target)
^- (quip move _this)
^- (quip card state)
=. audience tars
[[prompt:sh-out ~] this]
[[prompt:sh-out ~] all-state]
:: +create: new local mailbox
::
++ create
|= [security=chat-security =path gyf=(unit char)]
^- (quip move _this)
|= [security=rw-security =path gyf=(unit char) allow-history=(unit ?)]
^- (quip card state)
::TODO check if already exists
=/ =target [our-self path]
=. audience [target ~ ~]
=^ moz this
?. ?=(^ gyf) [~ this]
=^ moz all-state
?. ?=(^ gyf) [~ all-state]
(bind-glyph u.gyf target)
=- [[- moz] this]
=- [[- moz] all-state]
%^ act %do-create %chat-view
:- %chat-view-action
:^ %create path security
:: ensure we can read from/write to our own chats
::
:- :: read
!>
:* %create
path
security
:: ensure we can read from/write to our own chats
::
:: read
?- security
?(%channel %journal) ~
?(%village %mailbox) [our-self ~ ~]
==
:: write
?- security
?(%channel %mailbox) ~
?(%village %journal) [our-self ~ ~]
:: write
?- security
?(%channel %mailbox) ~
?(%village %journal) [our-self ~ ~]
==
(fall allow-history %.y)
==
:: +delete: delete local chats
::
++ delete
|= =path
^- (quip move _this)
=- [[- ~] this]
^- (quip card state)
=- [[- ~] all-state]
%^ act %do-delete %chat-view
:- %chat-view-action
!>
[%delete (target-to-path our-self path)]
:: +change-permission: modify permissions on a local chat
::
++ change-permission
|= [allow=? rw=?(%r %w %rw) =path ships=(set ship)]
^- (quip move _this)
:_ this
^- (quip card state)
:_ all-state
=; cards=(list card)
?. allow cards
%+ weld cards
%+ turn ~(tap in ships)
(cury invite-card path)
%+ murn
^- (list term)
?- rw
@ -648,7 +805,7 @@
%rw [%read %write ~]
==
|= =term
^- (unit move)
^- (unit card)
=. path
=- (snoc `^path`- term)
[%chat (target-to-path our-self path)]
@ -671,49 +828,55 @@
~
%- some
%^ act %do-permission %group-store
^- out-action
:- %group-action
!>
?: =(u.whitelist allow)
[%add ships path]
[%remove ships path]
:: +join: sync with remote mailbox
::
++ join
|= [=target gyf=(unit char)]
^- (quip move _this)
=^ moz this
?. ?=(^ gyf) [~ this]
|= [=target gyf=(unit char) ask-history=(unit ?)]
^- (quip card state)
=^ moz all-state
?. ?=(^ gyf) [~ all-state]
(bind-glyph u.gyf target)
=- [[- moz] this(audience [target ~ ~])]
=. audience [target ~ ~]
=; =card
[[card prompt:sh-out moz] all-state]
::TODO ideally we'd check permission first. attempting this and failing
:: gives ugly %chat-hook-reap
%^ act %do-join %chat-view
:- %chat-view-action
[%join target]
!>
[%join ship.target path.target (fall ask-history %.y)]
:: +leave: unsync & destroy mailbox
::
::TODO allow us to "mute" local chats using this
++ leave
|= =target
=- [[- ~] this]
=- [[- ~] all-state]
?: =(our-self ship.target)
%- print:sh-out
"can't ;leave local chats, maybe use ;delete instead"
%^ act %do-leave %chat-hook
:- %chat-hook-action
!>
[%remove (target-to-path target)]
:: +say: send messages
::
++ say
|= =letter
^- (quip move _this)
^- (quip card state)
~! bowl
=/ =serial (shaf %msg-uid eny.bowl)
:_ this(eny.bowl (shax eny.bowl))
^- (list move)
:_ all-state(eny (shax eny.bowl))
^- (list card)
%+ turn ~(tap in audience)
|= =target
%^ act %out-message %chat-hook
:- %chat-action
!>
:+ %message (target-to-path target)
[serial *@ our-self now.bowl letter]
:: +eval: run hoon, send code and result as message
@ -727,8 +890,8 @@
::
++ lookup-glyph
|= qur=(unit $@(glyph target))
^- (quip move _this)
=- [[- ~] this]
^- (quip card state)
=- [[- ~] all-state]
?^ qur
?^ u.qur
=+ gyf=(~(get by bound) u.qur)
@ -752,8 +915,8 @@
:: +show-settings: print enabled flags, timezone and width settings
::
++ show-settings
^- (quip move _this)
:_ this
^- (quip card state)
:_ all-state
:~ %- print:sh-out
%- zing
^- (list tape)
@ -773,24 +936,24 @@
::
++ set-setting
|= =term
^- (quip move _this)
[~ this(settings (~(put in settings) term))]
^- (quip card state)
[~ all-state(settings (~(put in settings) term))]
:: +unset-setting: disable settings flag
::
++ unset-setting
|= =term
^- (quip move _this)
[~ this(settings (~(del in settings) term))]
^- (quip card state)
[~ all-state(settings (~(del in settings) term))]
:: +set-width: configure cli printing width
::
++ set-width
|= w=@ud
[~ this(width w)]
[~ all-state(width w)]
:: +set-timezone: configure timestamp printing adjustment
::
++ set-timezone
|= tz=[? @ud]
[~ this(timez tz)]
[~ all-state(timez tz)]
:: +select: expand message from number reference
::
++ select
@ -799,7 +962,7 @@
:: (with leading zeros used for precision)
::
|= num=$@(rel=@ud [zeros=@u abs=@ud])
^- (quip move _this)
^- (quip card state)
|^ ?@ num
=+ tum=(scow %s (new:si | +(num)))
?: (gte rel.num count)
@ -813,11 +976,11 @@
(activate (scow %ud msg) (sub count +(msg)))
%- just-print
"…{(reap zeros.num '0')}{(scow %ud abs.num)}: no such telegram"
:: +just-print: full [moves state] output with a single print move
:: +just-print: full [cards state] output with a single print card
::
++ just-print
|= txt=tape
[[(print:sh-out txt) ~] this]
[[(print:sh-out txt) ~] all-state]
:: +index: get message index from absolute reference
::
++ index
@ -831,11 +994,11 @@
::
++ activate
|= [number=tape index=@ud]
^- (quip move _this)
^- (quip card state)
=+ gam=(snag index grams)
=. audience [source.gam ~ ~]
:_ this
^- (list move)
:_ all-state
^- (list card)
:~ (print:sh-out ['?' ' ' number])
(effect:sh-out ~(render-activate mr gam))
prompt:sh-out
@ -844,8 +1007,8 @@
:: +chats: display list of local mailboxes
::
++ chats
^- (quip move _this)
:_ this
^- (quip card state)
:_ all-state
:_ ~
%- print-more:sh-out
=/ all
@ -862,9 +1025,9 @@
:: +help: print (link to) usage instructions
::
++ help
^- (quip move _this)
=- [[- ~] this]
(print:sh-out "see https://urbit.org/docs/using/messaging/")
^- (quip card state)
=- [[- ~] all-state]
(print:sh-out "see https://urbit.org/using/operations/using-your-ship/#messaging")
--
--
::
@ -872,30 +1035,37 @@
::
++ sh-out
|%
:: +effect: console effect move
:: +effect: console effect card
::
++ effect
|= fec=sole-effect:sole-sur
^- move
[bone.cli %diff %sole-effect fec]
^- card
::TODO don't hard-code session id 'drum' here
[%give %fact `/sole/drum %sole-effect !>(fec)]
:: +tab: print tab-complete list
::
++ tab
|= options=(list [cord tank])
^- card
(effect %tab options)
:: +print: puts some text into the cli as-is
::
++ print
|= txt=tape
^- move
^- card
(effect %txt txt)
:: +print-more: puts lines of text into the cli
::
++ print-more
|= txs=(list tape)
^- move
^- card
%+ effect %mor
(turn txs |=(t=tape [%txt t]))
:: +note: prints left-padded ---| txt
::
++ note
|= txt=tape
^- move
^- card
=+ lis=(simple-wrap txt (sub width 16))
%- print-more
=+ ?:((gth (lent lis) 0) (snag 0 lis) "")
@ -905,7 +1075,7 @@
:: +prompt: update prompt to display current audience
::
++ prompt
^- move
^- card
%+ effect %pro
:+ & %talk-line
^- tape
@ -931,9 +1101,9 @@
::
++ show-envelope
|= [=target =envelope]
^- (list move)
^- (list card)
%+ weld
^- (list move)
^- (list card)
?. =(0 (mod count 5)) ~
:_ ~
=+ num=(scow %ud count)
@ -955,19 +1125,19 @@
::
++ show-create
|= =target
^- move
^- card
(note "new: {~(phat tr target)}")
:: +show-delete: print mailbox deletion notification
::
++ show-delete
|= =target
^- move
^- card
(note "del: {~(phat tr target)}")
:: +show-glyph: print glyph un/bind notification
::
++ show-glyph
|= [=glyph target=(unit target)]
^- (list move)
^- (list card)
:_ [prompt ~]
%- note
%+ weld "set: {[glyph ~]} "
@ -1002,7 +1172,12 @@
(lth (lent path.one) (lent path.two))
:: if they're from different ships, neither ours, pick hierarchically.
(lth (xeb ship.one) (xeb ship.two))
:: +phat: render target fully
:: +full: render target fully, always
::
++ full
^- tape
(weld (scow %p ship.one) (spud path.one))
:: +phat: render target with local shorthand
::
:: renders as ~ship/path.
:: for local mailboxes, renders just /path.

480
pkg/arvo/app/chat-hook.hoon
View File

@ -2,64 +2,134 @@
:: mirror chat data from foreign to local based on read permissions
:: allow sending chat messages to foreign paths based on write perms
::
/- *permission-store, *chat-hook
/+ *chat-json
/- *permission-store, *chat-hook, *invite-store
/+ *chat-json, default-agent, verb
|%
+$ move [bone card]
+$ card card:agent:gall
::
+$ card
$% [%diff [%chat-update chat-update]]
[%quit ~]
[%poke wire dock poke]
[%pull wire dock ~]
[%peer wire dock path]
==
::
+$ state
$% [%0 state-zero]
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: synced=(map path ship)
boned=(map wire (list bone))
$: %0
synced=(map path ship)
invite-created=_|
allow-history=(map path ?)
==
::
+$ poke
$% [%chat-action chat-action]
[%permission-action permission-action]
[%invite-action invite-action]
[%chat-view-action chat-view-action]
==
::
+$ fact
$% [%chat-update chat-update]
==
--
=| state-zero
=* state -
%+ verb |
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
^- (quip card _this)
:_ this(invite-created %.y)
:~ (invite-poke:cc [%create /chat])
[%pass /invites %agent [our.bol %invite-store] %watch /invitatory/chat]
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]
==
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(chat-action vase))
%chat-hook-action (poke-chat-hook-action:cc !<(chat-hook-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?+ path (on-watch:def path)
[%backlog *] [(watch-backlog:cc t.path) this]
[%mailbox *] [(watch-mailbox:cc t.path) this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%watch-ack
=^ cards state
(watch-ack:cc wire p.sign)
[cards this]
::
%kick
=^ cards state
(kick:cc wire)
[cards this]
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%chat-update
=^ cards state
(fact-chat-update:cc wire !<(chat-update q.cage.sign))
[cards this]
::
%invite-update
=^ cards state
(fact-invite-update:cc wire !<(invite-update q.cage.sign))
[cards this]
::
%permission-update
=^ cards state
(fact-permission-update:cc wire !<(permission-update q.cage.sign))
[cards this]
==
==
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ [bol=bowl:gall state]
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
:_ this
[ost.bol %peer /permissions [our.bol %permission-store] /updates]~
[~ this(+<+ u.old)]
|_ bol=bowl:gall
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (quip card _state)
(poke-chat-action (json-to-action jon))
::
++ poke-chat-action
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%message -.act)
:: local
:_ this
:_ state
?: (team:title our.bol src.bol)
?. (~(has by synced) path.act)
~
=/ ship (~(got by synced) path.act)
=/ appl ?:(=(ship our.bol) %chat-store %chat-hook)
[ost.bol %poke / [ship appl] [%chat-action act]]~
[%pass / %agent [ship appl] %poke %chat-action !>(act)]~
:: foreign
=/ ship (~(get by synced) path.act)
?~ ship
@ -72,193 +142,280 @@
=: author.envelope.act src.bol
when.envelope.act now.bol
==
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]~
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]~
::
++ poke-chat-hook-action
|= act=chat-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add-owned
?> (team:title our.bol src.bol)
=/ chat-path [%mailbox path.act]
?: (~(has by synced) path.act)
[~ this]
=. synced (~(put by synced) path.act our.bol)
:_ (track-bone chat-path)
[~ state]
=: synced (~(put by synced) path.act our.bol)
allow-history (~(put by allow-history) path.act allow-history.act)
==
:_ state
%+ weld
[ost.bol %peer chat-path [our.bol %chat-store] chat-path]~
[%pass chat-path %agent [our.bol %chat-store] %watch chat-path]~
(create-permission [%chat path.act] security.act)
::
%add-synced
?> (team:title our.bol src.bol)
=/ chat-path [%mailbox (scot %p ship.act) path.act]
?: (~(has by synced) [(scot %p ship.act) path.act])
[~ this]
[~ state]
=. synced (~(put by synced) [(scot %p ship.act) path.act] ship.act)
:_ (track-bone chat-path)
[ost.bol %peer chat-path [ship.act %chat-hook] chat-path]~
?. ask-history.act
=/ chat-path [%mailbox (scot %p ship.act) path.act]
:_ state
[%pass chat-path %agent [ship.act %chat-hook] %watch chat-path]~
:: TODO: only ask for backlog from previous point
=/ chat-history [%backlog (scot %p ship.act) (weld path.act /0)]
:_ state
[%pass chat-history %agent [ship.act %chat-hook] %watch chat-history]~
::
%remove
=/ ship (~(get by synced) path.act)
?~ ship
[~ this]
[~ state]
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
:: delete one of our.bol own paths
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%mailbox path.act])
==
:_ state(synced (~(del by synced) path.act))
%- zing
:~ (pull-wire [%mailbox path.act])
:~ (pull-wire [%backlog (weld path.act /0)])
(pull-wire [%mailbox path.act])
(delete-permission [%chat path.act])
^- (list move)
%+ turn (prey:pubsub:userlib [%mailbox path.act] bol)
|= [=bone *]
[bone %quit ~]
[%give %kick `[%mailbox path.act] ~]~
==
?. |(=(u.ship src.bol) (team:title our.bol src.bol))
:: if neither ship = source or source = us, do nothing
[~ this]
[~ state]
:: delete a foreign ship's path
:- (pull-wire [%mailbox path.act])
%_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%mailbox path.act])
==
state(synced (~(del by synced) path.act))
==
::
++ peer-mailbox
++ watch-mailbox
|= pax=path
^- (quip move _this)
?> ?=([* ^] pax)
^- (list card)
?> ?=(^ pax)
?> (~(has by synced) pax)
:: scry permissions to check if read is permitted
?> (permitted-scry [(scot %p src.bol) %chat (weld pax /read)])
=/ box (chat-scry pax)
?~ box !!
:_ this
[ost.bol %diff %chat-update [%create (slav %p i.pax) pax]]~
[%give %fact ~ %chat-update !>([%create (slav %p i.pax) pax])]~
::
++ diff-permission-update
|= [wir=wire diff=permission-update]
^- (quip move _this)
:_ this
?- -.diff
++ watch-backlog
|= pax=path
^- (list card)
?> ?=(^ pax)
=/ last (dec (lent pax))
=/ backlog-start=(unit @ud)
%+ rush
(snag last `(list @ta)`pax)
dem:ag
=/ pas `path`(oust [last 1] `(list @ta)`pax)
?> ?=([* ^] pas)
?> (~(has by synced) pas)
:: scry permissions to check if read is permitted
?> (permitted-scry [(scot %p src.bol) %chat (weld pas /read)])
=/ box (chat-scry pas)
?~ box !!
:- [%give %fact ~ %chat-update !>([%create (slav %p i.pas) pas])]
%- zing
:~
?: ?&(?=(^ backlog-start) (~(got by allow-history) pas))
(paginate-messages pas u.box u.backlog-start)
~
[%give %kick `[%backlog pax] `src.bol]~
==
::
++ paginate-messages
|= [=path =mailbox start=@ud]
^- (list card)
=/ cards=(list card) ~
=/ end (lent envelopes.mailbox)
?: |((gte start end) =(end 0))
cards
=. envelopes.mailbox (slag start `(list envelope)`envelopes.mailbox)
|- ^- (list card)
?~ envelopes.mailbox
cards
?: (lte end 5.000)
=. cards
%+ snoc cards
%- messages-fact
[path start (lent envelopes.mailbox) envelopes.mailbox]
$(envelopes.mailbox ~)
=. cards
%+ snoc cards
%- messages-fact
:^ path start
(add start 5.000)
(scag 5.000 `(list envelope)`envelopes.mailbox)
=: start (add start 5.000)
end (sub end 5.000)
==
$(envelopes.mailbox (slag 5.000 `(list envelope)`envelopes.mailbox))
::
++ fact-invite-update
|= [wir=wire fact=invite-update]
^- (quip card _state)
?+ -.fact
[~ state]
::
%accepted
=/ ask-history
?~ (chat-scry [(scot %p ship.invite.fact) path.invite.fact])
%.y
%.n
:_ state
[(chat-view-poke [%join ship.invite.fact path.invite.fact ask-history])]~
==
::
++ fact-permission-update
|= [wir=wire fact=permission-update]
^- (quip card _state)
:_ state
?- -.fact
%create ~
%delete ~
%add (handle-permissions [%add path.diff who.diff])
%remove (handle-permissions [%remove path.diff who.diff])
%add (handle-permissions [%add path.fact who.fact])
%remove (handle-permissions [%remove path.fact who.fact])
==
::
++ handle-permissions
|= [kind=?(%add %remove) pax=path who=(set ship)]
^- (list move)
^- (list card)
?> ?=([* *] pax)
?. =(%chat i.pax) ~
:: check path to see if this is a %read permission
?. =(%read (snag (dec (lent pax)) `(list @t)`pax))
~
=/ sup
%- ~(gas by *(map [ship path] bone))
%+ turn ~(tap by sup.bol)
|=([=bone anchor=[ship path]] [anchor bone])
%- zing
%+ turn ~(tap in who)
|= check-ship=ship
?: (permitted-scry [(scot %p check-ship) pax])
|= =ship
?: (permitted-scry [(scot %p ship) pax])
~
:: if ship is not permitted, quit their subscription
:: if ship is not permitted, kick their subscription
=/ mail-path
(oust [(dec (lent t.pax)) (lent t.pax)] `(list @t)`t.pax)
=/ bne (~(get by sup) [check-ship [%mailbox mail-path]])
?~(bne ~ [u.bne %quit ~]~)
[%give %kick `[%mailbox mail-path] `ship]~
::
++ diff-chat-update
|= [wir=wire diff=chat-update]
^- (quip move _this)
++ fact-chat-update
|= [wir=wire fact=chat-update]
^- (quip card _state)
?: (team:title our.bol src.bol)
(handle-local diff)
(handle-foreign diff)
(handle-local fact)
(handle-foreign fact)
::
++ handle-local
|= diff=chat-update
^- (quip move _this)
?- -.diff
%keys [~ this]
%config [~ this]
%create [~ this]
%read [~ this]
|= fact=chat-update
^- (quip card _state)
?- -.fact
%keys [~ state]
%read [~ state]
%config [~ state]
%create [~ state]
%delete
?. (~(has by synced) path.diff)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[ost.bol %pull [%mailbox path.diff] [our.bol %chat-store] ~]~
?. (~(has by synced) path.fact)
[~ state]
:_ state(synced (~(del by synced) path.fact))
[%pass [%mailbox path.fact] %agent [our.bol %chat-store] %leave ~]~
::
%message
:_ this
%+ turn (prey:pubsub:userlib [%mailbox path.diff] bol)
|= [=bone *]
^- move
[bone %diff [%chat-update diff]]
:_ state
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
::
%messages
:_ state
[%give %fact `[%mailbox path.fact] %chat-update !>(fact)]~
==
::
++ handle-foreign
|= diff=chat-update
^- (quip move _this)
?- -.diff
%keys [~ this]
%config [~ this]
%read [~ this]
|= fact=chat-update
^- (quip card _state)
?- -.fact
%keys [~ state]
%read [~ state]
%config [~ state]
%create
:_ this
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%create ship.diff t.path.diff])]~
[(chat-poke [%create ship.fact t.path.fact])]~
::
%delete
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp
[~ this]
[~ state]
?. =(u.shp src.bol)
[~ this]
:_ this(synced (~(del by synced) path.diff))
:- (chat-poke diff)
[ost.bol %pull [%mailbox path.diff] [src.bol %chat-hook] ~]~
[~ state]
:_ state(synced (~(del by synced) path.fact))
:- (chat-poke [%delete path.fact])
[%pass [%mailbox path.fact] %agent [src.bol %chat-hook] %leave ~]~
::
%message
:_ this
?> ?=([* ^] path.diff)
=/ shp (~(get by synced) path.diff)
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke diff)]~
[(chat-poke [%message path.fact envelope.fact])]~
::
%messages
:_ state
?> ?=([* ^] path.fact)
=/ shp (~(get by synced) path.fact)
?~ shp ~
?. =(src.bol u.shp) ~
[(chat-poke [%messages path.fact envelopes.fact])]~
==
::
++ quit
++ kick
|= wir=wire
^- (quip move _this)
~& chat-hook-quit+wir
^- (quip card _state)
?: =(wir /permissions)
:_ this
[ost.bol %peer /permissions [our.bol %permission-store] /updates]~
?> ?=([* ^] wir)
?. (~(has by synced) t.wir)
:: no-op
[~ this]
~& %chat-hook-resubscribe
:_ (track-bone wir)
[ost.bol %peer wir [(slav %p i.t.wir) %chat-hook] wir]~
:_ state
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]~
::
?: ?=([%mailbox @ *] wir)
~& mailbox-kick+wir
?. (~(has by synced) t.wir)
:: no-op
[~ state]
~& %chat-hook-resubscribe
=/ =ship (~(got by synced) t.wir)
=/ mailbox=(unit mailbox) (chat-scry t.wir)
=/ chat-history
%+ welp backlog+t.wir
?~ mailbox
/0
/(scot %ud (lent envelopes.u.mailbox))
:_ state
[%pass chat-history %agent [ship %chat-hook] %watch chat-history]~
::
?: ?=([%backlog @ *] wir)
=/ pax `path`(oust [(dec (lent t.wir)) 1] `(list @ta)`t.wir)
?. (~(has by synced) pax) [~ state]
=/ mailbox=(unit mailbox) (chat-scry pax)
=. pax ?~(mailbox wir [%mailbox pax])
:_ state
[%pass pax %agent [(slav %p i.t.wir) %chat-hook] %watch pax]~
!!
::
++ reap
++ watch-ack
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?~ saw
[~ this]
[~ state]
?> ?=(^ wir)
:_ this(synced (~(del by synced) t.wir))
:_ state(synced (~(del by synced) t.wir))
%. ~
%- slog
:* leaf+"chat-hook failed subscribe on {(spud t.wir)}"
@ -268,17 +425,32 @@
::
++ chat-poke
|= act=chat-action
^- move
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
^- card
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
::
++ chat-view-poke
|= act=chat-view-action
^- card
[%pass / %agent [our.bol %chat-view] %poke %chat-view-action !>(act)]
::
++ permission-poke
|= act=permission-action
^- move
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
^- card
[%pass / %agent [our.bol %permission-store] %poke %permission-action !>(act)]
::
++ invite-poke
|= act=invite-action
^- card
[%pass / %agent [our.bol %invite-store] %poke %invite-action !>(act)]
::
++ messages-fact
|= [=path start=@ud end=@ud envelopes=(list envelope)]
^- card
[%give %fact ~ %chat-update !>([%messages path start end envelopes])]
::
++ create-permission
|= [pax=path sec=chat-security]
^- (list move)
|= [pax=path sec=rw-security]
^- (list card)
=/ read-perm (weld pax /read)
=/ write-perm (weld pax /write)
?- sec
@ -305,7 +477,7 @@
::
++ delete-permission
|= pax=path
^- (list move)
^- (list card)
=/ read-perm (weld pax /read)
=/ write-perm (weld pax /write)
:~ (permission-poke [%delete read-perm])
@ -323,32 +495,24 @@
=. pax ;:(weld /=chat-store/(scot %da now.bol)/mailbox pax /noun)
.^((unit mailbox) %gx pax)
::
++ invite-scry
|= uid=serial
^- (unit invite)
=/ pax /=invite-store/(scot %da now.bol)/invite/chat/(scot %uv uid)/noun
.^((unit invite) %gx pax)
::
++ permitted-scry
|= pax=path
^- ?
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
::
++ pull-wire
|= pax=path
^- (list move)
^- (list card)
?> ?=(^ pax)
=/ bnd (~(get by boned) pax)
?~ bnd ~
=/ shp (~(get by synced) t.pax)
?~ shp ~
%+ turn u.bnd
|= =bone
^- move
?: =(u.shp our.bol)
[bone %pull pax [our.bol %chat-store] ~]
[bone %pull pax [u.shp %chat-hook] ~]
::
[%pass pax %agent [our.bol %chat-store] %leave ~]~
[%pass pax %agent [u.shp %chat-hook] %leave ~]~
--

304
pkg/arvo/app/chat-store.hoon
View File

@ -1,20 +1,15 @@
:: chat-store: data store that holds linear sequences of chat messages
::
/+ *chat-json, *chat-eval
/+ *chat-json, *chat-eval, default-agent
|%
+$ move [bone card]
::
+$ card
$% [%diff diff]
[%quit ~]
==
::
+$ state
$% [%0 state-zero]
+$ card card:agent:gall
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: =inbox
$: %0
=inbox
==
::
+$ diff
@ -24,56 +19,97 @@
==
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(chat-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
|^
=/ cards=(list card)
?+ path (on-watch:def path)
[%keys ~] (give %chat-update !>([%keys ~(key by inbox)]))
[%all ~] (give %chat-initial !>(inbox))
[%configs ~] (give %chat-configs !>((inbox-to-configs inbox)))
[%updates ~] ~
[%mailbox @ *]
?> (~(has by inbox) t.path)
=/ =ship (slav %p i.t.path)
(give %chat-update !>([%create ship t.t.path]))
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] ``noun+!>(inbox)
[%x %configs ~] ``noun+!>((inbox-to-configs inbox))
[%x %keys ~] ``noun+!>(~(key by inbox))
[%x %envelopes *] (peek-x-envelopes:cc t.t.path)
[%x %mailbox *]
?~ t.t.path
~
``noun+!>((~(get by inbox) t.t.path))
::
[%x %config *]
?~ t.t.path
~
=/ mailbox (~(get by inbox) t.t.path)
?~ mailbox
~
``noun+!>(config.u.mailbox)
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ peek-x-all
|= pax=path
^- (unit (unit [%noun (map path mailbox)]))
[~ ~ %noun inbox]
::
++ peek-x-configs
|= pax=path
^- (unit (unit [%noun chat-configs]))
:^ ~ ~ %noun
(inbox-to-configs inbox)
::
++ peek-x-keys
|= pax=path
^- (unit (unit [%noun (set path)]))
[~ ~ %noun ~(key by inbox)]
::
++ peek-x-mailbox
|= pax=path
^- (unit (unit [%noun (unit mailbox)]))
?~ pax ~
=/ mailbox=(unit mailbox) (~(get by inbox) pax)
[~ ~ %noun mailbox]
::
++ peek-x-config
|= pax=path
^- (unit (unit [%noun config]))
?~ pax ~
=/ mailbox (~(get by inbox) pax)
?~ mailbox ~
:^ ~ ~ %noun
config.u.mailbox
|_ bol=bowl:gall
::
++ peek-x-envelopes
|= pax=path
^- (unit (unit [%noun (list envelope)]))
^- (unit (unit [%noun vase]))
?+ pax ~
[@ @ *]
=/ mail-path t.t.pax
=/ mailbox (~(get by inbox) mail-path)
?~ mailbox
[~ ~ %noun ~]
[~ ~ %noun !>(~)]
=* envelopes envelopes.u.mailbox
=/ sign-test=[?(%neg %pos) @]
%- need
@ -93,142 +129,136 @@
=* start +.sign-test
?: =(-.sign-test %neg)
?: (gth start length)
[~ ~ %noun envelopes]
[~ ~ %noun (swag [(sub length start) start] envelopes)]
[~ ~ %noun !>(envelopes)]
[~ ~ %noun !>((swag [(sub length start) start] envelopes))]
::
=/ end (slav %ud i.t.pax)
?. (lte start end)
~
=. end ?:((lth end length) end length)
[~ ~ %noun (swag [start (sub end start)] envelopes)]
[~ ~ %noun !>((swag [start (sub end start)] envelopes))]
==
::
++ peer-keys
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we send the list of keys then send events when they change
:_ this
[ost.bol %diff %chat-update [%keys ~(key by inbox)]]~
::
++ peer-all
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %chat-initial inbox]~
::
++ peer-configs
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %chat-configs (inbox-to-configs inbox)]~
::
++ peer-updates
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
[~ this]
::
++ peer-mailbox
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
?> (~(has by inbox) pax)
=^ =ship pax
?> ?=([* ^] pax)
[(slav %p i.pax) t.pax]
:_ this
[ost.bol %diff %chat-update [%create ship pax]]~
::
++ poke-json
|= jon=json
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
(poke-chat-action (json-to-action jon))
::
++ poke-chat-action
|= action=chat-action
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
?- -.action
%create (handle-create action)
%delete (handle-delete action)
%message (handle-message action)
%read (handle-read action)
%create (handle-create action)
%delete (handle-delete action)
%message (handle-message action)
%messages (handle-messages action)
%read (handle-read action)
==
::
++ handle-create
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%create -.act)
=/ pax [(scot %p ship.act) path.act]
?: (~(has by inbox) pax)
[~ this]
[~ state]
:- (send-diff pax act)
this(inbox (~(put by inbox) pax *mailbox))
state(inbox (~(put by inbox) pax *mailbox))
::
++ handle-delete
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%delete -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
:- (send-diff path.act act)
this(inbox (~(del by inbox) path.act))
state(inbox (~(del by inbox) path.act))
::
++ handle-message
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%message -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
=* letter letter.envelope.act
=? letter &(?=(%code -.letter) ?=(~ output.letter))
=/ =hoon (ream expression.letter)
letter(output (eval bol hoon))
=: length.config.u.mailbox +(length.config.u.mailbox)
number.envelope.act +(length.config.u.mailbox)
envelopes.u.mailbox (snoc envelopes.u.mailbox envelope.act)
==
[~ state]
=. letter.envelope.act (evaluate-letter [author letter]:envelope.act)
=. u.mailbox (append-envelope u.mailbox envelope.act)
:- (send-diff path.act act)
this(inbox (~(put by inbox) path.act u.mailbox))
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ handle-messages
|= act=chat-action
^- (quip card _state)
?> ?=(%messages -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ state]
=/ evaluated-envelopes=(list envelope) ~
|- ^- (quip card _state)
?~ envelopes.act
:_ state(inbox (~(put by inbox) path.act u.mailbox))
%+ send-diff path.act
:* %messages
path.act
(sub length.config.u.mailbox (lent evaluated-envelopes))
length.config.u.mailbox
evaluated-envelopes
==
=. letter.i.envelopes.act (evaluate-letter [author letter]:i.envelopes.act)
=. evaluated-envelopes (snoc evaluated-envelopes i.envelopes.act)
=. u.mailbox (append-envelope u.mailbox i.envelopes.act)
$(envelopes.act t.envelopes.act)
::
++ handle-read
|= act=chat-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%read -.act)
=/ mailbox=(unit mailbox) (~(get by inbox) path.act)
?~ mailbox
[~ this]
[~ state]
=. read.config.u.mailbox length.config.u.mailbox
:- (send-diff path.act act)
this(inbox (~(put by inbox) path.act u.mailbox))
state(inbox (~(put by inbox) path.act u.mailbox))
::
++ evaluate-letter
|= [author=ship =letter]
^- ^letter
=? letter
?& ?=(%code -.letter)
?=(~ output.letter)
(team:title our.bol author)
==
=/ =hoon (ream expression.letter)
letter(output (eval bol hoon))
letter
::
++ append-envelope
|= [=mailbox =envelope]
^- ^mailbox
=. number.envelope +(length.config.mailbox)
=: length.config.mailbox +(length.config.mailbox)
envelopes.mailbox (snoc envelopes.mailbox envelope)
==
mailbox
::
++ update-subscribers
|= [pax=path act=chat-action]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %chat-update act]
|= [pax=path update=chat-update]
^- (list card)
[%give %fact `pax %chat-update !>(update)]~
::
++ send-diff
|= [pax=path act=chat-action]
^- (list move)
|= [pax=path upd=chat-update]
^- (list card)
%- zing
:~ (update-subscribers /all act)
(update-subscribers /updates act)
(update-subscribers [%mailbox pax] act)
?. |(=(%read -.act) =(%message -.act))
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%mailbox pax] upd)
?. |(|(=(%read -.upd) =(%message -.upd)) =(%messages -.upd))
~
(update-subscribers /configs act)
?. |(=(%create -.act) =(%delete -.act))
(update-subscribers /configs upd)
?. |(=(%create -.upd) =(%delete -.upd))
~
(update-subscribers /keys act)
(update-subscribers /keys upd)
==
::
--

321
pkg/arvo/app/chat-view.hoon
View File

@ -6,7 +6,7 @@
*group-store,
*permission-group-hook,
*chat-hook
/+ *server, *chat-json
/+ *server, *chat-json, default-agent
/= index
/^ octs
/; as-octs:mimes:html
@ -40,17 +40,7 @@
/: /===/app/chat/img /_ /png/
::
|%
::
+$ move [bone card]
::
+$ card
$% [%http-response =http-event:http]
[%connect wire binding:eyre term]
[%peer wire dock path]
[%poke wire dock poke]
[%diff %json json]
[%quit ~]
==
+$ card card:agent:gall
::
+$ poke
$% [%launch-action [@tas path @t]]
@ -61,112 +51,162 @@
[%permission-group-hook-action permission-group-hook-action]
==
--
::
|_ [bol=bowl:gall ?]
::
++ this .
::
++ prep
|= old=(unit ?)
^- (quip move _this)
?~ old
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
chat-core +>
cc ~(. chat-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
^- (quip card _this)
=/ launcha [%launch-action !>([%chat-view /configs '/~chat/js/tile.js'])]
:_ this
:~ [ost.bol %peer / [our.bol %chat-store] /updates]
[ost.bol %connect / [~ /'~chat'] %chat-view]
(launch-poke [/configs '/~chat/js/tile.js'])
:~ [%pass /updates %agent [our.bol %chat-store] %watch /updates]
[%pass / %arvo %e %connect [~ /'~chat'] %chat-view]
[%pass /chat-view %agent [our.bol %launch] %poke launcha]
==
[~ this(+<+ u.old)]
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
?+ mark (on-poke:def mark vase)
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ this
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
poke-handle-http-request:cc
::
%json
:_ this
(poke-chat-view-action:cc (json-to-view-action !<(json vase)))
::
%chat-view-action
:_ this
(poke-chat-view-action:cc !<(chat-view-action vase))
==
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bol src.bol)
|^
?: ?=([%http-response *] path)
[~ this]
?: =(/primary path)
:: create inbox with 100 messages max per mailbox and send that along
:: then quit the subscription
:_ this
[%give %fact ~ %json !>((inbox-to-json truncated-inbox-scry))]~
?: =(/configs path)
[[%give %fact ~ %json !>(*json)]~ this]
(on-watch:def path)
::
++ truncated-inbox-scry
^- inbox
=/ =inbox .^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
%- ~(run by inbox)
|= =mailbox
^- ^mailbox
[config.mailbox (truncate-envelopes envelopes.mailbox)]
::
++ truncate-envelopes
|= envelopes=(list envelope)
^- (list envelope)
=/ length (lent envelopes)
?: (lth length 100)
envelopes
(swag [(sub length 100) 100] envelopes)
--
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%kick
:_ this
[%pass / %agent [our.bol %chat-store] %watch /updates]~
::
%fact
?+ p.cage.sign (on-agent:def wire sign)
%chat-update
:_ this
(diff-chat-update:cc !<(chat-update q.cage.sign))
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-save on-save:def
++ on-load on-load:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
--
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
|_ bol=bowl:gall
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
::
^- simple-payload:http
=+ url=(parse-request-line url.request.inbound-request)
=/ name=@t
=+ back-path=(flop site.url)
?~ back-path
''
i.back-path
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
?+ site.url
:_ this
[ost.bol %http-response not-found:app]~
?+ site.url not-found:gen
[%'~chat' %css %index ~] (css-response:gen style)
[%'~chat' %js %tile ~] (js-response:gen tile-js)
[%'~chat' %js %index ~] (js-response:gen script)
::
:: styling
[%'~chat' %img @t *]
=/ name=@t i.t.t.site.url
=/ img (~(get by chat-png) name)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
::
[%'~chat' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~chat' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
:: images
::
[%'~chat' %img *]
=/ img (as-octs:mimes:html (~(got by chat-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
::
[%'~chat' %paginate @t @t *]
[%'~chat' %paginate @t @t *]
=/ start (need (rush i.t.t.site.url dem))
=/ end (need (rush i.t.t.t.site.url dem))
=/ pax t.t.t.t.site.url
=/ envelopes (envelope-scry [(scot %ud start) (scot %ud end) pax])
:_ this
:~
:+ ost.bol
%http-response
%- json-response:app
%- json-to-octs
%+ envelopes-update
envelopes
[start end pax]
==
%- json-response:gen
%- json-to-octs
%- update-to-json
[%messages pax start end envelopes]
::
:: inbox page
::
[%'~chat' *]
:_ this
[ost.bol %http-response (html-response:app index)]~
[%'~chat' *] (html-response:gen index)
==
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (list card)
?. =(src.bol our.bol)
[~ this]
~
(poke-chat-view-action (json-to-view-action jon))
::
++ poke-chat-view-action
|= act=chat-view-action
^- (quip move _this)
^- (list card)
?. =(src.bol our.bol)
[~ this]
~
?- -.act
%create
:: TODO: add invites
=/ pax [(scot %p our.bol) path.act]
=/ group-read=path [%chat (weld pax /read)]
=/ group-write=path [%chat (weld pax /write)]
:_ this
%- zing
:~ :~ (group-poke [%bundle group-read])
(group-poke [%bundle group-write])
(group-poke [%add read.act group-read])
(group-poke [%add write.act group-write])
(chat-poke [%create our.bol path.act])
(chat-hook-poke [%add-owned pax security.act])
(chat-hook-poke [%add-owned pax security.act allow-history.act])
==
(create-security [%chat pax] security.act)
:~ (permission-hook-poke [%add-owned group-read group-read])
@ -177,7 +217,6 @@
%delete
=/ group-read [%chat (weld path.act /read)]
=/ group-write [%chat (weld path.act /write)]
:_ this
:~ (chat-hook-poke [%remove path.act])
(permission-hook-poke [%remove group-read])
(permission-hook-poke [%remove group-write])
@ -189,82 +228,51 @@
%join
=/ group-read [%chat (scot %p ship.act) (weld path.act /read)]
=/ group-write [%chat (scot %p ship.act) (weld path.act /write)]
:_ this
:~ (chat-hook-poke [%add-synced ship.act path.act])
:~ (chat-hook-poke [%add-synced ship.act path.act ask-history.act])
(permission-hook-poke [%add-synced ship.act group-write])
(permission-hook-poke [%add-synced ship.act group-read])
==
::
==
::
++ peer-primary
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: create inbox with 100 messages max per mailbox and send that along
:: then quit the subscription
:_ this
[ost.bol %diff %json (inbox-to-json (truncate-inbox all-scry))]~
::
++ peer-configs
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:_ this
[ost.bol %diff %json *json]~
::
++ diff-chat-update
|= [wir=wire upd=chat-update]
^- (quip move _this)
|= upd=chat-update
^- (list card)
=/ updates-json (update-to-json upd)
=/ configs-json (configs-to-json configs-scry)
:_ this
%+ weld
%+ turn (prey:pubsub:userlib /primary bol)
|= [=bone *]
[bone %diff %json updates-json]
%+ turn (prey:pubsub:userlib /configs bol)
|= [=bone *]
[bone %diff %json configs-json]
::
++ quit
|= wir=wire
^- (quip move _this)
:_ this
[ost.bol %peer / [our.bol %chat-store] /updates]~
:~ [%give %fact `/primary %json !>(updates-json)]
[%give %fact `/configs %json !>(configs-json)]
==
::
:: +utilities
::
++ launch-poke
|= [=path =cord]
^- move
[ost.bol %poke / [our.bol %launch] [%launch-action %chat-view path cord]]
::
++ chat-poke
|= act=chat-action
^- move
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
^- card
[%pass / %agent [our.bol %chat-store] %poke %chat-action !>(act)]
::
++ group-poke
|= act=group-action
^- move
[ost.bol %poke / [our.bol %group-store] [%group-action act]]
^- card
[%pass / %agent [our.bol %group-store] %poke %group-action !>(act)]
::
++ chat-hook-poke
|= act=chat-hook-action
^- move
[ost.bol %poke / [our.bol %chat-hook] [%chat-hook-action act]]
^- card
[%pass / %agent [our.bol %chat-hook] %poke %chat-hook-action !>(act)]
::
++ permission-hook-poke
|= act=permission-hook-action
^- move
[ost.bol %poke / [our.bol %permission-hook] [%permission-hook-action act]]
^- card
:* %pass / %agent [our.bol %permission-hook]
%poke %permission-hook-action !>(act)
==
::
++ perm-group-hook-poke
|= act=permission-group-hook-action
^- move
=/ pok [%permission-group-hook-action act]
[ost.bol %poke / [our.bol %permission-group-hook] pok]
^- card
:* %pass / %agent [our.bol %permission-group-hook]
%poke %permission-group-hook-action !>(act)
==
::
++ envelope-scry
|= pax=path
@ -272,17 +280,13 @@
=. pax ;:(weld /=chat-store/(scot %da now.bol)/envelopes pax /noun)
.^((list envelope) %gx pax)
::
++ all-scry
^- inbox
.^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
::
++ configs-scry
^- chat-configs
.^(chat-configs %gx /=chat-store/(scot %da now.bol)/configs/noun)
::
++ create-security
|= [pax=path sec=chat-security]
^- (list move)
|= [pax=path sec=rw-security]
^- (list card)
=/ read (weld pax /read)
=/ write (weld pax /write)
?- sec
@ -305,40 +309,5 @@
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
==
::
==
::
++ envelopes-update
|= [envelopes=(list envelope) start=@ud end=@ud pax=path]
^- json
=, enjs:format
%+ frond %chat-update
%- pairs
:~
:- %messages
%- pairs
:~ [%path (path pax)]
[%start (numb start)]
[%end (numb end)]
[%envelopes [%a (turn envelopes enve)]]
==
==
::
++ truncate-envelopes
|= envelopes=(list envelope)
^- (list envelope)
=/ length (lent envelopes)
?: (lth length 100)
envelopes
(swag [(sub length 100) 100] envelopes)
::
++ truncate-inbox
|= box=inbox
^- inbox
%- ~(run by box)
|= mail=mailbox
^- mailbox
:- config.mail
(truncate-envelopes envelopes.mail)
::
--

3
pkg/arvo/app/chat/css/index.css
View File

File diff suppressed because one or more lines are too long

BIN
pkg/arvo/app/chat/img/ChatSwitcherClosed.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 866 B

BIN
pkg/arvo/app/chat/img/ChatSwitcherLink.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 861 B

BIN
pkg/arvo/app/chat/img/popout.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 854 B

BIN
pkg/arvo/app/chat/img/touch_icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 10 KiB

13
pkg/arvo/app/chat/index.html
View File

@ -5,8 +5,21 @@
<meta charset="utf-8" />
<meta name="viewport"
content="width=device-width, initial-scale=1, shrink-to-fit=no"/>
<meta name="apple-mobile-web-app-capable" content="yes" />
<meta name="apple-touch-fullscreen" content="yes" />
<meta name="apple-mobile-web-app-status-bar-style" content="default" />
<link rel="apple-touch-icon" href="/~chat/img/touch_icon.png">
<link rel="stylesheet" href="/~chat/css/index.css" />
<link rel="icon" type="image/png" href="/~launch/img/Favicon.png">
<link rel="manifest"
href='data:application/manifest+json,{
"name": "Chat",
"short_name": "Chat",
"description": "A%20Chat%20application%20for%20your%20Urbit%20ship.",
"display": "standalone",
"background_color": "%23FFFFFF",
"theme_color": "%23000000"}' />
</head>
<body>
<div id="root" />

2
pkg/arvo/app/chat/js/index.js
View File

File diff suppressed because one or more lines are too long

2
pkg/arvo/app/chat/js/tile.js
View File

File diff suppressed because one or more lines are too long

997
pkg/arvo/app/claz.hoon
View File

File diff suppressed because it is too large Load Diff

114
pkg/arvo/app/clock.hoon
View File

@ -1,4 +1,4 @@
/+ *server
/+ *server, default-agent, verb
/= tile-js
/^ octs
/; as-octs:mimes:html
@ -8,61 +8,44 @@
==
=, format
::
|%
:: +move: output effect
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
+$ move [bone card]
:: +card: output effect payload
::
+$ poke
$% [%launch-action [@tas path @t]]
==
::
+$ card
$% [%poke wire dock poke]
[%http-response =http-event:http]
[%connect wire binding:eyre term]
[%diff %json json]
==
::
--
::
|_ [bol=bowl:gall ~]
::
++ this .
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ prep
|= old=(unit ~)
^- (quip move _this)
++ on-init
^- (quip card:agent:gall _this)
=/ launcha
[%launch-action [%clock /tile '/~clock/js/tile.js']]
[%launch-action !>([%clock /tile '/~clock/js/tile.js'])]
:_ this
:~
[ost.bol %connect / [~ /'~clock'] %clock]
[ost.bol %poke /clock [our.bol %launch] launcha]
:~ [%pass / %arvo %e %connect [~ /'~clock'] %clock]
[%pass /clock %agent [our.bowl %launch] %poke launcha]
==
:: bootstrapping to get %goad started OTA
::
++ peer-tile
|= pax=path
^- (quip move _this)
[[ost.bol %diff %json *json]~ this]
++ on-save !>(%2)
++ on-load
|= old-state=vase
=/ old !<(?(~ %1 %2) old-state)
=^ cards this
?: ?=(%2 old)
`this
:_ this :_ ~
[%pass /behn %arvo %b %wait +(now.bowl)]
::
[cards this]
::
++ send-tile-diff
|= jon=json
^- (list move)
%+ turn (prey:pubsub:userlib /tile bol)
|= [=bone ^]
[bone %diff %json jon]
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _this)
?. ?=(%handle-http-request mark)
(on-poke:def mark vase)
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ this
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
|= =inbound-request:eyre
^- (quip move _this)
=/ request-line (parse-request-line url.request.inbound-request)
=/ back-path (flop site.request-line)
=/ name=@t
@ -72,9 +55,36 @@
i.back-path
::
?~ back-path
[[ost.bol %http-response not-found:app]~ this]
not-found:gen
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
[[ost.bol %http-response not-found:app]~ this]
(js-response:gen tile-js)
not-found:gen
::
++ on-watch
|= =path
^- (quip card:agent:gall _this)
?: ?=([%http-response *] path)
`this
?. =(/tile path)
(on-watch:def path)
[[%give %fact ~ %json !>(*json)]~ this]
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?: ?=(%wake +<.sign-arvo)
?^ error.sign-arvo
:_ this :_ ~
[%pass /dill %arvo %d %flog %crud %clock-fail u.error.sign-arvo]
:_ this :_ ~
[%pass /gall %arvo %g %goad | `%hood]
::
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-fail on-fail:def
--

2
pkg/arvo/app/clock/js/tile.js
View File

File diff suppressed because one or more lines are too long

923
pkg/arvo/app/dns-bind.hoon
View File

@ -1,923 +0,0 @@
/- *dns-bind, dns, hall
/+ tapp, stdio
::
:: tapp types and boilerplate
::
=> |%
++ collector-app `dock`[~zod %dns-collector]
+$ app-state
$: %0
:: nem: authoritative state
::
nem=(unit nameserver)
==
+$ peek-data _!!
+$ in-poke-data
$% [%dns-authority =authority]
[%dns-bind =ship =target]
[%handle-http-request =inbound-request:eyre]
[%handle-http-cancel =inbound-request:eyre]
[%noun noun=*]
==
+$ out-poke-data
$% [%dns-bind =ship =target]
[%dns-complete =ship =binding:dns]
[%drum-unlink =dock]
==
+$ in-peer-data
$% [%dns-request =request:dns]
==
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
--
::
:: oauth2 implementation
::
=> |%
:: +oauth2-config: as one would expect
::
+$ oauth2-config
$: auth-url=@t
exchange-url=@t
domain=turf
initial-path=path
redirect-path=path
scopes=(list @t)
==
:: +oauth2: library core
::
++ oauth2
|_ [our=@p now=@da config=oauth2-config code=@t =hart:eyre secrets=@t]
::
++ local-uri
|= [our=ship =path]
^- @t
:: XX can't scry in +mule
::
:: =/ =hart:eyre .^(hart:eyre %e /(scot %p our)/host/real)
(crip (en-purl:html [hart [~ path] ~]))
::
:: XX can't scry in +mule
::
:: ++ code
:: ^- @t
:: %- crip
:: +:(scow %p .^(@p %j /(scot %p our)/code/(scot %da now)/(scot %p our)))
::
:: to initialize these values: |init-oauth2 /com/googleapis
::
++ oauth2-secrets
^- [client-id=@t client-secret=@t]
=; =wain
?> ?=([@t @t ~] wain)
[i.wain i.t.wain]
::
%- to-wain:format
%- need
%+ de:crub:crypto code
%+ slav %uw
:: XX can't scry in +mule
::
:: .^(@ %cx :(weld /(scot %p our)/home/(scot %da now)/sec domain.config /atom))
secrets
::
++ initial-uri (local-uri our initial-path.config)
++ redirect-uri (local-uri our redirect-path.config)
::
++ redirect-to-provider
^- @t
=/ url (need (de-purl:html auth-url.config))
=. r.url
:* ['access_type' 'offline']
['response_type' 'code']
['prompt' 'consent']
['client_id' client-id:oauth2-secrets]
['redirect_uri' redirect-uri]
['scope' (rap 3 (join ' ' scopes.config))]
r.url
==
(crip (en-purl:html url))
::
++ retrieve-access-token
|= code=@t
^- request:http
=/ hed
:~ ['Accept' 'application/json']
['Content-Type' 'application/x-www-form-urlencoded']
==
=/ bod
%- some %- as-octt:mimes:html
%- tail %- tail:en-purl:html
:~ ['client_id' client-id:oauth2-secrets]
:: note: required, unused parameter
::
['redirect_uri' redirect-uri]
['client_secret' client-secret:oauth2-secrets]
['grant_type' 'authorization_code']
['code' code]
==
[%'POST' exchange-url.config hed bod]
::
++ parse-token-response
|= =octs
^- (unit [access=@t expires=@u refresh=@t])
%. q.octs
;~ biff
de-json:html
=, dejs-soft:format
(ot 'access_token'^so 'expires_in'^ni 'refresh_token'^so ~)
==
:: XX implement
::
++ refresh-token !!
--
--
::
:: helpers
::
=> |%
:: +name: fully-qualified domain name for :ship
::
++ name
|= [=ship =turf]
(cat 3 (en-turf:html (weld turf /(crip +:(scow %p ship)))) '.')
:: +lame: domain name for :ship (without trailing '.')
::
++ lame
|= [=ship =turf]
(en-turf:html (weld turf /(crip +:(scow %p ship))))
:: +endpoint: append :path to :purl
::
++ endpoint
|= [=purl:eyre =path]
^+ purl
purl(q.q (weld q.q.purl path))
:: +params: append :params to :purl
::
++ params
|= [=purl:eyre =quay:eyre]
^+ purl
purl(r (weld r.purl quay))
:: +json-octs: deserialize json and apply reparser
::
++ json-octs
|* [bod=octs wit=fist:dejs:format]
=/ jon (de-json:html q.bod)
?~ jon ~
(wit u.jon)
:: +ship-turf: parse ship from first subdomain
::
++ ship-turf
|= [nam=@t aut-dom=turf]
^- (unit ship)
=/ dom=(unit host:eyre)
(rush nam ;~(sfix thos:de-purl:html dot))
?: ?| ?=(~ dom)
?=(%| -.u.dom)
?=(~ p.u.dom)
==
~
=/ who
(rush (head (flop p.u.dom)) fed:ag)
?~ who ~
?. =(aut-dom (flop (tail (flop p.u.dom))))
~
:: galaxies always excluded
::
?: ?=(%czar (clan:title u.who))
~
who
--
::
:: service providers
::
=> |%
:: +provider: initialize provider-specific core
::
++ provider
|= aut=authority
?- -.pro.aut
%fcloud ~(. fcloud aut)
%gcloud ~(. gcloud aut)
==
:: |fcloud: Cloudflare provider
::
++ fcloud
=> |%
++ parse-raw-record
|= aut-dom=turf
^- $- json
(unit [=ship id=@ta tar=target])
=, dejs:format
%+ cu
|= [id=@t typ=@t nam=@t dat=@t]
^- (unit [=ship id=@ta tar=target])
:: XX fix this
::
=/ him (ship-turf (cat 3 nam '.') aut-dom)
?: ?=(~ him)
~
?+ typ
~
::
%'A'
=/ adr (rush dat lip:ag)
?~ adr ~
`[u.him `@ta`id %direct %if u.adr]
::
%'CNAME'
:: XX fix this
::
=/ for (ship-turf (cat 3 dat '.') aut-dom)
?~ for ~
`[u.him `@ta`id %indirect u.for]
==
:: XX parse dates, proxied, ttl?
::
%- ot :~
'id'^so
'type'^so
'name'^so
'content'^so
==
--
::
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://api.cloudflare.com/client/v4'))
:: +headers: standard HTTP headers for all |fcloud requests
::
++ headers
|= aut=authority
?> ?=(%fcloud -.pro.aut)
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['X-Auth-Email' [email.auth.pro.aut ~]]
['X-Auth-Key' [key.auth.pro.aut ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
[(endpoint base /zones/[zone.pro.aut]) %get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%fcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
(crip +:(scow %if p.tar))
(lame p.tar dom.aut)
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (lame him dom.aut)]
['type' %s type]
['content' %s data]
:: XX make configureable?
::
['ttl' %n ~.1]
['proxied' %b %.n]
==
:: +create: provider-specific record-creation request
::
++ create
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
(record him tar)
?~ pre
:- (endpoint base /zones/[zone.pro.aut]/['dns_records'])
[%post (headers aut) `bod]
:- (endpoint base /zones/[zone.pro.aut]/['dns_records']/[id.u.pre])
[%put (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
|= page=(unit @t)
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
:: XX more url params:
:: ?type ?per-page ?order ?direction
::
:- %+ params
(endpoint base /zones/[zone.pro.aut]/['dns_records'])
?~(page ~ ['page' u.page]~)
[%get (headers aut) ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= $: success=?
response=(list (unit [=ship id=@ta tar=target]))
paginate=[page=@ud per-page=@ud count=@ud total-count=@ud]
==
^- (pair (list [=ship id=@ta tar=target]) (unit @t))
?. success [~ ~]
:- (murn response same)
:: XX calculate next page number if applicable
::
~
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(ar (parse-raw-record dom.aut))
:- 'result_info'
%- ot :~
'page'^ni
'per_page'^ni
'count'^ni
'total_count'^ni
==
==
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= [success=? response=(unit [=ship id=@ta tar=target])]
^- (unit [=ship id=@ta tar=target])
?. success ~
response
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(parse-raw-record dom.aut)
==
--
:: |gcloud: GCP provider
::
++ gcloud
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://www.googleapis.com/dns/v1/projects'))
:: +headers: standard HTTP headers for all |gcloud requests
::
++ headers
|= aut=authority
?> ?=(%gcloud -.pro.aut)
?. ?=(^ auth.pro.aut)
~| %gcloud-missing-auth !!
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['Authorization' [`@t`(cat 3 'Bearer ' access.u.auth.pro.aut) ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%gcloud -.pro.aut)
:- (endpoint base /[project.pro.aut]/['managedZones']/[zone.pro.aut])
[%get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%gcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
[%s (crip +:(scow %if p.tar))]
[%s (name p.tar dom.aut)]
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (name him dom.aut)]
['type' %s type]
:: XX make configureable?
::
['ttl' %n ~.300]
['rrdatas' %a data ~]
==
:: +create: provider-specific record-creation request
::
++ create
=, eyre
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/changes
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
:- %o
%- ~(gas by *(map @t json))
:- ['additions' %a (record him tar) ~]
?~ pre ~
[['deletions' %a (record him tar.u.pre) ~] ~]
[url %post (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
=, eyre
|= page=(unit @t)
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/rrsets
=/ hed=math (headers aut)
=? hed ?=(^ page)
(~(put by hed) 'pageToken' [u.page]~)
[url %get hed ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%gcloud -.pro.aut)
=, dejs:format
=> |%
++ page (uf ~ (mu so))
++ records
%+ uf ~
%+ cu
|*(a=(list (unit)) (murn a same))
(ar parse-record)
--
:: XX parse but don't produce
:: 'kind'^(su (jest "dns#resourceRecordSetsListResponse'))
::
(ou 'rrsets'^records 'nextPageToken'^page ~)
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
?> ?=(%gcloud -.pro.aut)
=, dejs:format
%+ cu
|= [typ=@t nam=@t dat=(list @t)]
^- (unit [=ship id=@ta tar=target])
:: gcloud doesn't expose UUIDs for bindings
::
=/ id %$
=/ him (ship-turf nam dom.aut)
?: |(?=(~ him) ?=(~ dat) ?=(^ t.dat))
~
?+ typ
~
::
%'A'
=/ adr (rush i.dat lip:ag)
?~ adr ~
`[u.him id %direct %if u.adr]
::
%'CNAME'
=/ for (ship-turf i.dat dom.aut)
?~ for ~
`[u.him id %indirect u.for]
==
::
%- ot :~
:: 'kind'^(su (jest "dns#resourceRecordSet'))
::
'type'^so
'name'^so
'rrdatas'^(ar so)
==
--
--
::
:: monadic helpers (XX move to stdio?)
::
=> |%
:: +backoff: exponential backoff timer
::
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
::
++ request
|= =hiss:eyre
=/ m (async:stdio (unit httr:eyre))
^- form:m
;< ~ bind:m (send-hiss:stdio hiss)
take-maybe-sigh:stdio
::
++ request-retry
|= [=hiss:eyre max=@ud limit=@dr]
=/ m (async:stdio (unit httr:eyre))
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m ~)
;< ~ bind:m (backoff try limit)
;< rep=(unit httr:eyre) bind:m (request hiss)
:: XX needs a better predicate. LTE will make this easier
::
?: &(?=(^ rep) =(200 p.u.rep))
(pure:m (some u.rep))
loop(try +(try))
--
::
:: application actions
::
=> |%
++ confirm-authority
|= =authority
=/ m (async:stdio ?)
^- form:m
;< rep=(unit httr:eyre) bind:m
(request-retry zone:(provider authority) 5 ~m10)
(pure:m &(?=(^ rep) =(200 p.u.rep)))
::
++ retrieve-existing
|= =authority
=/ m (async:stdio (map ship bound))
^- form:m
=| existing=(map ship bound)
=| next-page=(unit @t)
;< now=@da bind:m get-time:stdio
|- ^- form:m
=* loop $
;< rep=(unit httr:eyre) bind:m
(request-retry (existing:(provider authority) next-page) 5 ~m10)
?: ?| ?=(~ rep)
?=(~ r.u.rep)
==
(pure:m existing)
::
=* octs u.r.u.rep
=+ ^- [dat=(list [=ship id=@ta =target]) page=(unit @t)]
:: XX gross
::
=- ?~(- [~ ~] -)
(json-octs octs parse-list:(provider authority))
=. existing
|- ^+ existing
?~ dat
existing
=/ =bound [now id.i.dat target.i.dat ~]
$(dat t.dat, existing (~(put by existing) ship.i.dat bound))
?~ page
(pure:m existing)
loop(next-page page)
::
++ create-binding
|= [=authority =ship =target existing=(unit bound)]
=/ m (async:stdio (unit bound))
^- form:m
?: &(?=(^ existing) =(target cur.u.existing))
(pure:m existing)
::
=/ pre=(unit [@ta ^target])
?~(existing ~ (some [id cur]:u.existing))
;< rep=(unit httr:eyre) bind:m
(request (create:(provider authority) ship target pre))
:: XX retryable?
::
?. &(?=(^ rep) =(200 p.u.rep))
?: &(?=(^ rep) =(401 p.u.rep))
:: XX automate
::
~& %authentication-failure
~& (skim q.u.rep |=((pair @t @t) ?=(%www-authenticate p)))
(pure:m ~)
::
~& [%create-bind-failed rep]
(pure:m ~)
::
=* httr u.rep
=/ id=@ta
?. ?=(%fcloud -.pro.authority) ~.
?. ?=(^ r.httr)
~| [%authority-create-confirm-id rep] !!
=/ dat=(unit [^ship id=@ta ^target])
(json-octs u.r.httr parse-record:(provider authority))
?~(dat ~. id.u.dat)
::
;< now=@da bind:m get-time:stdio
=/ =bound
[now id target ?~(existing ~ [[wen cur] hit]:u.existing)]
(pure:m (some bound))
::
++ initialize-authority
|= [aut=authority state=app-state]
=/ m tapp-async
^- form:m
?> ?=(^ nem.state)
=* nam u.nem.state
;< good=? bind:m (confirm-authority aut)
?. good
~& %dns-authority-failed
(pure:m state(nem ~))
::
:: XX wait-effect
::
;< existing=(map ship bound) bind:m (retrieve-existing aut)
=. bon.nam (~(uni by bon.nam) existing)
=. nem.state (some nam)
::
:: XX wait-effect
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
--
::
:: |oauth2-core: configured oauth functionality (for |gcloud only)
::
=> |%
++ oauth2-core
|= [=bowl:gall code=@t =hart:eyre secrets=@t]
=/ =oauth2-config
:* auth-url='https://accounts.google.com/o/oauth2/v2/auth'
exchange-url='https://www.googleapis.com/oauth2/v4/token'
domain=/com/googleapis
redirect-path=/dns/oauth
initial-path=/dns/oauth/result
:~ 'https://www.googleapis.com/auth/ndev.clouddns.readwrite'
'https://www.googleapis.com/auth/cloud-platform.read-only'
== ==
~(. oauth2 our.bowl now.bowl oauth2-config code hart secrets)
--
::
:: the app itself
::
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
::
++ handle-peek handle-peek:default-tapp
++ handle-peer handle-peer:default-tapp
::
++ handle-init
=/ m tapp-async
^- form:m
;< success=? bind:m (bind-route:stdio [~ /dns/oauth] dap.bowl)
~| %dns-unable-to-bind-route
?> success
;< ~ bind:m (poke-app:stdio [[our %hood] [%drum-unlink our dap]]:bowl)
(pure:m state)
::
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?. (team:title [our src]:bowl)
~| %bind-yoself !!
?- -.in-poke-data
%noun
?: ?=(%debug noun.in-poke-data)
~& bowl
:: XX redact secrets
::
~& state
(pure:m state)
::
:: XX heavy-handed, will duplicate subscriptions
:: should track bones
::
?: ?=(%resubscribe noun.in-poke-data)
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
::
~& %poke-unknown
(pure:m state)
::
%dns-authority
?. =(~ nem.state)
~| %authority-reset-wat-do !!
=* aut authority.in-poke-data
=/ nam=nameserver [aut ~ ~]
=. nem.state (some nam)
:: XX move this into the provider interface
::
?: ?& ?=(%gcloud -.pro.aut)
?=(~ auth.pro.aut)
==
~& %do-the-oauth-thing
~& initial-uri:(oauth2-core bowl scry.pro.aut)
(pure:m state)
::
(initialize-authority aut state)
::
%dns-bind
?~ nem.state
~| %bind-not-authority !!
=* nam u.nem.state
=* who ship.in-poke-data
=* tar target.in-poke-data
?: ?=(%indirect -.tar)
~| %indirect-unsupported !!
:: defer %indirect where target isn't yet bound
::
:: ?: ?& ?=(%indirect -.tar)
:: !(~(has by bon.nam) p.tar)
:: ==
:: =. dep.nam (~(put ju dep.nam) p.tar [who tar])
:: =. nem.state (some nam)
:: (pure:m state)
=/ existing (~(get by bon.nam) who)
;< new=(unit bound) bind:m (create-binding aut.nam who tar existing)
?~ new
~& [%bind-failed in-poke-data]
(pure:m state)
=/ =turf
(weld dom.aut.nam /(crip +:(scow %p who)))
;< ~ bind:m
(poke-app:stdio collector-app [%dns-complete who +.tar turf])
=. bon.nam (~(put by bon.nam) who u.new)
=. nem.state (some nam)
::
:: XX wait-effect
::
=/ dep=(list [=ship =target])
~(tap in (~(get ju dep.nam) who))
|- ^- form:m
=* loop $
?~ dep
=. dep.nam (~(del by dep.nam) who)
=. nem.state (some nam)
(pure:m state)
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship target]:i.dep)
loop(dep t.dep)
::
%handle-http-cancel
~& %tapp-http-cant-cancel
(pure:m state)
::
%handle-http-request
:: always stash request bone for giving response
::
=/ =bone ost.bowl
:: XX maybe always (set-raw-contract %request) so transaction failure is captured?
::
=* inbound-request inbound-request.in-poke-data
?~ nem.state
~& :* %not-an-authority
%http-request
=> inbound-request
[authenticated secure address [method url]:request]
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%403 ~] ~ %.y])
(pure:m state)
::
=* nam u.nem.state
?> ?=(%gcloud -.pro.aut.nam)
::
=/ parsed=(unit (pair pork:eyre quay:eyre))
%+ rush
url.request.inbound-request
;~(plug ;~(pose apat:de-purl:html (easy *pork:eyre)) yque:de-purl:html)
::
?. ?=(^ parsed)
~| [%invalid-url url.request.inbound-request] !!
=* url q.p.u.parsed
=* ext p.p.u.parsed
=* params q.u.parsed
::
?+ url
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%404 ~] ~ %.y])
(pure:m state)
::
[%dns %oauth ~]
=/ link (trip redirect-to-provider:(oauth2-core bowl scry.pro.aut.nam))
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p make sure that the oauth credential is configured
with a redirect uri of {(trip redirect-uri:(oauth2-core bowl scry.pro.aut.nam))}
==
;a(href link): {link}
==
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%200 ~] bod %.y])
(pure:m state)
::
[%dns %oauth %result ~]
=/ code (~(got by (my params)) %code)
:: XX make path configurable
::
=/ hed [['Location' '/dns/oauth/success'] ~]
::
;< ~ bind:m
(send-request:stdio (retrieve-access-token:(oauth2-core bowl scry.pro.aut.nam) code))
;< rep=(unit client-response:iris) bind:m
take-maybe-response:stdio
:: XX retry
::
?> ?& ?=(^ rep)
?=(%finished -.u.rep)
?=(^ full-file.u.rep)
==
=/ data (parse-token-response:oauth2 data.u.full-file.u.rep)
=. auth.pro.aut.nam (some [access refresh]:(need data))
=. nem.state (some nam)
:: XX use expiry to set refresh timer
::
:: XX may need to send this as a card so we don't wait
::
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%301 hed] ~ %.y])
(initialize-authority aut.nam state)
::
[%dns %oauth %success ~]
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p: you may close the browser window
;p
;span: XX remove me
:: XX make path configurable
::
;a(href "/dns/oauth"): again
==
==
==
;< ~ bind:m (send-effect:stdio %http-response %start [%201 ~] bod %.y)
(pure:m state)
==
==
::
++ handle-diff
|= [=dock =path =in-peer-data]
=/ m tapp-async
^- form:m
?. =(dock collector-app)
(pure:m state)
=* req request.in-peer-data
=/ =target [%direct address.req]
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship.req target])
(pure:m state)
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?. ?=(%quit -.sign)
:: XX handle stuff
::
(pure:m state)
::
?. ?& =(dock.sign collector-app)
=(path.sign /requests)
==
~& [%unexpected-quit-wat-do [dock path]:sign]
(pure:m state)
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
--

176
pkg/arvo/app/dns-collector.hoon
View File

@ -1,8 +1,10 @@
/- dns
/+ default-agent, verb
::
:: app types and boilerplate
::
=> |%
+$ card card:agent:gall
+$ app-state
$: %0
requested=(map ship address:dns)
@ -17,83 +19,56 @@
[%dns-complete =ship =binding:dns]
[%noun noun=*]
==
+$ out-poke-data
$% [%drum-unlink =dock]
==
+$ out-peer-data
$% [%dns-binding =binding:dns]
[%dns-request =request:dns]
==
+$ card
$% [%diff out-peer-data]
[%poke wire =dock out-poke-data]
==
+$ move [bone card]
--
::
=| moves=(list move)
|_ [=bowl:gall state=app-state]
::
++ this .
::
++ abet
^- (quip move _this)
[(flop moves) this(moves ~)]
::
++ emit
|= mov=move
^+ this
this(moves [mov moves])
::
++ emil
|= moz=(list move)
|- ^+ this
?~ moz
this
$(moz t.moz, ..this (emit i.moz))
::
++ poke-app
|= [=wire =dock =out-poke-data]
^+ this
(emit [ost.bowl %poke wire dock out-poke-data])
::
|%
++ give-result
|= [=the=path =out-peer-data]
^+ this
%- emil
%+ turn
^- (list bone)
%+ murn ~(tap by sup.bowl)
|= [ost=bone =ship =sub=path]
`(unit bone)`?.(=(the-path sub-path) ~ (some ost))
|= =bone
[bone %diff out-peer-data]
|= [=the=path =cage]
^- card
[%give %fact `the-path cage]
--
::
++ prep
|= old=(unit app-state)
^- (quip move _this)
=< abet
?~ old
(poke-app /unlink [[our %hood] [%drum-unlink our dap]]:bowl)
this(state u.old)
^- agent:gall
=| state=app-state
%+ verb |
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ poke
|= =in-poke-data
^- (quip move _this)
=< abet
?- -.in-poke-data
%noun
?: ?=(%debug noun.in-poke-data)
~& bowl
~& state
this
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(app-state old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
|^
?+ mark (on-poke:def mark vase)
%noun (handle-noun !<(noun vase))
%dns-address (handle-dns-address !<(address:dns vase))
%dns-complete (handle-dns-complete !<([ship binding:dns] vase))
==
::
++ handle-noun
|= noun=*
^- (quip card _this)
?: ?=(%debug noun)
~& bowl=bowl
~& state=state
`this
::
~& %poke-unknown
this
`this
::
%dns-address
++ handle-dns-address
|= adr=address:dns
^- (quip card _this)
=* who src.bowl
=* adr address.in-poke-data
=/ rac (clan:title who)
?. ?=(?(%king %duke) rac)
~| [%dns-collector-bind-invalid who] !!
@ -104,23 +79,26 @@
=/ dun=(unit binding:dns) (~(get by completed.state) who)
?: &(?=(^ dun) =(adr address.u.dun))
=. requested.state (~(del by requested.state) who)
(give-result /(scot %p who) %dns-binding u.dun)
:_ this :_ ~
(give-result /(scot %p who) %dns-binding !>(u.dun))
::
?: &(?=(^ req) =(adr u.req))
this
`this
:: XX check address?
=/ =request:dns [who adr]
=. requested.state (~(put by requested.state) request)
(give-result /requests %dns-request request)
:_ this :_ ~
(give-result /requests %dns-request !>(request))
::
%dns-complete
++ handle-dns-complete
|= [who=ship =binding:dns]
^- (quip card _this)
:: XX or confirm valid binding?
::
?. (team:title [our src]:bowl)
~| %complete-yoself !!
=* who ship.in-poke-data
=* adr address.binding.in-poke-data
=* tuf turf.binding.in-poke-data
=* adr address.binding
=* tuf turf.binding
=/ req=(unit address:dns) (~(get by requested.state) who)
:: ignore established bindings that don't match requested
::
@ -128,47 +106,49 @@
!=(adr u.req)
==
~& %unknown-complete
this
`this
=: requested.state (~(del by requested.state) who)
completed.state (~(put by completed.state) who [adr tuf])
==
(give-result /(scot %p who) %dns-binding adr tuf)
==
:_ this :_ ~
(give-result /(scot %p who) %dns-binding !>([adr tuf]))
--
::
++ peek
++ on-watch
|= =path
^- (unit (unit peek-data))
?+ path [~ ~]
[%x %requested ~]
[~ ~ %requested ~(tap by requested.state)]
::
[%x %completed ~]
[~ ~ %completed ~(tap by completed.state)]
==
::
++ peer
|= =path
^- (quip move _this)
=< abet
:: will be immediately unlinked, see +prep
::
^- (quip card _this)
?: ?=([%sole *] path)
this
!!
?. ?=([@ ~] path)
~| %invalid-path !!
?: ?=(%requests i.path)
=/ requests ~(tap by requested.state)
|- ^+ this
|- ^- (quip card _this)
=* loop $
?~ requests
this
=. ..this (give-result path %dns-request i.requests)
loop(requests t.requests)
`this
=/ card (give-result path %dns-request !>(i.requests))
=^ cards this loop(requests t.requests)
[[card cards] this]
::
=/ who=(unit @p) (slaw %p i.path)
?~ who
~| %invalid-path !!
?~ dun=(~(get by completed.state) u.who)
this
(give-result path %dns-binding u.dun)
`this
:_ this :_ ~
(give-result path %dns-binding !>(u.dun))
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path [~ ~]
[%x %requested ~] [~ ~ %requested !>(~(tap by requested.state))]
[%x %completed ~] [~ ~ %completed !>(~(tap by completed.state))]
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

294
pkg/arvo/app/dns.hoon
View File

@ -1,294 +0,0 @@
/- dns, hall
/+ tapp, stdio
::
:: tapp types and boilerplate
::
=> |%
++ collector-app `dock`[~zod %dns-collector]
+$ app-state
$: %0
requested=(unit address:dns)
completed=(unit binding:dns)
==
+$ peek-data _!!
+$ in-poke-data
$% [%dns-auto ames-domains=(list turf)]
[%dns-address =address:dns]
==
+$ out-poke-data
$% [%dns-address =address:dns]
[%hall-action %phrase audience:hall (list speech:hall)]
==
+$ in-peer-data
$% [%dns-binding =binding:dns]
==
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ stdio (^stdio out-poke-data out-peer-data)
--
::
:: monadic helpers (XX move to stdio?)
::
=> |%
:: +backoff: exponential backoff timer
::
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
::
++ request
|= =hiss:eyre
=/ m (async:stdio (unit httr:eyre))
^- form:m
;< ~ bind:m (send-hiss:stdio hiss)
take-maybe-sigh:stdio
::
:: +self-check-http: confirm our availability at .host on port 80
::
:: XX needs better success/failure predicates
:: XX bind route to self and handle request inside tx?
::
++ self-check-http
|= [=host:eyre max=@ud]
=/ m (async:stdio ?)
^- form:m
:: XX also scry into eyre
:: q:.^(hart:eyre %e /(scot %p our)/host/real)
=/ =hiss:eyre
=/ url=purl:eyre
[[sec=| por=~ host] [ext=`~.udon path=/static] query=~]
[url %get ~ ~]
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m |)
;< ~ bind:m (backoff try ~h1)
;< rep=(unit httr:eyre) bind:m (request hiss)
?: ?& ?=(^ rep)
|(=(200 p.u.rep) =(307 p.u.rep))
==
(pure:m &)
?. ?| ?=(~ rep)
=(504 p.u.rep)
==
(pure:m |)
loop(try +(try))
::
++ hall-app-message
|= [app=term =cord =tang]
=/ m (async:stdio ,~)
^- form:m
=/ msg=speech:hall
:+ %app app
=/ line [%lin & cord]
?~(tang line [%fat [%tank tang] line])
;< our=@p bind:m get-identity:stdio
=/ act
[%phrase (sy [our %inbox] ~) [msg ~]]
(poke-app:stdio [our %hall] %hall-action act)
--
::
:: application actions
::
=> |%
:: +turf-confirm-install: self check and install domain
::
++ turf-confirm-install
|= =turf
=/ m (async:stdio ?)
^- form:m
;< good=? bind:m (self-check-http &+turf 5)
?. good
(pure:m |)
;< ~ bind:m (install-domain:stdio turf)
(pure:m &)
::
:: +galaxy-domains
::
++ galaxy-domains
|= ames-domains=(list turf)
=/ m (async:stdio ,~)
^- form:m
;< our=@p bind:m get-identity:stdio
:: XX urbit/urbit#1314
::
:: ;< now=@da bind:m get-time:stdio
:: =/ ames-domains=(list turf)
:: .^((list turf) %j /(scot %p our)/turf/(scot %da now))
|- ^- form:m
=* loop $
?~ ames-domains
(pure:m ~)
=/ =turf
(weld i.ames-domains /(crip +:(scow %p our)))
;< good=? bind:m (turf-confirm-install turf)
=/ msg=(pair cord tang)
?: good
[(cat 3 'confirmed access via ' (en-turf:html turf)) ~]
:- (cat 3 'unable to access via ' (en-turf:html turf))
:~ leaf+"XX check via nslookup"
leaf+"XX confirm port 80"
==
;< ~ bind:m (hall-app-message %dns msg)
loop(ames-domains t.ames-domains)
::
:: +request-by-ip
::
++ request-by-ip
|= if=@if
=/ m (async:stdio ?)
^- form:m
;< good=? bind:m (self-check-http |+if 5)
?. good
:: XX details
~& %bail-early
(pure:m |)
;< ~ bind:m (poke-app:stdio collector-app [%dns-address %if if])
;< our=@p bind:m get-identity:stdio
;< ~ bind:m (peer-app:stdio collector-app /(scot %p our))
(pure:m &)
--
::
=* tapp-async tapp-async:tapp
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
|_ [=bowl:gall state=app-state]
::
++ handle-init handle-init:default-tapp
++ handle-peek handle-peek:default-tapp
++ handle-peer handle-peer:default-tapp
::
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?. (team:title [our src]:bowl)
~| %configure-yoself !!
?- -.in-poke-data
::
:: "automatic" dns binding -- currently only for galaxies
::
:: XX could be in +handle-init
:: XX use ip reflection for other classes
::
%dns-auto
?. ?=(%czar (clan:title our.bowl))
:: XX details
::
~& %galaxy-only
(pure:m state)
;< ~ bind:m (galaxy-domains ames-domains.in-poke-data)
(pure:m state)
::
:: manual dns binding -- by explicit ipv4
::
%dns-address
=* adr address.in-poke-data
=/ rac (clan:title our.bowl)
?. ?=(?(%king %duke) rac)
~| [%dns-collector-bind-invalid rac] !!
?: (reserved:eyre if.adr)
~| [%dns-collector-reserved-address if.adr] !!
;< requested=? bind:m (request-by-ip if.adr)
:: XX save failure?
::
~? =(requested.state (some address.in-poke-data))
%re-requesting
=? requested.state requested
(some address.in-poke-data)
(pure:m state)
==
::
++ handle-diff
|= [=dock =path =in-peer-data]
=/ m tapp-async
^- form:m
?. =(dock collector-app)
~| [%unexpected-diff-dock-wat-do dock] !!
?. =(path /(scot %p our.bowl))
~| [%unexpected-diff-path-wat-do path] !!
?- -.in-peer-data
%dns-binding
=* binding binding.in-peer-data
?~ requested.state
~| %unexpected-binding-wat-do !!
?. =(u.requested.state address.binding)
~| %mismatch-binding-wat-do !!
;< good=? bind:m (turf-confirm-install turf.binding)
=/ msg=(pair cord tang)
?: good
[(cat 3 'confirmed access via ' (en-turf:html turf.binding)) ~]
:- (cat 3 'unable to access via ' (en-turf:html turf.binding))
:~ leaf+"XX check via nslookup"
leaf+"XX confirm port 80"
==
;< ~ bind:m (hall-app-message %dns msg)
=? completed.state good (some binding)
:: XX save failure?s
:: XX unsubscribe?
(pure:m state)
==
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?+ -.sign
~| [%unexpected-sign sign] !!
:: print %poke nacks
::
%coup
?. =(collector-app dock.sign)
(pure:m state)
?~ error.sign
=/ msg=cord
(cat 3 'request for DNS sent to ' (scot %p p:collector-app))
;< ~ bind:m (hall-app-message %dns msg ~)
(pure:m state)
:: XX details
~& %dns-ip-request-failed
%- (slog u.error.sign)
(pure:m state)
:: re-subscribe if (involuntarily) unsubscribed
::
%quit
?. =(path.sign /(scot %p our.bowl))
~| [%unexpected-quit-path-wat-do path.sign] !!
;< ~ bind:m (peer-app:stdio collector-app /(scot %p our.bowl))
(pure:m state)
:: print %peer nacks
::
%reap
?. =(path.sign /(scot %p our.bowl))
~| [%unexpected-reap-path-wat-do path.sign] !!
?~ error.sign
=/ msg=cord
(cat 3 'awaiting response from ' (scot %p p:collector-app))
;< ~ bind:m (hall-app-message %dns msg ~)
(pure:m state)
:: XX details
~& %dns-domain-subscription-failed
%- (slog u.error.sign)
(pure:m state)
==
--

469
pkg/arvo/app/dojo.hoon
View File

@ -2,17 +2,19 @@
:::: /hoon/dojo/app :: ::::
:: :: ::
/? 309 :: arvo kelvin
/- sole, lens :: console structures
/+ sole :: console library
=, sole
/- *sole, lens :: console structures
/+ sole, pprint, ::
auto=language-server-complete, ::
easy-print=language-server-easy-print ::
:: :: ::
:::: :: ::::
:: :: ::
=> |% :: external structures
++ id @tasession :: session id
++ house :: all state
$: $5
egg/@u :: command count
hoc/(map bone session) :: conversations
hoc/(map id session) :: conversations
== ::
++ session :: per conversation
$: say/sole-share :: command-line state
@ -29,7 +31,7 @@
old/(set term) :: used TLVs
buf/tape :: multiline buffer
== ::
++ monkey :: per conversation
++ monkey :: per conversation
$: say/sole-share :: command-line state
dir/beam :: active path
poy/(unit dojo-project) :: working
@ -62,6 +64,7 @@
$~ [%ex *hoon]
$% {$ur p/@t} :: http GET request
{$ge p/dojo-model} :: generator
{$te p/term q/(list dojo-source)} :: thread
{$dv p/path} :: core from source
{$ex p/hoon} :: hoon expression
{$sa p/mark} :: example mark value
@ -93,45 +96,6 @@
== ::
++ bead {p/(set beam) q/cage} :: computed result
++ goal {p/ship q/term} :: flat application
++ clap :: action, user
$% {$peer p/path} :: subscribe
{$poke p/(cask)} :: apply
{$pull ~} :: unsubscribe
== ::
++ club :: action, system
$% {$peer p/path} :: subscribe
{$poke p/cage} :: apply
{$pull ~} :: unsubscribe
== ::
++ card :: general card
$% {$diff $sole-effect sole-effect} ::
{$send wire {ship term} clap} ::
[%request wire request:http outbound-config:iris] :: %l
[%build wire ? schematic:ford]
[%kill wire ~]
{$deal wire sock term club} ::
{$info wire toro:clay} ::
== ::
++ move (pair bone card) :: user-level move
++ sign ::
$% :: %made: build result; response to %build +task
::
$: %made
:: date: formal date of the build
::
date=@da
:: result: result of the build; either complete build, or error
::
$= result
$% :: %complete: contains the result of the completed build
::
[%complete build-result=build-result:ford]
:: %incomplete: couldn't finish build; contains error message
::
[%incomplete =tang]
== ==
{$unto p/internal-gift:gall}
==
--
=>
|%
@ -241,6 +205,7 @@
;~ pose
;~(plug (cold %ur lus) parse-url)
;~(plug (cold %ge lus) parse-model)
;~(plug (cold %te hep) sym (star ;~(pfix ace parse-source)))
;~(plug (cold %as pad) sym ;~(pfix ace parse-source))
;~(plug (cold %do cab) parse-hoon ;~(pfix ace parse-source))
parse-value
@ -330,11 +295,15 @@
:: ::
=, gall
=+ foo=*monkey
|_ $: hid/bowl :: system state
house :: program state
== ::
=| house :: program state
=* state -
=> |%
::
++ xskol `$-(type tank)`type-to-tank:pprint
++ xsell `$-(vase tank)`vase-to-tank:pprint
::
++ he :: per session
|_ {moz/(list move) session} ::
|_ {hid/bowl:gall =id moz/(list card:agent:gall) session}
::
++ he-beam
^- beam
@ -357,20 +326,28 @@
?> ?=($~ pux)
:: pin all builds to :now.hid so they don't get cached forever
::
(he-card(poy `+>+<(pux `way)) %build way live=%.n schematic)
%- he-card(poy `+>+<(pux `way))
[%pass way %arvo %f %build live=%.n schematic]
::
++ dy-request
|= [way=wire =request:http]
^+ +>+>
?> ?=(~ pux)
(he-card(poy `+>+<(pux `way)) %request way request *outbound-config:iris)
%- he-card(poy `+>+<(pux `way))
[%pass way %arvo %i %request request *outbound-config:iris]
::
++ dy-stop :: stop work
^+ +>
=. poy ~
?~ pux +>
%. [%txt "! cancel {<u.pux>}"]
he-diff:(he-card [%kill u.pux ~])
=< he-diff
%- he-card
?: =(/wool u.pux)
:: really shoud stop the thread as well
::
[%pass u.pux %agent [our.hid %spider] %leave ~]
[%pass u.pux %arvo %f %kill ~]
::
++ dy-slam :: call by ford
|= {way/wire gat/vase sam/vase}
@ -427,14 +404,9 @@
$as =^(mor +>.$ (dy-init-source q.bul) [bul(q mor) +>.$])
$do =^(mor +>.$ (dy-init-source q.bul) [bul(q mor) +>.$])
$ge =^(mod +>.$ (dy-init-model p.bul) [[%ge mod] +>.$])
$te =^(mod +>.$ (dy-init-ordered q.bul) [bul(q mod) +>.$])
$ur [bul +>.$]
$tu =^ dof +>.$
|- ^+ [p.bul +>.^$]
?~ p.bul [~ +>.^$]
=^ dis +>.^$ (dy-init-source i.p.bul)
=^ mor +>.^$ $(p.bul t.p.bul)
[[dis mor] +>.^$]
[[%tu dof] +>.$]
$tu =^(dof +>.$ (dy-init-ordered p.bul) [[%tu dof] +>.$])
==
::
++ dy-init-model :: ++dojo-model
@ -565,19 +537,18 @@
::
$poke
%- he-card(poy ~)
:* %deal
/poke
[our.hid p.p.p.mad]
q.p.p.mad
:* %pass
/poke
%agent
p.p.mad
%poke
cay
==
::
$file
%- he-card(poy ~) :*
%info
/file
(foal:space:userlib (en-beam:format p.p.mad) cay)
%- he-card(poy ~)
:* %pass /file %arvo %c
%info (foal:space:userlib (en-beam:format p.p.mad) cay)
==
::
$flat
@ -669,23 +640,27 @@
::
++ dy-type :: sole action
|= act/sole-action
?- -.act
$det (dy-edit +.act)
?- -.dat.act
$det (dy-edit +.dat.act)
$ret (dy-done (tufa buf.say))
$clr dy-stop
$tab +>+>
==
::
++ dy-cage |=(num/@ud (~(got by rez) num)) :: known cage
++ dy-vase |=(num/@ud q:(dy-cage num)) :: known vase
++ dy-sore
|= src/(list dojo-source)
^- vase
?~ src
!>(~)
(slop (dy-vase p.i.src) $(src t.src))
::
++ dy-silk-vase |=(vax/vase [%$ %noun vax]) :: vase to silk
++ dy-silk-sources :: arglist to silk
|= src/(list dojo-source)
^- schematic:ford
::
:+ %$ %noun
|-
?~ src !>(~)
(slop (dy-vase p.i.src) $(src t.src))
[%$ %noun (dy-sore src)]
::
++ dy-silk-config :: configure
|= {cay/cage cig/dojo-config}
@ -719,23 +694,6 @@
:+ %$ %noun
?~(b !>([~ ~]) (dy-vase p.u.b))
::
++ dy-hoon-head :: dynamic state
:: todo: how do i separate the toplevel 'dojo state' comment?
:: dojo state
::
:: our: the name of this urbit
:: now: the current time
:: eny: a piece of random entropy
::
^- cage
:- %noun
=+ sloop=|=({a/vase b/vase} ?:(=(*vase a) b ?:(=(*vase b) a (slop a b))))
%+ sloop
%- ~(rep by var)
|= {{a/term @ b/vase} c/vase} ^- vase
(sloop b(p face+[a p.b]) c)
!>([our=our now=now eny=eny]:hid)
::
++ dy-made-dial :: dialog product
|= cag/cage
^+ +>+>
@ -766,12 +724,28 @@
|= cag/cage
(dy-hand %noun q.cag)
::
++ dy-wool-poke
|= [fil=term src=(list dojo-source)]
^+ +>+>
?> ?=(~ pux)
=/ tid (scot %ta (cat 3 'dojo_' (scot %uv (sham eny.hid))))
=. poy `+>+<.$(pux `/wool)
=. +>+>.$
%- he-card
[%pass /wool %agent [our.hid %spider] %watch /thread-result/[tid]]
%- he-card
=/ =cage :: also sub
[%spider-start !>([~ `tid fil (dy-sore src)])]
[%pass /wool %agent [our.hid %spider] %poke cage]
::
++ dy-make :: build step
^+ +>
?> ?=(^ cud)
=+ bil=q.u.cud :: XX =*
?: ?=($ur -.bil)
(dy-request /hand `request:http`[%'GET' p.bil ~ ~])
?: ?=($te -.bil)
(dy-wool-poke p.bil q.bil)
%- dy-ford
^- [path schematic:ford]
?- -.bil
@ -809,7 +783,7 @@
=+ too=(dy-hoon-mark gen)
=- ?~(too - [%cast he-disc u.too -])
:+ %ride gen
:- [%$ dy-hoon-head]
:- [%$ he-hoon-head]
:^ %plan he-rail `coin`blob+**
`scaffold:ford`[he-rail zuse sur lib ~ ~]
::
@ -844,33 +818,27 @@
==
::
++ he-abet :: resolve
[(flop moz) %_(+> hoc (~(put by hoc) ost.hid +<+))]
::
++ he-abut :: discard
=> he-stop
[(flop moz) %_(+> hoc (~(del by hoc) ost.hid))]
[(flop moz) %_(state hoc (~(put by hoc) id +<+>+))]
::
++ he-card :: emit gift
|= cad/card
|= =card:agent:gall
^+ +>
%_(+> moz [[ost.hid cad] moz])
::
++ he-send
|= {way/wire him/ship dap/term cop/clap}
^+ +>
(he-card %send way [him dap] cop)
=? card ?=(%pass -.card)
card(p [id p.card])
%_(+> moz [card moz])
::
++ he-diff :: emit update
|= fec/sole-effect
^+ +>
(he-card %diff %sole-effect fec)
(he-card %give %fact `/sole/[id] %sole-effect !>(fec))
::
++ he-stop :: abort work
^+ .
?~(poy . ~(dy-stop dy u.poy))
::
++ he-peer :: subscribe to
|=(pax/path ?>(=(~ pax) he-prom))
|= pax/path
?>(=(~ pax) he-prom)
::
++ he-pine :: restore prompt
^+ .
@ -939,15 +907,45 @@
(he-diff(poy ~) %tan message.build-result.result)
== ==
::
++ he-unto :: result from behn
|= {way/wire cit/internal-gift:gall}
++ he-unto :: result from agent
|= {way/wire cit/sign:agent:gall}
^+ +>
?. ?=($coup -.cit)
?. ?=($poke-ack -.cit)
~& [%strange-unto cit]
+>
?~ p.cit
(he-diff %txt ">=")
(he-diff %tan u.p.cit)
::
++ he-wool
|= [way=wire =sign:agent:gall]
^+ +>
?- -.sign
%poke-ack
?~ p.sign
+>.$
=. +>.$ (he-diff(poy ~) %tan u.p.sign)
(he-card %pass /wool %agent [our.hid %spider] %leave ~)
::
%watch-ack
?~ p.sign
+>.$
(he-diff(poy ~) %tan u.p.sign)
::
%fact
?+ p.cage.sign ~|([%dojo-thread-bad-mark-result p.cage.sign] !!)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%+ he-diff(poy ~) %tan
(flop `^tang`[leaf+"thread failed: {<term>}" tang])
::
%thread-done
?> ?=(^ poy)
(~(dy-hand dy u.poy(pux ~)) %noun q.cage.sign)
==
::
%kick +>.$
==
:: +he-http-response: result from http-client
::
++ he-http-response
@ -1107,15 +1105,79 @@
==
==
::
++ he-tab
|= pos=@ud
^+ +>
=* res +>
=+ ^- [back-pos=@ud fore-pos=@ud txt=tape]
(insert-magic:auto (add (lent buf) pos) :(weld buf (tufa buf.say)))
=/ id-len (sub fore-pos back-pos)
=/ fore-pos-diff (sub fore-pos pos)
=+ vex=((full parse-command-line:he-parser) [1 1] txt)
?. ?=([* ~ [* @ %ex *] *] vex)
res
=/ typ p:(slop q:he-hoon-head !>(..dawn))
=/ tl (tab-list-hoon:auto typ p.q.q.p.u.q.vex)
=/ advance (advance-hoon:auto typ p.q.q.p.u.q.vex)
=? res ?=(^ advance)
=/ to-send
(trip (rsh 3 (sub pos back-pos) u.advance))
=| fxs=(list sole-effect)
=. .
|- ^+ +.$
?. (gth fore-pos-diff 0)
+.$
=^ lic say (~(transmit sole say) %del pos)
%= $
fxs [det+lic fxs]
fore-pos-diff (dec fore-pos-diff)
==
:: =. pos (add pos fore-pos-diff)
|- ^+ res
?~ to-send
(he-diff %mor (flop fxs))
=^ lic say (~(transmit sole say) %ins pos `@c`i.to-send)
$(to-send t.to-send, fxs [`sole-effect`det+lic fxs], pos +(pos))
:: If couldn't search (eg cursor not in appropriate position), do
:: nothing.
::
?: ?=(~ tl)
res
:: If no options, ring the bell
::
?: =([~ ~] tl)
(he-diff %bel ~)
:: If only one option, don't print unless the option is already
:: typed in.
::
?: &(?=([* ~] u.tl) !=((met 3 (need advance)) id-len))
res
:: Else, print results
::
=/ lots (gth (lent u.tl) 10)
%+ he-diff %tab
%+ turn u.tl
|= [=term =type]
~| term
:- term
?: lots
*tank
:: +perk is broken because *perk crashes.
::
?: =(%perk term)
*tank
~(duck easy-print type)
::
++ he-type :: apply input
|= act/sole-action
^+ +>
?^ poy
he-pine:(~(dy-type dy u.poy) act)
?- -.act
$det (he-stir +.act)
?- -.dat.act
$det (he-stir +.dat.act)
$ret (he-done (tufa buf.say))
$clr he-pine(buf "")
$tab (he-tab +.dat.act)
==
::
++ he-lame :: handle error
@ -1125,75 +1187,134 @@
?^ poy
he-pine:~(dy-amok dy u.poy)
he-pine :: XX give mean to original keystroke
::
++ he-hoon-head :: dynamic state
:: todo: how do i separate the toplevel 'dojo state' comment?
:: dojo state
::
:: our: the name of this urbit
:: now: the current time
:: eny: a piece of random entropy
::
^- cage
:- %noun
=+ sloop=|=({a/vase b/vase} ?:(=(*vase a) b ?:(=(*vase b) a (slop a b))))
%+ sloop
%- ~(rep by var)
|= {{a/term @ b/vase} c/vase} ^- vase
(sloop b(p face+[a p.b]) c)
!>([our=our now=now eny=eny]:hid)
--
--
^- agent:gall
|_ hid=bowl:gall
++ on-init
`..on-init
::
++ prep
|= old/(unit house)
^+ [~ ..prep]
?~ old `..prep
`..prep(+<+ u.old)
++ on-save
!>(state)
::
:: pattern: ++ foo |=(data he-abet:(~(he-foo he (~(got by hoc) ost)) data))
++ arm (arm-session ~ (~(got by hoc) ost.hid))
++ arm-session
|= {moz/(list move) ses/session}
=> ~(. he moz ses)
=- [wrap=- +]
=+ he-arm=he-type
|@ ++ $
|: +<.he-arm
^- (quip move _..he)
he-abet:(he-arm +<)
--
++ on-load
|= =old-state=vase
=/ old-state !<(house old-state-vase)
`..on-init(state old-state)
::
++ peer-sole
~? !=(our.hid src.hid) [%dojo-peer-stranger ost.hid src.hid]
?> (team:title our.hid src.hid)
=^ moz .
?. (~(has by hoc) ost.hid) [~ .]
~& [%dojo-peer-replaced ost.hid]
~(he-abut he ~ (~(got by hoc) ost.hid))
=+ ses=%*(. *session -.dir [our.hid %home ud+0])
(wrap he-peer):(arm-session moz ses)
::
++ poke-sole-action
|= act/sole-action ~| poke+act %. act
(wrap he-type):arm
::
++ poke-lens-command
|= com/command:lens ~| poke-lens+com %. com
(wrap he-lens):arm
::
++ poke-json
|= jon=json
^- [(list move) _+>.$]
~& jon=jon
[~ +>.$]
:: +poke-wipe: clear all dojo sessions
::
++ poke-wipe
|= *
^- [(list move) _+>.$]
~& %dojo-wipe
=. hoc
%- ~(run by hoc)
|= =session
%_ session
sur ~
lib ~
var ~
old ~
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _..on-init)
=^ moves state
^- (quip card:agent:gall house)
?+ mark ~|([%dojo-poke-bad-mark mark] !!)
%sole-action
=/ act !<(sole-action vase)
he-abet:(~(he-type he hid id.act ~ (~(got by hoc) id.act)) act)
::
%lens-command
=+ !<([=id =command:lens] vase)
he-abet:(~(he-lens he hid id ~ (~(got by hoc) id)) command)
::
%json
~& jon=!<(json vase)
`state
::
%wipe
~& %dojo-wipe
=. hoc
%- ~(run by hoc)
|= =session
%_ session
sur ~
lib ~
var ~
old ~
==
[~ state]
==
::
[~ +>.$]
[moves ..on-init]
::
++ made (wrap he-made):arm
++ http-response (wrap he-http-response):arm
++ lame (wrap he-lame):arm
++ unto (wrap he-unto):arm
++ pull
|= {pax/path}
^- (quip move _+>)
=^ moz +> ~(he-abut he ~ (~(got by hoc) ost.hid))
[moz +>.$(hoc (~(del by hoc) ost.hid))]
++ on-watch
|= =path
^- (quip card:agent:gall _..on-init)
~? !=(our.hid src.hid) [%dojo-peer-stranger src.hid]
?> (team:title our.hid src.hid)
?> ?=([%sole @ ~] path)
=/ id i.t.path
=? hoc (~(has by hoc) id)
~& [%dojo-peer-replaced id]
(~(del by hoc) id)
=/ =session %*(. *session -.dir [our.hid %home ud+0])
=^ moves state
he-abet:~(he-prom he hid id ~ session)
[moves ..on-init]
::
++ on-leave
|= =path
?> ?=([%sole *] path)
=. hoc (~(del by hoc) t.path)
[~ ..on-init]
::
++ on-peek
|= path
*(unit (unit cage))
::
++ on-agent
|= [=wire =sign:agent:gall]
?> ?=([@ @ *] wire)
=/ =session (~(got by hoc) i.wire)
=/ he-full ~(. he hid i.wire ~ session)
=^ moves state
=< he-abet
^+ he
?+ i.t.wire ~|([%dojo-bad-on-agent wire -.sign] !!)
%poke (he-unto:he-full t.wire sign)
%wool (he-wool:he-full t.wire sign)
==
[moves ..on-init]
::
++ on-arvo
|= [=wire =sign-arvo]
?> ?=([@ *] wire)
=/ =session (~(got by hoc) i.wire)
=/ he-full ~(. he hid i.wire ~ session)
=^ moves state
=< he-abet
?+ +<.sign-arvo ~|([%dojo-bad-take +<.sign-arvo] !!)
%made (he-made:he-full t.wire +>.sign-arvo)
%http-response (he-http-response:he-full t.wire +>.sign-arvo)
==
[moves ..on-init]
:: if dojo fails unexpectedly, kill whatever each session is working on
::
++ on-fail
|= [=term =tang]
=/ sessions=(list (pair id session)) ~(tap by hoc)
|- ^- (quip card:agent:gall _..on-init)
?~ sessions
[~ ..on-init]
=^ cards-1 state
he-abet:(~(he-lame he hid p.i.sessions ~ q.i.sessions) term tang)
=^ cards-2 ..on-init
$(sessions t.sessions)
[(weld cards-1 cards-2) ..on-init]
--

63
pkg/arvo/app/eth-manage.hoon
View File

@ -1,63 +0,0 @@
:: usage:
:: :eth-manage %look
:: kick polling from eth mainnet node
:: :eth-manage [%wind 1.000.000]
:: rewind to block 1.000.000
=> $~ |%
++ move (pair bone card)
++ card
$% [%turf wire ~]
[%vein wire]
[%look wire src=(each ship purl:eyre)]
[%wind wire p=@ud]
==
++ state
$: a/@
==
--
=, gall
|_ $: hid/bowl
state
==
++ poke
|= [mar=@tas val=*]
^- (quip move _+>)
:_ +>.$
?+ val ~&(%oops ~)
%turf [ost.hid %turf /hi ~]~
%vein [ost.hid %vein /hi]~
[%wind @ud] [ost.hid %wind /hi +.val]~
::
%look-ethnode
:_ ~
=/ pul
(need (de-purl:html 'http://eth-mainnet.urbit.org:8545'))
[ost.hid %look /hi |+pul]
::
[%look-kick who=@p]
:_ ~
[ost.hid %look /hi %& who.val]
==
::
++ vein
|= [wir/wire =life ven=(map life ring)]
^- (quip move _+>)
~& [%pierc life ven]
`+>.$
::
++ turf
|= [wir/wire pax=(list path)]
^- (quip move _+>)
~& [%slurp pax]
`+>.$
::
++ prep
|= old/(unit noun)
^- [(list move) _+>.$]
?~ old
`+>.$
=+ new=((soft state) u.old)
?~ new
`+>.$
`+>.$(+<+ u.new)
--

912
pkg/arvo/app/eth-watcher.hoon
View File

@ -1,571 +1,379 @@
:: watcher: ethereum event log collector
:: eth-watcher: ethereum event log collector
::
/+ *eth-watcher
/- *eth-watcher, spider
/+ default-agent, verb
=, ethereum-types
=, able:jael
::
=, ethereum
=, rpc
::
|%
++ state
$: eyes=(map name eye)
==
::
++ eye
$: config
latest-block=@ud
filter-id=@ud
poll-timer=(unit @da)
snapshot
sap=history
==
::
++ history
$: interval=_100
max-count=_10
count=@ud
latest-block=@ud
snaps=(qeu snapshot)
==
::
++ move (pair bone card)
++ card
$% [%hiss wire (unit user:eyre) mark %hiss hiss:eyre]
[%wait wire @da]
[%rest @da]
[%info wire desk nori:clay]
[%diff %eth-watcher-update update]
[%quit ~]
==
--
::
|_ [bowl:gall state]
::
++ prep
|= old=(unit state)
?~ old
[~ ..prep]
[~ ..prep(+<+ u.old)]
::
++ poke-noun
|= [what=?(%save %load) =name]
^- (quip move _+>)
=+ eye=(~(gut by eyes) name *eye)
?- what
%save
=/ pax=path
/(scot %p our)/home/(scot %da now)/watcher/[name]/jam
:_ +>.$
:_ ~
^- move
:* ost
%info
/jamfile
(foal:space:userlib pax [%jam !>((jam eye))])
==
::
%load
=. eyes
%+ ~(put by eyes) name
=- (^eye (cue .^(@ %cx -)))
/(scot %p our)/home/(scot %da now)/watcher/[name]/jam
done:new-filter:(open:watcher name)
==
::
++ poke-eth-watcher-action
|= act=action
^- (quip move _+>)
?- -.act
%watch
done:(init:watcher +.act)
::
%clear
wipe:(open:watcher +.act)
==
::
++ peek-x
|= pax=path
^- (unit (unit [%noun *]))
?. ?=([@ *] pax) ~
=+ eye=(~(get by eyes) i.pax)
?~ eye [~ ~]
:: /name: all logs
::
?~ t.pax ``[%noun logs.u.eye]
:: /name/num: most recent num logs
::
=+ num=(slaw %ud i.t.pax)
?^ num ``[%noun (scag u.num logs.u.eye)]
:: /name/debug: debug information
::
?. ?=(%debug i.t.pax) ~
=- ``[%noun -]
=, u.eye
:* node=(en-purl:html node)
last=last-heard-block
lent=(lent logs)
time=poll-timer
==
::
++ peer
|= pax=path
^- (quip move _+>)
?> ?=([@ ~] pax)
done:(put-snapshot-diff:(open:watcher i.pax) ost)
::
++ wake
|= [wir=wire error=(unit tang)]
^- (quip move _+>)
?^ error
%- (slog u.error)
[~ ..wake]
?> ?=([@ %poll ~] wir)
done:poll-filter:(open:watcher i.wir)
::
++ sigh-tang
|= [wir=wire res=tang]
^- (quip move _+>)
~& ['something went wrong!' wir]
~_ res
[~ +>.$]
::
++ sigh-json-rpc-response
|= [wir=wire res=response:rpc:jstd]
^- (quip move _+>)
?> ?=([@ *] wir)
=< done
%- sigh-json-rpc-response:(open:watcher i.wir)
[t.wir res]
::
++ watcher
|_ $: =name
=eye
rewind-block=(unit @ud)
new-logs=loglist
moves=(list move)
=> |%
+$ card card:agent:gall
+$ app-state
$: %2
dogs=(map path watchdog)
==
::
:: +open: initialize core
::
++ open
|= nom=^name
^+ +>
+>.$(name nom, eye (~(got by eyes) nom))
::
:: +init: set up eye and initialize core
::
++ init
|= [nom=^name =config]
^+ +>
=. name nom
=. eye
%*(. *^eye - config, last-heard-block from-block.config)
get-latest-block
::
:: +| outward
::
:: +wipe: delete eye
::
++ wipe
=> cancel-wait-poll
=> cancel-subscribers
:- (flop moves)
..watcher(eyes (~(del by eyes) name))
::
:: +done: store changes, update subscribers
::
++ done
^- [(list move) _..watcher]
=? . ?=(^ rewind-block)
:: if we're rewinding to a block, then we throw away any moves
:: and changes we were going to make.
::
=: moves *(list move)
new-logs *loglist
==
(restore-block u.rewind-block)
:: if we have any updates, send them
::
=? . !=(~ new-logs)
(fan-diff %logs new-logs)
:: produce moves, store updated state
::
:- (flop moves)
..watcher(eyes (~(put by eyes) name eye))
::
:: +put-move: store side-effect
::
++ put-move
|= =card
%_(+> moves [[ost card] moves])
::
++ put-moves
|= moz=(list move)
%_(+> moves (weld (flop moz) moves))
::
:: +put-rpc-request: store rpc request to ethereum node
::
++ put-rpc-request
|= [wir=wire id=(unit @t) req=request]
^+ +>
%- put-move
^- card
:* %hiss
[name wir]
~
%json-rpc-response
%hiss
%+ json-request node.eye
(request-to-json id req)
==
::
:: +put-log: store change made by event
::
++ put-log
|= log=event-log
%_ +>
new-logs (store-new-logs ~[log] new-logs)
logs.eye (store-new-logs ~[log] logs.eye)
heard.eye (~(put in heard.eye) (log-to-id log))
==
::
:: +| subscriptions
::
++ put-diff
|= [for=bone dif=update]
%_(+> moves [[for %diff %eth-watcher-update dif] moves])
::
++ put-snapshot-diff
|= for=bone
(put-diff for %snap last-heard-block.eye heard.eye logs.eye)
::
++ get-subscribers
^- (list bone)
%+ murn ~(tap by sup)
|= [b=bone s=ship p=path]
^- (unit bone)
?> ?=([@ *] p)
?:(=(name i.p) `b ~)
::
++ fan-diff
|= dif=update
%- put-moves
%+ turn get-subscribers
|= b=bone
^- move
[b %diff %eth-watcher-update dif]
::
++ cancel-subscribers
%- put-moves
%+ turn get-subscribers
|=(b=bone [b %quit ~])
::
:: +| catch-up-operations
::
:: +get-latest-block
::
:: Get latest block from eth node and compare to our own latest block.
:: Get intervening blocks in chunks until we're caught up, then set
:: up a filter going forward.
::
++ get-latest-block
=> cancel-wait-poll
(put-rpc-request /catch-up/block-number `'block number' %eth-block-number ~)
::
:: +catch-up: get next chunk
::
++ catch-up
|= from-block=@ud
^+ +>
?: (gte from-block latest-block.eye)
new-filter
=/ next-block (min latest-block.eye (add from-block 5.760)) :: ~d1
~? debug=|
[%catching-up from=from-block to=latest-block.eye]
%- put-rpc-request
:+ /catch-up/step/(scot %ud from-block)/(scot %ud next-block)
`'catch up'
:* %eth-get-logs
`number+from-block
`number+next-block
contracts.eye
topics.eye
==
::
:: +| filter-operations
::
:: +new-filter: request a new polling filter
::
:: Listens from the last-heard block onward.
::
++ new-filter
%- put-rpc-request
:+ /filter/new `'new filter'
^- request:rpc
:* %eth-new-filter
`number+last-heard-block.eye
?~(to-block.eye ~ `number+u.to-block.eye)
contracts.eye
topics.eye
==
::
:: +read-filter: get all events the filter captures
::
++ read-filter
%- put-rpc-request
:+ /filter/logs `'filter logs'
[%eth-get-filter-logs filter-id.eye]
::
:: +poll-filter: get all new events since last poll (or filter creation)
::
++ poll-filter
?: =(0 filter-id.eye)
~& %no-filter-bad-poll
.
%- put-rpc-request
:+ /filter/changes `'poll filter'
[%eth-get-filter-changes filter-id.eye]
::
:: +wait-poll: remind us to poll in four minutes
::
:: Four minutes because Ethereum RPC filters time out after five.
:: We don't check for an existing timer or clear an old one here,
:: sane flows shouldn't see this being called superfluously.
::
++ wait-poll
=+ wen=(add now ~m4)
%- put-move(poll-timer.eye `wen)
[%wait name^/poll wen]
::
:: +cancel-wait-poll: remove poll reminder
::
++ cancel-wait-poll
?~ poll-timer.eye ..cancel-wait-poll
%- put-move(poll-timer.eye ~)
[%rest u.poll-timer.eye]
::
:: +| filter-results
::
:: +sigh-json-rpc-response: process rpc response
::
++ sigh-json-rpc-response
|= [wir=wire res=response:rpc:jstd]
^+ +>
~! -.res
?: ?=(%fail -.res)
?: =(405 p.hit.res)
~& 'HTTP 405 error (expected if using infura)'
+>.$
?. =(5 (div p.hit.res 100))
~& [%http-error hit.res]
+>.$
?+ wir
~& [%retrying-node ~] ::((soft tang) q.res)]
wait-poll
[%catch-up %step @ta @ta ~]
~& %retrying-catch-up
(catch-up (slav %ud `@ta`i.t.t.wir))
+$ context [=path dog=watchdog]
+$ watchdog
$: config
running=(unit =tid:spider)
=number:block
=pending-logs
=history
blocks=(list block)
==
?+ wir ~|([%weird-sigh-wire wir] !!)
[%filter %new *]
(take-new-filter res)
::
[%filter *]
(take-filter-results res)
:: history: newest block first, oldest event first
+$ history (list loglist)
--
::
:: Helpers
::
=> |%
++ wait
|= [=path now=@da time=@dr]
^- card
[%pass [%timer path] %arvo %b %wait (add now time)]
::
[%catch-up %block-number ~]
(take-block-number res)
++ wait-shortcut
|= [=path now=@da]
^- card
[%pass [%timer path] %arvo %b %wait now]
::
[%catch-up %step @ta @ta ~]
=/ from-block (slav %ud `@ta`i.t.t.wir)
=/ next-block (slav %ud `@ta`i.t.t.t.wir)
(take-catch-up-step res from-block next-block)
++ poke-spider
|= [=path our=@p =cage]
^- card
[%pass [%running path] %agent [our %spider] %poke cage]
::
++ watch-spider
|= [=path our=@p =sub=path]
^- card
[%pass [%running path] %agent [our %spider] %watch sub-path]
::
++ leave-spider
|= [=path our=@p]
^- card
[%pass [%running path] %agent [our %spider] %leave ~]
--
::
:: Main
::
^- agent:gall
=| state=app-state
%+ verb |
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
[~ this]
::
++ on-save !>(state)
++ on-load
|= old=vase
|^
=+ !<(old-state=app-states old)
=? old-state ?=(%0 -.old-state)
%- (slog leaf+"upgrading eth-watcher from %0" ~)
^- app-state-1
%= old-state
- %1
dogs
%- ~(run by dogs.old-state)
|= dog=watchdog-0
%= dog
-> [~m5 ->.dog]
==
==
::
:: +take-new-filter: store filter-id and read it
=^ cards-1=(list card) old-state
?. ?=(%1 -.old-state)
`old-state
%- (slog leaf+"upgrading eth-watcher from %1" ~)
:_ old-state(- %2)
%+ turn ~(tap by dogs.old-state)
|= [=path dog=watchdog]
(wait-shortcut path now.bowl)
::
++ take-new-filter
|= rep=response:rpc:jstd
^+ +>
~| rep
?< ?=(%batch -.rep)
?< ?=(%fail -.rep)
?: ?=(%error -.rep)
~& [%filter-error--retrying message.rep]
new-filter
=- read-filter(filter-id.eye -)
(parse-eth-new-filter-res res.rep)
[cards-1 this(state ?>(?=(%2 -.old-state) old-state))]
::
:: +take-filter-results: parse results into event-logs and process them
+$ app-states
$%(app-state-0 app-state-1 app-state)
::
++ take-filter-results
|= rep=response:rpc:jstd
^+ +>
?< ?=(%batch -.rep)
?< ?=(%fail -.rep)
?: ?=(%error -.rep)
?. ?| =('filter not found' message.rep) :: geth
=('Filter not found' message.rep) :: parity
==
~& [%unhandled-filter-error +.rep]
+>
~& [%filter-timed-out--recreating block=last-heard-block.eye +.rep]
:: arguably should rewind 40 blocks on the off chance the chain reorganized
:: when we blinked. this will also restart the filter.
::
:: (restore-block ?:((lth last-heard-block 40) 0 (sub.add last-heard-block 40)))
::
:: counter-argument: it's a royal pain to restore from a snapshot
:: every time you can't ping the node for 5 minutes. this is likely
:: to destabilize the network. better to manually restore if we
:: notice an anomaly.
::
:: third way: don't trust anything that doesn't have 40 confirmations
::
new-filter
:: kick polling timer, only if it hasn't already been.
=? +> |(?=(~ poll-timer.eye) (gth now u.poll-timer.eye))
wait-poll
(take-events rep)
+$ app-state-1
$: %1
dogs=(map path watchdog)
==
::
:: +take-block-number: take block number and start catching up
+$ app-state-0
$: %0
dogs=(map path watchdog-0)
==
::
++ take-block-number
|= rep=response:rpc:jstd
^+ +>
?< ?=(%batch -.rep)
?< ?=(%fail -.rep)
?: ?=(%error -.rep)
~& [%take-block-number-error--retrying message.rep]
get-latest-block
=. latest-block.eye (parse-eth-block-number res.rep)
(catch-up last-heard-block.eye)
+$ watchdog-0
$: config-0
running=(unit =tid:spider)
=number:block
=pending-logs
=history
blocks=(list block)
==
::
:: +take-catch-up-step: process chunk
::
++ take-catch-up-step
|= [rep=response:rpc:jstd from-block=@ud next-block=@ud]
^+ +>
?< ?=(%batch -.rep)
?< ?=(%fail -.rep)
?: ?=(%error -.rep)
~& [%catch-up-step-error--retrying message.rep]
(catch-up from-block)
=. +>.$ (take-events rep)
(catch-up next-block)
::
:: +take-events: process events
::
++ take-events
|= rep=response:rpc:jstd
^+ +>
?< ?=(%batch -.rep)
?< ?=(%fail -.rep)
?< ?=(%error -.rep)
?. ?=(%a -.res.rep)
~& [%events-not-array rep]
!!
=* changes p.res.rep
~? &(debug=| (gth (lent changes) 0))
:* %processing-changes
changes=(lent changes)
block=last-heard-block.eye
id=filter-id.eye
==
|- ^+ +>.^$
?~ changes +>.^$
=. +>.^$
(take-event-log (parse-event-log i.changes))
$(changes t.changes)
::
:: +take-event-log: obtain changes from event-log
::
++ take-event-log
|= log=event-log
^+ +>
?~ mined.log
~& %ignoring-unmined-event
+>
=* place u.mined.log
?: (~(has in heard.eye) block-number.place log-index.place)
?. removed.u.mined.log
~? debug=|
[%ignoring-duplicate-event tx=transaction-hash.u.mined.log]
+>
:: block was reorganized away, so rewind to this block and
:: start syncing again.
::
~& :* 'removed event! Perhaps chain has reorganized?'
tx-hash=transaction-hash.u.mined.log
block-number=block-number.u.mined.log
block-hash=block-hash.u.mined.log
==
%= +>
rewind-block
:- ~
?~ rewind-block
block-number.place
(min block-number.place u.rewind-block)
==
=. last-heard-block.eye
(max block-number.place last-heard-block.eye)
?: ?& (gte block-number.place from-block.eye)
?| ?=(~ to-block.eye)
(lte block-number.place u.to-block.eye)
==
==
(put-log log)
~& :* %event-block-out-of-range
got=block-number.place
from=from-block.eye
to=to-block.eye
==
+>.$
::
:: +restore-block: rewind to block or earlier
::
++ restore-block
|= block=@ud
^+ +>
=/ old-qeu snaps.sap.eye
:: clear history
::
=: snaps.sap.eye ~
count.sap.eye 0
latest-block.sap.eye 0
==
:: find a snapshot we can use, remove ones that are too new
::
=^ snap=snapshot +>.$
?: |(=(~ old-qeu) (lth block last-heard-block:(need ~(top to old-qeu))))
[%*(. *snapshot last-heard-block from-block.eye) +>.$]
|- ^- [snapshot _+>.^$]
=^ snap=snapshot old-qeu
~(get to old-qeu)
=: count.sap.eye +(count.sap.eye)
latest-block.sap.eye last-heard-block.snap
snaps.sap.eye (~(put to snaps.sap.eye) snap)
==
?: |(=(~ old-qeu) (lth block last-heard-block:(need ~(top to old-qeu))))
[snap +>.^$]
$
~& [%restoring-block block last-heard-block.snap]
(restore-snap snap)
::
:: +restore-snap: revert state to snapshot
::
++ restore-snap
|= snap=snapshot
^+ +>
:: notify subscribers
::TODO be more nuanced about what changed, maybe
::
=. +>.$ (fan-diff snap+snap)
:: restore state and kick new fetch cycle
::
%= get-latest-block
last-heard-block.eye last-heard-block.snap
heard.eye heard.snap
logs.eye logs.snap
+$ config-0
$: url=@ta
from=number:block
contracts=(list address:ethereum)
=topics
==
--
::
++ on-poke
|= [=mark =vase]
?: ?=(%noun mark)
~& state
`this
?. ?=(%eth-watcher-poke mark)
(on-poke:def mark vase)
::
=+ !<(=poke vase)
?- -.poke
%watch
:: fully restart the watchdog if it doesn't exist yet,
:: or if the new config changes more than just the url or refresh rate.
=/ restart=?
?| !(~(has by dogs.state) path.poke)
?! .= ->+:(~(got by dogs.state) path.poke)
+>.config.poke
==
::
=/ already (~(has by dogs.state) path.poke)
~? &(already restart)
[dap.bowl 'overwriting existing watchdog on' path.poke]
=/ wait-cards
?: already
~
[(wait-shortcut path.poke now.bowl) ~]
::
=/ restart-cards
=/ dog (~(get by dogs.state) path.poke)
?. ?& restart
?=(^ dog)
?=(^ running.u.dog)
==
~
=/ =cage [%spider-stop !>([u.running.u.dog &])]
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
=/ new-dog
=/ dog=watchdog
?: restart *watchdog
(~(got by dogs.state) path.poke)
%_ dog
- config.poke
number from.config.poke
==
=. dogs.state (~(put by dogs.state) path.poke new-dog)
[wait-cards this]
::
%clear
=. dogs.state (~(del by dogs.state) path.poke)
[~ this]
==
::
:: +on-watch: subscribe & get initial subscription data
::
:: /logs/some-path:
::
++ on-watch
|= =path
^- (quip card agent:gall)
?. ?=([%logs ^] path)
~| [%invalid-subscription-path path]
!!
:_ this :_ ~
:* %give %fact ~ %eth-watcher-diff !>
:- %history
^- loglist
%- zing
%- flop
=< history
(~(gut by dogs.state) t.path *watchdog)
==
::
++ on-leave on-leave:def
::
:: +on-peek: get diagnostics data
::
:: /block/some-path: get next block number to check for /some-path
::
++ on-peek
|= =path
^- (unit (unit cage))
?+ path ~
[%x %block ^]
?. (~(has by dogs.state) t.t.path) ~
:+ ~ ~
:- %atom
!>(number:(~(got by dogs.state) t.t.path))
::
[%x %dogs ~]
``noun+!>(~(key by dogs.state))
==
::
++ on-agent
|= [=wire =sign:agent:gall]
|^
^- (quip card agent:gall)
?. ?=([%running *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack
?~ p.sign
[~ this]
%- (slog leaf+"eth-watcher couldn't start thread" u.p.sign)
:_ (clear-running t.wire) :_ ~
(leave-spider t.wire our.bowl)
::
%watch-ack
?~ p.sign
[~ this]
%- (slog leaf+"eth-watcher couldn't start listen to thread" u.p.sign)
[~ (clear-running t.wire)]
::
%kick [~ (clear-running t.wire)]
%fact
=* path t.wire
=/ dog (~(get by dogs.state) path)
?~ dog
[~ this]
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%- (slog leaf+"eth-watcher failed; will retry" leaf+<term> tang)
[~ this(dogs.state (~(put by dogs.state) path u.dog(running ~)))]
::
%thread-done
=+ !<([vows=disavows pup=watchpup] q.cage.sign)
=. u.dog
%_ u.dog
- -.pup
number number.pup
blocks blocks.pup
pending-logs pending-logs.pup
==
=^ cards-1 u.dog (disavow path u.dog vows)
=^ cards-2 u.dog (release-logs path u.dog)
=. dogs.state (~(put by dogs.state) path u.dog(running ~))
[(weld cards-1 cards-2) this]
==
==
::
++ clear-running
|= =path
=/ dog (~(get by dogs.state) path)
?~ dog
this
this(dogs.state (~(put by dogs.state) path u.dog(running ~)))
::
++ disavow
|= [=path dog=watchdog vows=disavows]
^- (quip card watchdog)
=/ history-ids=(list [id:block loglist])
%+ murn history.dog
|= logs=loglist
^- (unit [id:block loglist])
?~ logs
~
`[[block-hash block-number]:(need mined.i.logs) logs]
=/ actual-vows=disavows
%+ skim vows
|= =id:block
(lien history-ids |=([=history=id:block *] =(id history-id)))
=/ actual-history=history
%+ murn history-ids
|= [=id:block logs=loglist]
^- (unit loglist)
?: (lien actual-vows |=(=vow=id:block =(id vow-id)))
~
`logs
:_ dog(history actual-history)
%+ turn actual-vows
|= =id:block
[%give %fact `[%logs path] %eth-watcher-diff !>([%disavow id])]
::
++ release-logs
|= [=path dog=watchdog]
^- (quip card watchdog)
?: (lth number.dog 30)
`dog
=/ rel-number (sub number.dog 30)
=/ numbers=(list number:block) ~(tap in ~(key by pending-logs.dog))
=. numbers (sort numbers lth)
|- ^- (quip card watchdog)
?~ numbers
`dog
?: (gth i.numbers rel-number)
$(numbers t.numbers)
=^ cards-1 dog
=/ =loglist (~(get ja pending-logs.dog) i.numbers)
=. pending-logs.dog (~(del by pending-logs.dog) i.numbers)
?~ loglist
`dog
=. history.dog [loglist history.dog]
:_ dog
%+ turn loglist
|= =event-log:rpc:ethereum
^- card
[%give %fact `[%logs path] %eth-watcher-diff !>([%log event-log])]
=^ cards-2 dog $(numbers t.numbers)
[(weld cards-1 cards-2) dog]
--
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card agent:gall)
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
%wake
?. ?=([%timer *] wire) ~& weird-wire=wire [~ this]
=* path t.wire
?. (~(has by dogs.state) path)
[~ this]
=/ dog=watchdog
(~(got by dogs.state) path)
?^ error.sign-arvo
:: failed, try again. maybe should tell user if fails more than
:: 5 times.
::
%- (slog leaf+"eth-watcher failed; will retry" ~)
[[(wait path now.bowl refresh-rate.dog)]~ this]
:: start a new thread that checks for updates
::
=^ cards-1=(list card) dog
:: if still running, kill it and restart
::
?~ running.dog
`dog
::
%- (slog leaf+"eth-watcher still running; will restart" ~)
=/ =cage [%spider-stop !>([u.running.dog |])]
:_ dog(running ~)
:~ (leave-spider path our.bowl)
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
==
::
=^ cards-2=(list card) dog
=/ new-tid=@ta
(cat 3 'eth-watcher--' (scot %uv eny.bowl))
:_ dog(running `new-tid)
=/ args
:^ ~ `new-tid %eth-watcher
!>(`watchpup`[- number pending-logs blocks]:dog)
:~ (watch-spider path our.bowl /thread-result/[new-tid])
(poke-spider path our.bowl %spider-start !>(args))
==
::
:- [(wait path now.bowl refresh-rate.dog) (weld cards-1 cards-2)]
this(dogs.state (~(put by dogs.state) path dog))
==
::
++ on-fail on-fail:def
--

147
pkg/arvo/app/example-tapp-fetch.hoon
View File

@ -1,147 +0,0 @@
:: Little app to demonstrate the structure of programs written with the
:: transaction monad.
::
:: Fetches the top comment of each of the top 10 stories from Hacker News
::
/+ tapp, stdio
::
:: Preamble
::
=>
|%
+$ state
$: top-comments=(list tape)
==
+$ peek-data _!!
+$ in-poke-data [%noun =cord]
+$ out-poke-data ~
+$ in-peer-data ~
+$ out-peer-data
$% [%comments (list tape)]
==
++ tapp (^tapp state peek-data in-poke-data out-poke-data in-peer-data out-peer-data)
++ stdio (^stdio out-poke-data out-peer-data)
--
=>
|%
:: Helper function to print a comment
::
++ comment-to-tang
|= =tape
^- tang
%+ welp
%+ turn (rip 10 (crip tape))
|= line=cord
leaf+(trip line)
[leaf+""]~
::
:: All the URLs we fetch from
::
++ urls
=/ base "https://hacker-news.firebaseio.com/v0/"
:* top-stories=(weld base "topstories.json")
item=|=(item=@ud `tape`:(welp base "item/" +>:(scow %ui item) ".json"))
==
--
=, async=async:tapp
=, tapp-async=tapp-async:tapp
=, stdio
::
:: The app
::
%- create-tapp-poke-peer-take:tapp
^- tapp-core-poke-peer-take:tapp
|_ [=bowl:gall state]
::
:: Main function
::
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
::
:: If requested to print, just print what we have in our state
::
?: =(cord.in-poke-data 'print')
~& 'drumroll please...'
;< now=@da bind:m get-time
;< ~ bind:m (wait (add now ~s3))
~& 'Top comments:'
%- (slog (zing (turn top-comments comment-to-tang)))
(pure:m top-comments)
?: =(cord.in-poke-data 'poll')
;< ~ bind:m (wait-effect (add now.bowl ~s15))
(pure:m top-comments)
::
:: Otherwise, fetch the top HN stories
::
=. top-comments ~
::
:: If this whole thing takes more than 15 seconds, cancel it
::
%+ (set-timeout _top-comments) (add now.bowl ~s15)
;< =top-stories=json bind:m (fetch-json top-stories:urls)
=/ top-stories=(list @ud)
((ar ni):dejs:format top-stories-json)
::
:: Loop through the first 5 stories
::
=. top-stories (scag 5 top-stories)
|- ^- form:m
=* loop $
::
:: If done, tell subscribers and print the results
::
?~ top-stories
;< ~ bind:m (give-result /comments %comments top-comments)
(handle-poke %noun 'print')
::
:: Else, fetch the story info
::
~& "fetching item #{+>:(scow %ui i.top-stories)}"
;< =story-info=json bind:m (fetch-json (item:urls i.top-stories))
=/ story-comments=(unit (list @ud))
((ot kids+(ar ni) ~):dejs-soft:format story-info-json)
::
:: If no comments, say so
::
?: |(?=(~ story-comments) ?=(~ u.story-comments))
=. top-comments ["<no top comment>" top-comments]
loop(top-stories t.top-stories)
::
:: Else, fetch comment info
::
;< =comment-info=json bind:m (fetch-json (item:urls i.u.story-comments))
=/ comment-text=(unit tape)
((ot text+sa ~):dejs-soft:format comment-info-json)
::
:: If no text (eg comment deleted), record that
::
?~ comment-text
=. top-comments ["<top comment has no text>" top-comments]
loop(top-stories t.top-stories)
::
:: Else, add text to state
::
=. top-comments [u.comment-text top-comments]
loop(top-stories t.top-stories)
::
++ handle-peer
|= =path
=/ m tapp-async
^- form:m
~& [%tapp-fetch-take-peer path]
(pure:m top-comments)
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
:: ignore %poke/peer acknowledgements
::
?. ?=(%wake -.sign)
(pure:m top-comments)
;< =state bind:m (handle-poke %noun 'fetch')
=. top-comments state
(pure:m top-comments)
--

50
pkg/arvo/app/example-tapp-subscribe.hoon
View File

@ -1,50 +0,0 @@
/+ tapp, stdio
=>
|%
+$ subscription-state
$: target=[her=ship app=term]
=path
==
+$ state
$: subscription=(unit subscription-state)
==
+$ peek-data _!!
+$ in-poke-data [%noun =cord]
+$ out-poke-data [%noun =cord]
+$ out-peer-data ~
+$ in-peer-data
$% [%comments comments=(list tape)]
==
++ tapp (^tapp state peek-data in-poke-data out-poke-data in-peer-data out-peer-data)
++ stdio (^stdio out-poke-data out-peer-data)
--
=, async=async:tapp
=, tapp-async=tapp-async:tapp
=, stdio
%- create-tapp-poke-diff:tapp
^- tapp-core-poke-diff:tapp
|_ [=bowl:gall state]
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?: =(cord.in-poke-data 'pull')
?~ subscription
(async-fail %no-subscription ~)
;< ~ bind:m (pull-app [target path]:u.subscription)
(pure:m ~)
=/ target [our.bowl %example-tapp-fetch]
;< ~ bind:m (poke-app target %noun 'print')
;< ~ bind:m (peer-app target /comments)
=. subscription `[target /comments]
;< ~ bind:m (wait (add now.bowl ~s3))
(pure:m subscription)
::
++ handle-diff
|= [[her=ship app=term] =path data=in-peer-data]
=/ m tapp-async
^- form:m
?> ?=(%comments -.data)
~& subscriber-got-data=(lent comments.data)
(pure:m subscription)
--

603
pkg/arvo/app/gaze.hoon
View File

@ -1,147 +1,266 @@
:: gaze: azimuth statistics
::
/+ *eth-watcher
:: general flow:
:: - receive events
:: - process events whose timestamp is known
:: - request timestamps for unknown block numbers (if not already running)
:: - receive timestamps, process events
::
/- eth-watcher
/+ default-agent, verb
=, ethereum
=, azimuth
::
|%
++ state
$: :: qued: event logs waiting on block timestamp, oldest first
:: time: timstamps of block numbers
:: seen: events sorted by timestamp, newest first
:: days: stats by day, newest first
=> |%
+$ state-0
$: %0
:: qued: event logs waiting on block timestamp, oldest first
:: time: timstamps of block numbers
:: seen: events sorted by timestamp, newest first
:: days: stats by day, newest first
::
running=(unit @ta)
qued=loglist
time=(map @ud @da)
seen=(list [wen=@da wat=event])
days=(list [day=@da sat=stats])
==
::
+$ loglist loglist:eth-watcher
+$ event
$% [%azimuth who=ship dif=diff-point]
[%invite by=ship of=ship gift=ship to=address]
==
::
+$ stats
$: spawned=(list @p)
activated=(list @p)
transfer-p=(list @p)
transferred=(list @p)
configured=(list @p)
breached=(list @p)
request=(list @p)
sponsor=(list @p)
management-p=(list @p)
voting-p=(list @p)
spawn-p=(list @p)
invites-senders=(list @p)
==
::
+$ card card:agent:gall
::
++ node-url 'http://eth-mainnet.urbit.org:8545'
++ refresh-rate ~h1
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
[setup-cards:do this]
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> ?=(%noun mark)
=/ =noun !<(noun vase)
|- ^- [cards=(list card) =_this]
?+ noun ~|([dap.bowl %unknown-poke noun] !!)
%reconnect
:_ this
:~ leave-eth-watcher:do
watch-eth-watcher:do
==
::
%reload
:- cards:$(noun %reconnect)
this(qued ~, seen ~, days ~)
::
%rewatch
:_ this:$(noun %reset)
:~ leave-eth-watcher:do
clear-eth-watcher:do
setup-eth-watcher:do
await-eth-watcher:do
==
::
%export
[export:do this]
::
%debug
~& latest=(turn (scag 5 seen) head)
~& oldest=(turn (slag (sub (max 5 (lent seen)) 5) seen) head)
~& :- 'order is'
=- ?:(sane 'sane' 'insane')
%+ roll seen
|= [[this=@da *] last=@da sane=?]
:- this
?: =(*@da last) &
(lte this last)
~& time=~(wyt by time)
~& qued=(lent qued)
~& days=(lent days)
[~ this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
%kick
?. =(/watcher wire) [~ this]
[[watch-eth-watcher:do]~ this]
::
%fact
?+ wire (on-agent:def wire sign)
[%watcher ~]
?. ?=(%eth-watcher-diff p.cage.sign)
(on-agent:def wire sign)
=^ cards state
%- handle-eth-watcher-diff:do
!<(diff:eth-watcher q.cage.sign)
[cards this]
::
qued=loglist
time=(map @ud @da)
seen=(list [wen=@da wat=event])
days=(list [day=@da sat=stats])
==
::
++ event
$% [%azimuth who=ship dif=diff-point]
::TODO [%invites *]
==
::
++ stats
$: spawned=(list @p)
activated=(list @p)
transfer-p=(list @p)
transferred=(list @p)
configured=(list @p)
breached=(list @p)
request=(list @p)
sponsor=(list @p)
management-p=(list @p)
voting-p=(list @p)
spawn-p=(list @p)
==
::
::
++ move (pair bone card)
++ card
$% [%poke wire [ship %eth-watcher] %eth-watcher-action action]
[%peer wire [ship %eth-watcher] path]
[%hiss wire (unit user:eyre) mark %hiss hiss:eyre]
[%wait wire @da]
[%info wire desk nori:clay]
==
--
::
|_ [bowl:gall state]
++ node-url (need (de-purl:html 'http://eth-mainnet.urbit.org:8545'))
++ export-frequency ~h1
::
++ prep
|= old=(unit state)
?~ old
:_ ..prep
[ost %wait /export (add now export-frequency)]~
[~ ..prep(+<+ u.old)]
::
:: +poke-noun: do a thing
::
:: %kick-watcher: reset, tell %eth-watcher to look for events for us
:: %regaze: reset (but keep timestamps), subscribe to eth-watcher
:: %debug: print debug info
::
++ poke-noun
|= a=?(%kick-watcher %regaze %debug)
^- (quip move _+>)
?- a
%kick-watcher
:_ +>.$(qued ~, seen ~, days ~, time ~)
:~
:- ost
:* %poke
/look
[our %eth-watcher]
%eth-watcher-action
[%timestamps @ ~]
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
=/ =tank leaf+"{(trip dap.bowl)} thread failed; will retry"
%- (slog tank leaf+<term> tang)
=^ cards state
request-timestamps:do
[cards this]
::
^- action
:+ %watch dap
:* node-url
public:contracts
~
~[azimuth:contracts]
~
==
%thread-done
=^ cards state
%- save-timestamps:do
!<((list [@ud @da]) q.cage.sign)
[cards this]
==
==
==
::
%regaze
:_ +>.$(qued ~, seen ~, days ~)
:~
:- ost
:* %peer
/look
[our %eth-watcher]
/[dap]
==
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?+ +<.sign-arvo ~|([dap.bowl %strange-arvo-sign +<.sign-arvo] !!)
%wake
?: =(/export wire)
[[wait-export:do export:do] this]
?: =(/watch wire)
[[watch-eth-watcher:do]~ this]
~& [dap.bowl %strange-wake wire]
[~ this]
==
::
%debug
~& latest=(turn (scag 5 seen) head)
~& oldest=(turn (slag (sub (lent seen) 5) seen) head)
~& :- 'order is'
=- ?:(sane 'sane' 'insane')
%+ roll seen
|= [[this=@da *] last=@da sane=?]
:- this
?: =(*@da last) &
(lte this last)
~& time=~(wyt by time)
~& qued=(lent qued)
~& days=(lent days)
[~ +>.$]
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
++ setup-cards
^- (list card)
:~ wait-export
setup-eth-watcher
:: we punt on subscribing to the eth-watcher for a little while.
:: this way we get a %history diff containing all past events,
:: instead of so many individual %log diffs that we bail meme.
:: (to repro, replace this with `watch-eth-watcher`)
::
await-eth-watcher
==
::
:: +diff-eth-watcher-update: process new logs, clear state on rollback
++ wait
|= [=wire =@dr]
^- card
[%pass wire %arvo %b %wait (add now.bowl dr)]
::
++ diff-eth-watcher-update
|= [=wire =^update]
^- (quip move _+>)
=^ logs +>.$
?- -.update
%snap ~& [%got-snap (lent logs.snapshot.update)]
[logs.snapshot.update +>.$(qued ~, seen ~)]
%logs ~& [%got-logs (lent loglist.update)]
[loglist.update +>.$]
++ wait-export (wait /export refresh-rate)
::
++ to-eth-watcher
|= [=wire =task:agent:gall]
^- card
[%pass wire %agent [our.bowl %eth-watcher] task]
::
++ setup-eth-watcher
%+ to-eth-watcher /setup
:+ %poke %eth-watcher-poke
!> ^- poke:eth-watcher
:+ %watch /[dap.bowl]
:* node-url
refresh-rate
public:mainnet-contracts
~[azimuth delegated-sending]:mainnet-contracts
~
==
::
:: see also comment in +setup-cards
++ await-eth-watcher (wait /watch ~m30)
::
++ watch-eth-watcher
%+ to-eth-watcher /watcher
[%watch /logs/[dap.bowl]]
::
++ leave-eth-watcher
%+ to-eth-watcher /watcher
[%leave ~]
::
++ clear-eth-watcher
%+ to-eth-watcher /clear
:+ %poke %eth-watcher-poke
!> ^- poke:eth-watcher
[%clear /logs/[dap.bowl]]
::
++ poke-spider
|= [=wire =cage]
^- card
[%pass wire %agent [our.bowl %spider] %poke cage]
::
++ watch-spider
|= [=wire =sub=path]
^- card
[%pass wire %agent [our.bowl %spider] %watch sub-path]
::
:: +handle-eth-watcher-diff: process new logs, clear state on rollback
::
:: processes logs for which we know the timestamp
:: adds timestamp-less logs to queue
::
++ handle-eth-watcher-diff
|= =diff:eth-watcher
^- (quip card _state)
=^ logs state
^- [loglist _state]
?- -.diff
%history ~& [%got-history (lent loglist.diff)]
[loglist.diff state(qued ~, seen ~)]
%log ~& %got-log
[[event-log.diff ~] state]
%disavow ~& %disavow-unimplemented
[~ state]
==
?~ logs [~ +>.$]
=- =^ moz +>.$ (queue-logs mistime) :: oldest first
=. +>.$ (process-logs havtime) :: oldest first
[moz +>.$]
:: sort based on timstamp known, throw out lockup logs
::
%+ roll `loglist`logs
|= [log=event-log:rpc havtime=loglist mistime=loglist]
^+ [havtime mistime]
=+ bon=block-number:(need mined.log)
?: (is-lockup-block bon) [havtime mistime]
?: (~(has by time) bon)
[[log havtime] mistime]
[havtime [log mistime]]
%- process-logs
%+ skip logs
|= =event-log:rpc
%- is-lockup-block
block-number:(need mined.event-log)
::
:: +is-lockup-block: whether the block contains lockup/ignorable transactions
::
@ -160,83 +279,56 @@
?: in &
&((gte num start) (lte num end))
::
:: +queue-logs: hold on to new logs, requesting timestamps for them
::
++ queue-logs
|= logs=loglist :: oldest first
^- (quip move _+>)
?~ logs [~ +>]
:- [(request-timestamps logs) ~]
+>(qued (weld qued logs))
::
:: +request-timestamps: request block timestamps for the logs as necessary
::
:: will come back as a thread result
::
++ request-timestamps
|= logs=loglist
^- move
=- [ost %hiss /timestamps ~ %json-rpc-response %hiss -]
^- hiss:eyre
%+ json-request:rpc node-url
:- %a
^- (list json)
%+ turn
^- (list @ud)
=- ~(tap in -)
%- ~(gas in *(set @ud))
^- (list @ud)
%+ turn logs
|= log=event-log:rpc
block-number:(need mined.log)
|= num=@ud
^- json
~! *request:rpc
%+ request-to-json:rpc
`(scot %ud num)
[%eth-get-block-by-number num |]
^- (quip card _state)
?~ qued [~ state]
?^ running [~ state]
=/ tid=@ta
%+ scot %ta
:((cury cat 3) dap.bowl '_' (scot %uv eny.bowl))
:_ state(running `tid)
:~ (watch-spider /timestamps/[tid] /thread-result/[tid])
::
%+ poke-spider /timestamps/[tid]
:- %spider-start
=- !>([~ `tid %eth-get-timestamps -])
!> ^- [@t (list @ud)]
:- node-url
=- ~(tap in -)
%- ~(gas in *(set @ud))
^- (list @ud)
%+ turn qued
|= log=event-log:rpc
block-number:(need mined.log)
==
::
:: +sigh-json-rpc-response: get block details, extract timestamps
:: +save-timestamps: store timestamps into state
::
++ sigh-json-rpc-response
|= [=wire =response:rpc:jstd]
^- (quip move _+>)
?> ?=([%timestamps ~] wire)
?: ?=(?(%error %fail) -.response)
~? ?=(%error -.response) [%rpc-error +.response]
~? ?=(%fail -.response) [%httr-fail hit.response]
~& %retrying-timestamps
[[(request-timestamps qued) ~] +>]
?> ?=(%batch -.response)
=- [~ (process-logs(time -, qued ~) qued)]
%- ~(gas by time)
=/ max=@ud
(roll ~(tap in ~(key by time)) max)
:: for every result, get the block number and timestamp
::
%+ turn bas.response
|= res=response:rpc:jstd
^- (pair @ud @da)
~| res
?> ?=(%result -.res)
~| id.res
:- (slav %ud id.res)
%- from-unix:chrono:userlib
%- parse-hex-result:rpc
?> ?=(%o -.res.res)
(~(got by p.res.res) 'timestamp')
++ save-timestamps
|= timestamps=(list [@ud @da])
^- (quip card _state)
=. time (~(gas by time) timestamps)
=. running ~
(process-logs ~)
::
:: +process logs that are in the queue
:: +process-logs: handle new incoming logs
::
++ process-logs
|= logs=loglist :: oldest first
^+ +>
?~ logs +>
=- %_ +>.$
|= new=loglist :: oldest first
^- (quip card _state)
=. qued (weld qued new)
?~ qued [~ state]
=- %_ request-timestamps
qued (flop rest) :: oldest first
seen (weld logs seen) :: newest first
days (count-events (flop logs)) :: oldest first
==
%+ roll `loglist`logs
|= [log=event-log:rpc rest=loglist logs=(list [wen=@da wat=event])]
%+ roll `loglist`qued
|= [log=event-log:rpc [rest=loglist logs=(list [wen=@da wat=event])]]
:: to ensure logs are processed in sane order,
:: stop processing as soon as we skipped one
::
@ -255,11 +347,28 @@
++ event-log-to-event
|= log=event-log:rpc
^- (unit event)
?: =(azimuth:contracts address.log)
?: =(azimuth:mainnet-contracts address.log)
=+ (event-log-to-point-diff log)
?~ - ~
`azimuth+u
::TODO delegated sending support
?: =(delegated-sending:mainnet-contracts address.log)
?. .= i.topics.log
0x4763.8e3c.ddee.2204.81e4.c3f9.183d.639c.
0efe.a7f0.5fcd.2df4.1888.5572.9f71.5419
~
=+ ^- [of=@ pool=@] ::TODO =/
~| t.topics.log
%+ decode-topics:abi:ethereum t.topics.log
~[%uint %uint]
=+ ^- [by=@ gift=@ to=@] ::TODO =/
~| data.log
%+ decode-topics:abi:ethereum
%+ rash data.log
=- ;~(pfix (jest '0x') -)
%+ stun [3 3]
(bass 16 (stun [64 64] hit))
~[%uint %uint %address]
`invite+[by of gift to]
~
::
:: +count-events: add events to the daily stats
@ -304,33 +413,34 @@
++ count-event
|= [eve=event sat=stats]
^- stats
?> ?=(%azimuth -.eve)
?+ -.dif.eve sat
%spawned sat(spawned [who.dif.eve spawned.sat])
%activated sat(activated [who.eve activated.sat])
%transfer-proxy ?: =(0x0 new.dif.eve) sat
sat(transfer-p [who.eve transfer-p.sat])
%owner sat(transferred [who.eve transferred.sat])
%keys sat(configured [who.eve configured.sat])
%continuity sat(breached [who.eve breached.sat])
%escape ?~ new.dif.eve sat
sat(request [who.eve request.sat])
%sponsor ?. has.new.dif.eve sat
sat(sponsor [who.eve sponsor.sat])
%management-proxy sat(management-p [who.eve management-p.sat])
%voting-proxy sat(voting-p [who.eve voting-p.sat])
%spawn-proxy sat(spawn-p [who.eve spawn-p.sat])
?- -.eve
%invite sat(invites-senders [by.eve invites-senders.sat])
::
%azimuth
?+ -.dif.eve sat
%spawned sat(spawned [who.dif.eve spawned.sat])
%activated sat(activated [who.eve activated.sat])
%transfer-proxy ?: =(0x0 new.dif.eve) sat
sat(transfer-p [who.eve transfer-p.sat])
%owner sat(transferred [who.eve transferred.sat])
%keys sat(configured [who.eve configured.sat])
%continuity sat(breached [who.eve breached.sat])
%escape ?~ new.dif.eve sat
sat(request [who.eve request.sat])
%sponsor ?. has.new.dif.eve sat
sat(sponsor [who.eve sponsor.sat])
%management-proxy sat(management-p [who.eve management-p.sat])
%voting-proxy sat(voting-p [who.eve voting-p.sat])
%spawn-proxy sat(spawn-p [who.eve spawn-p.sat])
==
==
::
::
:: +wake-export: periodically export data
:: +export: periodically export data
::
++ wake-export
|= [=wire ~]
^- (quip move _+>)
:_ +>
:~ [ost %wait /export (add now export-frequency)]
(export-move %days (export-days days))
++ export
^- (list card)
:~ (export-move %days (export-days days))
(export-move %months (export-months days))
(export-move %events export-raw)
==
@ -339,10 +449,10 @@
::
++ export-move
|= [nom=@t dat=(list @t)]
^- move
:^ ost %info /export/[nom]
^- card
=- [%pass /export/[nom] %arvo %c %info -]
%+ foal:space:userlib
/(scot %p our)/home/(scot %da now)/gaze-exports/[nom]/txt
/(scot %p our.bowl)/home/(scot %da now.bowl)/gaze-exports/[nom]/txt
[%txt !>(dat)]
::
:: +peek-x: accept gall scry
@ -351,7 +461,7 @@
:: %/months/txt: per month, digest stats
:: %/raw/txt: all observed events
::
++ peek-x
++ peek-x ::TODO
|= pax=path
^- (unit (unit (pair mark *)))
?~ pax ~
@ -395,6 +505,7 @@
(weld management-p.sat management-p.sat.i.mos)
(weld voting-p.sat voting-p.sat.i.mos)
(weld spawn-p.sat spawn-p.sat.i.mos)
(weld invites-senders.sat invites-senders.sat.i.mos)
==
::
:: +export-days: generate a csv of stats per day
@ -412,21 +523,24 @@
"configured,"
"configured (unique),"
"escape request,"
"sponsor change"
"sponsor change,"
"invites,"
"invites (unique senders)"
==
|^ ^- (list @t)
%+ turn days
|= [day=@da stats]
%- crip
;: weld
(scow %da day) ","
(count spawned) ","
(count activated) ","
(count transfer-p) ","
(unique transferred) ","
(unique configured) ","
(count request) ","
(count sponsor)
(scow %da day) ","
(count spawned) ","
(count activated) ","
(count transfer-p) ","
(unique transferred) ","
(unique configured) ","
(count request) ","
(count sponsor) ","
(unique invites-senders)
==
::
++ count
@ -452,20 +566,25 @@
"date,"
"point,"
"event,"
"field 1"
"field 1,field2,field3"
==
|^ ^- (list @t)
%+ turn seen
|= [wen=@da wat=event]
%- crip
;: weld
(scow %da wen) ","
(pon who.wat) ","
(point-diff-to-row dif.wat)
==
:: (cork tail event-to-row crip)
|= [wen=@da =event]
(crip "{(scow %da wen)},{(event-to-row event)}")
::
++ event-to-row
|= =event
?- -.event
%azimuth (point-diff-to-row +.event)
%invite (invite-to-row +.event)
==
::
++ point-diff-to-row
|= dif=diff-point
|= [who=ship dif=diff-point]
^- tape
%+ weld "{(pon who)},"
?- -.dif
%full "full,"
%owner "owner,{(adr new.dif)}"
@ -473,7 +592,7 @@
%spawned "spawned,{(pon who.dif)}"
%keys "keys,{(num life.dif)}"
%continuity "breached,{(num new.dif)}"
%sponsor "sponsor,{(spo has.new.dif)} {(pon who.new.dif)}"
%sponsor "sponsor,{(spo has.new.dif)},{(pon who.new.dif)}"
%escape "escape-req,{(req new.dif)}"
%management-proxy "management-p,{(adr new.dif)}"
%voting-proxy "voting-p,{(adr new.dif)}"
@ -481,6 +600,10 @@
%transfer-proxy "transfer-p,{(adr new.dif)}"
==
::
++ invite-to-row
|= [by=ship of=ship ship to=address]
"{(pon by)},invite,{(pon of)},{(adr to)}"
::
++ num (d-co:co 1)
++ pon (cury scow %p)
++ adr |=(a=@ ['0' 'x' ((x-co:co (mul 2 20)) a)])

66
pkg/arvo/app/goad.hoon Normal file
View File

@ -0,0 +1,66 @@
/+ default-agent, verb
%+ verb |
^- agent:gall
=>
|%
++ warp
|= =bowl:gall
[%pass /clay %arvo %c %warp our.bowl %home ~ %next %z da+now.bowl /sys]
::
++ wait
|= =bowl:gall
[%pass /behn %arvo %b %wait +(now.bowl)]
::
++ goad
|= force=?
:~ [%pass /gall %arvo %g %goad force ~]
==
--
::
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
++ on-init
:: subscribe to /sys and do initial goad
::
[[(warp bowl) (wait bowl) ~] this]
::
++ on-save on-save:def
++ on-load on-load:def
++ on-poke
|= [=mark =vase]
?: ?=([%noun * %go] +<)
[(goad |) this]
?: ?=([%noun * %force] +<)
[(goad &) this]
(on-poke:def mark vase)
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
?+ wire (on-arvo:def wire sign-arvo)
[%clay ~]
:: on writ, wait
::
?> ?=(%writ +<.sign-arvo)
:_ this
:~ (warp bowl)
(wait bowl)
==
::
[%behn ~]
:: on wake, goad
::
?> ?=(%wake +<.sign-arvo)
?^ error.sign-arvo
:_ this :_ ~
[%pass /dill %arvo %d %flog %crud %goad-fail u.error.sign-arvo]
%- (slog leaf+"goad: recompiling all apps" ~)
[(goad |) this]
==
::
++ on-fail on-fail:def
--

265
pkg/arvo/app/group-hook.hoon
View File

@ -1,128 +1,169 @@
:: group-hook: allow syncing group data from foreign paths to local paths
::
/- *group-store, *group-hook
/+ default-agent
|%
+$ move [bone card]
+$ card card:agent:gall
::
+$ card
$% [%diff [%group-update group-update]]
[%quit ~]
[%poke wire dock [%group-action group-action]]
[%pull wire dock ~]
[%peer wire dock path]
++ versioned-state
$% state-zero
==
::
+$ state
$% [%0 state-zero]
==
::
+$ state-zero
$: synced=(map path ship)
boned=(map wire (list bone))
$: %0
synced=(map path ship)
==
::
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
group-core +>
gc ~(. group-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?. ?=(%group-hook-action mark)
(on-poke:def mark vase)
=^ cards state
(poke-group-hook-action:gc !<(group-hook-action vase))
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
?. ?=([%group @ *] path)
(on-watch:def path)
?. (~(has by synced.state) t.path)
(on-watch:def path)
=/ scry-path=^path
:(welp /=group-store/(scot %da now.bowl) t.path /noun)
=/ grp=(unit group)
.^((unit group) %gx scry-path)
?~ grp
(on-watch:def path)
:_ this
[%give %fact ~ %group-update !>([%path u.grp t.path])]~
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?+ -.sign (on-agent:def wire sign)
::
%watch-ack
?~ p.sign
[~ this]
%- (slog u.p.sign)
?> ?=([@ @ *] wire)
=/ =ship (slav %p i.wire)
=. synced.state (~(del by synced.state) t.t.wire)
[~ this]
::
%kick
?> ?=([@ @ *] wire)
=/ =ship (slav %p i.wire)
?. (~(has by synced.state) wire)
[~ this]
=/ group-path [%group wire]
=/ group-wire [i.wire group-path]
:_ this
[%pass group-wire %agent [ship %group-hook] %watch group-path]~
::
%fact
?. ?=(%group-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
?: (team:title our.bowl src.bowl)
(handle-local:gc !<(group-update q.cage.sign))
(handle-foreign:gc !<(group-update q.cage.sign))
[cards this]
==
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
[~ this]
[~ this(+<+ u.old)]
|_ bol=bowl:gall
::
++ poke-group-hook-action
|= act=group-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add
?. (team:title our.bol src.bol)
[~ this]
[~ state]
=/ group-path [%group path.act]
=/ group-wire [(scot %p ship.act) group-path]
?: (~(has by synced) path.act)
[~ this]
=. synced (~(put by synced) path.act ship.act)
:_ (track-bone group-wire)
?: (~(has by synced.state) path.act)
[~ state]
=. synced.state (~(put by synced.state) path.act ship.act)
:_ state
?: =(ship.act our.bol)
[ost.bol %peer group-wire [ship.act %group-store] group-path]~
[ost.bol %peer group-wire [ship.act %group-hook] group-path]~
[%pass group-wire %agent [ship.act %group-store] %watch group-path]~
[%pass group-wire %agent [ship.act %group-hook] %watch group-path]~
::
%remove
=/ ship (~(get by synced) path.act)
=/ ship (~(get by synced.state) path.act)
?~ ship
[~ this]
[~ state]
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
:: delete one of our own paths
=/ group-wire [(scot %p our.bol) %group path.act]
:_ this(synced (~(del by synced) path.act))
%+ weld
:_ state(synced (~(del by synced.state) path.act))
%+ snoc
(pull-wire group-wire path.act)
^- (list move)
%+ turn (prey:pubsub:userlib [%group path.act] bol)
|= [=bone *]
^- move
[bone %quit ~]
[%give %kick `[%group path.act] ~]
?: |(=(u.ship src.bol) (team:title our.bol src.bol))
:: delete a foreign ship's path
=/ group-wire [(scot %p u.ship) %group path.act]
:_ this(synced (~(del by synced) path.act))
:_ state(synced (~(del by synced.state) path.act))
(pull-wire group-wire path.act)
:: don't allow
[~ this]
[~ state]
==
::
++ peer-group
|= pax=path
^- (quip move _this)
?~ pax !!
?> (~(has by synced) pax)
=/ grp (group-scry pax)
?~ grp !!
:_ this
[ost.bol %diff [%group-update [%path u.grp pax]]]~
::
++ diff-group-update
|= [wir=wire diff=group-update]
^- (quip move _this)
?: (team:title our.bol src.bol)
(handle-local diff)
(handle-foreign diff)
::
++ handle-local
|= diff=group-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%keys [~ this]
%path [~ this]
%bundle [~ this]
%add [(update-subscribers [%group pax.diff] diff) this]
%remove [(update-subscribers [%group pax.diff] diff) this]
%keys [~ state]
%path [~ state]
%bundle [~ state]
%add [(update-subscribers [%group pax.diff] diff) state]
%remove [(update-subscribers [%group pax.diff] diff) state]
::
%unbundle
:_ this(synced (~(del by synced) pax.diff))
%+ weld
:_ state(synced (~(del by synced.state) pax.diff))
%+ snoc
(update-subscribers [%group pax.diff] diff)
^- (list move)
%+ turn (prey:pubsub:userlib [%group pax.diff] bol)
|= [=bone *]
[bone %quit ~]
[%give %kick `[%group pax.diff] ~]
==
::
++ handle-foreign
|= diff=group-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%keys [~ this]
%bundle [~ this]
%keys [~ state]
%bundle [~ state]
::
%path
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
:~ (group-poke pax.diff [%unbundle pax.diff])
@ -131,61 +172,37 @@
==
::
%add
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
[(group-poke pax.diff diff)]~
::
%remove
:_ this
:_ state
?~ pax.diff ~
=/ ship (~(get by synced) pax.diff)
=/ ship (~(get by synced.state) pax.diff)
?~ ship ~
?. =(src.bol u.ship) ~
[(group-poke pax.diff diff)]~
::
%unbundle
?~ pax.diff
[~ this]
=/ ship (~(get by synced) pax.diff)
[~ state]
=/ ship (~(get by synced.state) pax.diff)
?~ ship
[~ this]
[~ state]
?. =(src.bol u.ship)
[~ this]
:_ this(synced (~(del by synced) pax.diff))
[~ state]
:_ state(synced (~(del by synced.state) pax.diff))
[(group-poke pax.diff diff)]~
==
::
++ quit
|= wir=wire
^- (quip move _this)
=^ =ship wir
?> ?=([* ^] wir)
[(slav %p i.wir) t.t.wir]
?. (~(has by synced) wir)
[~ this]
=/ group-path [%group wir]
=/ group-wire [(scot %p ship) group-path]
:_ (track-bone group-wire)
[ost.bol %peer group-wire [ship %group-hook] group-path]~
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
=^ =ship wir
?> ?=([* ^] wir)
[(slav %p i.wir) t.t.wir]
~& %insufficient-permissions-for-group
[((slog u.saw) ~) this(synced (~(del by synced) wir))]
::
++ group-poke
|= [pax=path action=group-action]
^- move
[ost.bol %poke pax [our.bol %group-store] [%group-action action]]
^- card
[%pass pax %agent [our.bol %group-store] %poke %group-action !>(action)]
::
++ group-scry
|= pax=path
@ -194,35 +211,17 @@
::
++ update-subscribers
|= [pax=path diff=group-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
^- move
[bone %diff [%group-update diff]]
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
^- (list card)
[%give %fact `pax %group-update !>(diff)]~
::
++ pull-wire
|= [wir=wire pax=path]
^- (list move)
=/ bnd (~(get by boned) wir)
?~ bnd
~
=/ shp (~(get by synced) pax)
^- (list card)
=/ shp (~(get by synced.state) pax)
?~ shp
~
%+ turn u.bnd
|= ost=bone
^- move
?: =(u.shp our.bol)
[ost %pull wir [our.bol %group-store] ~]
[ost %pull wir [u.shp %group-hook] ~]
[%pass wir %agent [our.bol %group-store] %leave ~]~
[%pass wir %agent [u.shp %group-hook] %leave ~]~
::
--

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

@ -1,15 +1,17 @@
:: group-store: data store for groups of ships
::
/- *group-store
/+ default-agent
|%
+$ move [bone [%diff diff]]
+$ card card:agent:gall
::
+$ state
$% [%0 state-zero]
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: =groups
$: %0
=groups
==
::
+$ diff
@ -18,50 +20,71 @@
==
--
::
|_ [bol=bowl:gall state]
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
group-core +>
gc ~(. group-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?: ?=(%group-action mark)
(poke-group-action:gc !<(group-action vase))
(on-poke:def mark 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 %group-initial !>(groups))
[%keys ~] (give %group-update !>([%keys ~(key by groups)]))
[%group *]
(give %group-update !>([%path (~(got by groups) t.path) t.path]))
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
::
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x *] ``noun+!>((~(get by groups) t.path))
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ this .
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ peek-x
|= pax=path
^- (unit (unit [%noun (unit group)]))
?~ pax
[~ ~ %noun ~]
=/ grp=(unit group) (~(get by groups) pax)
[~ ~ %noun grp]
::
++ peer-all
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
:_ this
[ost.bol %diff %group-initial groups]~
::
++ peer-keys
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we send the list of keys then send events when they change
:_ this
[ost.bol %diff %group-update [%keys ~(key by groups)]]~
::
++ peer-group
|= pax=path
^- (quip move _this)
?> (team:title our.bol src.bol)
=/ grp (~(got by groups) pax)
:_ this
[ost.bol %diff %group-update [%path grp pax]]~
|_ bol=bowl:gall
::
++ poke-group-action
|= action=group-action
^- (quip move _this)
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%add (handle-add action)
@ -72,66 +95,64 @@
::
++ handle-add
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%add -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
=/ members (~(got by groups) pax.act)
=. members (~(uni in members) members.act)
?: =(members (~(got by groups) pax.act))
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act members))
state(groups (~(put by groups) pax.act members))
::
++ handle-remove
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%remove -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
=/ members (~(got by groups) pax.act)
=. members (~(dif in members) members.act)
?: =(members (~(got by groups) pax.act))
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act members))
state(groups (~(put by groups) pax.act members))
::
++ handle-bundle
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%bundle -.act)
?~ pax.act
[~ this]
[~ state]
?: (~(has by groups) pax.act)
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(put by groups) pax.act *group))
state(groups (~(put by groups) pax.act *group))
::
++ handle-unbundle
|= act=group-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%unbundle -.act)
?~ pax.act
[~ this]
[~ state]
?. (~(has by groups) pax.act)
[~ this]
[~ state]
:- (send-diff pax.act act)
this(groups (~(del by groups) pax.act))
state(groups (~(del by groups) pax.act))
::
++ update-subscribers
|= [pax=path act=group-action]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %group-update act]
^- (list card)
[%give %fact `pax %group-update !>(act)]~
::
++ send-diff
|= [pax=path act=group-action]
^- (list move)
^- (list card)
%- zing
:~ (update-subscribers /all act)
(update-subscribers [%group pax] act)
@ -141,4 +162,3 @@
==
::
--

3406
pkg/arvo/app/hall.hoon
View File

File diff suppressed because it is too large Load Diff

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

@ -2,6 +2,7 @@
:::: /hoon/hood/app :: ::
:: :: ::
/? 310 :: zuse version
/- *sole
/+ sole, :: libraries
:: XX these should really be separate apps, as
:: none of them interact with each other in
@ -21,13 +22,18 @@
=> |%
+$ part [%module %0 pith]
+$ pith ~
::
+$ move [bone card]
+$ card $% [%fake ~]
==
++ take
|~ [wire sign-arvo]
*(quip card:agent:gall part)
++ take-agent
|~ [wire gift:agent:gall]
*(quip card:agent:gall part)
++ poke
|~ [mark vase]
*(quip card:agent:gall part)
--
|= [bowl:gall own=part]
|_ moz=(list move)
|_ moz=(list card:agent:gall)
++ abet [(flop moz) own]
--
--
@ -37,9 +43,9 @@
!:
=> |% ::
++ hood-old :: unified old-state
{?($0 $1) lac/(map @tas hood-part-old)} ::
{?($1 $2) lac/(map @tas hood-part-old)} ::
++ hood-1 :: unified state
{$1 lac/(map @tas hood-part)} ::
{$2 lac/(map @tas hood-part)} ::
++ hood-good :: extract specific
=+ hed=$:hood-head
|@ ++ $
@ -77,130 +83,141 @@
:: :: ::
:::: :: :: app proper
:: :: ::
=, gall
|_ $: hid/bowl :: gall environment
hood-1 :: module states
== ::
++ able :: find+make part
=+ hed=$:hood-head
|@ ++ $
=+ rep=(~(get by lac) hed)
=+ par=?^(rep u.rep `hood-part`(hood-make our.hid hed))
((hood-good hed) par)
--
^- agent:gall
=| hood-1 :: module states
=> |%
++ help
|= hid/bowl:gall
|%
++ able :: find+make part
=+ hed=$:hood-head
|@ ++ $
=+ rep=(~(get by lac) hed)
=+ par=?^(rep u.rep `hood-part`(hood-make our.hid hed))
((hood-good hed) par)
--
::
++ ably :: save part
=+ $:{(list) hood-part}
|@ ++ $
[+<- (~(put by lac) +<+< +<+)]
--
:: :: ::
:::: :: :: generic handling
:: :: ::
++ prep
|= old/(unit hood-old) ^- (quip _!! _+>)
:- ~
?~ old +>
+>(lac (~(run by lac.u.old) hood-port))
::
++ poke-hood-load :: recover lost brain
|= dat/hood-part
?> =(our.hid src.hid)
~& loaded+-.dat
[~ (~(put by lac) -.dat dat)]
::
::
++ from-module :: create wrapper
|* _[identity=%module start=..$ finish=_abet]:(hood-module)
=- [wrap=- *start] :: usage (wrap handle-arm):from-foo
|* handle/_finish
|= a=_+<.handle
=. +>.handle (start hid (able identity))
^- (quip card:agent:gall _lac)
%- ably
^- (quip card:agent:gall hood-part)
(handle a)
:: per-module interface wrappers
++ from-drum (from-module %drum [..$ _se-abet]:(hood-drum))
++ from-helm (from-module %helm [..$ _abet]:(hood-helm))
++ from-kiln (from-module %kiln [..$ _abet]:(hood-kiln))
++ from-write (from-module %write [..$ _abet]:(hood-write))
--
--
|_ hid/bowl:gall :: gall environment
++ on-init
`..on-init
::
++ ably :: save part
=+ $:{(list) hood-part}
|@ ++ $
[(flop +<-) %_(+> lac (~(put by lac) +<+< +<+))]
--
:: :: ::
:::: :: :: generic handling
:: :: ::
++ prep
|= old/(unit hood-old) ^- (quip _!! _+>)
:- ~
?~ old +>
+>(lac (~(run by lac.u.old) hood-port))
++ on-save
!>([%2 lac])
::
++ poke-hood-load :: recover lost brain
|= dat/hood-part
?> =(our.hid src.hid)
~& loaded+-.dat
[~ %_(+> lac (~(put by lac) -.dat dat))]
++ on-load
|= =old-state=vase
=/ old-state !<(hood-old old-state-vase)
=^ cards lac
=. lac lac.old-state
?. ?=(%1 -.old-state)
`lac
((wrap on-load):from-drum:(help hid) %1)
[cards ..on-init]
::
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall agent:gall)
=/ h (help hid)
=^ cards lac
?: =(%helm (end 3 4 mark))
((wrap poke):from-helm:h mark vase)
?: =(%drum (end 3 4 mark))
((wrap poke):from-drum:h mark vase)
?: =(%kiln (end 3 4 mark))
((wrap poke):from-kiln:h mark vase)
?: =(%write (end 3 5 mark))
((wrap poke):from-write:h mark vase)
:: XX should rename and move to libs
::
?+ mark ~|([%poke-hood-bad-mark mark] !!)
%hood-load (poke-hood-load:h !<(hood-part vase))
%atom ((wrap poke-atom):from-helm:h !<(@ vase))
%dill-belt ((wrap poke-dill-belt):from-drum:h !<(dill-belt:dill vase))
%dill-blit ((wrap poke-dill-blit):from-drum:h !<(dill-blit:dill vase))
%hood-sync ((wrap poke-sync):from-kiln:h !<([desk ship desk] vase))
==
[cards ..on-init]
::
++ from-module :: create wrapper
|* _[identity=%module start=..$ finish=_abet]:(hood-module)
=- [wrap=- *start] :: usage (wrap handle-arm):from-foo
|* handle/_finish
|= a=_+<.handle
=. +>.handle (start hid (able identity))
(ably (handle a))
++ on-watch
|= =path
=/ h (help hid)
=^ cards lac
?+ path ~|([%hood-bad-path wire] !!)
[%drum *] ((wrap peer):from-drum:h t.path)
==
[cards ..on-init]
::
:: per-module interface wrappers
++ from-drum (from-module %drum [..$ _se-abet]:(hood-drum))
++ from-helm (from-module %helm [..$ _abet]:(hood-helm))
++ from-kiln (from-module %kiln [..$ _abet]:(hood-kiln))
++ from-write (from-module %write [..$ _abet]:(hood-write))
++ on-leave
|= path
`..on-init
::
:: :: ::
:::: :: :: switchboard
:: :: ::
++ coup-drum-phat (wrap take-coup-phat):from-drum
++ coup-helm-hi (wrap coup-hi):from-helm
++ coup-kiln-fancy (wrap take-coup-fancy):from-kiln
++ coup-kiln-reload (wrap take-coup-reload):from-kiln
++ coup-kiln-spam (wrap take-coup-spam):from-kiln
++ diff-sole-effect-drum-phat (wrap diff-sole-effect-phat):from-drum
++ init-helm |=({way/wire *} [~ +>])
++ mack-kiln (wrap mack):from-kiln
++ made-write (wrap made):from-write
++ made-kiln (wrap take-made):from-kiln
++ mere-kiln (wrap take-mere):from-kiln
++ mere-kiln-sync (wrap take-mere-sync):from-kiln
++ wake-kiln-autocommit (wrap take-wake-autocommit):from-kiln
++ wake-kiln-overload (wrap take-wake-overload):from-kiln
++ wake-helm-automass (wrap take-wake-automass):from-helm
++ onto-drum (wrap take-onto):from-drum
++ peer-drum (wrap peer):from-drum
++ poke-atom (wrap poke-atom):from-helm
++ poke-dill-belt (wrap poke-dill-belt):from-drum
++ poke-dill-blit (wrap poke-dill-blit):from-drum
++ poke-drum-put (wrap poke-put):from-drum
++ poke-drum-link (wrap poke-link):from-drum
++ poke-drum-unlink (wrap poke-unlink):from-drum
++ poke-drum-exit (wrap poke-exit):from-drum
++ poke-drum-start (wrap poke-start):from-drum
++ poke-drum-set-boot-apps (wrap poke-set-boot-apps):from-drum
++ poke-helm-hi (wrap poke-hi):from-helm
::++ poke-helm-invite (wrap poke-invite):from-helm
++ poke-helm-knob (wrap poke-knob):from-helm
++ poke-helm-mass (wrap poke-mass):from-helm
++ poke-helm-reload (wrap poke-reload):from-helm
++ poke-helm-reload-desk (wrap poke-reload-desk):from-helm
++ poke-helm-reset (wrap poke-reset):from-helm
++ poke-helm-serve (wrap poke-serve):from-helm
++ poke-helm-send-hi (wrap poke-send-hi):from-helm
++ poke-helm-verb (wrap poke-verb):from-helm
++ poke-helm-rekey (wrap poke-rekey):from-helm
++ poke-helm-moon (wrap poke-moon):from-helm
++ poke-helm-nuke (wrap poke-nuke):from-helm
++ poke-helm-automass (wrap poke-automass):from-helm
++ poke-helm-cancel-automass (wrap poke-cancel-automass):from-helm
++ poke-helm-bonk (wrap poke-bonk):from-helm
++ poke-hood-sync (wrap poke-sync):from-kiln
++ poke-kiln-commit (wrap poke-commit):from-kiln
++ poke-kiln-info (wrap poke-info):from-kiln
++ poke-kiln-label (wrap poke-label):from-kiln
++ poke-kiln-merge (wrap poke-merge):from-kiln
++ poke-kiln-cancel (wrap poke-cancel):from-kiln
++ poke-kiln-cancel-autocommit (wrap poke-cancel-autocommit):from-kiln
++ poke-kiln-mount (wrap poke-mount):from-kiln
++ poke-kiln-rm (wrap poke-rm):from-kiln
++ poke-kiln-schedule (wrap poke-schedule):from-kiln
++ poke-kiln-track (wrap poke-track):from-kiln
++ poke-kiln-sync (wrap poke-sync):from-kiln
++ poke-kiln-syncs (wrap poke-syncs):from-kiln
++ poke-kiln-start-autoload (wrap poke-start-autoload):from-kiln
++ poke-kiln-wipe-ford (wrap poke-wipe-ford):from-kiln
++ poke-kiln-keep-ford (wrap poke-keep-ford):from-kiln
++ poke-kiln-autoload (wrap poke-autoload):from-kiln
++ poke-kiln-overload (wrap poke-overload):from-kiln
++ poke-kiln-wash-gall (wrap poke-wash-gall):from-kiln
++ poke-kiln-unmount (wrap poke-unmount):from-kiln
++ poke-kiln-unsync (wrap poke-unsync):from-kiln
++ poke-kiln-permission (wrap poke-permission):from-kiln
++ poke-write-sec-atom (wrap poke-sec-atom):from-write
++ poke-write-paste (wrap poke-paste):from-write
++ poke-write-tree (wrap poke-tree):from-write
++ poke-write-wipe (wrap poke-wipe):from-write
++ quit-drum-phat (wrap quit-phat):from-drum
++ reap-drum-phat (wrap reap-phat):from-drum
++ woot-helm (wrap take-woot):from-helm
++ writ-kiln-autoload (wrap take-writ-autoload):from-kiln
++ writ-kiln-find-ship (wrap take-writ-find-ship):from-kiln
++ writ-kiln-sync (wrap take-writ-sync):from-kiln
++ bound (wrap take-bound):from-helm
++ on-peek
|= path
*(unit (unit cage))
::
++ on-agent
|= [=wire =sign:agent:gall]
=/ h (help hid)
=^ cards lac
?+ wire ~|([%hood-bad-wire wire] !!)
[%helm *] ((wrap take-agent):from-helm:h wire sign)
[%kiln *] ((wrap take-agent):from-kiln:h wire sign)
[%drum *] ((wrap take-agent):from-drum:h wire sign)
[%write *] ((wrap take-agent):from-write:h wire sign)
==
[cards ..on-init]
::
++ on-arvo
|= [=wire =sign-arvo]
=/ h (help hid)
=^ cards lac
?+ wire ~|([%hood-bad-wire wire] !!)
[%helm *] ((wrap take):from-helm:h t.wire sign-arvo)
[%drum *] ((wrap take):from-drum:h t.wire sign-arvo)
[%kiln *] ((wrap take-general):from-kiln:h t.wire sign-arvo)
[%write *] ((wrap take):from-write:h t.wire sign-arvo)
==
[cards ..on-init]
::
++ on-fail
|= [term tang]
`..on-init
--

114
pkg/arvo/app/invite-hook.hoon Normal file
View File

@ -0,0 +1,114 @@
:: invite-hook: receive invites from any source
::
:: only handles %invite actions. accepts json, but only from the host team.
:: can be poked by the host team to send an invite out to someone.
:: can be poked by foreign ships to send an invite to us.
::
/+ *invite-json, default-agent, verb
::
|%
+$ state-0 [%0 ~]
::
+$ card card:agent:gall
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
[~ this]
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
:_ this
?+ mark (on-poke:def mark vase)
%json
:: only accept json from ourselves.
::
?> (team:title our.bowl src.bowl)
=/ act (json-to-action !<(json vase))
?> ?=(%invite -.act)
[(invite-hook-poke:do recipient.invite.act act)]~
::
%invite-action
=/ act=invite-action !<(invite-action vase)
?. ?=(%invite -.act) ~
:: if the sender is us,
::
?: (team:title our.bowl src.bowl)
:: outgoing. we must be inviting another ship. send them the invite.
::
?> !(team:title our.bowl ship.invite.act)
[(invite-hook-poke:do recipient.invite.act act)]~
:: else incoming. ensure invitatory exists and invite is not a duplicate.
::
?> ?=(^ (invitatory-scry:do path.act))
?> ?=(~ (invite-scry:do path.act uid.act))
[(invite-poke:do path.act act)]~
==
::
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
::
++ invite-hook-poke
|= [=ship action=invite-action]
^- card
:* %pass
/invite-hook
%agent
[ship %invite-hook]
%poke
%invite-action
!>(action)
==
::
++ invite-poke
|= [=path action=invite-action]
^- card
:* %pass
path
%agent
[our.bowl %invite-store]
%poke
%invite-action
!>(action)
==
::
++ invitatory-scry
|= pax=path
^- (unit invitatory)
=. pax
;:(weld /=invite-store/(scot %da now.bowl)/invitatory pax /noun)
.^((unit invitatory) %gx pax)
::
++ invite-scry
|= [pax=path uid=serial]
^- (unit invite)
=. pax
;:(weld /=invite-store/(scot %da now.bowl)/invite pax /(scot %uv uid)/noun)
.^((unit invite) %gx pax)
--

182
pkg/arvo/app/invite-store.hoon Normal file
View File

@ -0,0 +1,182 @@
/+ *invite-json, default-agent
|%
+$ card card:agent:gall
::
+$ versioned-state
$% state-zero
==
::
+$ state-zero
$: %0
=invites
==
--
::
=| state-zero
=* state -
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
inv-core +>
ic ~(. inv-core bol)
def ~(. (default-agent this %|) bol)
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-invite-action:ic (json-to-action !<(json vase)))
%invite-action (poke-invite-action:ic !<(invite-action vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=/ cards=(list card)
?+ path (on-watch:def path)
[%all ~] [%give %fact ~ %invite-initial !>(invites)]~
[%updates ~] ~
[%invitatory *]
=/ inv=invitatory (~(got by invites) t.path)
[%give %fact ~ %invite-update !>([%invitatory inv])]~
==
[cards this]
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %all ~] (peek-x-all:ic t.t.path)
[%x %invitatory *] (peek-x-invitatory:ic t.t.path)
[%x %invite *] (peek-x-invite:ic t.t.path)
==
::
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ bol=bowl:gall
::
++ peek-x-all
|= pax=path
^- (unit (unit cage))
[~ ~ %noun !>(invites)]
::
++ peek-x-invitatory
|= pax=path
^- (unit (unit cage))
?~ pax
~
=/ invitatory=(unit invitatory) (~(get by invites) pax)
[~ ~ %noun !>(invitatory)]
::
++ peek-x-invite
|= pax=path
^- (unit (unit cage))
:: /:path/:uid
=/ pas (flop pax)
?~ pas
~
=/ uid=serial (slav %uv i.pas)
=. pax (scag (dec (lent pax)) `(list @ta)`pax)
=/ invitatory=(unit invitatory) (~(get by invites) pax)
?~ invitatory
~
=/ invite=(unit invite) (~(get by u.invitatory) uid)
[~ ~ %noun !>(invite)]
::
++ poke-invite-action
|= action=invite-action
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%create (handle-create action)
%delete (handle-delete action)
%invite (handle-invite action)
%accept (handle-accept action)
%decline (handle-decline action)
==
::
++ handle-create
|= act=invite-action
^- (quip card _state)
?> ?=(%create -.act)
?: (~(has by invites) path.act)
[~ state]
:- (send-diff path.act act)
state(invites (~(put by invites) path.act *invitatory))
::
++ handle-delete
|= act=invite-action
^- (quip card _state)
?> ?=(%delete -.act)
?. (~(has by invites) path.act)
[~ state]
:- (send-diff path.act act)
state(invites (~(del by invites) path.act))
::
++ handle-invite
|= act=invite-action
^- (quip card _state)
?> ?=(%invite -.act)
?. (~(has by invites) path.act)
[~ state]
=/ container (~(got by invites) path.act)
=. uid.act (sham eny.bol)
=. container (~(put by container) uid.act invite.act)
:- (send-diff path.act act)
state(invites (~(put by invites) path.act container))
::
++ handle-accept
|= act=invite-action
^- (quip card _state)
?> ?=(%accept -.act)
?. (~(has by invites) path.act)
[~ state]
=/ container (~(got by invites) path.act)
=/ invite (~(get by container) uid.act)
?~ invite
[~ state]
=. container (~(del by container) uid.act)
:- (send-diff path.act [%accepted path.act uid.act u.invite])
state(invites (~(put by invites) path.act container))
::
++ handle-decline
|= act=invite-action
^- (quip card _state)
?> ?=(%decline -.act)
?. (~(has by invites) path.act)
[~ state]
=/ container (~(got by invites) path.act)
=/ invite (~(get by container) uid.act)
?~ invite
[~ state]
=. container (~(del by container) uid.act)
:- (send-diff path.act act)
state(invites (~(put by invites) path.act container))
::
++ update-subscribers
|= [pax=path upd=invite-update]
^- card
[%give %fact `pax %invite-update !>(upd)]
::
++ send-diff
|= [pax=path upd=invite-update]
^- (list card)
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%invitatory pax] upd)
==
::
--

72
pkg/arvo/app/invite-view.hoon Normal file
View File

@ -0,0 +1,72 @@
:: invite-view: provide a json interface to invite-store
::
:: accepts subscriptions at the /primary path.
:: passes through all invites and their updates.
:: only accepts subcriptions from the host's team.
::
::TODO could maybe use /lib/proxy-hook, be renamed invite-proxy-hook
::
/+ *invite-json, default-agent
::
|%
+$ card card:agent:gall
--
::
=>
|%
++ watch-updates
|= our=ship
^- card
[%pass /store %agent [our %invite-store] %watch /updates]
--
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
[[(watch-updates our.bowl)]~ this]
::
++ on-save on-save:def
++ on-load
|= old=vase
^- (quip card _this)
[~ this]
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title our.bowl src.bowl)
?. =(/primary path)
(on-watch:def path)
:_ this
=/ =invites
.^(invites %gx /=invite-store/(scot %da now.bowl)/all/noun)
[%give %fact ~ %json !>((invites-to-json invites))]~
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
:_ this
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack] !!)
%watch-ack ~
%kick [(watch-updates our.bowl)]~
::
%fact
~| [dap.bowl %unexpected-fact-mark p.cage.sign]
?> ?=(%invite-update p.cage.sign)
:~ :*
%give %fact
`/primary %json
!>((update-to-json !<(invite-update q.cage.sign)))
== ==
==
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-leave on-leave:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--

324
pkg/arvo/app/language-server.hoon Normal file
View File

@ -0,0 +1,324 @@
/+ *server,
auto=language-server-complete,
lsp-parser=language-server-parser,
easy-print=language-server-easy-print,
rune-snippet=language-server-rune-snippet,
default-agent
|%
+$ card card:agent:gall
+$ lsp-req
$: uri=@t
$% [%sync changes=(list change)]
[%completion position]
[%commit @ud]
[%hover position]
==
==
::
+$ change
$: range=(unit range)
range-length=(unit @ud)
text=@t
==
::
+$ range
$: start=position
end=position
==
::
+$ position
[row=@ud col=@ud]
::
+$ all-state bufs=(map uri=@t buf=wall)
--
^- agent:gall
=| all-state
=* state -
=<
|_ =bowl:gall
+* this .
lsp-core +>
lsp ~(. lsp-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^+ on-init:*agent:gall
^- (quip card _this)
~& > %lsp-init
:_ this :_ ~
:* %pass /connect
%arvo %e
%connect [~ /'~language-server-protocol'] %language-server
==
::
++ on-save !>(state)
++ on-load
^+ on-load:*agent:gall
|= old-state=vase
^- (quip card _this)
~& > %lsp-upgrade
[~ this(state !<(all-state old-state))]
::
++ on-poke
^+ on-poke:*agent:gall
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%handle-http-request
(handle-http-request:lsp !<([eyre-id=@ta inbound-request:eyre] vase))
==
[cards this]
::
++ on-watch
|= =path
?. ?=([%http-response @ ~] path)
(on-watch:def path)
`this
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
^+ on-arvo:*agent:gall
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%connect ~] ?>(?=(%bound +<.sign-arvo) `state)
==
[cards this]
::
++ on-fail on-fail:def
--
::
|_ bow=bowl:gall
::
++ parser
=, dejs:format
|^
%: ot
uri+so
:- %data
%- of
:~ sync+sync
completion+position
commit+ni
hover+position
==
~
==
::
++ sync
%- ar
%: ou
range+(uf ~ (pe ~ range))
'rangeLength'^(uf ~ (pe ~ ni))
text+(un so)
~
==
::
++ range
%: ot
start+position
end+position
~
==
::
++ position
%: ot
line+ni
character+ni
~
==
--
::
++ json-response
|= [eyre-id=@ta jon=json]
^- (list card)
(give-simple-payload:app eyre-id (json-response:gen (json-to-octs jon)))
::
:: +handle-http-request: received on a new connection established
::
++ handle-http-request
|= [eyre-id=@ta =inbound-request:eyre]
^- (quip card _state)
?> ?=(^ body.request.inbound-request)
=/ =lsp-req
%- parser
(need (de-json:html q.u.body.request.inbound-request))
=/ buf (~(gut by bufs) uri.lsp-req *wall)
=^ cards buf
?- +<.lsp-req
%sync (handle-sync buf eyre-id +>.lsp-req)
%completion (handle-completion buf eyre-id +>.lsp-req)
%commit (handle-commit buf eyre-id uri.lsp-req)
%hover (handle-hover buf eyre-id +>.lsp-req)
==
=. bufs
(~(put by bufs) uri.lsp-req buf)
[cards state]
::
++ regen-diagnostics
|= buf=wall
^- json
=/ t=tape
(zing (join "\0a" buf))
=/ parse
(lily:auto t (lsp-parser *beam))
?: ?=(%| -.parse)
(format-diagnostic p.parse)
=, enjs:format
%- pairs
:~ good+b+&
==
::
++ format-diagnostic
|= [row=@ col=@]
^- json
=, enjs:format
%- pairs
:~ good+b+|
:+ %diagnostics %a :_ ~
=/ loc (pairs line+(numb (dec row)) character+(numb col) ~)
%- pairs
:~ range+(pairs start+loc end+loc ~)
severity+n+'1'
message+s+'syntax error'
==
==
::
++ handle-commit
|= [buf=wall eyre-id=@ta uri=@t]
^- [(list card) wall]
:_ buf
=/ jon
(regen-diagnostics buf)
:_ (json-response eyre-id jon)
:*
%pass
/commit
%agent
[our.bow %hood]
%poke
%kiln-commit
!>([q.byk.bow |])
==
::
++ handle-hover
|= [buf=wall eyre-id=@ta row=@ud col=@ud]
^- [(list card) wall]
=/ txt
(zing (join "\0a" buf))
=+ (get-id:auto (get-pos buf row col) txt)
?~ id
[(json-response eyre-id *json) buf]
=/ match=(unit (option:auto type))
(search-exact:auto u.id (get-identifiers:auto -:!>(..zuse)))
?~ match
[(json-response eyre-id *json) buf]
=/ contents
%- crip
;: weld
"`"
~(ram re ~(duck easy-print detail.u.match))
"`"
==
:_ buf
%+ json-response eyre-id
%- pairs:enjs:format
[contents+s+contents ~]
::
++ handle-sync
|= [buf=wall eyre-id=@ta changes=(list change)]
:- (json-response eyre-id *json)
|- ^- wall
?~ changes
buf
?: ?|(?=(~ range.i.changes) ?=(~ range-length.i.changes))
=/ =wain (to-wain:format text.i.changes)
=. buf (turn wain trip)
$(changes t.changes)
=/ =tape (zing (join "\0a" buf))
=/ start-pos (get-pos buf start.u.range.i.changes)
=/ end-pos (get-pos buf end.u.range.i.changes)
=. tape
;: weld
(scag start-pos tape)
(trip text.i.changes)
(slag end-pos tape)
==
=. buf (to-wall tape)
$(changes t.changes)
::
++ to-wall
|= =tape
^- wall
%+ roll (flop tape)
|= [char=@tD =wall]
?~ wall
[[char ~] ~]
?: =('\0a' char)
[~ wall]
[[char i.wall] t.wall]
::
++ get-pos
|= [buf=wall position]
^- @ud
?~ buf
0
?: =(0 row)
col
%+ add +((lent i.buf)) :: +1 because newline
$(row (dec row), buf t.buf)
::
++ safe-sub
|= [a=@ b=@]
?: (gth b a)
0
(sub a b)
::
++ handle-completion
|= [buf=wall eyre-id=@ta row=@ud col=@ud]
^- [(list card) wall]
=/ =tape (zing (join "\0a" buf))
=/ pos (get-pos buf row col)
:_ buf
:: Check if we're on a rune
::
=/ rune (swag [(safe-sub pos 2) 2] tape)
?: (~(has by runes:rune-snippet) rune)
(json-response eyre-id (rune-snippet rune))
:: Don't run on large files because it's slow
::
?: (gth (lent buf) 1.000)
=, enjs:format
(json-response eyre-id (pairs good+b+& result+~ ~))
::
=/ tl
(tab-list-tape:auto -:!>(..zuse) pos tape)
=, enjs:format
%+ json-response eyre-id
?: ?=(%| -.tl)
(format-diagnostic p.tl)
?~ p.tl
*json
%- pairs
:~ good+b+&
::
:- %result
%- pairs
:~ 'isIncomplete'^b+&
::
:- %items
:- %a
=/ lots (gth (lent u.p.tl) 10)
%- flop
%+ turn (scag 50 u.p.tl)
|= [=term =type]
?: lots
(frond label+s+term)
=/ detail (crip ~(ram re ~(duck easy-print type)))
(pairs label+s+term detail+s+detail ~)
==
==
--

230
pkg/arvo/app/launch.hoon
View File

@ -1,5 +1,5 @@
/- launch
/+ *server
/+ *server, default-agent
::
/= index
/^ $-(marl manx)
@ -22,129 +22,143 @@
/^ (map knot @)
/: /===/app/launch/img /_ /png/
::
=, launch
::
|%
+$ state
$% [%0 tiles=(set tile) data=tile-data path-to-tile=(map path @tas)]
+$ versioned-state
$% state-zero
==
+$ state-zero
$: %0
tiles=(set tile:launch)
data=tile-data:launch
path-to-tile=(map path @tas)
==
::
+$ move [bone card]
::
+$ card
$% [%http-response =http-event:http]
[%connect wire binding:eyre term]
[%peer wire dock path]
[%diff %json json]
==
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall sta=state]
=| state-zero
=* state -
^- agent:gall
|_ bol=bowl:gall
+* this .
def ~(. (default-agent this %|) bol)
++ on-init
^- (quip card _this)
:_ this
[%pass / %arvo %e %connect [~ /] %launch]~
::
++ this .
++ on-save !>(state)
::
++ prep
|= old=(unit state)
^- (quip move _this)
?~ old
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [mar=mark vas=vase]
^- (quip card _this)
?+ mar (on-poke:def mar vas)
::
%launch-action
=/ act !<(action:launch vas)
=/ beforedata (~(get by data) name.act)
=/ newdata
?~ beforedata
(~(put by data) name.act [*json url.act])
(~(put by data) name.act [jon.u.beforedata url.act])
=/ new-tile `tile:launch`[`@tas`name.act `path`subscribe.act]
:- [%pass subscribe.act %agent [our.bol name.act] %watch subscribe.act]~
%= this
tiles (~(put in tiles) new-tile)
data newdata
path-to-tile (~(put by path-to-tile) subscribe.act name.act)
==
::
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vas)
:_ this
[ost.bol %connect / [~ /] %launch]~
[~ this(sta u.old)]
::
++ poke-launch-action
|= act=action
^- (quip move _this)
=/ beforedata (~(get by data.sta) name.act)
=/ newdata
?~ beforedata
(~(put by data.sta) name.act [*json url.act])
(~(put by data.sta) name.act [jon.u.beforedata url.act])
:- [ost.bol %peer subscribe.act [our.bol name.act] subscribe.act]~
%= this
tiles.sta (~(put in tiles.sta) [name.act subscribe.act])
data.sta newdata
path-to-tile.sta (~(put by path-to-tile.sta) subscribe.act name.act)
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
|= =inbound-request:eyre
^- simple-payload:http
=/ request-line (parse-request-line url.request.inbound-request)
=/ name=@t
=/ back-path (flop site.request-line)
?~ back-path
''
i.back-path
?+ site.request-line
not-found:gen
::
~
=/ hym=manx
%- index
^- marl
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
^- manx
;script@"{(trip url)}";
(manx-response:gen hym)
::
[%'~launch' %css %index ~] :: styling
(css-response:gen style)
::
[%'~launch' %js %index ~] :: javascript
(js-response:gen script)
::
[%'~launch' %img *] :: images
=/ img=(unit @) (~(get by launch-png) `@ta`name)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
::
[%'~modulo' %session ~]
=/ session-js
%- as-octt:mimes:html
;: weld
"window.ship = '{+:(scow %p our.bol)}';"
"window.urb = new Channel();"
==
(js-response:gen session-js)
==
==
::
++ peer-main
|= [pax=path]
^- (quip move _this)
=/ data/json
++ on-watch
|= pax=path
^- (quip card _this)
?: ?=([%http-response *] pax)
[~ this]
?. ?=([%main *] pax)
(on-watch:def pax)
=/ data=json
%- pairs:enjs:format
%+ turn ~(tap by data.sta)
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
[key jon]
:_ this
[ost.bol %diff %json data]~
[%give %fact ~ %json !>(data)]~
::
++ diff-json
|= [pax=path jon=json]
^- (quip move _this)
=/ name/@tas (~(got by path-to-tile.sta) pax)
=/ data/(unit [json url=@t]) (~(get by data.sta) name)
?~ data
[~ this]
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-fail on-fail:def
++ on-agent
|= [wir=wire sin=sign:agent:gall]
^- (quip card _this)
?. ?=(%fact -.sin)
(on-agent:def wir sin)
?. ?=(%json p.cage.sin)
(on-agent:def wir sin)
::
:-
%+ turn (prey:pubsub:userlib /main bol)
|= [=bone *]
[bone %diff %json (frond:enjs:format name jon)]
::
%= this
data.sta (~(put by data.sta) name [jon url.u.data])
==
=/ jon=json !<(json q.cage.sin)
=/ name=@tas (~(got by path-to-tile) wir)
=/ dat=(unit [json url=@t]) (~(get by data) name)
?~ dat [~ this]
:_ this(data (~(put by data) name [jon url.u.dat]))
[%give %fact `/main %json !>((frond:enjs:format name jon))]~
::
++ generate-script-marl
|= data=tile-data
^- marl
%+ turn ~(tap by data)
|= [key=@tas [jon=json url=@t]]
^- manx
;script@"{(trip url)}";
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ name=@t
=/ back-path (flop site.request-line)
?~ back-path
''
i.back-path
=/ site (flop site.request-line)
?~ site
=/ hym=manx (index (generate-script-marl data.sta))
:_ this
[ost.bol %http-response (manx-response:app hym)]~
?+ site.request-line
:_ this
[ost.bol %http-response not-found:app]~
::
:: styling
::
[%'~launch' %css %index ~]
:_ this
[ost.bol %http-response (css-response:app style)]~
::
:: javascript
::
[%'~launch' %js %index ~]
:_ this
[ost.bol %http-response (js-response:app script)]~
::
:: images
::
[%'~launch' %img *]
=/ img (as-octs:mimes:html (~(got by launch-png) `@ta`name))
:_ this
[ost.bol %http-response (png-response:app img)]~
==
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
++ on-arvo
|= [wir=wire sin=sign-arvo]
^- (quip card:agent:gall _this)
?. ?=(%bound +<.sin)
(on-arvo:def wir sin)
[~ this]
::
--

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

@ -1,5 +1,5 @@
/- lens, *sole
/+ base64, *server
/- lens, *sole
/+ base64, *server, default-agent
/= lens-mark /: /===/mar/lens/command
/!noun/
=, format
@ -10,57 +10,32 @@
$% [%json =json]
[%mime =mime]
==
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%connect wire binding:eyre term]
[%http-response =http-event:http]
[%peer wire dock path]
[%peer wire dock path]
[%poke wire dock poke]
[%pull wire dock ~]
==
::
+$ poke
$% [%lens-command command:lens]
[%import *]
==
::
+$ state
$% $: %0
job=(unit [=bone com=command:lens])
job=(unit [eyre-id=@ta com=command:lens])
==
==
::
--
::
|_ [bow=bowl:gall state=state]
=| =state
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ this .
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(^state old))
::
++ prep
|= old=(unit *)
^- (quip move _this)
[~ this]
::
:: alerts us that we were bound. we need this because the vane calls back.
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ poke-handle-http-request
%- (require-authorization:app ost.bow move this)
|= =inbound-request:eyre
^- (quip move _this)
::
?^ job.state
:_ this
[ost.bow %http-response %start [%500 ~] ~ %.y]~
++ on-poke
|= [=mark =vase]
^- (quip card:agent:gall _this)
?. ?=(%handle-http-request mark)
(on-poke:def mark vase)
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
?> ?=(~ job.state)
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ site (flop site.request-line)
@ -72,77 +47,151 @@
::
?: ?=(%export -.source.com)
~& [%export app.source.com]
:_ this(job.state (some [ost.bow com]))
[ost.bow %peer /export [our.bow app.source.com] /export]~
:_ this(job.state (some [eyre-id com]))
[%pass /export %agent [our.bowl app.source.com] %watch /export]~
::
?: ?=(%import -.source.com)
?~ enc=(de:base64 base64-jam.source.com)
:_ this
[ost.bow %http-response %start [%500 ~] ~ %.y]~
!!
::
=/ c=* (cue q.u.enc)
::
:_ this(job.state (some [ost.bow com]))
[ost.bow %poke /import [our.bow app.source.com] %import c]~
:_ this(job.state (some [eyre-id com]))
[%pass /import %agent [our.bowl app.source.com] %poke %import !>(c)]~
::
:_ this(job.state (some [ost.bow com]))
[ost.bow %peer /sole [our.bow %dojo] /sole]~
:_ this(job.state (some [eyre-id com]))
[%pass /sole %agent [our.bowl %dojo] %watch /sole/[eyre-id]]~
::
++ diff-sole-effect
|= [=wire fec=sole-effect]
^- (quip move _this)
=/ out
|- ^- (unit lens-out)
=* loop $
?+ -.fec
~
++ on-watch
|= =path
^- (quip card:agent:gall _this)
?: ?=([%http-response *] path)
`this
(on-watch:def path)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card:agent:gall _this)
|^
?+ wire (on-agent:def wire sign)
[%import ~]
?> ?=(%poke-ack -.sign)
?> ?=(^ job.state)
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
[[200 ~] `(as-octt:mimes:html "\"Imported data\"")]
::
[%export ~]
?+ -.sign (on-agent:def wire sign)
%watch-ack
?~ p.sign
`this
?> ?=(^ job.state)
:_ this(job.state ~)
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
::
%tan
%- some
:- %json
%- wall:enjs:format
(turn (flop p.fec) |=(=tank ~(ram re tank)))
::
%txt
(some %json s+(crip p.fec))
::
%sag
%- some
[%mime p.fec (as-octs:mimes:html (jam q.fec))]
::
%sav
:: XX use +en:base64 or produce %mime a la %sag
::
%- some
:- %json
%- pairs:enjs:format
:~ file+s+(crip <`path`p.fec>)
data+s+(crip (en-base64:mimes:html q.fec))
==
::
%mor
=/ all `(list lens-out)`(murn p.fec |=(a=sole-effect loop(fec a)))
?~ all ~
~| [%multiple-effects all]
?> ?=(~ t.all)
(some i.all)
%fact
=^ cards this (take-export !<(* q.cage.sign))
:_ this :_ cards
?> ?=(^ job.state)
?> ?=(%export -.source.com.u.job.state)
[%pass /export %agent [our.bowl app.source.com.u.job.state] %leave ~]
==
::
?~ out
[~ this]
?> ?=(^ job.state)
:_ this(job.state ~)
:_ ~
:+ bone.u.job.state
%http-response
?- -.u.out
%json
(json-response:app (json-to-octs json.u.out))
[%sole ~]
?+ -.sign (on-agent:def wire sign)
%watch-ack
?> ?=(^ job.state)
?^ p.sign
:_ this(job.state ~)
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
:_ this :_ ~
:* %pass /sole
%agent [our.bowl %dojo]
%poke %lens-command !>
[eyre-id.u.job.state com.u.job.state]
==
::
%fact
?> ?=(%sole-effect p.cage.sign)
=^ cards this (take-sole-effect !<(sole-effect q.cage.sign))
[[[%pass /sole %agent [our.bowl %dojo] %leave ~] cards] this]
==
==
::
%mime
:* %start
:~ 200
['content-type' 'application/octet-stream']
++ take-export
|= data=*
^- (quip card:agent:gall _this)
?> ?=(^ job.state)
?> ?=(%export -.source.com.u.job.state)
=/ app-name=tape (trip app.source.com.u.job.state)
=/ output=@t (crip "/{app-name}/jam")
::
=/ jon=json
=/ =atom (jam data)
=/ =octs [(met 3 atom) atom]
=/ enc (en:base64 octs)
(pairs:enjs:format file+s+output data+s+enc ~)
::
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
(json-response:gen (json-to-octs jon))
::
++ take-sole-effect
|= fec=sole-effect
^- (quip card:agent:gall _this)
=/ out
|- ^- (unit lens-out)
=* loop $
?+ -.fec
~
::
%tan
%- some
:- %json
%- wall:enjs:format
(turn (flop p.fec) |=(=tank ~(ram re tank)))
::
%txt
(some %json s+(crip p.fec))
::
%sag
%- some
[%mime p.fec (as-octs:mimes:html (jam q.fec))]
::
%sav
:: XX use +en:base64 or produce %mime a la %sag
::
%- some
:- %json
%- pairs:enjs:format
:~ file+s+(crip <`path`p.fec>)
data+s+(crip (en-base64:mimes:html q.fec))
==
::
%mor
=/ all `(list lens-out)`(murn p.fec |=(a=sole-effect loop(fec a)))
?~ all ~
~| [%multiple-effects all]
?> ?=(~ t.all)
(some i.all)
==
::
?~ out
[~ this]
::
?> ?=(^ job.state)
:_ this(job.state ~)
%+ give-simple-payload:app eyre-id.u.job.state
?- -.u.out
%json
(json-response:gen (json-to-octs json.u.out))
::
%mime
=/ headers
:~ ['content-type' 'application/octet-stream']
?> ?=([@ @ ~] p.mime.u.out)
:- 'content-disposition'
^- @t
@ -150,90 +199,16 @@
'attachment; filename='
(rap 3 '"' i.p.mime.u.out '.' i.t.p.mime.u.out '"' ~)
==
(some q.mime.u.out)
%.y
[[200 headers] (some q.mime.u.out)]
==
==
--
::
++ diff-export
|= [=wire data=*]
^- (quip move _this)
::
?> ?=(^ job.state)
:: herb will do whatever we tell it to, so by convention have it write to an
:: app name based on the file name.
::
?> ?=(%export -.source.com.u.job.state)
=/ app-name=tape (trip app.source.com.u.job.state)
=/ output=@t (crip "/{app-name}/jam")
::
=/ jon=json
=/ =atom (jam data)
=/ =octs [(met 3 atom) atom]
=/ enc (en:base64 octs)
(pairs:enjs:format file+s+output data+s+enc ~)
::
:_ this(job.state ~)
:~ [bone.u.job.state %http-response (json-response:app (json-to-octs jon))]
[ost.bow %pull /export [our.bow app.source.com.u.job.state] ~]
==
::
++ quit
|= =wire
^- (quip move _this)
~& [%quit wire]
[~ this]
::
++ reap
|= [=wire saw=(unit tang)]
^- (quip move _this)
::
?: =([%export ~] wire)
[~ this]
::
?^ saw
[((slog u.saw) ~) this]
?> ?=(^ job.state)
:_ this
:~ [ost.bow %poke /sole [our.bow %dojo] %lens-command com.u.job.state]
:: XX move to +diff-sole-effect?
::
[ost.bow %pull /sole [our.bow %dojo] ~]
==
::
++ coup
|= [=wire saw=(unit tang)]
^- (quip move _this)
::
?: =([%import ~] wire)
?> ?=(^ job.state)
:_ this(job.state ~)
:_ ~
:* bone.u.job.state
%http-response
%start
[%200 ~]
[~ (as-octt:mimes:html "\"Imported data\"")]
%.y
==
::
?^ saw
[((slog u.saw) ~) this]
[~ this]
::
:: +poke-handle-http-cancel: received when a connection was killed
::
++ poke-handle-http-cancel
|= =inbound-request:eyre
^- (quip move _this)
:: the only long lived connections we keep state about are the stream ones.
::
[~ this]
::
++ poke-noun
|= a=*
^- (quip move _this)
~& poke+a
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-fail on-fail:def
--

231
pkg/arvo/app/link-listen-hook.hoon Normal file
View File

@ -0,0 +1,231 @@
:: link-listen-hook: get your friends' bookmarks
::
:: on-init, subscribes to all groups on this ship.
:: for every ship in a group, we subscribe to their link's local-pages
:: at the group path (through link-proxy-hook),
:: and forwards all entries into our link as submissions.
::
/- *link, group-store
/+ default-agent, verb
::
|%
+$ state-0
$: %0
~
::NOTE this means we could get away with just producing cards everywhere,
:: never producing new state outside of the agent interface core.
:: we opt to keep ^-(quip card _state) in place for most logic arms
:: because it doesn't cost much, results in unsurprising code, and
:: makes adding any state in the future easier.
==
::
+$ card card:agent:gall
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
:_ this
[watch-groups:do]~
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?: ?=([%groups ~] wire)
=^ cards state
(take-groups-sign:do sign)
[cards this]
?: ?=([%links @ ^] wire)
=^ cards state
(take-links-sign:do (slav %p i.t.wire) t.t.wire sign)
[cards this]
?: ?=([%forward ^] wire)
=^ cards state
(take-forward-sign:do t.wire sign)
[cards this]
~| [dap.bowl %weird-wire wire]
!!
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=([%g %done *] sign-arvo)
(on-arvo:def wire sign-arvo)
?~ error.sign-arvo [~ this]
=/ =tank leaf+"{(trip dap.bowl)}'s message went wrong!"
%- (slog tank tang.u.error.sign-arvo)
[~ this]
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--
::
::
|_ =bowl:gall
::
:: groups subscription
::
++ watch-groups
^- card
[%pass /groups %agent [our.bowl %group-store] %watch /all]
::
++ take-groups-sign
|= =sign:agent:gall
^- (quip card _state)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack /groups] !!)
%kick [[watch-groups]~ state]
::
%watch-ack
?~ p.sign [~ state]
=/ =tank
:- %leaf
"{(trip dap.bowl)} failed subscribe to groups. very wrong!"
%- (slog tank u.p.sign)
[~ state]
::
%fact
=* mark p.cage.sign
=* vase q.cage.sign
~& [dap.bowl %fact mark]
?+ mark ~|([dap.bowl %unexpected-mark mark] !!)
%group-initial (handle-group-initial !<(groups:group-store vase))
%group-update (handle-group-update !<(group-update:group-store vase))
==
==
::
++ handle-group-initial
|= =groups:group-store
^- (quip card _state)
=| cards=(list card)
=/ groups=(list [=path =group:group-store])
~(tap by groups)
|-
?~ groups [cards state]
=^ caz state
%- handle-group-update
[%add [group path]:i.groups]
$(cards (weld cards caz), groups t.groups)
::
++ handle-group-update
|= upd=group-update:group-store
^- (quip card _state)
:_ state
?+ -.upd ~
?(%path %add %remove)
=/ whos=(list ship) ~(tap in members.upd)
|- ^- (list card)
?~ whos ~
:: no need to subscribe to ourselves
::
?: =(our.bowl i.whos)
$(whos t.whos)
:_ $(whos t.whos)
%. [i.whos pax.upd]
?: ?=(%remove -.upd)
end-link-subscription
start-link-subscription
==
::
:: link subscriptions
::
++ start-link-subscription
|= [who=ship where=path]
^- card
:* %pass
[%links (scot %p who) where]
%agent
[who %link-proxy-hook]
%watch
[%local-pages where]
==
::
++ end-link-subscription
|= [who=ship where=path]
^- card
:* %pass
[%links (scot %p who) where]
%agent
[who %link-proxy-hook]
%leave
~
==
::
++ take-links-sign
|= [who=ship where=path =sign:agent:gall]
^- (quip card _state)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack /links who where] !!)
%kick [[(start-link-subscription who where)]~ state]
::
%watch-ack
?~ p.sign [~ state]
:: our subscription request got rejected for whatever reason,
:: (most likely difference in group membership,)
:: so we don't try again.
::TODO but now the only way to retry is to remove from group and re-add...
:: this is a problem because our and their group may not update
:: simultaneously...
[~ state]
::
%fact
=* mark p.cage.sign
=* vase q.cage.sign
?+ mark ~|([dap.bowl %unexpected-mark mark] !!)
%link-update (handle-link-update who where !<(update vase))
==
==
::
++ handle-link-update
|= [who=ship where=path =update]
^- (quip card _state)
?> ?=(%local-pages -.update)
?> =(src.bowl who)
:_ state
%+ turn pages.update
|= =page
^- card
:* %pass
[%forward (scot %p who) where]
%agent
[our.bowl %link-store]
%poke
%link-action
!>([%hear where src.bowl page])
==
::
++ take-forward-sign
|= [=wire =sign:agent:gall]
^- (quip card _state)
~| [%unexpected-sign on=[%forward wire] -.sign]
?> ?=(%poke-ack -.sign)
?~ p.sign [~ state]
=/ =tank
:- %leaf
;: weld
(trip dap.bowl)
" failed to save submission from "
(spud wire)
==
%- (slog tank u.p.sign)
[~ state]
--

231
pkg/arvo/app/link-proxy-hook.hoon Normal file
View File

@ -0,0 +1,231 @@
:: link-proxy-hook: make local pages available to foreign ships
::
:: this is a "proxy" style hook, relaying foreign subscriptions into local
:: stores if permission conditions are met.
:: the patterns herein should one day be generalized into a proxy-hook lib.
::
:: this adopts a very primitive view of groups-store as containing only
:: groups of interesting (rather than uninteresting) ships. it sets the
:: permission condition to be that ship must be in group matching the path
:: it's subscribing to.
:: we check this on-watch, but also subscribe to groups so that we can kick
:: subscriptions if needed (eg ship removed from group).
::
:: we deduplicate incoming subscriptions on the same path, ensuring we have
:: exactly one local subscription per unique incoming subscription path.
:: this comes at the cost of assuming that the store's initial response is
:: whatever's returned by the scry at that path, but perhaps that should
:: become part of the stores standard anyway.
::
/- *link, group-store
/+ default-agent, verb
|%
+$ state-0
$: %0
::TODO we use this to detect "first sub started" and "last sub left",
:: but can't we use [wex sup]:bowl for that?
active=(map path (set ship))
==
::
+$ card card:agent:gall
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %&) bowl)
::
++ on-init
^- (quip card _this)
:_ this
[watch-groups:do]~
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-watch
|= =path
^- (quip card _this)
:: the local ship should just use link-store directly
::TODO do we want to allow this anyway, to avoid client-side target checks?
::
?< (team:title [our src]:bowl)
?> (permitted:do src.bowl path)
=^ cards state
(start-proxy:do src.bowl path)
[cards this]
::
++ on-leave
|= =path
^- (quip card _this)
=^ cards state
(stop-proxy:do src.bowl path)
[cards this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?: ?=([%groups ~] wire)
=^ cards state
(take-groups-sign:do sign)
[cards this]
?: ?=([%proxy ^] wire)
=^ cards state
(handle-proxy-sign t.wire sign)
[cards this]
~| [dap.bowl %weird-wire wire]
!!
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
++ permitted
|= [who=ship =path]
^- ?
:: we only expose /local-pages, and only to ships in the relevant group
::
?. ?=([%local-pages ^] path) |
=; group
?& ?=(^ group)
(~(has in u.group) who)
==
.^ (unit group:group-store)
%gx
(scot %p our.bowl)
%group-store
(scot %da now.bowl)
(snoc t.path %noun)
==
::
:: groups subscription
::TODO largely copied from link-listen-hook. maybe make a store-listener lib?
::
++ watch-groups
^- card
[%pass /groups %agent [our.bowl %group-store] %watch /all]
::
++ take-groups-sign
|= =sign:agent:gall
^- (quip card _state)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack /groups] !!)
%kick [[watch-groups]~ state]
::
%watch-ack
?~ p.sign [~ state]
=/ =tank
:- %leaf
"{(trip dap.bowl)} failed subscribe to group store. very wrong!"
%- (slog tank u.p.sign)
[~ state]
::
%fact
=* mark p.cage.sign
=* vase q.cage.sign
~& [dap.bowl %fact mark]
?+ mark ~|([dap.bowl %unexpected-mark mark] !!)
%group-initial [~ state]
%group-update (handle-group-update !<(group-update:group-store vase))
==
==
::
++ handle-group-update
|= upd=group-update:group-store
^- (quip card _state)
:_ state
?. ?=(%remove -.upd) ~
=/ whos=(list ship) ~(tap in members.upd)
|- ^- (list card)
?~ whos ~
:: no need to remove to ourselves
::
?: =(our.bowl i.whos)
$(whos t.whos)
:_ $(whos t.whos)
::NOTE this depends kind of unfortunately on the fact that we only accept
:: subscriptions to /local-pages/* paths. it'd be more correct if we
:: "just" looked at all paths in the map, and found the matching ones.
(kick-proxy i.whos [%local-pages pax.upd])
::
:: proxy subscriptions
::
++ kick-proxy
|= [who=ship =path]
^- card
[%give %kick `path `who]
::
++ handle-proxy-sign
|= [=path =sign:agent:gall]
^- (quip card _state)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack path] !!)
%fact [[%give %fact `path cage.sign]~ state]
%kick [[(proxy-pass-link-store path %watch path)]~ state]
::
%watch-ack
?~ p.sign [~ state]
=/ =tank
:- %leaf
"{(trip dap.bowl)} failed subscribe to link-store. very wrong!"
%- (slog tank u.p.sign)
[~ state]
==
::
++ proxy-pass-link-store
|= [=path =task:agent:gall]
^- card
:* %pass
[%proxy path]
%agent
[our.bowl %link-store]
task
==
::
++ initial-response
|= =path
^- card
=/ initial=update
[%local-pages path .^(pages %gx path)]
[%give %fact ~ %link-update !>(initial)]
::
++ start-proxy
|= [who=ship =path]
^- (quip card _state)
:_ state(active (~(put ju active) path who))
:_ ~
:: if we already have a local subscription open,
::
?. =(~ (~(get ju active) path))
:: gather the initial response ourselves, and send that.
::
(initial-response path)
:: else, open a local subscription,
:: sending outward its initial response when we hear it.
::
(proxy-pass-link-store path %watch path)
::
++ stop-proxy
|= [who=ship =path]
^- (quip card _state)
=. active (~(del ju active) path who)
:_ state
:: if there are still subscriptions remaining, do nothing.
::
?. =(~ (~(get ju active) path)) ~
:: else, close the local subscription.
::
[(proxy-pass-link-store path %leave ~)]~
--

230
pkg/arvo/app/link-server-hook.hoon Normal file
View File

@ -0,0 +1,230 @@
:: link-server: accessing link-store via eyre
::
:: only accepts requests authenticated as the host ship.
::
:: GET requests:
:: /~link/local-pages/[some-path].json?p=0
:: our submissions on path, with optional pagination
::
:: POST requests:
:: /~link/add/[some-path]
:: send {title url} json, will save link at path
::
/+ *link, *server, default-agent, verb
::
|%
+$ state-0
$: %0
~
::NOTE this means we could get away with just producing cards everywhere,
:: never producing new state outside of the agent interface core.
:: we opt to keep ^-(quip card _state) in place for most logic arms
:: because it doesn't cost much, results in unsurprising code, and
:: makes adding any state in the future easier.
==
::
+$ card card:agent:gall
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
:_ this
[start-serving:do]~
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-watch
|= =path
^- (quip card _this)
?: ?=([%http-response *] path)
[~ this]
(on-watch:def path)
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?. ?=(%handle-http-request mark)
(on-poke:def mark vase)
:_ this
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
(handle-http-request:do eyre-id inbound-request)
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?. ?=(%bound +<.sign-arvo)
(on-arvo:def wire sign-arvo)
[~ this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?. ?=(%poke-ack -.sign)
(on-agent:def wire sign)
?~ p.sign [~ this]
=/ =tank
leaf+"{(trip dap.bowl)} failed writing to %link-store"
%- (slog tank u.p.sign)
[~ this]
::
++ on-peek on-peek:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
::
++ start-serving
^- card
[%pass / %arvo %e %connect [~ /'~link'] dap.bowl]
::
++ do-action
|= =action
^- card
[%pass / %agent [our.bowl %link-store] %poke %link-action !>(action)]
::
++ do-add
|= [=path title=@t =url]
^- card
(do-action %add path title url)
::
++ handle-http-request
|= [eyre-id=@ta =inbound-request:eyre]
^- (list card)
::NOTE we don't use +require-authorization because it's too restrictive
:: on the flow we want here.
::
?. ?& authenticated.inbound-request
=(src.bowl our.bowl)
==
::TODO `*octs -> ~ everywhere once no-data bug is fixed
(give-simple-payload:app eyre-id [[403 ~] `*octs])
:: request-line: parsed url + params
::
=/ =request-line
%- parse-request-line
url.request.inbound-request
=* req-head header-list.request.inbound-request
=- ::TODO =; [cards=(list card) =simple-payload:http]
%+ weld cards
(give-simple-payload:app eyre-id simple-payload)
^- [cards=(list card) =simple-payload:http]
?+ method.request.inbound-request [~ not-found:gen]
%'OPTIONS'
[~ (include-cors-headers req-head [[200 ~] `*octs])]
::
%'GET'
[~ (handle-get req-head request-line)]
::
%'POST'
(handle-post req-head request-line body.request.inbound-request)
==
::
++ handle-post
|= [request-headers=header-list:http =request-line body=(unit octs)]
^- [(list card) simple-payload:http]
=- ::TODO =; [success=? cards=(list card)]
:- cards
%+ include-cors-headers
request-headers
::TODO it would be more correct to wait for the %poke-ack instead of
:: sending this response right away... but link-store pokes can't
:: actually fail right now, so it's fine.
[[?:(success 200 400) ~] `*octs]
^- [success=? cards=(list card)]
?~ body [| ~]
?+ request-line [| ~]
[[~ [%'~link' %add ^]] ~]
^- [? (list card)]
=/ jon=(unit json) (de-json:html q.u.body)
?~ jon [| ~]
=/ page=(unit [title=@t =url])
%. u.jon
(ot title+so url+so ~):dejs-soft:format
?~ page [| ~]
[& [(do-add t.t.site.request-line [title url]:u.page) ~]]
==
::
++ handle-get
|= [request-headers=header-list:http =request-line]
%+ include-cors-headers
request-headers
^- simple-payload:http
:: args: map of params
:: p: pagination index
::
=/ args
%- ~(gas by *(map @t @t))
args.request-line
=/ p=(unit @ud)
%+ biff (~(get by args) 'p')
(curr rush dim:ag)
?+ request-line not-found:gen
::TODO expose submissions, other data
:: local links by recency as json
::
[[[~ %json] [%'~link' %local-pages ^]] *]
%- json-response:gen
%- json-to-octs ::TODO include in +json-response:gen
^- json
:- %a
%+ turn
`pages`(get-pages t.t.site.request-line p)
`$-(page json)`page:en-json
==
::
++ include-cors-headers
|= [request-headers=header-list:http =simple-payload:http]
^+ simple-payload
=* out-heads headers.response-header.simple-payload
=; =header-list:http
|-
?~ header-list simple-payload
=* new-head i.header-list
=. out-heads
(set-header:http key.new-head value.new-head out-heads)
$(header-list t.header-list)
=/ origin=@t
=/ headers=(map @t @t)
(~(gas by *(map @t @t)) request-headers)
(~(gut by headers) 'origin' '*')
:~ 'Access-Control-Allow-Origin'^origin
'Access-Control-Allow-Credentials'^'true'
'Access-Control-Request-Method'^'OPTIONS, GET, POST'
'Access-Control-Allow-Methods'^'OPTIONS, GET, POST'
'Access-Control-Allow-Headers'^'content-type'
==
::
++ page-size 25
++ get-pages
|= [=path p=(unit @ud)]
^- pages
=; =pages
?~ p pages
%+ scag page-size
%+ slag (mul u.p page-size)
pages
.^ pages
%gx
(scot %p our.bowl)
%link-store
(scot %da now.bowl)
%local-pages
(snoc path %noun)
==
--

172
pkg/arvo/app/link-store.hoon Normal file
View File

@ -0,0 +1,172 @@
:: link: social bookmarking
::
:: the paths under which links are submitted are generally expected to
:: correspond to existing group paths. for strictly-local collections of
:: links, arbitrary paths are probably fair game, but could trip up
:: primitive ui implementations.
::
:: scry and subscription paths:
::
:: /local-pages/[some-group] all pages we saved by recency
:: /submissions/[some-group] all submissions by recency
::
/+ *link, default-agent, verb
::
|%
+$ state-0
$: %0
by-group=(map path links)
by-site=(map site (list [path submission]))
==
::
+$ links
$: ::NOTE all lists by recency
=submissions
ours=pages
==
::
+$ card card:agent:gall
--
::
=| state-0
=* state -
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title [our src]:bowl) ::TODO /lib/store
=^ cards state
?+ mark (on-poke:def mark vase)
::TODO move json conversion into mark once mark performance improves
%json (do-action:do (action:de-json !<(json vase)))
%link-action (do-action:do !<(action vase))
==
[cards this]
::
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%y ?(%local-pages %submissions) ~]
``noun+!>(~(key by by-group))
::
[%x %local-pages ^]
``noun+!>((get-local-pages:do t.t.path))
::
[%x %submissions ^]
``noun+!>((get-submissions:do t.t.path))
==
::
++ on-watch
|= =path
^- (quip card _this)
?> (team:title [our src]:bowl) ::TODO /lib/store
:_ this
|^ ?+ path (on-watch:def path)
[%local-pages ^]
%+ give %link-update
[%local-pages t.path (get-local-pages:do t.path)]
::
[%submissions ^]
%+ give %link-update
[%submissions t.path (get-submissions:do t.path)]
==
::
++ give
|* [=mark =noun]
^- (list card)
[%give %fact ~ mark !>(noun)]~
--
::
++ on-leave on-leave:def
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
::
:: writing
::
++ do-action
|= =action
^- (quip card _state)
?- -.action
%add (add-page +.action)
%hear (hear-submission +.action)
==
:: +add-page: save a page ourselves
::
++ add-page
|= [=path title=@t =url]
^- (quip card _state)
?< =(~ path)
:: add page to group ours
::
=/ =links (~(gut by by-group) path *links)
=/ =page [title url now.bowl]
=. ours.links [page ours.links]
=. by-group (~(put by by-group) path links)
:: do generic submission logic
::
=^ cards state
(hear-submission path [our.bowl page])
:: send updates to subscribers
::
:_ state
:_ cards
:+ %give %fact
:+ `[%local-pages path]
%link-update
!>([%local-pages path [page]~])
:: +hear-submission: record page someone else saved
::
++ hear-submission
|= [=path =submission]
^- (quip card _state)
?< =(~ path)
:: add link to group submissions
::
=/ =links (~(gut by by-group) path *links)
=. submissions.links [submission submissions.links]
=. by-group (~(put by by-group) path links)
:: add submission to global sites
::
=/ =site (site-from-url url.submission)
=. by-site (~(add ja by-site) site [path submission])
:: send updates to subscribers
::
:_ state
:_ ~
:+ %give %fact
:+ `[%submissions path]
%link-update
!>([%submissions path [submission]~])
::
:: reading
::
++ get-local-pages
|= =path
^- pages
ours:(~(gut by by-group) path *links)
::
++ get-submissions
|= =path
^- submissions
submissions:(~(gut by by-group) path *links)
--

51
pkg/arvo/app/modulo.hoon
View File

@ -1,51 +0,0 @@
/+ *server
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%connect wire binding:eyre term]
[%disconnect wire binding:eyre]
[%http-response =http-event:http]
==
::
--
::
|_ [bow=bowl:gall ~]
::
++ this .
::
++ prep
|= old=(unit *)
^- (quip move _this)
?~ old
:_ this
[ost.bow %connect / [~ /'~modulo'] %modulo]~
[~ this]
::
:: alerts us that we were bound. we need this because the vane calls back.
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ session-js
^- octs
%- as-octt:mimes:html
;: weld
"window.ship = '{+:(scow %p our.bow)}';"
"window.urb = new Channel();"
==
::
:: +poke-handle-http-request: received on a new connection established
::
++ poke-handle-http-request
%- (require-authorization:app ost.bow move this)
|= =inbound-request:eyre
^- (quip move _this)
[[ost.bow %http-response (js-response:app session-js)]~ this]
::
--

275
pkg/arvo/app/permission-group-hook.hoon
View File

@ -1,121 +1,164 @@
:: permission-group-hook:
:: mirror the ships in some group to some set of permission paths
:: permission-group-hook: groups into permissions
::
:: mirror the ships in specified groups to specified permission paths
::
/- *group-store, *permission-group-hook
/+ *permission-json
/+ *permission-json, default-agent, verb
::
|%
+$ move [bone card]
::
+$ card
$% [%diff [%group-update group-update]]
[%poke wire dock poke]
[%pull wire dock ~]
[%peer wire dock path]
==
::
+$ state
$% [%0 state-zero]
$% [%0 state-0]
==
::
+$ group-path path
::
+$ permission-path path
::
+$ state-zero
+$ state-0
$: relation=(map group-path (set permission-path))
==
::
+$ poke
$% [%permission-action permission-action]
==
::
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall state]
=| state-0
=* state -
::
++ this .
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?+ mark (on-poke:def mark vase)
%json
:: only accept json from the host team
::
?> (team:title our.bowl src.bowl)
=^ cards state
%- handle-action:do
%- json-to-perm-group-hook-action
!<(json vase)
[cards this]
::
%permission-group-hook-action
=^ cards state
%- handle-action:do
!<(permission-group-hook-action vase)
[cards this]
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?. ?=([%group *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack ~|([dap.bowl %unexpected-poke-ack wire] !!)
::
%kick
:_ this
[(watch-group:do t.wire)]~
::
%watch-ack
?~ p.sign [~ this]
=/ =tank leaf+"{(trip dap.bowl)} failed subscribe at {(spud wire)}"
%- (slog tank u.p.sign)
[~ this(relation (~(del by relation) t.wire))]
::
%fact
?. ?=(%group-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
%- handle-group-update:do
!<(group-update q.cage.sign)
[cards this]
==
::
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ poke-json
|= =json
^- (quip move _this)
?> (team:title our.bol src.bol)
(poke-permission-group-hook-action (json-to-perm-group-hook-action json))
::
++ poke-permission-group-hook-action
|_ =bowl:gall
++ handle-action
|= act=permission-group-hook-action
^- (quip move _this)
?> (team:title our.bol src.bol)
^- (quip card _state)
?> (team:title our.bowl src.bowl)
?- -.act
%associate (handle-associate group.act permissions.act)
%dissociate (handle-dissociate group.act permissions.act)
==
::
++ handle-associate
|= [group=path permission-paths=(set [path kind])]
^- (quip move _this)
|= [group=group-path associate=(set [permission-path kind])]
^- (quip card _state)
=/ perms (~(get by relation) group)
:: if relation does not exist, create it and subscribe.
=/ permissions=(set path)
%- ~(run in permission-paths)
|=([=path =kind] path)
=/ perm-paths=(set path)
(~(run in associate) head)
?~ perms
=/ group-path [%group group]
:_ this(relation (~(put by relation) group permissions))
[ost.bol %peer group-path [our.bol %group-store] group-path]~
:_ state(relation (~(put by relation) group perm-paths))
(snoc (recreate-permissions perm-paths associate) (watch-group group))
::
=. u.perms (~(uni in u.perms) permissions)
:_ this(relation (~(put by relation) group u.perms))
=/ grp (group-scry group)
=. u.perms (~(uni in u.perms) perm-paths)
:_ state(relation (~(put by relation) group u.perms))
%+ weld
%+ turn ~(tap in permissions)
|=(=path (permission-poke path [%delete path]))
%+ turn ~(tap in permission-paths)
|= [=path =kind]
=/ pem *permission
=. kind.pem kind
(permission-poke path [%create path pem])
(recreate-permissions perm-paths associate)
?~ grp
~
(add-members group u.grp u.perms)
::
++ handle-dissociate
|= [group=path permissions=(set path)]
^- (quip move _this)
=/ perms (~(get by relation) group)
?~ perms
[~ this]
|= [group=path remove=(set permission-path)]
^- (quip card _state)
=/ perms=(set permission-path)
(fall (~(get by relation) group) *(set permission-path))
?: =(~ perms)
[~ state]
:: remove what we must. if that means we are no longer mirroring this group
:: into any permissions, remove it from state entirely.
::
=. permissions (~(del in u.perms) permissions)
?~ permissions
:_ this(relation (~(del by relation) group))
[(group-pull [%group group])]~
[~ this(relation (~(put by relation) group permissions))]
=. perms (~(del in perms) remove)
?~ perms
:_ state(relation (~(del by relation) group))
[(group-pull group)]~
[~ state(relation (~(put by relation) group perms))]
::
++ diff-group-update
|= [wir=wire diff=group-update]
^- (quip move _this)
++ handle-group-update
|= diff=group-update
^- (quip card _state)
?- -.diff
%keys
[~ this]
%bundle
[~ this]
%keys [~ state]
%bundle [~ state]
::
%path
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%add path members.diff])
=/ perms (~(got by relation) pax.diff)
:_ state
(add-members pax.diff members.diff perms)
::
%add
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
[~ state]
:_ state
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%add path members.diff])
@ -124,8 +167,8 @@
:: set all permissions paths
=/ perms (~(get by relation) pax.diff)
?~ perms
[~ this]
:_ this
[~ state]
:_ state
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%remove path members.diff])
@ -134,38 +177,60 @@
:: pull subscriptions
=/ perms (~(get by relation) pax.diff)
?~ perms
:_ this(relation (~(del by relation) pax.diff))
[(group-pull [%group pax.diff])]~
:_ this(relation (~(del by relation) pax.diff))
:- (group-pull [%group pax.diff])
:_ state(relation (~(del by relation) pax.diff))
[(group-pull pax.diff)]~
:_ state(relation (~(del by relation) pax.diff))
:- (group-pull pax.diff)
%+ turn ~(tap in u.perms)
|= =path
(permission-poke path [%delete path])
==
::
++ quit
|= wir=wire
^- (quip move _this)
:: no-op
[~ this]
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
=. wir ?^(wir t.wir ~)
~& %reap-permission-group-hook
[((slog u.saw) ~) this(relation (~(del by relation) wir))]
::
++ permission-poke
|= [pax=path action=permission-action]
^- move
[ost.bol %poke pax [our.bol %permission-store] [%permission-action action]]
|= [=wire action=permission-action]
^- card
:* %pass
[%write wire]
%agent
[our.bowl %permission-store]
%poke
[%permission-action !>(action)]
==
::
++ group-scry
|= pax=path
^- (unit group)
.^((unit group) %gx ;:(weld /=group-store/(scot %da now.bowl) pax /noun))
::
++ add-members
|= [pax=path mem=(set ship) perms=(set path)]
^- (list card)
%+ turn ~(tap in perms)
|= =path
(permission-poke path [%add path mem])
::
++ recreate-permissions
|= [perm-paths=(set path) associate=(set [permission-path kind])]
^- (list card)
%+ weld
%+ turn ~(tap in perm-paths)
|= =path
(permission-poke path [%delete path])
%+ turn ~(tap in associate)
|= [=path =kind]
=| pem=permission
=. kind.pem kind
(permission-poke path [%create path pem])
::
::
++ watch-group
|= =group-path
^- card
=. group-path [%group group-path]
[%pass group-path %agent [our.bowl %group-store] %watch group-path]
::
++ group-pull
|= =path
^- move
[ost.bol %pull [%group path] [our.bol %group-store] ~]
::
|= =group-path
^- card
[%pass [%group group-path] %agent [our.bowl %group-store] %leave ~]
--

432
pkg/arvo/app/permission-hook.hoon
View File

@ -1,281 +1,329 @@
:: permission-hook: allows mirroring permissions between local and foreign
:: ships. access control to an owned permission path is specified by the
:: access-control path.
:: permission-hook: mirror remote permissions
::
:: allows mirroring permissions between local and foreign ships.
:: local permission path are exposed according to the permssion paths
:: configured for them as `access-control`.
::
/- *permission-hook
/+ *permission-json
/+ *permission-json, default-agent
::
|%
+$ move [bone card]
::
+$ card
$% [%diff [%permission-update permission-update]]
[%quit ~]
[%poke wire dock [%permission-action permission-action]]
[%pull wire dock ~]
[%peer wire dock path]
==
::
+$ state
$% [%0 state-zero]
$% [%0 state-0]
==
::
+$ owner-access [ship=ship access-control=path]
::
+$ state-zero
+$ state-0
$: synced=(map path owner-access)
access-control=(map path (set path))
boned=(map wire (list bone))
==
::
+$ card card:agent:gall
--
::
|_ [bol=bowl:gall state]
=| state-0
=* state -
::
++ this .
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?+ mark (on-poke:def mark vase)
%permission-hook-action
=^ cards state
(handle-permission-hook-action:do !<(permission-hook-action vase))
[cards this]
==
::
++ on-watch
|= =path
^- (quip card _this)
?. ?=([%permission ^] path) (on-watch:def path)
=^ cards state
(handle-watch-permission:do t.path)
[cards this]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?- -.sign
%poke-ack (on-agent:def wire sign)
::
%fact
?. ?=(%permission-update p.cage.sign)
(on-agent:def wire sign)
=^ cards state
(handle-permission-update:do wire !<(permission-update q.cage.sign))
[cards this]
::
%watch-ack
?~ p.sign [~ this]
?> ?=(^ wire)
:_ this(synced (~(del by synced) t.wire))
::NOTE we could've gotten rejected for permission reasons, so we don't
:: try to resubscribe automatically.
%. ~
%- slog
:* leaf+"permission-hook failed subscribe on {(spud t.wire)}"
leaf+"stack trace:"
u.p.sign
==
::
%kick
?> ?=([* ^] wire)
:: if we're not actively using it, we can safely ignore the %kick.
::
?. (~(has by synced) t.wire)
[~ this]
:: otherwise, resubscribe.
::
=/ =owner-access (~(got by synced) t.wire)
:_ this
[%pass wire %agent [ship.owner-access %permission-hook] %watch wire]~
==
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
++ prep
|= old=(unit state)
^- (quip move _this)
[~ ?~(old this this(+<+ u.old))]
::
++ poke-permission-hook-action
|_ =bowl:gall
++ handle-permission-hook-action
|= act=permission-hook-action
^- (quip move _this)
^- (quip card _state)
?- -.act
%add-owned
?> (team:title our.bol src.bol)
?> (team:title our.bowl src.bowl)
?: (~(has by synced) owned.act)
[~ this]
=. synced (~(put by synced) owned.act [our.bol access.act])
=/ access-paths
?. (~(has by access-control) access.act)
[owned.act ~ ~]
(~(put in (~(got by access-control) access.act)) owned.act)
[~ state]
=. synced (~(put by synced) owned.act [our.bowl access.act])
=. access-control
(~(put by access-control) access.act access-paths)
(~(put ju access-control) access.act owned.act)
=/ perm-path [%permission owned.act]
:_ (track-bone perm-path)
[ost.bol %peer perm-path [our.bol %permission-store] perm-path]~
:_ state
[%pass perm-path %agent [our.bowl %permission-store] %watch perm-path]~
::
%add-synced
?> (team:title our.bol src.bol)
?> (team:title our.bowl src.bowl)
?: (~(has by synced) path.act)
[~ this]
[~ state]
=. synced (~(put by synced) path.act [ship.act ~])
=/ perm-path [%permission path.act]
:_ (track-bone perm-path)
[ost.bol %peer perm-path [ship.act %permission-hook] perm-path]~
:_ state
[%pass perm-path %agent [ship.act %permission-hook] %watch perm-path]~
::
%remove
=/ owner-access=(unit owner-access) (~(get by synced) path.act)
=/ owner-access=(unit owner-access)
(~(get by synced) path.act)
?~ owner-access
[~ this]
?: &(=(ship.u.owner-access our.bol) (team:title our.bol src.bol))
:: delete one of our.bol own paths
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
::
access-control
(~(del by access-control) access-control.u.owner-access)
==
%- zing
:~ (pull-wire [%permission path.act])
^- (list move)
%+ turn (prey:pubsub:userlib [%permission path.act] bol)
|= [=bone *]
[bone %quit ~]
==
?. |(=(ship.u.owner-access src.bol) (team:title our.bol src.bol))
:: if neither ship = source or source = us, do nothing
[~ this]
:: delete a foreign ship's path
:_ %_ this
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
[~ state]
:: if we own it, and it's us asking,
::
?: ?& =(ship.u.owner-access our.bowl)
(team:title our.bowl src.bowl)
==
(pull-wire [%permission path.act])
:: delete the permission path and its subscriptions from this hook.
::
:- :- [%give %kick `[%permission path.act] ~]
(leave-permission path.act)
%_ state
synced (~(del by synced) path.act)
::
access-control
(~(del by access-control) access-control.u.owner-access)
==
:: else, if either source = ship or source = us,
::
?: |(=(ship.u.owner-access src.bowl) (team:title our.bowl src.bowl))
:: delete a foreign ship's path.
::
:- (leave-permission path.act)
%_ state
synced (~(del by synced) path.act)
boned (~(del by boned) [%permission path.act])
==
:: else, ignore action entirely.
::
[~ state]
==
::
++ peer-permission
|= pax=path
^- (quip move _this)
?> ?=([* ^] pax)
=/ =owner-access (~(got by synced) pax)
?> =(our.bol ship.owner-access)
++ handle-watch-permission
|= =path
^- (quip card _state)
=/ =owner-access (~(got by synced) path)
?> =(our.bowl ship.owner-access)
:: scry permissions to check if subscriber is allowed
?> (permitted-scry (scot %p src.bol) access-control.owner-access)
=/ pem (permission-scry pax)
:_ this
[ost.bol %diff %permission-update [%create pax pem]]~
::
?> (permitted src.bowl access-control.owner-access)
=/ pem (permission-scry path)
:_ state
[%give %fact ~ %permission-update !>([%create path pem])]~
::
++ diff-permission-update
|= [wir=wire diff=permission-update]
^- (quip move _this)
?: (team:title our.bol src.bol)
++ handle-permission-update
|= [=wire diff=permission-update]
^- (quip card _state)
?: (team:title our.bowl src.bowl)
(handle-local diff)
(handle-foreign diff)
::
++ handle-local
|= diff=permission-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%create [~ this]
%add (change-local-permission [%add path.diff who.diff])
%remove (change-local-permission [%remove path.diff who.diff])
%create [~ state]
%add (change-local-permission %add [path who]:diff)
%remove (change-local-permission %remove [path who]:diff)
::
%delete
?. (~(has by synced) path.diff)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[ost.bol %pull [%permission path.diff] [our.bol %permission-store] ~]~
[~ state]
:_ state(synced (~(del by synced) path.diff))
:_ ~
:* %pass
[%permission path.diff]
%agent
[our.bowl %permission-store]
[%leave ~]
==
==
::
++ change-local-permission
|= [kind=?(%add %remove) pax=path who=(set ship)]
^- (quip move _this)
:_ this
%+ weld
?- kind
%add (update-subscribers [%permission pax] [%add pax who])
%remove (update-subscribers [%permission pax] [%remove pax who])
==
^- (quip card _state)
:_ state
:- ?- kind
%add (update-subscribers [%permission pax] [%add pax who])
%remove (update-subscribers [%permission pax] [%remove pax who])
==
=/ access-paths=(unit (set path)) (~(get by access-control) pax)
:: check if this path changes the access permissions for other paths
?~ access-paths
~
?~ access-paths ~
(quit-subscriptions kind pax who u.access-paths)
::
++ handle-foreign
|= diff=permission-update
^- (quip move _this)
^- (quip card _state)
?- -.diff
%create (change-foreign-permission path.diff diff)
%add (change-foreign-permission path.diff diff)
%remove (change-foreign-permission path.diff diff)
?(%create %add %remove)
(change-foreign-permission path.diff diff)
::
%delete
?> ?=([* ^] path.diff)
=/ owner-access=(unit owner-access) (~(get by synced) path.diff)
=/ owner-access=(unit owner-access)
(~(get by synced) path.diff)
?~ owner-access
[~ this]
?. =(ship.u.owner-access src.bol)
[~ this]
:_ this(synced (~(del by synced) path.diff))
[~ state]
?. =(ship.u.owner-access src.bowl)
[~ state]
:_ state(synced (~(del by synced) path.diff))
:~ (permission-poke diff)
[ost.bol %pull [%permission path.diff] [src.bol %permission-hook] ~]
::
:* %pass
[%permission path.diff]
%agent
[src.bowl %permission-hook]
[%leave ~]
==
==
==
::
++ change-foreign-permission
|= [pax=path diff=permission-update]
^- (quip move _this)
?> ?=([* ^] pax)
=/ owner-access=(unit owner-access) (~(get by synced) pax)
:_ this
|= [=path diff=permission-update]
^- (quip card _state)
?> ?=([* ^] path)
=/ owner-access=(unit owner-access)
(~(get by synced) path)
:_ state
?~ owner-access ~
?. =(src.bol ship.u.owner-access) ~
?. =(src.bowl ship.u.owner-access) ~
[(permission-poke diff)]~
::
++ quit-subscriptions
|= [kind=?(%add %remove) pax=path who=(set ship) access-paths=(set path)]
^- (list move)
=/ perm (permission-scry pax)
?. ?|
?&(=(kind.perm %black) =(kind %add))
?&(=(kind.perm %white) =(kind %remove))
|= $: kind=?(%add %remove)
perm-path=path
who=(set ship)
access-paths=(set path)
==
:: if allow, do nothing
~
=/ sup
%- ~(gas by *(map [ship path] bone))
%+ turn ~(tap by sup.bol)
|=([=bone anchor=[ship path]] [anchor bone])
:: if ban, iterate through
:: all ships that have been banned
:: and all affected paths that have had their permissions changed
:: then quit their subscriptions
^- (list card)
=/ perm (permission-scry perm-path)
:: if the change resolves to "allow",
::
?. ?| ?&(=(%black kind.perm) =(%add kind))
?&(=(%white kind.perm) =(%remove kind))
==
:: do nothing.
~
:: else, it resolves to "deny"/"ban".
:: kick subscriptions for all ships, at all affected paths.
::
%- zing
%+ turn ~(tap in who)
|= check-ship=ship
^- (list move)
%+ murn ~(tap in access-paths)
^- (list card)
%+ turn ~(tap in access-paths)
|= access-path=path
^- (unit move)
=/ bne (~(get by sup) [check-ship [%permission access-path]])
?~(bne ~ `[u.bne %quit ~])
::
++ quit
|= wir=wire
^- (quip move _this)
~& permission-hook-quit+wir
?> ?=([* ^] wir)
?. (~(has by synced) t.wir)
:: no-op
[~ this]
=/ =owner-access (~(got by synced) t.wir)
~& %permission-hook-resubscribe
:_ (track-bone wir)
[ost.bol %peer wir [ship.owner-access %permission-hook] wir]~
::
++ reap
|= [wir=wire saw=(unit tang)]
^- (quip move _this)
?~ saw
[~ this]
?> ?=(^ wir)
:_ this(synced (~(del by synced) t.wir))
%. ~
%- slog
:* leaf+"permission-hook failed subscribe on {(spud t.wir)}"
leaf+"stack trace:"
u.saw
==
[%give %kick `[%permission access-path] `check-ship]
::
++ permission-scry
|= pax=path
^- permission
=. pax ;:(weld /=permission-store/(scot %da now.bol)/permission pax /noun)
=. pax ;:(weld /=permission-store/(scot %da now.bowl)/permission pax /noun)
(need .^((unit permission) %gx pax))
::
++ permitted-scry
|= pax=path
^- ?
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
++ permitted
|= [who=ship =path]
.^ ?
%gx
(scot %p our.bowl)
%permission-store
(scot %da now.bowl)
%permitted
(scot %p src.bowl)
(snoc path %noun)
==
::
++ permission-poke
|= act=permission-action
^- move
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
^- card
:* %pass
/permission-action
%agent
[our.bowl %permission-store]
%poke
%permission-action
!>(act)
==
::
++ update-subscribers
|= [pax=path upd=permission-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %permission-update upd]
|= [=path upd=permission-update]
^- card
[%give %fact `path %permission-update !>(upd)]
::
++ track-bone
|= wir=wire
^+ this
=/ bnd (~(get by boned) wir)
?^ bnd
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
this(boned (~(put by boned) wir [ost.bol]~))
::
++ pull-wire
|= pax=path
^- (list move)
?> ?=([* ^] pax)
=/ bnd (~(get by boned) pax)
?~ bnd ~
=/ owner-access=(unit owner-access) (~(get by synced) t.pax)
++ leave-permission
|= =path
^- (list card)
=/ owner-access=(unit owner-access)
(~(get by synced) path)
?~ owner-access ~
%+ turn u.bnd
|= =bone
?: =(ship.u.owner-access our.bol)
[bone %pull pax [our.bol %permission-store] ~]
[bone %pull pax [ship.u.owner-access %permission-hook] ~]
::
:_ ~
=/ perm-path [%permission path]
?: =(ship.u.owner-access our.bowl)
[%pass perm-path %agent [our.bowl %permission-store] %leave ~]
[%pass perm-path %agent [ship.u.owner-access %permission-hook] %leave ~]
--

195
pkg/arvo/app/permission-store.hoon
View File

@ -1,79 +1,95 @@
:: permission-store: data store for keeping track of permissions
:: permissions are white lists or black lists of ships
:: permission-store: track black- and whitelists of ships
::
/- *permission-store
/+ default-agent
::
|%
+$ move [bone [%diff diff]]
+$ card card:agent:gall
::
+$ diff
$% [%permission-initial =permission-map]
[%permission-update =permission-update]
+$ versioned-state
$% state-zero
==
::
+$ state
$: permissions=permission-map
+$ state-zero
$: %0
permissions=permission-map
==
--
=| state-zero
=* state -
^- agent:gall
=<
|_ =bowl:gall
+* this .
permission-core +>
pc ~(. permission-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?: ?=(%permission-action mark)
(poke-permission-action:pc !<(permission-action vase))
(on-poke:def mark 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 %permission-initial !>(permissions))
[%updates ~] ~
[%permission @ *]
=/ =vase !>([%create t.path (~(got by permissions) t.path)])
(give %permission-update vase)
==
[cards this]
::
++ give
|= =cage
^- (list card)
[%give %fact ~ cage]~
--
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %keys ~] ``noun+!>(~(key by permissions))
[%x %permission *]
?~ t.t.path ~
``noun+!>((~(get by permissions) t.t.path))
::
[%x %permitted @ *]
?~ t.t.t.path ~
=/ pem (~(get by permissions) t.t.t.path)
?~ pem ~
=/ who (slav %p i.t.t.path)
=/ has (~(has in who.u.pem) who)
``noun+!>(?-(kind.u.pem %black !has, %white has))
==
++ on-agent on-agent:def
++ on-arvo on-arvo:def
++ on-fail on-fail:def
--
::
|_ [bol=bowl:gall %v0 state]
::
++ this .
::
:: gall interface
::
++ peer-all
|= =path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
:_ this
[ost.bol %diff %permission-initial permissions]~
::
++ peer-updates
|= =path
^- (quip move _this)
?> (team:title our.bol src.bol)
:: we now proxy all events to this path
[~ this]
::
++ peer-permission
|= =path
^- (quip move _this)
?~ path !!
?> (team:title our.bol src.bol)
?> (~(has by permissions) path)
:_ this
[ost.bol %diff %permission-update [%create path (~(got by permissions) path)]]~
::
++ peek-x-keys
|= pax=path
^- (unit (unit [%noun (set path)]))
[~ ~ %noun ~(key by permissions)]
::
++ peek-x-permission
|= =path
^- (unit (unit [%noun (unit permission)]))
?~ path
~
[~ ~ %noun (~(get by permissions) path)]
::
++ peek-x-permitted
|= =path
^- (unit (unit [%noun ?]))
?~ path
~
=/ pem (~(get by permissions) t.path)
?~ pem
~
=/ who (slav %p i.path)
=/ has (~(has in who.u.pem) who)
:^ ~ ~ %noun
?-(kind.u.pem %black !has, %white has)
|_ bol=bowl:gall
::
++ poke-permission-action
|= action=permission-action
^- (quip move _this)
^- (quip card _state)
?> (team:title our.bol src.bol)
?- -.action
%add (handle-add action)
@ -86,99 +102,96 @@
::
++ handle-add
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%add -.act)
?~ path.act
[~ this]
[~ state]
:: TODO: calculate diff
:: =+ new=(~(dif in who.what.action) who.u.pem)
:: ?~(new ~ `what.action(who new))
?. (~(has by permissions) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
=/ perm (~(got by permissions) path.act)
=. who.perm (~(uni in who.perm) who.act)
this(permissions (~(put by permissions) path.act perm))
state(permissions (~(put by permissions) path.act perm))
::
++ handle-remove
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%remove -.act)
?~ path.act
[~ this]
[~ state]
?. (~(has by permissions) path.act)
[~ this]
[~ state]
=/ perm (~(got by permissions) path.act)
=. who.perm (~(dif in who.perm) who.act)
:: TODO: calculate diff
:: =+ new=(~(int in who.what.action) who.u.pem)
:: ?~(new ~ `what.action(who new))
:- (send-diff path.act act)
this(permissions (~(put by permissions) path.act perm))
state(permissions (~(put by permissions) path.act perm))
::
++ handle-create
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%create -.act)
?~ path.act
[~ this]
[~ state]
?: (~(has by permissions) path.act)
[~ this]
[~ state]
:: TODO: calculate diff
:- (send-diff path.act act)
this(permissions (~(put by permissions) path.act permission.act))
state(permissions (~(put by permissions) path.act permission.act))
::
++ handle-delete
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%delete -.act)
?~ path.act
[~ this]
[~ state]
?. (~(has by permissions) path.act)
[~ this]
[~ state]
:- (send-diff path.act act)
this(permissions (~(del by permissions) path.act))
state(permissions (~(del by permissions) path.act))
::
++ handle-allow
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%allow -.act)
?~ path.act
[~ this]
[~ state]
=/ perm (~(get by permissions) path.act)
?~ perm
[~ this]
[~ state]
?: =(kind.u.perm %white)
(handle-add [%add +.act])
(handle-remove [%remove +.act])
::
++ handle-deny
|= act=permission-action
^- (quip move _this)
^- (quip card _state)
?> ?=(%deny -.act)
?~ path.act
[~ this]
[~ state]
=/ perm (~(get by permissions) path.act)
?~ perm
[~ this]
[~ state]
?: =(kind.u.perm %black)
(handle-add [%add +.act])
(handle-remove [%remove +.act])
::
++ update-subscribers
|= [pax=path upd=permission-update]
^- (list move)
%+ turn (prey:pubsub:userlib pax bol)
|= [=bone *]
[bone %diff %permission-update upd]
^- (list card)
[%give %fact `pax %permission-update !>(upd)]~
::
++ send-diff
|= [pax=path upd=permission-update]
^- (list move)
^- (list card)
%- zing
:~ (update-subscribers /all upd)
(update-subscribers /updates upd)
(update-subscribers [%permission pax] upd)
==
::
--

619
pkg/arvo/app/ph.hoon
View File

@ -1,619 +0,0 @@
:: Test the pH of your aquarium. See if it's safe to put in real fish.
::
:: usage:
:: :aqua [%run-test %test-add]
::
:: TODO:
:: - Restore a fleet
:: - Compose tests
::
/- aquarium, ph
/+ ph, ph-tests, ph-azimuth, ph-philter
=, ph-sur=^ph
=, aquarium
=, ph
=, ph-philter
=> $~ |%
+$ move (pair bone card)
+$ card
$% [%poke wire dock poke-type]
[%peer wire dock path]
[%pull wire dock ~]
[%diff diff-type]
==
::
+$ poke-type
$% [%aqua-events (list aqua-event)]
[%drum-start term term]
[%aqua-vane-control ?(%subscribe %unsubscribe)]
==
::
+$ diff-type
$% [%aqua-effects aqua-effects]
==
::
+$ state
$: %0
test-core=(unit test-core-state)
tests=(map term [(list ship) _*form:(ph ,~)])
other-state
==
::
+$ test-core-state
$: lab=term
hers=(list ship)
test=_*form:(ph ,~)
==
::
+$ other-state
$: test-qeu=(qeu term)
results=(list (pair term ?))
effect-log=(list [who=ship uf=unix-effect])
==
--
=, gall
=/ vane-apps=(list term)
~[%aqua-ames %aqua-behn %aqua-dill %aqua-eyre]
|_ $: hid=bowl
state
==
++ this .
++ manual-tests
^- (list (pair term [(list ship) _*form:(ph ,~)]))
=+ (ph-tests our.hid)
=+ ph-azimuth=(ph-azimuth our.hid)
=/ eth-node (spawn:ph-azimuth ~bud)
=/ m (ph ,~)
:~ :+ %boot-bud
~[~bud]
(raw-ship ~bud ~)
::
:+ %add
~[~bud]
;< ~ bind:m (raw-ship ~bud ~)
|= pin=ph-input
?: =(%init -.q.uf.pin)
[& (dojo ~bud "[%test-result (add 2 3)]") %wait ~]
?: (is-dojo-output ~bud who.pin uf.pin "[%test-result 5]")
[& ~ %done ~]
[& ~ %wait ~]
::
:+ %hi
~[~bud ~dev]
;< ~ bind:m (raw-ship ~bud ~)
~& > "BUD DONE"
;< ~ bind:m (raw-ship ~dev ~)
~& > "DEV DONE"
(send-hi ~bud ~dev)
::
:+ %boot-planet
~[~bud ~marbud ~linnup-torsyx]
(planet ~linnup-torsyx)
::
:+ %second-cousin-hi
~[~bud ~marbud ~linnup-torsyx ~dev ~mardev ~mitnep-todsut]
;< ~ bind:m (planet ~linnup-torsyx)
;< ~ bind:m (planet ~mitnep-todsut)
(send-hi ~linnup-torsyx ~mitnep-todsut)
::
:+ %change-file
~[~bud]
;< ~ bind:m (raw-ship ~bud ~)
;< file=@t bind:m (touch-file ~bud %home)
(check-file-touched ~bud %home file)
::
:+ %child-sync
~[~bud ~marbud]
;< ~ bind:m (star ~marbud)
;< file=@t bind:m (touch-file ~bud %base)
(check-file-touched ~marbud %home file)
::
:+ %boot-az
~[~bud]
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
(raw-real-ship:eth-node ~bud)
(pure:m ~)
::
:+ %hi-az
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > %dev-done
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > %bud-done
(send-hi ~bud ~dev)
(pure:m ~)
::
:+ %moon-az
~[~bud ~marbud ~linnup-torsyx ~linnup-torsyx-linnup-torsyx ~dev]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~linnup-torsyx)
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~linnup-torsyx)
~& > 'LINNUP DONE'
;< ~ bind:m (raw-real-ship:eth-node ~linnup-torsyx-linnup-torsyx)
~& > 'MOON LINNUP DONE'
;< ~ bind:m (send-hi ~bud ~linnup-torsyx-linnup-torsyx)
~& > 'HI DOWN DONE'
;< ~ bind:m (send-hi ~linnup-torsyx-linnup-torsyx ~marbud)
~& > 'HI UP DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
;< ~ bind:m (send-hi ~linnup-torsyx-linnup-torsyx ~dev)
~& > 'HI OVER UP DONE'
;< ~ bind:m (send-hi ~dev ~linnup-torsyx-linnup-torsyx)
~& > 'HI OVER DOWN DONE'
(pure:m ~)
(pure:m ~)
::
:+ %breach-hi
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
(send-hi ~bud ~dev)
~& > 'HI DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~dev ~bud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (send-hi-not-responding ~bud ~dev)
~& > 'HI NOT RESPONDING DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'REBOOT DEV DONE'
(wait-for-dojo ~bud "hi ~dev successful")
~& > 'DONE'
(pure:m ~)
::
:+ %breach-hi-cousin
~[~bud ~dev ~marbud ~mardev]
=. eth-node (spawn:eth-node ~dev)
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~mardev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
;< ~ bind:m (raw-real-ship:eth-node ~dev)
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
;< ~ bind:m (raw-real-ship:eth-node ~mardev)
(send-hi ~marbud ~mardev)
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~mardev ~marbud)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (send-hi-not-responding ~marbud ~mardev)
;< ~ bind:m (raw-real-ship:eth-node ~mardev)
(wait-for-dojo ~marbud "hi ~mardev successful")
(pure:m ~)
::
:+ %breach-sync
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH FILE DONE'
(check-file-touched ~marbud %home file)
~& > 'TOUCH FILE CHECK DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~bud ~marbud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< ~ bind:m (just-events (dojo ~bud "|merge %base ~marbud %kids, =gem %this"))
~& > 'THIS MERGE STARTED DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:+ %breach-multiple
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH DONE'
(check-file-touched ~marbud %home file)
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~bud ~marbud)
~& > 'BREACH-1 DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
(raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~marbud ~bud)
~& > 'BREACH-2 DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD RE DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:+ %breach-sudden
~[~bud ~marbud]
=. eth-node (spawn:eth-node ~marbud)
=. eth-node (spawn:eth-node ~fipfes)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~marbud)
~& > 'MARBUD DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH FILE DONE'
(check-file-touched ~marbud %home file)
~& > 'TOUCH FILE CHECK DONE'
=. eth-node (breach:eth-node ~bud)
~& > 'BREACH EXECUTED'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD RE DONE'
;< ~ bind:m (just-events (dojo ~bud "|merge %base ~marbud %kids, =gem %this"))
~& > 'THIS MERGE STARTED DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-1 DONE'
;< file=@t bind:m (touch-file ~bud %base)
~& > 'TOUCH-2 DONE'
(check-file-touched ~marbud %home file)
~& > 'DONE DONE'
(pure:m ~)
::
:: Doesn't succeed because success is hard to define, just make
:: sure it doesn't crash in Gall
::
:+ %breach-gall
~[~bud ~dev]
=. eth-node (spawn:eth-node ~dev)
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~bud)
~& > 'BUD DONE'
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'DEV DONE'
;< ~ bind:m (just-events (dojo ~bud "|start %hall"))
;< ~ bind:m (just-events (dojo ~bud "|start %talk"))
;< ~ bind:m (just-events (dojo ~dev "|start %hall"))
;< ~ bind:m (just-events (dojo ~dev "|start %talk"))
;< ~ bind:m (just-events (dojo ~bud ";create channel %hi 'desc'"))
;< ~ bind:m (just-events (dojo ~dev ";join ~bud/hi"))
;< ~ bind:m (just-events (dojo ~bud "heyya"))
(wait-for-dojo ~dev "heyya")
~& > 'CHANNEL DONE'
;< eth-node=_eth-node bind:m
(breach-and-hear:eth-node our.hid ~dev ~bud)
~& > 'BREACH DONE'
;< [eth-node=_eth-node ~] bind:m
%+ (wrap-philter ,_eth-node ,~)
router:eth-node
;< ~ bind:m (raw-real-ship:eth-node ~dev)
~& > 'REBOOT DEV DONE'
(send-hi ~bud ~dev)
~& > 'DONE'
stall
==
::
++ install-tests
^+ this
=. tests (malt manual-tests)
this
::
++ prep
|= old=(unit [@ tests=* rest=*])
^- (quip move _this)
~& prep=%ph
=. this install-tests
`this
:: ?~ old
:: `this
:: =/ new ((soft other-state) rest.u.old)
:: ?~ new
:: `this
:: `this(+<+>+> u.new)
::
++ publish-aqua-effects
|= afs=aqua-effects
^- (list move)
%+ murn ~(tap by sup.hid)
|= [b=bone her=ship pax=path]
^- (unit move)
?. ?=([%effects ~] pax)
~
`[b %diff %aqua-effects afs]
::
++ run-events
|= [lab=term what=(list ph-event)]
^- (quip move _this)
?: =(~ what)
`this
=/ res
|- ^- (each (list aqua-event) ?)
?~ what
[%& ~]
?: ?=(%test-done -.i.what)
[%| p.i.what]
=/ nex $(what t.what)
?: ?=(%| -.nex)
nex
[%& `aqua-event`i.what p.nex]
?: ?=(%| -.res)
=^ moves-1 this (finish-test lab p.res)
=^ moves-2 this run-test
[(weld moves-1 moves-2) this]
[[ost.hid %poke /running [our.hid %aqua] %aqua-events p.res]~ this]
::
:: Cancel subscriptions to ships
::
++ finish-test
|= [lab=term success=?]
^- (quip move _this)
?~ test-core
`this
~& ?: success
"TEST {(trip lab)} SUCCESSFUL"
"TEST {(trip lab)} FAILED"
:_ this(test-core ~, results [[lab success] results])
%- zing
%+ turn hers.u.test-core
|= her=ship
^- (list move)
:~ [ost.hid %pull /[lab]/(scot %p her) [our.hid %aqua] ~]
:* ost.hid
%poke
/cancelling
[our.hid %aqua]
%aqua-events
[%pause-events her]~
==
==
::
:: Start another test if one is in the queue
::
++ run-test
^- (quip move _this)
?^ test-core
`this
?: =(~ test-qeu)
?~ results
`this
=/ throw-away print-results
`this(results ~)
=^ lab test-qeu ~(get to test-qeu)
~& [running-test=lab test-qeu]
=. effect-log ~
=+ ^- [ships=(list ship) test=_*form:(ph ,~)]
(~(got by tests) lab)
=> .(test-core `(unit test-core-state)`test-core)
=. test-core `[lab ships test]
=^ moves-1 this (subscribe-to-effects lab ships)
=^ moves-2 this
(diff-aqua-effects /[lab]/(scot %p -.ships) -.ships [/ %init ~]~)
[:(weld init-vanes pause-fleet subscribe-vanes moves-1 moves-2) this]
::
:: Print results with ~&
::
++ print-results
~& "TEST REPORT:"
=/ throw-away
%+ turn
results
|= [lab=term success=?]
~& "{?:(success "SUCCESS" "FAILURE")}: {(trip lab)}"
~
~& ?: (levy results |=([term s=?] s))
"ALL TESTS SUCCEEDED"
"FAILURES"
~
::
:: Should check whether we're already subscribed
::
++ subscribe-to-effects
|= [lab=@tas hers=(list ship)]
:_ this
%+ turn hers
|= her=ship
^- move
:* ost.hid
%peer
/[lab]/(scot %p her)
[our.hid %aqua]
/effects/(scot %p her)
==
::
:: Start the vane drivers
::
++ init-vanes
^- (list move)
%+ murn
`(list term)`[%aqua vane-apps]
|= vane-app=term
^- (unit move)
=/ app-started
.^(? %gu /(scot %p our.hid)/[vane-app]/(scot %da now.hid))
?: app-started
~
`[ost.hid %poke /start [our.hid %hood] %drum-start %home vane-app]
::
:: Restart the vane drivers' subscriptions
::
++ subscribe-vanes
^- (list move)
%+ turn
vane-apps
|= vane-app=term
[ost.hid %poke /init [our.hid vane-app] %aqua-vane-control %subscribe]
::
:: Pause all existing ships
::
++ pause-fleet
^- (list move)
:_ ~
:* ost.hid %poke /pause-fleet [our.hid %aqua] %aqua-events
%+ turn
.^((list ship) %gx /(scot %p our.hid)/aqua/(scot %da now.hid)/ships/noun)
|= who=ship
[%pause-events who]
==
::
:: User interface
::
++ poke-ph-command
|= com=cli:ph-sur
^- (quip move _this)
?- -.com
%init [init-vanes this]
%run
?. (~(has by tests) lab.com)
~& [%no-test lab.com]
`this
=. test-qeu (~(put to test-qeu) lab.com)
run-test
::
%cancel
=^ moves-1 this (finish-test %last |)
=. test-qeu ~
=^ moves-2 this run-test
[:(weld moves-1 moves-2) this]
::
%run-all
=. test-qeu
%- ~(gas to test-qeu)
(turn manual-tests head)
run-test
::
%print
~& lent=(lent effect-log)
~& %+ roll effect-log
|= [[who=ship uf=unix-effect] ~]
?: ?=(?(%blit %doze) -.q.uf)
~
?: ?=(%ergo -.q.uf)
~& [who [- +<]:uf %omitted-by-ph]
~
~& [who uf]
~
`this
==
::
:: Receive effects back from aqua
::
++ diff-aqua-effects
|= [way=wire afs=aqua-effects]
^- (quip move _this)
:: ~& [%diff-aqua-effect way who.afs]
?> ?=([@tas @ ~] way)
=/ lab i.way
?~ test-core
~& [%ph-dropping-done lab]
[[ost.hid %pull way [our.hid %aqua] ~]~ this]
?. =(lab lab.u.test-core)
~& [%ph-dropping-strange lab]
[[ost.hid %pull way [our.hid %aqua] ~]~ this]
=+ |- ^- $: thru-effects=(list unix-effect)
events=(list ph-event)
log=_effect-log
done=(unit ?)
test=_test.u.test-core
==
?~ ufs.afs
[~ ~ ~ ~ test.u.test-core]
=/ m-res=_*output:(ph ,~)
(test.u.test-core now.hid who.afs i.ufs.afs)
=? ufs.afs =(%cont -.next.m-res)
[i.ufs.afs [/ %init ~] t.ufs.afs]
=^ done=(unit ?) test.u.test-core
?- -.next.m-res
%wait [~ test.u.test-core]
%cont [~ self.next.m-res]
%fail [`| test.u.test-core]
%done [`& test.u.test-core]
==
=+ ^- _$
?~ done
$(ufs.afs t.ufs.afs)
[~ ~ ~ done test.u.test-core]
:^ ?: thru.m-res
[i.ufs.afs thru-effects]
thru-effects
(weld events.m-res events)
[[who i.ufs]:afs log]
[done test]
=. test.u.test-core test
=. effect-log (weld log effect-log)
=> .(test-core `(unit test-core-state)`test-core)
?^ done
=^ moves-1 this (finish-test lab u.done)
=^ moves-2 this run-test
[(weld moves-1 moves-2) this]
=/ moves-1 (publish-aqua-effects who.afs thru-effects)
=^ moves-2 this (run-events lab events)
[(weld moves-1 moves-2) this]
::
:: Subscribe to effects
::
++ peer-effects
|= pax=path
^- (quip move _this)
?. ?=(~ pax)
~& [%ph-bad-peer-effects pax]
`this
`this
::
:: Subscription cancelled
::
++ pull
|= pax=path
`+>.$
--

225
pkg/arvo/app/ping.hoon Normal file
View File

@ -0,0 +1,225 @@
:: Ping our sponsorship tree regularly for routing.
::
:: To traverse NAT, we need the response to come back from someone
:: we've sent a message to. We ping our sponsor so that they know
:: where we are. However, we also need to ping our galaxy because if
:: the other ship tries to respond directly, it may be blocked by our
:: firewall or NAT. Thus, the response must come from a ship we've
:: messaged directly, and the only one we can guarantee is our galaxy.
:: Note this issue manifests itself even for bootstrapping a planet to
:: talk to its own star.
::
/+ default-agent, verb
=* point point:able:kale
::
|%
+$ card card:agent:gall
+$ ship-state
$% [%idle ~]
[%poking ~]
[%waiting until=@da]
==
--
::
=| state=[%0 ships=(map ship [=rift =ship-state])]
=> |%
:: +print-error: maybe +slog
::
++ print-error
|= [=tape error=(unit tang)]
^+ same
?~ error same
%- (slog leaf+tape u.error) same
:: +set-timer: send a card to behn to set a timer
::
++ set-timer
|= [now=@da =ship]
^- (quip card _state)
=/ s (~(get by ships.state) ship)
?~ s
`state
?. ?=(%poking -.ship-state.u.s)
%- (slog leaf+"ping: strange state {<ship s>}" ~)
`state
=/ until (add ~m5 now)
=. ships.state
(~(put by ships.state) ship u.s(ship-state [%waiting until]))
:_ state
=/ =wire /ping-wait/(scot %p ship)/(scot %da until)
[%pass wire %arvo %b %wait `@da`until]~
:: +send-ping: poke their %ping app
::
++ send-ping
|= [our=@p now=@da =ship]
^- (quip card _state)
::
?: =(our ship)
`state
=/ s (~(get by ships.state) ship)
?~ s
`state
?. ?=(%idle -.ship-state.u.s)
`state
:_ state(ships (~(put by ships.state) ship u.s(ship-state [%poking ~])))
[%pass /ping-send/(scot %p ship) %agent [ship %ping] %poke %noun !>(~)]~
:: +stop-ping-ship: stop listening to jael if not sponsor or old rift
::
++ stop-ping-ship
|= [our=@p now=@da =ship =old=rift =ship-state]
^- (quip card _state)
=+ .^(=new=rift %j /=rift/(scot %da now)/(scot %p ship))
:: if nothing's changed about us, don't cancel
::
?: ?& =(old-rift new-rift)
(~(has in (silt (saxo:title our now our))) ship)
==
`state
:: otherwise, kill jael subscription and timer
::
:_ state(ships (~(del by ships.state) ship))
[%pass /jael/(scot %p ship) %arvo %j %nuke (silt ship ~)]~
:: +start-ping-ship: start listening to jael updates if not already
::
:: While %public-keys is idempotent in most senses, it does
:: trigger a response, and this function is called on that
:: response, so we need a guard to avoid an infinite loop.
::
++ start-ping-ship
|= [our=@p now=@da =ship]
^- (quip card _state)
::
?: (~(has by ships.state) ship)
(send-ping our now ship)
::
;< new-state=_state (rind card state)
=+ .^(=rift %j /=rift/(scot %da now)/(scot %p ship))
:_ state(ships (~(put by ships.state) ship rift %idle ~))
[%pass /jael/(scot %p ship) %arvo %j %public-keys (silt ship ~)]~
=. state new-state
::
(send-ping our now ship)
:: +kick: idempotent operation to make clean start for all pings
::
++ kick
|= [our=@p now=@da]
^- (quip card _state)
?: =(%czar (clan:title our))
`state
::
=/ old-ships=(list [=ship =rift =ship-state]) ~(tap by ships.state)
|- ^- (quip card _state)
=* loop $
?^ old-ships
;< new-state=_state (rind card state)
(stop-ping-ship our now i.old-ships)
=. state new-state
loop(old-ships t.old-ships)
::
=/ new-ships (saxo:title our now our)
|- ^- (quip card _state)
=* loop $
?^ new-ships
;< new-state=_state (rind card state)
(start-ping-ship our now i.new-ships)
=. state new-state
loop(new-ships t.new-ships)
::
`state
:: +rind: bind for the the writer monad on (quip effect state)
::
++ rind
|* [effect=mold state=*]
|* state-type=mold
|= $: m-b=(quip effect state-type)
fun=$-(state-type (quip effect state-type))
==
^- (quip effect state-type)
=^ effects-1=(list effect) state m-b
=^ effects-2=(list effect) state (fun state)
[(weld effects-1 effects-2) state]
::
--
%+ verb |
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
:: +on-init: initializing on startup
::
++ on-init
^- [(list card) _this]
=^ cards state (kick our.bowl now.bowl)
[cards this]
::
++ on-save !>(state)
++ on-load
|= old=vase
=. state !<(_state old)
(on-poke %noun !>(%kick))
:: +on-poke: positively acknowledge pokes
::
++ on-poke
|= [=mark =vase]
?: =(q.vase %kick)
=. ships.state
%- ~(run by ships.state)
|= [=rift =ship-state]
[999.999 ship-state]
on-init
`this
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
``noun+!>(state)
:: +on-agent: handle ames ack
::
++ on-agent
|= [=wire =sign:agent:gall]
^- [(list card) _this]
?> ?=([%ping-send @ ~] wire)
?> ?=(%poke-ack -.sign)
::
%- (print-error "ping: ack" p.sign)
=^ cards state
(set-timer now.bowl (slav %p i.t.wire))
[cards this]
:: +on-arvo: handle timer firing
::
++ on-arvo
|= [=wire =sign-arvo]
^- [(list card) _this]
?+ wire !!
[%ping-wait @ @ ~]
?> ?=(%wake +<.sign-arvo)
=/ =ship (slav %p i.t.wire)
=/ until=@da (slav %da i.t.t.wire)
=/ s (~(get by ships.state) ship)
?~ s
`this
?. =([%waiting until] ship-state.u.s)
`this
=. ships.state (~(put by ships.state) ship u.s(ship-state [%idle ~]))
%- (print-error "ping: wake" error.sign-arvo)
=^ cards state
(send-ping our.bowl now.bowl ship)
[cards this]
::
[%jael @ ~]
:: whenever we get an update from Jael, kick
::
?> ?=(%public-keys +<.sign-arvo)
:_ this
[%pass /delay %arvo %b %wait now.bowl]~
:: Delayed until next event so that ames can clear its state
::
[%delay ~]
?> ?=(%wake +<.sign-arvo)
on-init
==
::
++ on-fail on-fail:def
--

199
pkg/arvo/app/pool-group-hook.hoon Normal file
View File

@ -0,0 +1,199 @@
:: pool-group-hook: maintain groups based on invite pool
::
:: looks at our invite tree, adds our siblings to group at +group-path
::
/- group-store, spider
/+ default-agent, verb
=, ethereum-types
=, able:jael
::
=> |%
++ group-path /invite-peers
++ refresh-rate ~m15
--
::
=> |%
+$ app-state
$: %0
running=(unit =tid:spider)
url=_'http://eth-mainnet.urbit.org:8545'
inviter=(unit ship)
invited=(set ship)
==
::
+$ card card:agent:gall
--
::
:: Main
::
=| state=app-state
::
%+ verb |
^- agent:gall
=<
|_ =bowl:gall
+* this .
do ~(. +> bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init
^- (quip card _this)
=^ cards state
poll-inviter:do
[cards this]
::
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(app-state old))]
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card agent:gall)
?. ?=([%running *] wire)
(on-agent:def wire sign)
?- -.sign
%poke-ack
?~ p.sign
[~ this]
%- (slog leaf+"{(trip dap.bowl)} couldn't start thread" u.p.sign)
:_ this(running.state ~)
~[(leave-spider:do t.wire) set-timer:do]
::
%watch-ack
?~ p.sign
[~ this]
=/ =tank leaf+"{(trip dap.bowl)} couldn't start listen to thread"
%- (slog tank u.p.sign)
[[set-timer:do]~ this(running.state ~)]
::
%kick [~ this(running.state ~)]
%fact
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%- (slog leaf+"{(trip dap.bowl)} failed; will retry" leaf+<term> tang)
[[set-timer:do]~ this(running.state ~)]
::
%thread-done
?+ t.wire ~|([dap.bowl %unexpected-thread-done wire] !!)
[%inviter ~]
=+ !<(res=@t q.cage.sign)
=/ inviter=ship
`@`(decode-results:abi:ethereum res [%uint]~)
:: if we weren't invited by anyone, don't do anything anymore.
::
?: =(0 inviter) [~ this(state state(running ~, inviter ~))]
=. inviter.state `inviter
=^ cards state
poll-invited:do
[cards this]
::
[%invited ~]
=+ !<(res=@t q.cage.sign)
=/ invited=(list ship)
;; (list ship)
(decode-results:abi:ethereum res [%array %uint]~)
=^ cards state
(process-invited:do invited)
[cards this(running.state ~)]
==
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?+ +<.sign-arvo ~|([dap.bowl %strange-arvo-sign +<.sign-arvo] !!)
%wake
=^ cards state
?~ inviter.state
poll-inviter:do
poll-invited:do
[cards this]
==
::
++ on-poke on-poke:def
++ on-peek on-peek:def
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--
::
|_ =bowl:gall
++ poke-spider
|= [=path =cage]
^- card
[%pass [%running path] %agent [our.bowl %spider] %poke cage]
::
++ watch-spider
|= [=path =sub=path]
^- card
[%pass [%running path] %agent [our.bowl %spider] %watch sub-path]
::
++ leave-spider
|= [=path]
^- card
[%pass [%running path] %agent [our.bowl %spider] %leave ~]
::
++ new-tid
|= eny=@uv
^- @t
%+ scot %ta
:((cury cat 3) dap.bowl '_' (scot %uv eny))
::
++ start-contract-read
|= [=wire req=proto-read-request:rpc:ethereum]
^- (quip card _state)
=/ new-tid (new-tid eny.bowl)
=/ args
[~ `new-tid %eth-read-contract !>([url.state req])]
:_ state(running `new-tid)
:~ (watch-spider wire /thread-result/[new-tid])
(poke-spider wire %spider-start !>(args))
==
::
++ poll-inviter
^- (quip card _state)
%+ start-contract-read /inviter
:+ `'invitedBy'
delegated-sending:contracts:azimuth
:- 'invitedBy(uint32)'
:~ [%uint `@`our.bowl]
==
::
++ poll-invited
^- (quip card _state)
?~ inviter.state
~& [dap.bowl %skipping-poll-invited]
[~ state]
%+ start-contract-read /invited
:+ `'getInvited'
delegated-sending:contracts:azimuth
:- 'getInvited(uint32)'
:~ [%uint `@`u.inviter.state]
==
::
++ process-invited
|= invited=(list ship)
=/ new=(list ship)
%+ skip invited
~(has in invited.state)
:_ state(invited (~(gas in invited.state) new))
:~ set-timer
::
:* %pass
/write
%agent
[our.bowl %group-store]
%poke
%group-action
!>([%add (sy new) group-path])
==
==
::
++ set-timer
^- card
[%pass /timer %arvo %b %wait (add now.bowl refresh-rate)]
--

1035
pkg/arvo/app/publish.hoon
View File

File diff suppressed because it is too large Load Diff

2
pkg/arvo/app/publish/js/index.js
View File

File diff suppressed because one or more lines are too long

385
pkg/arvo/app/send-txs.hoon
View File

@ -1,385 +0,0 @@
::
:: there's a small state machine here that goes like this (happy path):
:: =/ wen ~
:: apex
:: -> [if =(~ wen)]
:: -> apex
:: [else]
:: -> wen=`(add now ~s10)
:: -> send-next-batch
:: [n times]
:: -> eth-send-raw-transaction
:: -> sigh-send
:: -> wait 30s in behn
:: -> wake-see
:: [n times]
:: -> wen=~
:: -> eth-get-transaction-receipt
:: -> sigh-see
:: -> apex
::
|%
++ state
$: txs=(list @ux)
see=(set @ux)
wen=(unit @da)
outstanding-send=_|
==
::
++ move (pair bone card)
++ card
$% [%hiss wire ~ mark %hiss hiss:eyre]
[%info wire ship desk nori:clay]
[%rest wire @da]
[%wait wire @da]
==
--
::
|_ [bol=bowl:gall state]
::
++ this .
++ pretty-see (turn (sort (turn ~(tap in see) mug) lth) @p)
::
++ prep
|= old=(unit *)
?: ?=([~ * * ~ @da] old)
~& [%cancelling +>+>.old]
[[ost.bol %rest /see +>+>.old]~ ..prep]
[~ ..prep]
::
:: usage:
::
:: generate txs starting from nonce 0 on fake chain at 11 gwei
:: from address; store at path
:: :send-txs [%gen %/txs/eth-txs %fake 0 11 '0x0000000']
::
:: sign txs for gasses of 2 and 11 gwei; (~ for default gwei set)
:: store at path
:: :send-txs [%sign %/txs %/txs/eth-txs %/pk/txt ~[2 0]]
::
:: read nonce range from signed transactions at path
:: :send-txs [%read %txs/txt]
::
:: send all but first 50 txs from path
:: :send-txs [%send %/txs/txt 50]
::
++ poke-noun
|= $% [%sign bout=path in=path key=path gasses=(list @ud)]
::
[%read pax=path]
::
$: %send
pax=path
how=?(%nonce %number) :: tx nonce / index in file
range=(unit $@(@ud (pair @ud @ud))) :: inclusive. end optional
==
==
^- [(list move) _this]
?- +<-
%sign
:_ this
%+ turn
?. =(~ gasses) gasses
:: default gwei set
~[3 4 6 9 11 21 31]
|= gas=@ud
%+ write-file-wain
:: add gas amount to path
=+ end=(dec (lent bout))
=- (weld (scag end bout) -)
?: =(0 gas) [(snag end bout) /txt]
:_ /txt
(cat 3 (snag end bout) (crip '-' ((d-co:co 1) gas)))
::
%- sign
:+ in key
:: modify tx gas if non-zero gwei specified
?: =(0 gas) ~
`(mul gas 1.000.000.000)
::
%read
=+ tox=.^((list cord) %cx pax)
=+ [first last]=(read-nonces tox)
~& %+ weld
"Found nonces {(scow %ud first)} through {(scow %ud last)}"
" in {(scow %ud (lent tox))} transactions."
[~ this]
::
%send
~& 'loading txs...'
=. see ~
=/ tox=(list cord) .^((list cord) %cx pax)
=. tox
?~ range tox
=* r u.range
?: ?=(%number how)
?@ r
(slag r tox)
%+ slag p.r
(scag q.r tox)
=+ [first last]=(read-nonces tox)
?: !=((lent tox) +((sub last first)))
~| 'woah, probably non-contiguous set of transactions'
!!
?@ r
(slag (sub r first) tox)
(slag (sub p.r first) (scag (sub +(q.r) first) tox))
=. txs
%+ turn tox
(cork trip tape-to-ux)
~& [(lent txs) 'loaded txs']
~& [%clearing-see ~(wyt in see)]
=. see ~
=. outstanding-send |
apex
==
::
++ get-file
|= pax=path
~| pax
.^ (list cord) %cx
(weld /(scot %p our.bol)/home/(scot %da now.bol) pax)
==
::
:: sign pre-generated transactions
++ sign
=, rpc:ethereum
|= [in=path key=path gas=(unit @ud)]
^- (list cord)
?> ?=([@ @ @ *] key)
=/ pkf (get-file t.t.t.key)
?> ?=(^ pkf)
=/ pk (rash i.pkf ;~(pfix (jest '0x') hex))
=/ txs .^((list transaction) %cx in)
=/ enumerated
=/ n 1
|- ^- (list [@ud transaction])
?~ txs
~
[[n i.txs] $(n +(n), txs t.txs)]
%+ turn enumerated
|= [n=@ud tx=transaction]
~? =(0 (mod n 100)) [%signing n]
=? gas-price.tx ?=(^ gas) u.gas
(crip '0' 'x' ((x-co:co 0) (sign-transaction:key:ethereum tx pk)))
::
++ read-nonces
|= tox=(list cord)
^- [@ud @ud]
?: =(~ tox) :: not ?~ because fucking tmi
[0 0]
:- (read-nonce (snag 0 tox))
(read-nonce (snag (dec (lent tox)) tox))
::
++ read-nonce
|= tex=cord
^- @ud
::NOTE this is profoundly stupid but should work well enough
=+ (find "82" (trip tex))
?> ?=(^ -)
(rash (rsh 3 (add u 2) (end 3 (add u 6) tex)) hex)
::
++ write-file-wain
|= [pax=path tox=(list cord)]
^- move
?> ?=([@ desk @ *] pax)
:* ost.bol
%info
(weld /write pax)
our.bol
i.t.pax
=- &+[t.t.t.pax -]~
=/ y .^(arch %cy pax)
?~ fil.y
ins+txt+!>(tox)
mut+txt+!>(tox)
==
::
++ write-file-transactions
|= [pax=path tox=(list transaction:rpc:ethereum)]
^- move
?> ?=([@ desk @ *] pax)
:* ost.bol
%info
(weld /write pax)
our.bol
i.t.pax
=- &+[t.t.t.pax -]~
=/ y .^(arch %cy pax)
?~ fil.y
ins+eth-txs+!>(tox)
mut+eth-txs+!>(tox)
==
::
++ fan-requests
|= [wir=wire nodes=(list [tag=@tas url=purl:eyre]) jon=json]
:: =- ~& [batch=((list ,[bone * wire]) (turn - |=(* [- +< +>-]:+<))) jon=jon] -
^- (list move)
%+ turn nodes
|= [tag=@tas url=purl:eyre]
^- move
:- ost.bol
:^ %hiss (weld wir ~[tag]) ~
:+ %json-rpc-response %hiss
(json-request:rpc:ethereum url jon)
::
++ batch-requests
|= [wir=wire req=(list [(unit @t) request:rpc:ethereum])]
^- (list move)
%^ fan-requests
wir
:~ => (need (de-purl:html 'http://35.226.110.143:8545'))
geth+.(p.p |)
::
=> (need (de-purl:html 'http://104.198.35.227:8545'))
parity+.(p.p |)
==
a+(turn req request-to-json:rpc:ethereum)
::
++ send-next-batch
^- [(list move) _this]
?: outstanding-send
~& 'waiting for previous send to complete'
`this
?: =(0 (lent txs))
~& 'all sent!'
[~ this(txs ~, see ~, wen ~, outstanding-send |)]
:: ~& send-next-batch=pretty-see
=/ new-count (sub 500 ~(wyt in see))
?: =(0 new-count)
~& %no-new-txs-yet
`this
:_ this(txs (slag new-count txs), outstanding-send &)
~& ['remaining txs: ' (lent txs)]
~& ['sending txs...' new-count]
%+ batch-requests /send
%+ turn (scag new-count txs)
|= tx=@ux
:- `(crip 'id-' (scot %ux (end 3 10 tx)) ~)
[%eth-send-raw-transaction tx]
::
++ sigh-json-rpc-response-send
|= [wir=wire res=response:rpc:jstd]
^- [(list move) _this]
?: ?=(%fail -.res)
~& %send-failed
`this
?> ?=(%batch -.res)
:: ~& sigh-send-a=pretty-see
=. see
%- ~(uni in see)
%- silt
^- (list @ux)
%+ murn bas.res
|= r=response:rpc:jstd
^- (unit @ux)
?: ?=(%error -.r)
?: ?| =('known transaction' (end 3 17 message.r))
=('Known transaction' (end 3 17 message.r))
=('Transaction with the same ' (end 3 26 message.r))
==
~& [%sent-a-known-transaction--skipping wir]
~
?: =('Nonce too low' message.r)
~& %nonce-too-low--skipping
~
~| :- 'transaction send failed, game over'
[code.r message.r]
!!
?> ?=(%result -.r)
:- ~
%- tape-to-ux
(sa:dejs:format res.r)
=. outstanding-send |
:: ~& sigh-send-b=pretty-see
`this
::
++ apex
^- [(list move) _this]
~& :_ ~(wyt in see)
'waiting for transaction confirms... '
?. =(~ wen) [~ this]
=. wen `(add now.bol ~s30)
:: ~& apex=[wen pretty-see]
=^ moves this send-next-batch
:: timer got un-set, meaning we're done here
?~ wen [moves this]
[[[ost.bol %wait /see (need wen)] moves] this]
::
++ wake-see
|= [wir=wire ~]
^- [(list move) _this]
=. wen ~
:: ~& wake-see=[wen pretty-see]
?: =(~ see)
apex
:_ this
%+ batch-requests /see
%+ turn ~(tap in see)
|= txh=@ux
:- `(crip 'see-0x' ((x-co:co 64) txh))
[%eth-get-transaction-receipt txh]
::
++ sigh-json-rpc-response-see
|= [wir=wire res=response:rpc:jstd]
^- [(list move) _this]
?: ?| ?=(%error -.res)
?=(%fail -.res)
==
~& [%bad-rpc-response--kicking res]
apex
:: `this
?> ?=(%batch -.res)
?: =(~ see)
apex
?: =(0 (lent bas.res))
::TODO node lost our txs?
~& [%txs-lost-tmp wir '!!']
apex
:: ~& sigh-see-a=pretty-see
=. see
%- ~(dif in see)
%- silt
^- (list @ux)
%+ murn bas.res
|= r=response:rpc:jstd
^- (unit @ux)
?< ?=(%batch -.r)
?< ?=(%fail -.r)
~| [id.r res]
=+ txh=(tape-to-ux (trip (rsh 3 4 id.r)))
:: ~& see-tx=[(@p (mug txh)) `@ux`txh]
=* done `txh
=* wait ~
?: ?=(%error -.r)
~& :- 'receipt fetch error'
[code.r message.r]
wait
?~ res.r wait
?> ?=(%o -.res.r)
=/ status
%- tape-to-ux
%- sa:dejs:format
(~(got by p.res.r) 'status')
?: =(1 status)
done
~& [%see-bad-status status]
wait
:: ~& sigh-see-b=pretty-see
apex
::
++ sigh-tang
|= [wir=wire err=tang]
~& [%sigh-tang wir]
~& (slog err)
?: =(~ wen) [~ this]
=. wen `(add now.bol ~s30)
[[ost.bol %wait /see (need wen)]~ this]
::
++ tape-to-ux
|= t=tape
(scan t zero-ux)
::
++ zero-ux
;~(pfix (jest '0x') hex)
--

132
pkg/arvo/app/soto.hoon Normal file
View File

@ -0,0 +1,132 @@
::
:: Soto: A Dojo relay for Urbit's Landscape interface
:: Relays sole-effects to subscribers and forwards sole-action pokes
::
/- sole
/+ *server, *soto, default-agent
/= index
/^ octs
/; as-octs:mimes:html
/: /===/app/soto/index
/| /html/
/~ ~
==
/= tile-js
/^ octs
/; as-octs:mimes:html
/: /===/app/soto/js/tile
/| /js/
/~ ~
==
/= script
/^ octs
/; as-octs:mimes:html
/: /===/app/soto/js/index
/| /js/
/~ ~
==
/= style
/^ octs
/; as-octs:mimes:html
/: /===/app/soto/css/index
/| /css/
/~ ~
==
/= soto-png
/^ (map knot @)
/: /===/app/soto/img /_ /png/
::
|%
+$ card card:agent:gall
+$ state-zero ~
::
--
=| state-zero
=* state -
^- agent:gall
|_ bol=bowl:gall
+* this .
soto-core +>
sc ~(. soto-core bol)
def ~(. (default-agent this %|) bol)
::
++ on-init
:_ this
:~ [%pass /bind/soto %arvo %e %connect [~ /'~dojo'] %soto]
:* %pass /launch/soto %agent [our.bol %launch] %poke
%launch-action !>([%soto /sototile '/~dojo/js/tile.js'])
==
==
++ on-save !>(state)
::
++ on-load
|= old=vase
[~ this(state !<(state-zero old))]
::
++ on-poke
|= [mar=mark vas=vase]
^- (quip card _this)
?> (team:title our.bol src.bol)
?. ?=(%handle-http-request mar)
(on-poke:def mar vas)
=+ !<([id=@ta req=inbound-request:eyre] vas)
:_ this
%+ give-simple-payload:app id
%+ require-authorization:app req
|= =inbound-request:eyre
^- simple-payload:http
=/ request-line (parse-request-line url.request.inbound-request)
?+ request-line
not-found:gen
:: main page
::
[[~ [%'~dojo' *]] *]
(html-response:gen index)
:: main js
::
[[[~ %js] [%'~dojo' %js %index ~]] ~]
(js-response:gen script)
:: tile js
::
[[[~ %js] [%'~dojo' %js %tile ~]] ~]
(js-response:gen tile-js)
:: styling
::
[[[~ %css] [%'~dojo' %css %index ~]] ~]
(css-response:gen style)
:: images
::
[[[~ %png] [%'~dojo' %img @t ~]] ~]
=/ filename=@t i.t.t.site.request-line
=/ img (~(get by soto-png) filename)
?~ img
not-found:gen
(png-response:gen (as-octs:mimes:html u.img))
==
::
++ on-watch
|= pax=path
^- (quip card _this)
?+ pax (on-watch:def pax)
[%http-response *]
[~ this]
::
[%sototile ~]
:_ this
[%give %fact ~ %json !>(~)]~
==
::
++ on-agent on-agent:def
::
++ on-arvo
|= [wir=wire sin=sign-arvo]
^- (quip card _this)
?: ?=(%bound +<.sin)
[~ this]
(on-arvo:def wir sin)
::
++ on-fail on-fail:def
++ on-leave on-leave:def
++ on-peek on-peek:def
::
--

1
pkg/arvo/app/soto/css/index.css Normal file
View File

File diff suppressed because one or more lines are too long

BIN
pkg/arvo/app/soto/img/Tile.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.4 KiB

16
pkg/arvo/app/soto/index.html Normal file
View File

@ -0,0 +1,16 @@
<!doctype html>
<html>
<head>
<title>Dojo</title>
<meta charset="utf-8" />
<meta name="viewport"
content="width=device-width, initial-scale=1, shrink-to-fit=no"/>
<link rel="stylesheet" href="/~dojo/css/index.css" />
</head>
<body class="bg-black">
<div id="root" />
<script src="/~/channel/channel.js"></script>
<script src="/~modulo/session.js"></script>
<script src="/~dojo/js/index.js"></script>
</body>
</html>

1
pkg/arvo/app/soto/js/index.js Normal file
View File

File diff suppressed because one or more lines are too long

1
pkg/arvo/app/soto/js/tile.js Normal file
View File

File diff suppressed because one or more lines are too long

477
pkg/arvo/app/spider.hoon Normal file
View File

@ -0,0 +1,477 @@
:: Thread manager
::
/- spider
/+ libstrand=strand, default-agent, verb
=, strand=strand:libstrand
|%
+$ card card:agent:gall
+$ thread thread:spider
+$ tid tid:spider
+$ input input:spider
+$ yarn (list tid)
+$ thread-form _*eval-form:eval:(strand ,vase)
+$ trie
$~ [*thread-form ~]
[=thread-form kid=(map tid trie)]
::
+$ trying ?(%find %build %none)
+$ state
$: starting=(map yarn [=trying =vase])
running=trie
tid=(map tid yarn)
==
::
+$ clean-slate
$: starting=(map yarn [=trying =vase])
running=(list yarn)
tid=(map tid yarn)
==
::
+$ start-args
[parent=(unit tid) use=(unit tid) file=term =vase]
--
::
:: Trie operations
::
|%
++ get-yarn
|= [=trie =yarn]
^- (unit =thread-form)
?~ yarn
`thread-form.trie
=/ son (~(get by kid.trie) i.yarn)
?~ son
~
$(trie u.son, yarn t.yarn)
::
++ get-yarn-children
|= [=trie =yarn]
^- (list ^yarn)
?~ yarn
(turn (tap-yarn trie) head)
=/ son (~(get by kid.trie) i.yarn)
?~ son
~
$(trie u.son, yarn t.yarn)
::
::
++ has-yarn
|= [=trie =yarn]
!=(~ (get-yarn trie yarn))
::
++ put-yarn
|= [=trie =yarn =thread-form]
^+ trie
?~ yarn
trie(thread-form thread-form)
=/ son (~(gut by kid.trie) i.yarn [*^thread-form ~])
%= trie
kid
%+ ~(put by kid.trie) i.yarn
$(trie son, yarn t.yarn)
==
::
++ del-yarn
|= [=trie =yarn]
^+ trie
?~ yarn
trie
|-
?~ t.yarn
trie(kid (~(del by kid.trie) i.yarn))
=/ son (~(get by kid.trie) i.yarn)
?~ son
trie
%= trie
kid
%+ ~(put by kid.trie) i.yarn
$(trie u.son, yarn t.yarn)
==
::
++ tap-yarn
=| =yarn
|= =trie
^- (list [=^yarn =thread-form])
%+ welp
?~ yarn
~
[(flop yarn) thread-form.trie]~
=/ kids ~(tap by kid.trie)
|- ^- (list [=^yarn =thread-form])
?~ kids
~
=/ next-1 ^$(yarn [p.i.kids yarn], trie q.i.kids)
=/ next-2 $(kids t.kids)
(welp next-1 next-2)
--
::
^- agent:gall
=| =state
=<
%+ verb |
|_ =bowl:gall
+* this .
spider-core +>
sc ~(. spider-core bowl)
def ~(. (default-agent this %|) bowl)
::
++ on-init on-init:def
++ on-save clean-state:sc
++ on-load
|= old-state=vase
=+ !<(=clean-slate old-state)
=. tid.state tid.clean-slate
=/ yarns=(list yarn)
%+ welp running.clean-slate
~(tap in ~(key by starting.clean-slate))
|- ^- (quip card _this)
?~ yarns
`this
?. ?=([@ ~] i.yarns)
$(yarns t.yarns)
~| killing=i.yarns
=^ cards-1 state
(handle-stop-thread:sc (yarn-to-tid i.yarns) |)
=^ cards-2 this
$(yarns t.yarns)
[(weld cards-1 cards-2) this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?: ?=(%spider-kill mark)
(on-load on-save)
=^ cards state
?+ mark (on-poke:def mark vase)
%spider-input (on-poke-input:sc !<(input vase))
%spider-start (handle-start-thread:sc !<(start-args vase))
%spider-stop (handle-stop-thread:sc !<([tid ?] vase))
==
[cards this]
::
++ on-watch
|= =path
^- (quip card _this)
=^ cards state
?+ path (on-watch:def path)
[%thread @ *] (on-watch:sc t.path)
[%thread-result @ ~] (on-watch-result:sc i.t.path)
==
[cards this]
::
++ on-leave on-leave:def
++ on-peek
|= =path
^- (unit (unit cage))
?+ path (on-peek:def path)
[%x %tree ~]
``noun+!>((turn (tap-yarn running.state) head))
::
[%x %starting @ ~]
``noun+!>((has-yarn running.state (~(got by tid.state) i.t.t.path)))
::
[%x %saxo @ ~]
``noun+!>((~(got by tid.state) i.t.t.path))
==
::
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
=^ cards state
?+ wire !!
[%thread @ *] (on-agent:sc i.t.wire t.t.wire sign)
==
[cards this]
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
=^ cards state
?+ wire (on-arvo:def wire sign-arvo)
[%thread @ *] (handle-sign:sc i.t.wire t.t.wire sign-arvo)
[%find @ ~] (handle-find:sc i.t.wire sign-arvo)
[%build @ ~] (handle-build:sc i.t.wire sign-arvo)
==
[cards this]
:: On unexpected failure, kill all outstanding strands
::
++ on-fail
|= [=term =tang]
^- (quip card _this)
%- (slog leaf+"spider crashed, killing all strands: {<term>}" tang)
(on-load on-save)
--
::
|_ =bowl:gall
++ on-poke-input
|= input
=/ yarn (~(got by tid.state) tid)
(take-input yarn ~ %poke cage)
::
++ on-watch
|= [=tid =path]
(take-input (~(got by tid.state) tid) ~ %watch path)
::
++ on-watch-result
|= =tid
^- (quip card ^state)
`state
::
++ handle-sign
|= [=tid =wire =sign-arvo]
=/ yarn (~(get by tid.state) tid)
?~ yarn
%- (slog leaf+"spider got sign for non-existent {<tid>}" ~)
`state
(take-input u.yarn ~ %sign wire sign-arvo)
::
++ on-agent
|= [=tid =wire =sign:agent:gall]
=/ yarn (~(get by tid.state) tid)
?~ yarn
%- (slog leaf+"spider got agent for non-existent {<tid>}" ~)
`state
(take-input u.yarn ~ %agent wire sign)
::
++ handle-start-thread
|= [parent-tid=(unit tid) use=(unit tid) file=term =vase]
^- (quip card ^state)
=/ parent-yarn=yarn
?~ parent-tid
/
(~(got by tid.state) u.parent-tid)
=/ new-tid (fall use (scot %uv (sham eny.bowl)))
=/ =yarn (snoc parent-yarn new-tid)
::
?: (has-yarn running.state yarn)
~| [%already-started yarn]
!!
?: (~(has by starting.state) yarn)
~| [%already-starting yarn]
!!
::
=: starting.state (~(put by starting.state) yarn [%find vase])
tid.state (~(put by tid.state) new-tid yarn)
==
=/ =card
=/ =schematic:ford [%path [our.bowl %home] %ted file]
[%pass /find/[new-tid] %arvo %f %build live=%.n schematic]
[[card ~] state]
::
++ handle-find
|= [=tid =sign-arvo]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
?> ?=([%f %made *] sign-arvo)
?: ?=(%incomplete -.result.sign-arvo)
(thread-fail-not-running tid %find-thread-incomplete tang.result.sign-arvo)
=/ =build-result:ford build-result.result.sign-arvo
?: ?=(%error -.build-result)
(thread-fail-not-running tid %find-thread-error message.build-result)
?. ?=([%path *] +.build-result)
(thread-fail-not-running tid %find-thread-strange ~)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%build vase]))
=/ =card
=/ =schematic:ford [%core rail.build-result]
[%pass /build/[tid] %arvo %f %build live=%.n schematic]
[[card ~] state]
::
++ handle-build
|= [=tid =sign-arvo]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
=. starting.state
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
?> ?=([%f %made *] sign-arvo)
?: ?=(%incomplete -.result.sign-arvo)
(thread-fail-not-running tid %build-thread-incomplete tang.result.sign-arvo)
=/ =build-result:ford build-result.result.sign-arvo
?: ?=(%error -.build-result)
(thread-fail-not-running tid %build-thread-error message.build-result)
=/ =cage (result-to-cage:ford build-result)
?. ?=(%noun p.cage)
(thread-fail-not-running tid %build-thread-strange >p.cage< ~)
=/ maybe-thread (mule |.(!<(thread q.cage)))
?: ?=(%| -.maybe-thread)
(thread-fail-not-running tid %thread-not-thread ~)
(start-thread yarn p.maybe-thread)
::
++ start-thread
|= [=yarn =thread]
^- (quip card ^state)
=/ =vase vase:(~(got by starting.state) yarn)
?< (has-yarn running.state yarn)
=/ m (strand ,^vase)
=/ res (mule |.((thread vase)))
?: ?=(%| -.res)
(thread-fail-not-running (yarn-to-tid yarn) %false-start p.res)
=/ =eval-form:eval:m
(from-form:eval:m p.res)
=: starting.state (~(del by starting.state) yarn)
running.state (put-yarn running.state yarn eval-form)
==
(take-input yarn ~)
::
++ handle-stop-thread
|= [=tid nice=?]
^- (quip card ^state)
=/ =yarn (~(got by tid.state) tid)
?: (has-yarn running.state yarn)
?: nice
(thread-done yarn *vase)
(thread-fail yarn %cancelled ~)
?: (~(has by starting.state) yarn)
(thread-fail-not-running tid %stopped-before-started ~)
~& [%thread-not-started yarn]
?: nice
(thread-done yarn *vase)
(thread-fail yarn %cancelled ~)
::
++ take-input
|= [=yarn input=(unit input:strand)]
^- (quip card ^state)
=/ m (strand ,vase)
?. (has-yarn running.state yarn)
%- (slog leaf+"spider got input for non-existent {<yarn>} 2" ~)
`state
=/ =eval-form:eval:m
thread-form:(need (get-yarn running.state yarn))
=| cards=(list card)
|- ^- (quip card ^state)
=^ r=[cards=(list card) =eval-result:eval:m] eval-form
=/ out
%- mule |.
(take:eval:m eval-form (convert-bowl yarn bowl) input)
?- -.out
%& p.out
%| [[~ [%fail %crash p.out]] eval-form]
==
=. running.state (put-yarn running.state yarn eval-form)
=/ =tid (yarn-to-tid yarn)
=. cards.r
%+ turn cards.r
|= =card
^- ^card
?+ card card
[%pass * *] [%pass [%thread tid p.card] q.card]
[%give %fact *]
?~ path.p.card
card
card(path.p `[%thread tid u.path.p.card])
::
[%give %kick *]
?~ path.p.card
card
card(path.p `[%thread tid u.path.p.card])
==
=. cards (weld cards cards.r)
=^ final-cards=(list card) state
?- -.eval-result.r
%next `state
%fail (thread-fail yarn err.eval-result.r)
%done (thread-done yarn value.eval-result.r)
==
[(weld cards final-cards) state]
::
++ thread-fail-not-running
|= [=tid =term =tang]
=/ =yarn (~(got by tid.state) tid)
:_ state(starting (~(del by starting.state) yarn))
%- welp :_ (thread-say-fail tid term tang)
=/ =trying trying:(~(got by starting.state) yarn)
?- trying
%find [%pass /find/[tid] %arvo %f %kill ~]~
%build [%pass /build/[tid] %arvo %f %kill ~]~
%none ~
==
::
++ thread-say-fail
|= [=tid =term =tang]
^- (list card)
:~ [%give %fact `/thread-result/[tid] %thread-fail !>([term tang])]
[%give %kick `/thread-result/[tid] ~]
==
::
++ thread-fail
|= [=yarn =term =tang]
^- (quip card ^state)
=/ =tid (yarn-to-tid yarn)
=/ fail-cards (thread-say-fail tid term tang)
=^ cards state (thread-clean yarn)
[(weld fail-cards cards) state]
::
++ thread-done
|= [=yarn =vase]
^- (quip card ^state)
:: %- (slog leaf+"strand {<yarn>} finished" (sell vase) ~)
=/ =tid (yarn-to-tid yarn)
=/ done-cards=(list card)
:~ [%give %fact `/thread-result/[tid] %thread-done vase]
[%give %kick `/thread-result/[tid] ~]
==
=^ cards state (thread-clean yarn)
[(weld done-cards cards) state]
::
++ thread-clean
|= =yarn
^- (quip card ^state)
=/ children=(list ^yarn)
[yarn (get-yarn-children running.state yarn)]
|- ^- (quip card ^state)
?~ children
`state
=^ cards-children state $(children t.children)
=^ cards-our state
=/ =^yarn i.children
=/ =tid (yarn-to-tid yarn)
=: running.state (del-yarn running.state yarn)
tid.state (~(del by tid.state) tid)
==
:_ state
%+ murn ~(tap by wex.bowl)
|= [[=wire =ship =term] [acked=? =path]]
^- (unit card)
?. ?& ?=([%thread @ *] wire)
=(tid i.t.wire)
==
~
`[%pass wire %agent [ship term] %leave ~]
[(welp cards-children cards-our) state]
::
++ convert-bowl
|= [=yarn =bowl:gall]
^- bowl:spider
:* our.bowl
src.bowl
(yarn-to-tid yarn)
(yarn-to-parent yarn)
wex.bowl
sup.bowl
eny.bowl
now.bowl
byk.bowl
==
::
++ yarn-to-tid
|= =yarn
^- tid
=/ nary (flop yarn)
?> ?=([@ *] nary)
i.nary
::
++ yarn-to-parent
|= =yarn
^- (unit tid)
=/ nary (flop yarn)
?> ?=([@ *] nary)
?~ t.nary
~
`i.t.nary
::
++ clean-state
!> ^- clean-slate
state(running (turn (tap-yarn running.state) head))
--

2592
pkg/arvo/app/talk.hoon
View File

File diff suppressed because it is too large Load Diff

252
pkg/arvo/app/test.hoon
View File

@ -1,6 +1,8 @@
/+ default-agent
::
|%
++ test
+$ card card:agent:gall
+$ test
$% [%arvo ~] ::UNIMPLEMENTED
[%marks ~] ::UNIMPLEMENTED
[%cores p=path]
@ -17,39 +19,98 @@
(rap 3 |-([i.b ?~(t.b ~ [a $(b t.b)])]))
::
++ fake-fcgi [%many [%blob *cred:eyre] $+[%n ~] ~]
++ build-core
|= [=disc:ford a=spur b=(list spur)]
^- card
~& >> (flop a)
:* %pass a-core+a
%arvo %f %build
live=|
^- schematic:ford
:- [%core disc %hoon a]
[%$ %cont !>(b)]
==
--
::
=, gall
=, ford
=, format
|_ {bowl $~}
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ peek _~
::
++ report-error
|= [=spur bud=build-result]
^- tang
=/ should-fail (~(get by failing) (flop spur))
?- -.bud
%success
?~ should-fail ~
:~ leaf+"warn: expected failure, {<`tape`u.should-fail>}"
leaf+"warn: built succesfully"
?: ?=(%bake +<.bud)
(sell q.cage.bud)
?> ?=(%core +<.bud)
(sell vase.bud)
==
::
%error
?^ should-fail
~[>[%failed-known `tape`(weld "TODO: " u.should-fail)]<]
(flop message.bud)
++ on-init on-init:def
++ on-save on-save:def
++ on-load on-load:def
++ on-poke
|= [=mark =vase]
:_ this
|^
=+ !<(a=test vase)
?- -.a
%arvo ~|(%stub !!) ::basically double solid?
%hoons ~&((list-hoons p.a ~) ~)
%names ~&((list-names p.a) ~)
%marks ~|(%stub !!) ::TODO restore historical handler
%renders ~&(%all-renderers-are-disabled ~)
%cores
=/ spurs [- +]:(list-hoons p.a skip=(sy /sys /ren /tests ~))
[(build-core [p q]:byk.bowl spurs) ~]
==
::
++ now-beak %_(byk.bowl r [%da now.bowl])
++ list-hoons
|= [under=path skipping=(set spur)] ^- (list spur)
=/ sup (flop under)
~& [%findining-hoons under=under]
|- ^- (list spur)
%- zing
%+ turn
=- (sort ~(tap by -) aor)
dir:.^(arch %cy (en-beam now-beak sup))
|= [a=knot ~] ^- (list spur)
=. sup [a sup]
?: (~(has in skipping) (flop sup))
~&(> [(flop sup) %out-of-scope] ~)
=/ ded (~(get by skip-completely) (flop sup))
?^ ded
~&(> [(flop sup) %skipped `tape`u.ded] ~)
?~ [fil:.^(arch %cy (en-beam now-beak [%hoon sup]))]
^$
~& (flop sup)
[sup ^$]
::
++ list-names
|= a/path ^- (list term)
=/ hon (list-hoons a ~)
%+ turn hon
|= b=spur
(join '-' (slag 1 (flop b)))
::
++ skip-completely
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
:- /ren/run "not meant to be called except on a (different) hoon file"
:- /ren/test-gen "temporarily disabled"
==
--
::
++ made-a-core
|= [=spur @da res=made-result]
:_ +>.$
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-arvo
|= [=wire =sign-arvo]
|^
:_ this
^- (list card)
?. ?=([%a-core *] wire)
(on-arvo:def wire sign-arvo)
?. ?=(%made +<.sign-arvo)
(on-arvo:def wire sign-arvo)
=/ =spur t.wire
=/ res result.sign-arvo
?: ?=([%incomplete *] res)
~& incomplete-core+spur
((slog tang.res) ~)
@ -63,108 +124,41 @@
;; [%success %$ %cont * p=(list ^spur)]
tail.build-result.res
?~ nex ~&(%cores-tested ~)
[ost (build-core nex)]~
::
++ build-core
|= [a=spur b=(list spur)]
~& >> (flop a)
:- %build
:+ a-core+a
live=|
^- schematic:ford
:- [%core now-disc %hoon a]
[%$ %cont !>(b)]
::
++ made-a-rend
|= [=spur @da res=made-result]
:_ +>.$
?> ?=([ren=term ~] spur)
=+ `[ren=term pax=path]`?~(spur !! spur)
?: ?=([%incomplete *] res)
~& incomplete-core+spur
((slog tang.res) ~)
?. ?=([%complete %success *] res)
~& unsuccessful-core+spur
((slog message.build-result.res) ~)
?> ?=(^ +<.build-result.res)
%- (slog (report-error /[ren]/ren head.build-result.res))
=/ nex=(list term)
=< p
;; [%success %$ %cont * p=(list term)]
tail.build-result.res
?~ nex ~&(%rens-tested ~)
[ost (build-rend nex)]~
::
++ build-rend
|= [a=term b=(list term)]
~& >> [%ren a]
:- %build
:+ a-rend+/[a]
live=|
^- schematic:ford
=/ bem=beam (need (de-beam %/example))
=/ =rail [[p q] s]:bem
:- [%bake a fake-fcgi rail]
[%$ %cont !>(b)]
::
++ poke-noun
|= a=test
:_ +>
?- -.a
%arvo ~|(%stub !!) ::basically double solid?
%hoons ~&((list-hoons p.a ~) ~)
%cores [ost (build-core [- +]:(list-hoons p.a skip=(sy /sys /ren /tests ~)))]~
%names ~&((list-names p.a) ~)
%marks ~|(%stub !!) ::TODO restore historical handler
%renders ~&(%all-renderers-are-disabled ~)
==
::
++ list-names
|= a/path ^- (list term)
=/ hon (list-hoons a ~)
%+ turn hon
|= b=spur
(join '-' (slag 1 (flop b)))
::
++ list-hoons
|= [under=path skipping=(set spur)] ^- (list spur)
=/ sup (flop under)
~& [%findining-hoons under=under]
|- ^- (list spur)
%- zing
%+ turn
=- (sort ~(tap by -) aor)
dir:.^(arch %cy (en-beam now-beak sup))
|= [a=knot ~] ^- (list spur)
=. sup [a sup]
?: (~(has in skipping) (flop sup))
~&(> [(flop sup) %out-of-scope] ~)
=/ ded (~(get by skip-completely) (flop sup))
?^ ded
~&(> [(flop sup) %skipped `tape`u.ded] ~)
?~ [fil:.^(arch %cy (en-beam now-beak [%hoon sup]))]
^$
~& (flop sup)
[sup ^$]
::
++ now-beak %_(byk r [%da now])
++ now-disc `disc:ford`[p.byk q.byk]
++ skip-completely
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
:- /ren/run "not meant to be called except on a (different) hoon file"
:- /ren/test-gen "temporarily disabled"
==
::
++ failing
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
[(build-core [p q]:byk.bowl nex) ~]
::
:- /gen/al "compiler types out-of-date"
:- /gen/musk "compiler types out-of-date"
++ report-error
|= [=spur bud=build-result]
^- tang
=/ should-fail (~(get by failing) (flop spur))
?- -.bud
%success
?~ should-fail ~
:~ leaf+"warn: expected failure, {<`tape`u.should-fail>}"
leaf+"warn: built succesfully"
?: ?=(%bake +<.bud)
(sell q.cage.bud)
?> ?=(%core +<.bud)
(sell vase.bud)
==
::
%error
?^ should-fail
~[>[%failed-known `tape`(weld "TODO: " u.should-fail)]<]
(flop message.bud)
==
::
:- /gen/cosmetic "incomplete"
:- /gen/lust "incomplete"
:- /gen/scantastic "incomplete"
==
++ failing
^~ ^- (map path tape)
%- my :~ ::TODO don't hardcode
::
:- /gen/al "compiler types out-of-date"
:- /gen/musk "compiler types out-of-date"
::
:- /gen/cosmetic "incomplete"
:- /gen/lust "incomplete"
:- /gen/scantastic "incomplete"
==
--
::
++ on-fail on-fail:def
--

23
pkg/arvo/app/time.hoon
View File

@ -1,23 +0,0 @@
::
:::: /hoon/time/app
::
/? 310
|%
++ card {$wait wire @da}
--
|_ {bowl:gall ~}
++ poke-noun
|= *
:_ +>.$ :_ ~
[ost %wait /(scot %da now) +(now)]
::
++ wake
|= {wir/wire error=(unit tang)}
?> ?=({@ ~} wir)
?^ error
%- (slog u.error)
~& %time-behn-failed
[~ +>.$]
~& [%took `@dr`(sub now (slav %da i.wir))]
[~ +>.$]
--

205
pkg/arvo/app/weather.hoon
View File

@ -1,4 +1,4 @@
/+ *server
/+ *server, *server, default-agent
/= tile-js
/^ octs
/; as-octs:mimes:html
@ -12,127 +12,139 @@
=, format
::
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%poke wire dock poke]
[%http-response =http-event:http]
[%diff %json json]
[%connect wire binding:eyre term]
[%request wire request:http outbound-config:iris]
[%wait wire @da]
==
+$ poke
$% [%launch-action [@tas path @t]]
==
+$ state
$% [%0 data=json time=@da location=@t timer=(unit @da)]
+$ card card:agent:gall
+$ versioned-state
$% state-zero
==
+$ state-zero [%0 data=json time=@da location=@t timer=(unit @da)]
--
=| state-zero
=* state -
^- agent:gall
=<
|_ bol=bowl:gall
+* this .
weather-core +>
wc ~(. weather-core bol)
def ~(. (default-agent this %|) bol)
++ on-init
:_ this
:~ [%pass /bind/weather %arvo %e %connect [~ /'~weather'] %weather]
:* %pass /launch/weather %agent [our.bol %launch] %poke
%launch-action !>([%weather /weathertile '/~weather/js/tile.js'])
==
==
++ on-save !>(state)
++ on-load
|= old=vase
`this(state !<(state-zero old))
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json
(poke-json:wc !<(json vase))
%handle-http-request
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
:_ state
%+ give-simple-payload:app eyre-id
%+ require-authorization:app inbound-request
poke-handle-http-request:wc
==
[cards this]
::
++ on-watch
|= =wire
^- (quip card _this)
?: ?=([%weathertile ~] wire)
:_ this
[%give %fact ~ %json !>(data)]~
?: ?=([%http-response *] wire)
[~ this]
(on-watch:def wire)
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card:agent:gall _this)
?: ?=(%bound +<.sign-arvo)
[~ this]
?: ?=(%wake +<.sign-arvo)
=^ cards state
(wake:wc wire error.sign-arvo)
[cards this]
?: ?=(%http-response +<.sign-arvo)
=^ cards state
(http-response:wc wire client-response.sign-arvo)
[cards this]
(on-arvo:def wire sign-arvo)
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent on-agent:def
++ on-fail on-fail:def
--
::
|_ [bol=bowl:gall state]
::
++ this .
::
++ bound
|= [wir=wire success=? binding=binding:eyre]
^- (quip move _this)
[~ this]
::
++ prep
|= old=(unit state)
^- (quip move _this)
=/ launcha
[%launch-action [%weather /weathertile '/~weather/js/tile.js']]
:-
:~
[ost.bol %connect / [~ /'~weather'] %weather]
[ost.bol %poke /weather [our.bol %launch] launcha]
==
?~ old
this
%= this
data data.u.old
time time.u.old
==
::
++ peer-weathertile
|= pax=path
^- (quip move _this)
[[ost.bol %diff %json data]~ this]
|_ bol=bowl:gall
::
++ poke-json
|= jon=json
^- (quip move _this)
^- (quip card _state)
?. ?=(%s -.jon)
[~ this]
=/ str/@t +.jon
=/ req/request:http (request-darksky str)
[~ state]
=/ str=@t +.jon
=/ req=request:http (request-darksky str)
=/ out *outbound-config:iris
=/ lismov [ost.bol %request /[(scot %da now.bol)] req out]~
=/ lismov [%pass /[(scot %da now.bol)] %arvo %i %request req out]~
?~ timer
:- [[ost.bol %wait /timer (add now.bol ~h3)] lismov]
%= this
:- [[%pass /timer %arvo %b %wait (add now.bol ~h3)] lismov]
%= state
location str
timer `(add now.bol ~h3)
timer `(add now.bol ~h3)
==
:- lismov
%= this
location str
==
[lismov state(location str)]
::
++ request-darksky
|= location=@t
^- request:http
=/ base
"https://api.darksky.net/forecast/634639c10670c7376dc66b6692fe57ca/"
=/ url/@t %- crip
:(weld base (trip location) "?units=auto")
=/ base 'https://api.darksky.net/forecast/634639c10670c7376dc66b6692fe57ca/'
=/ url=@t (cat 3 (cat 3 base location) '?units=auto')
=/ hed [['Accept' 'application/json']]~
[%'GET' url hed *(unit octs)]
::
++ send-tile-diff
|= jon=json
^- (list move)
%+ turn (prey:pubsub:userlib /weathertile bol)
|= [=bone ^]
[bone %diff %json jon]
::
++ http-response
|= [=wire response=client-response:iris]
^- (quip move _this)
^- (quip card _state)
:: ignore all but %finished
?. ?=(%finished -.response)
[~ this]
=/ data/(unit mime-data:iris) full-file.response
[~ state]
=/ data=(unit mime-data:iris) full-file.response
?~ data
:: data is null
[~ this]
=/ ujon/(unit json) (de-json:html q.data.u.data)
[~ state]
=/ ujon=(unit json) (de-json:html q.data.u.data)
?~ ujon
[~ this]
[~ state]
?> ?=(%o -.u.ujon)
?: (gth 200 status-code.response-header.response)
~& weather+u.ujon
~& weather+location
[~ this]
=/ jon/json %- pairs:enjs:format :~
[~ state]
=/ jon=json %- pairs:enjs:format :~
currently+(~(got by p.u.ujon) 'currently')
daily+(~(got by p.u.ujon) 'daily')
==
:- (send-tile-diff jon)
%= this
:- [%give %fact `/weathertile %json !>(jon)]~
%= state
data jon
time now.bol
==
::
++ poke-handle-http-request
%- (require-authorization:app ost.bol move this)
|= =inbound-request:eyre
^- (quip move _this)
^- simple-payload:http
::
=/ request-line (parse-request-line url.request.inbound-request)
=/ back-path (flop site.request-line)
=/ name=@t
@ -142,28 +154,27 @@
i.back-path
::
?~ back-path
:_ this ~
not-found:gen
?: =(name 'tile')
[[ost.bol %http-response (js-response:app tile-js)]~ this]
(js-response:gen tile-js)
?: (lte (lent back-path) 1)
[[ost.bol %http-response not-found:app]~ this]
not-found:gen
?: =(&2:site.request-line 'img')
=/ img (as-octs:mimes:html (~(got by weather-png) `@ta`name))
[[ost.bol %http-response (png-response:app img)]~ this]
[~ this]
(png-response:gen img)
not-found:gen
::
++ wake
|= [wir=wire err=(unit tang)]
^- (quip move _this)
^- (quip card _state)
?~ err
=/ req/request:http (request-darksky location)
=/ out *outbound-config:iris
:_ this(timer `(add now.bol ~h3))
:~
[ost.bol %request /[(scot %da now.bol)] req out]
[ost.bol %wait /timer (add now.bol ~h3)]
:_ state(timer `(add now.bol ~h3))
:~ [%pass /[(scot %da now.bol)] %arvo %i %request req out]
[%pass /timer %arvo %b %wait (add now.bol ~h3)]
==
~& err
[~ this]
%- (slog u.err)
[~ state]
::
--

6
pkg/arvo/gen/aqua/file.hoon
View File

@ -1,9 +1,11 @@
/- aquarium
=, aquarium
:- %say
|= [* [her=ship pax=path] ~]
|= [* [her=ship pax=path ~] ~]
:- %aqua-events :_ ~
^- aqua-event:aquarium
:+ %event her
?> ?=([@ @ @ *] pax)
=/ file [/text/plain (as-octs:mimes:html .^(@ %cx pax))]
[//sync/0v1n.2m9vh %into i.t.pax | [t.t.t.pax `file]~]~
:- //sync/0v1n.2m9vh
[%into `desk`i.t.pax | `mode:clay`[t.t.t.pax `file]~]

9
pkg/arvo/gen/azimuth-block.hoon Normal file
View File

@ -0,0 +1,9 @@
:: Print most recently seen ethereum block
::
:: Note we require 30 confirmation blocks, so we should expect to have
:: processed only those blocks which are this number minus 30.
::
:- %say
|= [[now=@da *] *]
:- %tang
[>.^(@ud %gx /=eth-watcher/(scot %da now)/block/azimuth-tracker/noun)< ~]

3
pkg/arvo/gen/azimuth-tracker/init.hoon
View File

@ -1,3 +0,0 @@
:- %say
|= [* ~ ~]
[%azimuth-tracker-poke %init ~]

3
pkg/arvo/gen/azimuth-tracker/kick.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= *
[%azimuth-tracker-poke %listen ~ %| %azimuth-tracker]

8
pkg/arvo/gen/azimuth-tracker/watch.hoon
View File

@ -1,7 +1,3 @@
=> |%
+$ config
[url=@ta =from=number:block:able:jael]
--
:- %say
|= [* config ~]
[%azimuth-tracker-poke %watch config]
|= [* [url=@ta ~] ~]
[%azimuth-tracker-poke %watch url]

7
pkg/arvo/gen/dns/auto.hoon
View File

@ -6,7 +6,7 @@
/+ *generators
:- %ask
|= [[now=@da eny=@uvJ bec=beak] ~ ~]
^- (sole-result [%dns-auto (list turf)])
^- (sole-result [%dns-auto ~])
=* our p.bec
=/ rac (clan:title our)
::
@ -23,7 +23,4 @@
%+ print leaf+msg3
%+ print leaf+msg2
(print leaf+msg1 no-product)
::
=/ ames-domains=(list turf)
.^((list turf) %j /(scot %p our)/turf/(scot %da now))
(produce [%dns-auto ames-domains])
(produce [%dns-auto ~])

10
pkg/arvo/gen/group-store/add.hoon Normal file
View File

@ -0,0 +1,10 @@
:: group-store|add: add members to a group
::
/- *group-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=path members=(list ship) ~] ~]
==
:- %group-action
^- group-action
[%add (sy members) path]

10
pkg/arvo/gen/group-store/create.hoon Normal file
View File

@ -0,0 +1,10 @@
:: group-store|create: initialize a group
::
/- *group-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=path ~] ~]
==
:- %group-action
^- group-action
[%bundle path]

10
pkg/arvo/gen/group-store/remove.hoon Normal file
View File

@ -0,0 +1,10 @@
:: group-store|remove: remove members from a group
::
/- *group-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=path members=(list ship) ~] ~]
==
:- %group-action
^- group-action
[%remove (sy members) path]

13
pkg/arvo/gen/hall/load-legacy.hoon
View File

@ -1,13 +0,0 @@
:: Load legacy messages from backup
::
:::: /gen/hall/load-old/hoon
::
/? 310
::
::::
::
:- %say
|= $: {now/@da eny/@uvJ byk/beak}
{{man/knot ~} ~}
==
[%load-legacy man]

13
pkg/arvo/gen/hall/load.hoon
View File

@ -1,13 +0,0 @@
:: Load channel messages from backup
::
:::: /hoon/load/hall/gen
::
/? 310
::
::::
::
:- %say
|= $: {now/@da eny/@uvJ byk/beak}
{{man/knot ~} ~}
==
[%hall-load man]

13
pkg/arvo/gen/hall/log.hoon
View File

@ -1,13 +0,0 @@
:: Enable channel logging to clay
::
:::: /hoon/log/hall/gen
::
/? 310
::
::::
::
:- %say
|= $: {now/@da eny/@uvJ byk/beak}
{{man/knot ~} ~}
==
[%hall-log man]

13
pkg/arvo/gen/hall/save.hoon
View File

@ -1,13 +0,0 @@
:: Save channel messages to backup
::
:::: /hoon/save/hall/gen
::
/? 310
::
::::
::
:- %say
|= $: {now/@da eny/@uvJ byk/beak}
{{man/knot ~} ~}
==
[%hall-save man]

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