urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-01 06:35:32 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into la/graph-store

Browse Source
This commit is contained in:
Logan Allen 2020-07-27 12:10:22 -07:00
commit 325667f9ec
248 changed files with 19282 additions and 13590 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
.travis.yml
View File

@ -1,6 +1,13 @@
stages:
- compile
# Don't run the combine stage in pull requests, because deploy is disabled there.
- name: combine
if: type != pull_request
jobs:
include:
- os: linux
- stage: compile
os: linux
language: nix
nix: 2.3.6
before_install:
@ -15,7 +22,8 @@ jobs:
- make release
- sh/ci-tests
- os: linux
- stage: compile
os: linux
language: generic
env: STACK_YAML=pkg/hs/stack.yaml
cache:
@ -32,7 +40,8 @@ jobs:
- stack test
- sh/release-king-linux64-dynamic
- os: osx
- stage: compile
os: osx
language: generic
sudo: required
env: STACK_YAML=pkg/hs/stack.yaml
@ -50,6 +59,12 @@ jobs:
- stack test
- sh/release-king-darwin-dynamic
- stage: combine
os: linux
language: generic
script:
- sh/combine-release-builds
deploy:
- skip_cleanup: true
provider: gcs

45
MAINTAINERS.md
View File

@ -119,7 +119,7 @@ the network.
Take [this PR][1], as an example. This constituted a great hotfix. It's a
single commit, targeting a problem that existed on the network at the time.
Here's it should be released and deployed OTA.
Here's how it should be released and deployed OTA.
[1]: https://github.com/urbit/urbit/pull/2025
@ -159,15 +159,31 @@ so that I can type e.g. `git mu origin/foo 1337`.
### Prepare a release commit
You should create Landscape or alternative pill builds, if or as appropriate
(i.e., if anything in Landscape changed -- don't trust any compiled JS/CSS
that's included in the commit), and commit these in a release commit.
You should always create a solid pill, in particular, as it's convenient for
tooling to be able to boot directly from a given release.
If you're making a Vere release, just play it safe and update all the pills.
For an Urbit OS release, after all the merge commits, make a release with the
commit message "release: urbit-os-v1.0.xx". This commit should have up-to-date
artifacts from pkg/interface and a new solid pill. If neither the pill nor the
JS need to be updated (e.g if the pill was already updated in the previous merge
commit), consider making the release commit with --allow-empty.
If anything in `pkg/interface` has changed, ensure it has been built and
deployed properly. You'll want to do this before making a pill, since you want
the pill to have the new files/hash. For most things, it is sufficient to run
`npm install; npm run build:prod` in `pkg/interface`.
However, if you've made a change to Landscape's JS, then you will need to build
a "glob" and upload it to bootstrap.urbit.org. To do this, run `npm install;
npm run build:prod` in `pkg/interface`, and add the resulting
`pkg/arvo/app/landscape/index.js` to a fakezod at that path (or just create a
new fakezod with `urbit -F zod -B bin/solid.pill -A pkg/arvo`). Run
`:glob|make`, and this will output a file in `fakezod/.urb/put/glob-0vXXX.glob`.
Upload this file to bootstrap.urbit.org, and modify `+hash` at the top of
`pkg/arvo/app/glob.hoon` to match the hash in the filename. Do not commit the
produced `index.js` and make sure it doesn't end up in your pills (they should
be less than 10MB each).
### Tag the resulting commit
What you should do here depends on the type of release being made.
@ -205,7 +221,7 @@ You can get the "contributions" section by the shortlog between the
last release and this release:
```
git log --pretty=short LAST_RELEASE.. | git shortlog
git shortlog LAST_RELEASE..
```
I originally tried to curate this list somewhat, but now just paste it
@ -264,8 +280,8 @@ separate releases.
(**Note**: the following steps are automated by some other Tlon-internal
tooling. Just ask `~nidsut-tomdun` for details.)
For Urbit OS updates, this means copying the files into ~zod's %base desk. The
changes will be synced to /~zod/kids and then propagated through other galaxies
For Urbit OS updates, this means copying the files into ~zod's %home desk. The
changes should be merged into /~zod/kids and then propagated through other galaxies
and stars to the rest of the network.
For consistency, I create a release tarball and then rsync the files in.
@ -273,9 +289,10 @@ For consistency, I create a release tarball and then rsync the files in.
```
$ wget https://github.com/urbit/urbit/archive/urbit-os-vx.y.z.tar.gz
$ tar xzf urbit-os-vx.y.z.tar.gz
$ herb zod -p hood -d "+hood/mount /=base="
$ rsync -zr --delete urbit-urbit-os-vx.y.z/pkg/arvo/ zod/base
$ herb zod -p hood -d "+hood/commit %base"
$ herb zod -p hood -d "+hood/mount /=home="
$ rsync -zr --delete urbit-urbit-os-vx.y.z/pkg/arvo/ zod/home
$ herb zod -p hood -d "+hood/commit %home"
$ herb zod -p hood -d "+hood/merge %kids our %home"
```
For Vere updates, this means simply shutting down each desired ship, installing

4
bin/brass.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:f738f60e9e028081864f317106f623d2f21a5fe5c2f6fdd83576e22d21a8c6a6
size 14862847
oid sha256:35d8930b9b35364605196d99766ec713154af9105ce7b9fabfaa50e8ca29a5fd
size 4448128

4
bin/ivory.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:9fbfbe75a6685df444621ebd27677716fd0abf7113020f3274c3b5c209e3616e
size 1304972
oid sha256:e5c82dea80aa7c5593f43fa4294db7974211abceedd907663da73889857642e7
size 1309381

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:6614c1334e3e27722a31e0ae41cfda9b5e1915d5fe75daa3a0ec8423a9574bc6
size 16649737
oid sha256:ecf3f8593815742e409008421f318b664124e672b1eecd131e4a1e49864a1c2a
size 6175676

1
nix/cachix/local.nix
View File

@ -13,7 +13,6 @@ let
murmur3-src = deps.murmur3.src;
scrypt-src = deps.scrypt.src;
secp256k1-src = deps.secp256k1.src;
sni-src = deps.sni.src;
softfloat3-src = deps.softfloat3.src;
uv-src = deps.uv.src;
};

7
nix/cachix/tests.nix Normal file
View File

@ -0,0 +1,7 @@
let
ops = import ../ops/default.nix {};
in
{
results = ops.test;
fakebus = ops.bus;
}

1
nix/crossdeps.nix
View File

@ -5,7 +5,6 @@ rec {
murmur3 = import ./deps/murmur3/cross.nix { inherit crossenv; };
uv = import ./deps/uv/cross.nix { inherit crossenv; };
ed25519 = import ./deps/ed25519/cross.nix { inherit crossenv; };
sni = import ./deps/sni/cross.nix { inherit crossenv; };
scrypt = import ./deps/scrypt/cross.nix { inherit crossenv; };
softfloat3 = import ./deps/softfloat3/cross.nix { inherit crossenv; };
secp256k1 = import ./deps/secp256k1/cross.nix { inherit crossenv; };

4
nix/deps-env.nix
View File

@ -10,7 +10,7 @@ let
libs =
with pkgs;
[ openssl zlib curl gmp scrypt libsigsegv ncurses openssl zlib lmdb ];
[ openssl curl gmp scrypt libsigsegv openssl zlib lmdb ];
osx =
with pkgs;
@ -20,7 +20,7 @@ let
vendor =
with deps;
[ argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ent ge-additions ivory-header ca-header ];
[ argon2 ed25519 h2o murmur3 scrypt secp256k1 softfloat3 uv ent ge-additions ivory-header ca-header ];
in

1
nix/deps/default.nix
View File

@ -5,7 +5,6 @@ rec {
murmur3 = import ./murmur3 { inherit pkgs; };
uv = import ./uv { inherit pkgs; };
ed25519 = import ./ed25519 { inherit pkgs; };
sni = import ./sni { inherit pkgs; };
scrypt = import ./scrypt { inherit pkgs; };
softfloat3 = import ./softfloat3 { inherit pkgs; };
secp256k1 = import ./secp256k1 { inherit pkgs; };

13
nix/deps/sni/builder.sh
View File

@ -1,13 +0,0 @@
source $stdenv/setup
CFLAGS="-O3 -Wall -ffast-math -Wno-unused-const-variable"
echo $CC $CFLAGS -c $src/src/tls.c -o tls.o
$CC $CFLAGS -c $src/src/tls.c -o tls.o
echo $AR rcs libsni.a tls.o
$AR rcs libsni.a tls.o
mkdir -p $out/{lib,include}
cp libsni.a $out/lib/
cp $src/src/tls.h $out/include/

18
nix/deps/sni/cross.nix
View File

@ -1,18 +0,0 @@
{ crossenv }:
crossenv.make_derivation rec {
name = "sni";
builder = ./builder.sh;
CC = "${crossenv.host}-gcc";
AR = "${crossenv.host}-ar";
src = crossenv.nixpkgs.fetchFromGitHub {
owner = "urbit";
repo = "sniproxy";
rev = "173beb88ee62bddd13874ca04ab338cdec704928";
sha256 = "1ib6p7vhpvbg6d5a2aimppsb09kjg4px4vlw5h3ys9zf9c1if5z4";
};
}

12
nix/deps/sni/default.nix
View File

@ -1,12 +0,0 @@
{ pkgs }:
pkgs.stdenv.mkDerivation rec {
name = "sni";
builder = ./builder.sh;
src = pkgs.fetchFromGitHub {
owner = "urbit";
repo = "sniproxy";
rev = "173beb88ee62bddd13874ca04ab338cdec704928";
sha256 = "1ib6p7vhpvbg6d5a2aimppsb09kjg4px4vlw5h3ys9zf9c1if5z4";
};
}

4
nix/nixcrpkgs/pkgs.nix
View File

@ -24,10 +24,6 @@ rec {
inherit crossenv;
};
ncurses = import ./pkgs/ncurses {
inherit crossenv;
};
pdcurses = import ./pkgs/pdcurses {
inherit crossenv;
};

3
nix/ops/boot-ship.nix
View File

@ -10,9 +10,10 @@ let
tlon = import ../pkgs { inherit pkgs; };
arvo = tlon.arvo;
urbit = tlon.urbit;
herb = tlon.herb;
in
import ./fakeship {
inherit pkgs tlon deps arvo pill ship debug;
inherit pkgs arvo pill ship urbit herb;
}

8
nix/ops/default.nix
View File

@ -31,16 +31,16 @@ let
ship = "zod";
};
in
rec {
bus = import ./fakeship {
inherit pkgs herb urbit arvo;
pill = bootsolid;
ship = "bus";
};
in
rec {
test = import ./test {
inherit pkgs herb urbit;
ship = bus;

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

@ -13,7 +13,7 @@ check () {
[ 3 -eq "$(herb $out -d 3)" ]
}
if check
if check && sleep 10 && check
then
echo "Boot success." >&2
herb $out -p hood -d '+hood/exit' || true

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

@ -7,13 +7,13 @@ chmod -R u+rw ./pier
$URBIT -d ./pier
cleanup () {
shutdown () {
if [ -e ./pier/.vere.lock ]
then kill $(< ./pier/.vere.lock) || true;
fi
}
trap cleanup EXIT
trap shutdown EXIT
# update pill strategy to ensure correct staging
#
@ -75,6 +75,8 @@ herb ./pier -p hood -d "+hood/unmount %stage"
herb ./pier -P solid.pill -d '+solid /=stage=/sys, =dub &'
herb ./pier -p hood -d '+hood/exit' || true
mv solid.pill $out
set +x

2
nix/pkgs/default.nix
View File

@ -21,7 +21,7 @@ let
mkUrbit = { debug }:
import ./urbit {
inherit pkgs ent debug ge-additions libaes_siv;
inherit (deps) argon2 murmur3 uv ed25519 sni scrypt softfloat3;
inherit (deps) argon2 murmur3 uv ed25519 scrypt softfloat3;
inherit (deps) secp256k1 h2o ivory-header ca-header;
};

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

@ -1,7 +1,7 @@
{
pkgs,
debug,
argon2, ed25519, ent, ge-additions, libaes_siv, h2o, murmur3, scrypt, secp256k1, sni, softfloat3, uv, ivory-header, ca-header
argon2, ed25519, ent, ge-additions, libaes_siv, h2o, murmur3, scrypt, secp256k1, softfloat3, uv, ivory-header, ca-header
}:
let
@ -23,10 +23,10 @@ let
deps =
with pkgs;
[ curl gmp sigseg ncurses openssl zlib lmdb ];
[ curl gmp sigseg openssl zlib lmdb ];
vendor =
[ argon2 softfloat3 ed25519 ent ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 sni ivory-header ca-header ];
[ argon2 softfloat3 ed25519 ent ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 ivory-header ca-header ];
urbit = pkgs.stdenv.mkDerivation {
inherit name meta;

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

@ -12,11 +12,11 @@ let
crossdeps =
with env;
[ curl libgmp libsigsegv ncurses openssl zlib lmdb ];
[ curl libgmp libsigsegv openssl zlib lmdb ];
vendor =
with deps;
[ argon2 softfloat3 ed25519 ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 sni ivory-header ca-header ];
[ argon2 softfloat3 ed25519 ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 ivory-header ca-header ];
in
@ -27,7 +27,6 @@ env.make_derivation {
MEMORY_DEBUG = debug;
CPU_DEBUG = debug;
EVENT_TIME_DEBUG = false;
NCURSES = env.ncurses;
name = "${name}-${env_name}";
exename = name;

1
nix/pkgs/urbit/release.sh
View File

@ -17,6 +17,5 @@ bash ./configure
make build/urbit build/urbit-worker -j8
mkdir -p $out/bin
cp -r $NCURSES/share/terminfo $out/bin/$exename-terminfo
cp ./build/urbit $out/bin/$exename
cp ./build/urbit-worker $out/bin/$exename-worker

2
nix/pkgs/urbit/shell.nix
View File

@ -12,5 +12,5 @@ import ./default.nix {
inherit (tlon)
ent ge-additions libaes_siv;
inherit (deps)
argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ivory-header ca-header;
argon2 ed25519 h2o murmur3 scrypt secp256k1 softfloat3 uv ivory-header ca-header;
}

2
nix/release.nix
View File

@ -33,7 +33,7 @@ let
builds-for-platform = plat:
plat.deps // {
inherit (plat.env) curl libgmp libsigsegv ncurses openssl zlib lmdb;
inherit (plat.env) curl libgmp libsigsegv openssl zlib lmdb;
inherit (plat.env) cmake_toolchain;
ent = ent plat;
ge-additions = ge-additions plat;

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

@ -649,24 +649,24 @@
++ tab-list
^- (list [@t tank])
:~
[%join leaf+";join ~ship/chat-name (glyph)"]
[%leave leaf+";leave ~ship/chat-name"]
[';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 /chat-name ~ships"]
[%banish leaf+";banish /chat-name ~ships"]
[';create' leaf+";create [type] /chat-name (glyph)"]
[';delete' leaf+";delete /chat-name"]
[';invite' leaf+";invite /chat-name ~ships"]
[';banish' leaf+";banish /chat-name ~ships"]
::
[%bind leaf+";bind [glyph] ~ship/chat-name"]
[%unbind leaf+";unbind [glyph]"]
[%what leaf+";what (~ship/chat-name) (glyph)"]
[';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"]
[';settings' leaf+";settings"]
[';set' leaf+";set key (value)"]
[';unset' leaf+";unset key"]
::
[%chats leaf+";chats"]
[%help leaf+";help"]
[';chats' leaf+";chats"]
[';help' leaf+";help"]
==
:: +work: run user command
::

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

@ -98,11 +98,13 @@
[crds old]
=/ [pax=path =ship]
i.syncs
?> ?=(^ pax)
?. =('~' i.pax)
$(syncs t.syncs)
=/ new-path=path
t.pax
=. synced.old
(~(del by synced.old) pax)
=/ new-path=path
?> ?=(^ pax)
?:(=('~' i.pax) t.pax pax)
?. =(ship our.bol)
=. synced.old
(~(put by synced.old) new-path ship)

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

@ -64,7 +64,7 @@
=? cards ?=(^ kick-paths)
:_ cards
[%give %kick kick-paths ~]
$(old [%3 inbox.old])
$(old [%3 inbox])
::
?(%0 %1) $(old (old-to-2 inbox.old))
::

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

@ -15,16 +15,20 @@
+$ versioned-state
$% state-zero
state-one
state-two
state-three
==
::
+$ state-zero [%0 state-base]
+$ state-one [%1 state-base]
+$ state-two [%2 state-base]
+$ state-three [%3 state-base]
+$ state-base
$: =synced
invite-created=_|
==
--
=| state-one
=| state-three
=* state -
%- agent:dbug
%+ verb |
@ -48,15 +52,71 @@
|= old-vase=vase
^- (quip card _this)
=/ old !<(versioned-state old-vase)
?: ?=(%1 -.old)
[~ this(state old)]
=/ upgraded-state
%* . *state-one
synced synced
invite-created invite-created
=| cards=(list card)
|^
|- ^- (quip card _this)
?: ?=(%3 -.old)
[cards this(state old)]
?: ?=(%2 -.old)
%_ $
old [%3 +.old]
::
cards
%+ welp
cards
%- zing
%+ turn
~(tap by synced.old)
|= [=path =ship]
^- (list card)
?. =(ship our.bol)
~
?> ?=([%ship *] path)
:~ (pass-store contacts+t.path %leave ~)
(pass-store contacts+path %watch contacts+path)
==
==
:_ this(state upgraded-state)
[%pass /group %agent [our.bol %group-store] %watch /updates]~
?: ?=(%1 -.old)
%_ $
-.old %2
::
synced.old
%- malt
%+ turn
~(tap by synced.old)
|= [=path =ship]
[ship+path ship]
::
cards
^- (list card)
;: welp
:~ [%pass /group %agent [our.bol %group-store] %leave ~]
[%pass /group %agent [our.bol %group-store] %watch /groups]
==
kick-old-subs
cards
==
==
%_ $
-.old %1
::
cards
:_ cards
[%pass /group %agent [our.bol %group-store] %watch /updates]
==
++ kick-old-subs
=/ paths
%+ turn
~(val by sup.bol)
|=([=ship =path] path)
?~ paths ~
[%give %kick paths ~]~
::
++ pass-store
|= [=wire =task:agent:gall]
^- card
[%pass wire %agent [our.bol %contact-store] task]
--
::
++ on-poke
|= [=mark =vase]
@ -227,6 +287,12 @@
?> ?=(^ wir)
[~ state(synced (~(del by synced) t.wir))]
::
++ migrate
|= wir=wire
^- wire
?> ?=([%contacts @ @ *] wir)
[%contacts %ship t.wir]
::
++ kick
|= wir=wire
^- (list card)
@ -238,6 +304,11 @@
[%pass /group %agent [our.bol %group-store] %watch /groups]~
::
[%contacts @ *]
=/ wir
?: =(%ship i.t.wir)
wir
(migrate wir)
?> ?=([%contacts @ @ *] wir)
?. (~(has by synced) t.wir) ~
=/ =ship (~(got by synced) t.wir)
?: =(ship our.bol)

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

@ -6,6 +6,8 @@
+$ versioned-state
$% state-zero
state-one
state-two
state-three
==
::
+$ rolodex-0 (map path contacts-0)
@ -29,9 +31,17 @@
$: %1
=rolodex
==
+$ state-two
$: %2
=rolodex
==
+$ state-three
$: %3
=rolodex
==
--
::
=| state-one
=| state-three
=* state -
%- agent:dbug
^- agent:gall
@ -47,8 +57,45 @@
++ on-load
|= old-vase=vase
=/ old !<(versioned-state old-vase)
=| cards=(list card)
|-
?: ?=(%3 -.old)
[cards this(state old)]
?: ?=(%2 -.old)
%_ $
-.old %3
::
rolodex.old
=/ def
(~(get by rolodex.old) /ship/~/default)
?~ def
rolodex.old
=. rolodex.old
(~(del by rolodex.old) /ship/~/default)
=. rolodex.old
(~(put by rolodex.old) /~/default u.def)
rolodex.old
==
?: ?=(%1 -.old)
[~ this(state old)]
=/ new-rolodex=^rolodex
%- malt
%+ turn
~(tap by rolodex.old)
|= [=path =contacts]
[ship+path contacts]
%_ $
old [%2 new-rolodex]
::
cards
=/ paths
%+ turn
~(val by sup.bol)
|=([=ship =path] path)
?~ paths cards
:_ cards
[%give %kick paths ~]
==
=/ new-rolodex=^rolodex
%- ~(run by rolodex.old)
|= cons=contacts-0
@ -64,7 +111,7 @@
color.con
~
==
[~ this(state [%1 new-rolodex])]
$(old [%1 new-rolodex])
::
++ on-poke
|= [=mark =vase]

6
pkg/arvo/app/dbug.hoon
View File

@ -492,11 +492,11 @@
++ v-ames
|%
++ peers
(scry (map ship ?(%alien %known)) %a %peers ~)
(scry (map ship ?(%alien %known)) %ax %$ /peers)
::
++ peer
|= who=ship
(scry ship-state:ames %a %peer /(scot %p who))
(scry ship-state:ames %ax %$ /peers/(scot %p who))
::
++ peer-to-json
=, ames
@ -768,7 +768,7 @@
++ v-behn
|%
++ timers
(scry ,(list [date=@da =duct]) %b %timers ~)
(scry ,(list [date=@da =duct]) %bx %$ /debug/timers)
--
::
:: clay

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

@ -683,7 +683,8 @@
~|(%one-argument !!)
=/ res (mule |.((slam q.cay (dy-vase p.i.p.cig))))
?: ?=(%| -.res)
(he-diff(poy ~) %tan p.res) :: TODO: or +dy-rash ?
:: TODO: or +dy-rash ?
(he-diff(poy ~) %tan leaf+"dojo: naked generator failure" p.res)
(dy-hand %noun p.res)
:: normal generator
::
@ -697,7 +698,7 @@
::
=/ wat (mule |.(!<(?(%ask %say) (slot 2 q.cay))))
?: ?=(%| -.wat)
(he-diff(poy ~) %tan p.wat)
(he-diff(poy ~) %tan leaf+"dojo: generator neither %ask nor %say" p.wat)
=- =/ res (mule -)
?: ?=(%| -.res)
(he-diff(poy ~) %tan leaf+"dojo: generator failure" p.res)
@ -811,10 +812,10 @@
%do
=/ gat (dy-eval p.bil)
?: ?=(%| -.gat)
(he-diff(poy ~) %tan p.gat)
(he-diff(poy ~) %tan leaf+"dojo: %do create gate failed" p.gat)
=/ res (mule |.((slam q.p.gat (dy-vase p.q.bil))))
?: ?=(%| -.res)
(he-diff(poy ~) %tan p.res)
(he-diff(poy ~) %tan leaf+"dojo: %do execute failed" p.res)
(dy-hand %noun p.res)
::
%tu
@ -848,7 +849,7 @@
|= =hoon
=/ res (dy-eval hoon)
?: ?=(%| -.res)
(he-diff(poy ~) %tan p.res)
(he-diff(poy ~) %tan leaf+"dojo: hoon expression failed" p.res)
(dy-hand p.res)
:: +dy-eval: run hoon source against the dojo subject
::
@ -975,7 +976,7 @@
+>
?~ p.cit
(he-diff %txt ">=")
(he-diff %tan u.p.cit)
(he-diff %tan leaf+"dojo: app poke failed" u.p.cit)
::
++ he-wool
|= [way=wire =sign:agent:gall]
@ -984,13 +985,13 @@
%poke-ack
?~ p.sign
+>.$
=. +>.$ (he-diff(poy ~) %tan u.p.sign)
=. +>.$ (he-diff(poy ~) %tan leaf+"dojo: thread poke failed" u.p.sign)
(he-card %pass /wool %agent [our.hid %spider] %leave ~)
::
%watch-ack
?~ p.sign
+>.$
(he-diff(poy ~) %tan u.p.sign)
(he-diff(poy ~) %tan leaf+"dojo: thread watch failed" u.p.sign)
::
%fact
?+ p.cage.sign ~|([%dojo-thread-bad-mark-result p.cage.sign] !!)

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

@ -318,7 +318,11 @@
%watch-ack
?~ p.sign
[~ this]
%- (slog leaf+"eth-watcher couldn't start listen to thread" u.p.sign)
%- (slog leaf+"eth-watcher couldn't start listening to thread" u.p.sign)
:: TODO: kill thread that may have started, although it may not
:: have started yet since we get this response before the
:: %start-spider poke is processed
::
[~ (clear-running t.wire)]
::
%kick [~ (clear-running t.wire)]
@ -413,7 +417,7 @@
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card agent:gall)
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
%wake
?. ?=([%timer *] wire) ~& weird-wire=wire [~ this]
=* path t.wire

142
pkg/arvo/app/file-server.hoon
View File

@ -1,14 +1,14 @@
/- srv=file-server
/- srv=file-server, glob
/+ *server, default-agent, verb, dbug
|%
+$ card card:agent:gall
+$ versioned-state
$% state-zero
+$ serving (map url-base=path [=content public=?])
+$ content
$% [%clay =path]
[%glob =glob:glob]
==
::
+$ serving (map url-base=path [clay-base=path public=?])
+$ state-zero
$: %0
+$ state-1
$: %1
=configuration:srv
=serving
==
@ -17,7 +17,7 @@
%+ verb |
%- agent:dbug
::
=| state-zero
=| state-1
=* state -
^- agent:gall
|_ =bowl:gall
@ -33,7 +33,7 @@
%+ turn
^- (list path)
[/ /'~landscape' ~]
|=(pax=path [pax [/app/landscape %.n]])
|=(pax=path [pax [clay+/app/landscape %.n]])
==
:~ (connect /)
(connect /'~landscape')
@ -49,7 +49,32 @@
++ on-load
|= old-vase=vase
^- (quip card _this)
[~ this(state !<(state-zero old-vase))]
|^
=+ !<(old-state=versioned-state old-vase)
=? old-state ?=(%0 -.old-state)
%= old-state
- %1
serving-0
%- ~(run by serving-0.old-state)
|= [=clay=path public=?]
^- [content ?]
[[%clay clay-path] public]
==
?> ?=(%1 -.old-state)
[~ this(state old-state)]
::
+$ versioned-state
$% state-1
state-0
==
::
+$ serving-0 (map url-base=path [=clay=path public=?])
+$ state-0
$: %0
=configuration:srv
=serving-0
==
--
::
++ on-poke
|= [=mark =vase]
@ -75,7 +100,14 @@
?: (~(has by serving) url-base)
~|("url already bound to {<(~(got by serving) url-base.act)>}" !!)
:- [%pass url-base %arvo %e %connect [~ url-base] %file-server]~
this(serving (~(put by serving) url-base [clay-base.act public.act]))
this(serving (~(put by serving) url-base clay+clay-base.act public.act))
::
%serve-glob
=* url-base url-base.act
?: (~(has by serving) url-base)
~|("url already bound to {<(~(got by serving) url-base.act)>}" !!)
:- [%pass url-base %arvo %e %connect [~ url-base] %file-server]~
this(serving (~(put by serving) url-base glob+glob.act public.act))
::
%unserve-dir
:- [%pass url-base.act %arvo %e %disconnect [~ url-base.act]]~
@ -84,9 +116,9 @@
%toggle-permission
?. (~(has by serving) url-base.act)
~|("url is not bound" !!)
=/ [clay-base=path public=?] (~(got by serving) url-base.act)
=/ [=content public=?] (~(got by serving) url-base.act)
:- ~
this(serving (~(put by serving) url-base.act [clay-base !public]))
this(serving (~(put by serving) url-base.act [content !public]))
::
%set-landscape-homepage-prefix
=. landscape-homepage-prefix.configuration prefix.act
@ -133,22 +165,36 @@
|= req-line=request-line
^- [simple-payload:http ?]
=/ pax=path (snoc site.req-line (need ext.req-line))
=/ clay-path=(unit [path ?]) (get-clay-path pax)
?~ clay-path [not-found:gen %.n]
=/ scry-path
:* (scot %p our.bowl)
q.byk.bowl
(scot %da now.bowl)
(lowercase -.u.clay-path)
=/ content=(unit [=content suffix=path public=?]) (get-content pax)
?~ content [not-found:gen %.n]
?- -.content.u.content
%clay
=/ scry-path
:* (scot %p our.bowl)
q.byk.bowl
(scot %da now.bowl)
(lowercase (weld path.content.u.content suffix.u.content))
==
?. .^(? %cu scry-path) [not-found:gen %.n]
=/ file (as-octs:mimes:html .^(@ %cx scry-path))
:_ public.u.content
?+ ext.req-line not-found:gen
[~ %html] (html-response:gen file)
[~ %js] (js-response:gen file)
[~ %css] (css-response:gen file)
[~ %png] (png-response:gen file)
==
?. .^(? %cu scry-path) [not-found:gen %.n]
=/ file (as-octs:mimes:html .^(@ %cx scry-path))
:_ +.u.clay-path
?+ ext.req-line not-found:gen
[~ %html] (html-response:gen file)
[~ %js] (js-response:gen file)
[~ %css] (css-response:gen file)
[~ %png] (png-response:gen file)
::
%glob
=/ data=(unit mime)
(~(get by glob.content.u.content) suffix.u.content)
?~ data
[not-found:gen %.n]
:_ public.u.content
=/ mime-type=@t (rsh 3 1 (crip <p.u.data>))
:: Should maybe inspect to see how long cache should hold
::
[[200 ['content-type' mime-type] max-1-da:gen ~] `q.u.data]
==
::
++ lowercase
@ -162,24 +208,24 @@
char
(add char ^~((sub 'a' 'A')))
::
++ get-clay-path
++ get-content
|= pax=path
^- (unit [path ?])
=/ first-try (match-clay-path pax (~(del by serving) /))
^- (unit [content path ?])
=/ first-try (match-content-path pax (~(del by serving) /))
?^ first-try first-try
=/ root (~(get by serving) /)
?~ root ~
(match-clay-path pax (~(gas by *^serving) [[/ u.root] ~]))
(match-content-path pax (~(gas by *^serving) [[/ u.root] ~]))
::
++ match-clay-path
++ match-content-path
|= [pax=path =^serving]
^- (unit [path ?])
^- (unit [content path ?])
%- ~(rep by serving)
|= [[url-base=path clay-base=path public=?] out=(unit [path ?])]
|= [[url-base=path =content public=?] out=(unit [content path ?])]
?^ out out
=/ suf (get-suffix url-base pax)
?~ suf ~
`[(weld clay-base u.suf) public]
`[content u.suf public]
::
++ get-suffix
|= [a=path b=path]
@ -218,11 +264,33 @@
?+ +<.sign (on-arvo:def wire sign)
%bound
?: accepted.sign [~ this]
~& [dap.bowl %failed-to-bind path.binding.sign]
[~ this(serving (~(del by serving) path.binding.sign))]
==
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-peek
|= =path
^- (unit (unit cage))
|^
?+ path (on-peek:def path)
[%x %clay %base %hash ~] ``hash+!>(base-hash)
==
:: stolen from +trouble
:: TODO: move to a lib?
++ base-hash
^- @uv
=+ .^ ota=(unit [=ship =desk =aeon:clay])
%gx /(scot %p our.bowl)/hood/(scot %da now.bowl)/kiln/ota/noun
==
?~ ota
*@uv
=/ parent (scot %p ship.u.ota)
=+ .^(=cass:clay %cs /[parent]/[desk.u.ota]/1/late/foo)
%^ end 3 3
.^(@uv %cz /[parent]/[desk.u.ota]/(scot %ud ud.cass))
--
++ on-agent on-agent:def
++ on-fail on-fail:def
--

187
pkg/arvo/app/glob.hoon Normal file
View File

@ -0,0 +1,187 @@
/- glob
/+ default-agent, verb, dbug
|%
++ hash 0v5.knd3c.vvtvt.h0gg0.8qcau.8iii4
+$ state-0 [%0 hash=@uv glob=(unit (each glob:glob tid=@ta))]
+$ all-states
$% state-0
==
+$ card card:agent:gall
--
|%
++ wait-timeout
|= [=path now=@da]
^- card
[%pass [%timer path] %arvo %b %wait (add now ~m30)]
::
++ wait-start
|= now=@da
^- card
[%pass /start %arvo %b %wait now]
::
++ poke-file-server
|= [our=@p =cage]
^- card
[%pass /serving/(scot %uv hash) %agent [our %file-server] %poke cage]
::
++ 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 ~]
--
=| state=state-0
=. hash.state hash
=/ serve-path=path /'~landscape'/js/index
^- agent:gall
%+ verb |
%- agent:dbug
^- agent:gall
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
++ on-init
^- (quip card _this)
:: delay through timer to make sure %spider has started
[[(wait-start now.bowl) ~] this]
::
++ on-save !>(state)
++ on-load
|= old-state=vase
^- (quip card _this)
~& > %initting
=+ !<(old=all-states old-state)
?> ?=(%0 -.old)
?~ glob.old
on-init
?: ?=(%& -.u.glob.old)
?: =(hash.old hash.state)
`this(state old)
on-init
=/ cancel-cards
=/ args [tid.p.u.glob.old &]
:~ (leave-spider /(scot %uv hash.old) our.bowl)
(poke-spider /(scot %uv hash.old) our.bowl %spider-stop !>(args))
==
=^ init-cards this on-init
[(weld cancel-cards init-cards) this]
::
++ on-poke
|= [=mark =vase]
^- (quip card _this)
?+ mark (on-poke:def mark vase)
%glob-make
:_ this
=/ home=path /(scot %p our.bowl)/home/(scot %da now.bowl)
=+ .^(=tube:clay %cc (weld home /js/mime))
=+ .^(js=@t %cx (weld home /app/landscape/js/index/js))
=+ !<(=mime (tube !>(js)))
=/ =glob:glob (~(put by *glob:glob) /js mime)
=/ =path /(cat 3 'glob-' (scot %uv (sham glob)))/glob
[%pass /make %agent [our.bowl %hood] %poke %drum-put !>([path (jam glob)])]~
::
%noun
?: =(%kick q.vase)
(on-load !>(state(hash *@uv)))
(on-poke:def mark vase)
==
::
++ on-watch on-watch:def
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-agent
|= [=wire =sign:agent:gall]
^- (quip card _this)
?: ?=([%serving @ ~] wire)
(on-agent:def wire sign)
?: ?=([%make ~] wire)
(on-agent:def wire sign)
?. ?=([%running @ ~] wire)
%- (slog leaf+"glob: strange on-agent! {<wire -.sign>}" ~)
(on-agent:def wire sign)
?- -.sign
%poke-ack
?~ p.sign
[~ this]
%- (slog leaf+"glob: couldn't start thread; will retry" u.p.sign)
:_ this(glob.state ~) :_ ~
(leave-spider t.wire our.bowl)
::
%watch-ack
?~ p.sign
[~ this]
%- (slog leaf+"glob: couldn't listen to thread; will retry" u.p.sign)
[~ this(glob.state ~)]
::
%kick
=? glob.state ?=([~ %| *] glob.state)
~
`this
::
%fact
=/ produced-hash (slav %uv i.t.wire)
?. =(hash.state produced-hash)
[~ this]
?+ p.cage.sign (on-agent:def wire sign)
%thread-fail
=+ !<([=term =tang] q.cage.sign)
%- (slog leaf+"glob: thread failed; will retry" leaf+<term> tang)
[~ this(glob.state ~)]
::
%thread-done
=+ !<(=glob:glob q.cage.sign)
?. =(hash.state (sham glob))
%: mean
leaf+"glob: hash doesn't match!"
>expected=hash.state<
>got=(sham glob)<
~
==
:_ this(glob.state `[%& glob]) :_ ~
%+ poke-file-server our.bowl
[%file-server-action !>([%serve-glob serve-path glob %&])]
==
==
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?: ?=([%start ~] wire)
=/ new-tid=@ta (cat 3 'glob--' (scot %uv eny.bowl))
=/ args [~ `new-tid %glob !>([hash.state ~])]
=/ action !>([%unserve-dir serve-path])
:_ this(glob.state `[%| new-tid])
:~ (poke-file-server our.bowl %file-server-action action)
(wait-timeout /[new-tid] now.bowl)
(watch-spider /(scot %uv hash.state) our.bowl /thread-result/[new-tid])
(poke-spider /(scot %uv hash.state) our.bowl %spider-start !>(args))
==
?. ?=([%timer @ ~] wire)
%- (slog leaf+"glob: strange on-arvo wire: {<wire [- +<]:sign-arvo>}" ~)
`this
?. ?=(%wake +<.sign-arvo)
%- (slog leaf+"glob: strange on-arvo sign: {<wire [- +<]:sign-arvo>}" ~)
`this
?: ?=([~ %& *] glob.state)
`this
?. ?| ?=(~ glob.state)
=(i.t.wire tid.p.u.glob.state)
==
`this
?^ error.sign-arvo
%- (slog leaf+"glob: timer handling failed; will retry" ~)
[[(wait-timeout t.wire now.bowl)]~ this]
%- (slog leaf+"glob: timed out; retrying" ~)
(on-load !>(state(hash *@uv)))
::
++ on-fail on-fail:def
--

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

@ -50,11 +50,15 @@
%0
:_ this(state *state-one)
|^
%+ turn
%+ murn
~(tap by synced.old)
|= [=path host=ship]
^- card
^- (unit card)
?> ?=([@ @ *] path)
:: ignore duplicate publish groups
?: =(4 (lent path))
~& "ignoring: {<path>}"
~
=/ pax=^path
?: =('~' i.path)
t.path
@ -65,8 +69,8 @@
(slav %p i.pax)
[ship i.t.pax]
?: =(our.bowl host)
(add-push rid)
(add-pull rid host)
`(add-push rid)
`(add-pull rid host)
::
++ poke-our
|= [app=term =cage]

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

@ -75,7 +75,9 @@
?: ?=(%1 -.old)
`this(state old)
|^
:- ~[kick-all]
:- :~ [%pass / %agent [our.bowl dap.bowl] %poke %noun !>(%perm-upgrade)]
kick-all
==
=* paths ~(key by groups.old)
=/ [unmanaged=(list path) managed=(list path)]
(skid ~(tap in paths) |=(=path =('~' (snag 0 path))))
@ -102,7 +104,7 @@
^+ groups
?~ paths
groups
?: =(/~/default i.paths)
?: |(=(/~/default i.paths) =(4 (lent i.paths)))
$(paths t.paths)
=/ [=resource =group]
(migrate-unmanaged i.paths)
@ -124,18 +126,16 @@
++ migrate-unmanaged
|= pax=path
^- [resource group]
=/ =group:state-zero:store
=/ members=(set ship)
(~(got by groups.old) pax)
=/ [=policy members=(set ship)]
(unmanaged-permissions pax)
=. members
(~(uni in members) group)
=| =invite:policy
?> ?=(^ pax)
=/ rid=resource
(resource-from-old-path t.pax)
=/ =tags
(~(put ju *tags) %admin entity.rid)
[rid members tags policy %.y]
:- rid
[members tags invite %.y]
::
++ resource-from-old-path
|= pax=path
@ -145,66 +145,17 @@
(slav %p i.pax)
[ship i.t.pax]
::
++ unmanaged-permissions
|= pax=path
^- [policy (set ship)]
=/ perm
~| pax
(scry-group-permissions pax)
?~ perm
[*invite:policy ~]
?: ?=(%black kind.u.perm)
:- [%open ~ who.u.perm]
~
:_ who.u.perm
*invite:policy
::
++ migrate-group
++ migrate-group
|= pax=path
=/ members
(~(got by groups.old) pax)
=^ =policy members
(migrate-permissions pax members)
=| =invite:policy
=/ rid=resource
(resource-from-old-path pax)
=/ =tags
(~(put ju *tags) %admin entity.rid)
[rid members tags policy %.n]
[rid members tags invite %.n]
::
++ migrate-permissions
|= [pax=path ships=(set ship)]
^- [policy (set ship)]
=/ perm
(scry-group-permissions pax)
?~ perm
[*invite:policy ships]
?> ?=(%white kind.u.perm)
[[%invite ~] (~(uni in ships) who.u.perm)]
::
++ scry-unmanaged-groups
^- (set path)
.^ (set path)
%gx
(scot %p our.bowl)
%permission-store
(scot %da now.bowl)
/keys/noun
==
::
++ scry-group-permissions
|= pax=path
^- (unit permission:permission-store)
.^ (unit permission:permission-store)
%gx
(scot %p our.bowl)
%permission-store
(scot %da now.bowl)
;: weld
/permission
pax
/noun
==
==
--
::
++ on-poke
@ -212,9 +163,13 @@
^- (quip card _this)
?> (team:title our.bowl src.bowl)
=^ cards state
?: ?=(?(%group-update %group-action) mark)
?+ mark (on-poke:def mark vase)
%noun (poke-noun:gc vase)
::
?(%group-update %group-action)
(poke-group-update:gc !<(update:store vase))
(on-poke:def mark vase)
::
==
[cards this]
::
++ on-watch
@ -286,6 +241,92 @@
(~(has in ban-ranks.policy) (clan:title ship))
==
==
++ poke-noun
|= =vase
^- (quip card _state)
=/ noun
!<(%perm-upgrade vase)
|^
=/ perms=(list path)
~(tap in scry-permissions)
|-
?~ perms
`state
=* pax i.perms
?> ?=(^ pax)
?: |(!=('~' i.pax) =(4 (lent pax)))
$(perms t.perms)
=/ rid=resource
(make-rid t.pax)
=/ perm
(scry-group-permissions pax)
?~ perm
$(perms t.perms)
?: (~(has by groups) rid)
%_ $
perms t.perms
::
groups
%+ ~(jab by groups) rid
(update-existing u.perm)
==
%_ $
perms t.perms
::
groups
%+ ~(put by groups) rid
(add-new u.perm)
==
++ make-rid
|= =path
^- resource
?> ?=([@ @ *] path)
:- (slav %p i.path)
i.t.path
::
++ add-new
|= =permission:permission-store
^- group
?: ?=(%black kind.permission)
[~ ~ [%open ~ who.permission] %.y]
[who.permission ~ [%invite ~] %.y]
::
++ update-existing
|= =permission:permission-store
|= =group
^+ group
?: ?=(%black kind.permission)
group
?> ?=(%invite -.policy.group)
%_ group
members (~(uni in members.group) who.permission)
==
::
++ scry-permissions
^- (set path)
.^ (set path)
%gx
(scot %p our.bol)
%permission-store
(scot %da now.bol)
/keys/noun
==
::
++ scry-group-permissions
|= pax=path
^- (unit permission:permission-store)
.^ (unit permission:permission-store)
%gx
(scot %p our.bol)
%permission-store
(scot %da now.bol)
;: weld
/permission
pax
/noun
==
==
--
::
++ poke-group-update
|= =update:store

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

@ -7,9 +7,17 @@
helm=state:helm
kiln=state:kiln
==
+$ state-7
$: %7
drum=state:drum
helm=state:helm
kiln=state:kiln
==
+$ any-state
$% state
state-7
[ver=?(%1 %2 %3 %4 %5 %6) lac=(map @tas fin-any-state)]
[%7 drum=state:drum helm=state:helm kiln=state:kiln]
==
+$ any-state-tuple
$: drum=any-state:drum
@ -41,7 +49,6 @@
++ on-leave on-leave:def
++ on-peek
|= =path
~& peeking=path
^- (unit (unit cage))
?+ path (on-peek:def path)
[* %kiln *] (on-peek:kiln-core path)

9
pkg/arvo/app/landscape/js/channel.js
View File

@ -9,6 +9,9 @@ class Channel {
this.onChannelError = (err) => {
console.error('event source error: ', err);
};
this.onChannelOpen = (e) => {
console.log('open', e);
};
}
init() {
@ -58,6 +61,10 @@ class Channel {
this.onChannelError = onError;
}
setOnChannelOpen(onOpen = (e) => {}) {
this.onChannelOpen = onOpen;
}
deleteOnUnload() {
window.addEventListener("unload", (event) => {
this.delete();
@ -216,6 +223,8 @@ class Channel {
}
}
this.eventSource.onopen = this.onChannelOpen;
this.eventSource.onerror = e => {
this.delete();
this.init();

351
pkg/arvo/app/landscape/js/index.js
View File

File diff suppressed because one or more lines are too long

19
pkg/arvo/app/metadata-hook.hoon
View File

@ -10,14 +10,19 @@
+$ card card:agent:gall
+$ versioned-state
$% state-zero
state-one
==
::
+$ state-zero
$: %0
synced=(map group-path ship)
==
+$ state-one
$: %1
synced=(map group-path ship)
==
--
=| state-zero
=| state-one
=* state -
%- agent:dbug
%+ verb |
@ -32,7 +37,17 @@
[[%pass /updates %agent [our.bowl %metadata-store] %watch /updates]~ this]
::
++ on-save !>(state)
++ on-load |=(=vase `this(state !<(state-zero vase)))
++ on-load
|= =vase
=/ old
!<(versioned-state vase)
?: ?=(%1 -.old)
`this(state old)
:: groups OTA did not migrate metadata syncs
:: we clear our syncs, and wait for metadata-store
:: to poke us with the syncs
`this
::
++ on-leave on-leave:def
++ on-peek on-peek:def
++ on-arvo on-arvo:def

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

@ -21,8 +21,8 @@
:: /app-name/%app-name associations for app
:: /group/%group-path associations for group
::
/- *metadata-store
/+ *metadata-json, default-agent, verb, dbug
/- *metadata-store, *metadata-hook
/+ *metadata-json, default-agent, verb, dbug, resource
|%
+$ card card:agent:gall
::
@ -44,13 +44,19 @@
state-base
==
::
+$ state-two
$: %2
state-base
==
::
+$ versioned-state
$% state-zero
state-one
state-two
==
--
::
=| state-one
=| state-two
=* state -
%+ verb |
%- agent:dbug
@ -69,9 +75,26 @@
^- (quip card _this)
=/ old
!<(versioned-state vase)
?: ?=(%1 -.old)
`this(state old)
=| cards=(list card)
|-
|^
?: ?=(%2 -.old)
[cards this(state old)]
?: ?=(%1 -.old)
%_ $
old [%2 +.old]
::
cards
%+ turn
~(tap in ~(key by group-indices.old))
|= =group-path
^- card
=/ rid=resource
(de-path:resource group-path)
?: =(our.bowl entity.rid)
(poke-md-hook %add-owned group-path)
(poke-md-hook %add-synced entity.rid group-path)
==
=/ new-state=state-one
%* . *state-one
associations (migrate-associations associations.old)
@ -79,7 +102,15 @@
app-indices (migrate-app-indices app-indices.old)
resource-indices (migrate-resource-indices resource-indices.old)
==
`this(state new-state)
$(old new-state)
::
++ poke-md-hook
|= act=metadata-hook-action
^- card
=/ =cage
:_ !>(act)
%metadata-hook-action
[%pass / %agent [our.bowl %metadata-hook] %poke cage]
::
++ new-group-path
|= =group-path
@ -96,9 +127,11 @@
++ migrate-md-resource
|= md-resource
^- md-resource
?. =(%chat app-name)
[app-name app-path]
[%chat (new-app-path app-path)]
?: =(%chat app-name)
[%chat (new-app-path app-path)]
?: =(%contacts app-name)
[%contacts ship+app-path]
[app-name app-path]
::
++ migrate-resource-indices
|= resource-indices=(jug md-resource group-path)
@ -120,9 +153,11 @@
%- ~(run in indices)
|= [=group-path =app-path]
:- (new-group-path group-path)
?. =(%chat app)
app-path
(new-app-path app-path)
?: =(%chat app)
(new-app-path app-path)
?: =(%contacts app)
ship+app-path
app-path
::
++ migrate-group-indices
|= group-indices=(jug group-path md-resource)

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

@ -230,6 +230,15 @@
?: =('~' i.writers.prev)
t.writers.prev
writers.prev
::
subscribers
?> ?=(^ subscribers.prev)
:- %ship
%+ scag 2
?: =('~' i.subscribers.prev)
t.subscribers.prev
subscribers.prev
==
::
++ convert-comment-2-3

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

@ -42,8 +42,10 @@
?. ?=([%all ~] wire) (on-watch:def wire)
=/ jon
%- pairs:enjs:format
:~ [%weather data]
[%location s+location]
:* ['location' s+location]
::
?. ?=([%o *] data) ~
~(tap by p.data)
==
:_ this
[%give %fact ~ %json !>(jon)]~

3
pkg/arvo/gen/glob/make.hoon Normal file
View File

@ -0,0 +1,3 @@
:- %say
|= *
[%glob-make ~]

30
pkg/arvo/gen/solid.hoon
View File

@ -69,13 +69,37 @@
|= [ovo=ovum ken=*]
[~ (slum ken [now ovo])]
::
:: our boot-ova is a list containing one massive formula:
:: boot-one: lifecycle formula (from +brass)
::
=/ boot-one
=> [boot-formula=** full-sequence=**]
!= =+ [state-gate main-sequence]=.*(full-sequence boot-formula)
|-
?@ main-sequence
state-gate
%= $
main-sequence +.main-sequence
state-gate .*(state-gate [%9 2 %10 [6 %1 -.main-sequence] %0 1])
==
::
:: kernel-formula
::
:: We evaluate :arvo-formula (for jet registration),
:: then ignore the result and produce :installed
:: then ignore the result and produce .installed
::
=/ kernel-formula
[%7 arvo-formula %1 installed]
::
:: boot-two: startup formula
::
=/ boot-two
=> [kernel-formula=** main-sequence=**]
!= [.*(0 kernel-formula) main-sequence]
::
:: boot-ova
::
=/ boot-ova=(list)
[[%7 arvo-formula %1 installed] ~]
[boot-one boot-two kernel-formula ~]
::
:: a pill is a 3-tuple of event-lists: [boot kernel userspace]
::

8
pkg/arvo/gen/timers.hoon
View File

@ -1,5 +1,9 @@
:: Find list of currently running Behn timers
:- %say
|= [[now=@da eny=@uvJ bec=beak] ~ ~]
:- %tang
[>.^((list [date=@da =duct]) %b (en-beam:format [p.bec %timers r.bec] /))< ~]
=; timers
[%tang >timers< ~]
.^ (list [date=@da =duct])
%bx
(en-beam:format [p.bec %$ r.bec] /debug/timers)
==

7
pkg/arvo/gen/trouble.hoon
View File

@ -10,6 +10,7 @@
[%base-hash base-hash]
[%home-hash .^(@uv %cz (pathify ~.home ~))]
[%kids-hash .^(@uv %cz (pathify ~.kids ~))]
[%glob-hash glob-state]
::
(info %our our)
(info %sponsor sponsor)
@ -51,4 +52,10 @@
=/ parent (scot %p ship.u.ota)
=+ .^(=cass:clay %cs /[parent]/[desk.u.ota]/1/late/foo)
.^(@uv %cz /[parent]/[desk.u.ota]/(scot %ud ud.cass))
::
++ glob-state
^- [@uv @tas]
=< [hash ?~(glob %waiting ?:(-.u.glob %done %trying))]
!< [@ud hash=@uv glob=(unit [? *])]
.^(vase %gx (weld (pathify ~.glob ~) /dbug/state/noun))
--

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

@ -103,6 +103,7 @@
%metadata-hook
%s3-store
%file-server
%glob
%graph-store
%graph-push-hook
%graph-pull-hook
@ -231,6 +232,8 @@
=? ..on-load (lte hood-version %5)
(se-born | %home %file-server)
=? ..on-load (lte hood-version %7)
(se-born | %home %glob)
=? ..on-load (lte hood-version %8)
=> (se-born | %home %group-push-hook)
(se-born | %home %group-pull-hook)
..on-load

2
pkg/arvo/lib/hood/helm.hoon
View File

@ -35,7 +35,7 @@
?~(caz this $(caz t.caz, this (emit i.caz)))
::
++ on-load
|= [hood-version=?(%1 %2 %3 %4 %5 %6 %7 %8) old=any-state]
|= [hood-version=@ud old=any-state]
=< abet
=? old ?=(%0 -.old) (state-0-to-1 old)
?> ?=(%1 -.old)

2
pkg/arvo/lib/hood/kiln.hoon
View File

@ -77,7 +77,7 @@
~[leaf+"from {<sud>}" leaf+"on {<who>}" leaf+"to {<syd>}"]
::
++ on-load
|= [hood-version=?(%1 %2 %3 %4 %5 %6 %7 %8) old=any-state]
|= [hood-version=@ud old=any-state]
=< abet
=? . ?=(%0 -.old)
=/ recognized-ota=(unit [syd=desk her=ship sud=desk])

1
pkg/arvo/lib/pull-hook.hoon
View File

@ -224,6 +224,7 @@
==
++ add
|= [=ship =resource]
~| resource
?< (~(has by tracking) resource)
=. tracking
(~(put by tracking) resource ship)

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

@ -205,7 +205,7 @@
=/ wire
(make-wire /store)
:_ state
[%pass wire %agent [our.bowl %group-store] %poke update-mark.config vase]~
[%pass wire %agent [our.bowl store-name.config] %poke update-mark.config vase]~
::
++ poke-hook-action
|= =action

12
pkg/arvo/lib/strandio.hoon
View File

@ -366,14 +366,20 @@
?> ?=(^ full-file.client-response)
(pure:m q.data.u.full-file.client-response)
::
++ fetch-json
++ fetch-cord
|= url=tape
=/ m (strand ,json)
=/ m (strand ,cord)
^- form:m
=/ =request:http [%'GET' (crip url) ~ ~]
;< ~ bind:m (send-request request)
;< =client-response:iris bind:m take-client-response
;< =cord bind:m (extract-body client-response)
(extract-body client-response)
::
++ fetch-json
|= url=tape
=/ m (strand ,json)
^- form:m
;< =cord bind:m (fetch-cord url)
=/ json=(unit json) (de-json:html cord)
?~ json
(strand-fail %json-parse-error ~)

14
pkg/arvo/mar/hash.hoon Normal file
View File

@ -0,0 +1,14 @@
|_ hash=@uv
::
++ grad %noun
++ grow
|%
++ noun hash
++ json
s+(rsh 3 2 (scot %uv hash))
--
++ grab
|%
++ noun @uv
--
--

2
pkg/arvo/mar/publish/comment.hoon
View File

@ -59,7 +59,7 @@
old-parser
==
--
++ noun comment
++ noun ?(comment-2 comment-3)
--
++ grad %mime
--

2
pkg/arvo/sur/file-server.hoon
View File

@ -1,6 +1,8 @@
/- glob
|%
+$ action
$% [%serve-dir url-base=path clay-base=path public=?]
[%serve-glob url-base=path =glob:glob public=?]
[%unserve-dir url-base=path]
[%toggle-permission url-base=path]
[%set-landscape-homepage-prefix prefix=(unit term)]

3
pkg/arvo/sur/glob.hoon Normal file
View File

@ -0,0 +1,3 @@
|%
+$ glob (map path mime)
--

2
pkg/arvo/sys/arvo.hoon
View File

@ -190,7 +190,7 @@
?. ?=({@ @ @ @ *} u.pux) ~
=+ :* hyr=(slaw %tas i.u.pux)
fal=(slaw %p i.t.u.pux)
dyc=(slaw %tas i.t.t.u.pux)
dyc=?~(i.t.t.u.pux (some %$) (slaw %tas i.t.t.u.pux))
ved=(slay i.t.t.t.u.pux)
tyl=t.t.t.t.u.pux
==

75
pkg/arvo/sys/vane/ames.hoon
View File

@ -738,42 +738,72 @@
--
:: +scry: dereference namespace
::
:: The ones producing vases are expected to be used like this:
::
:: &tang [(sell .^(vase %a /=peer=/~zod)) ~]
::
++ scry
|= [fur=(unit (set monk)) ren=@tas why=shop syd=desk lot=coin tyl=path]
^- (unit (unit cage))
?. =(lot [%$ %da now]) ~
?. =(%$ ren) [~ ~]
?. =([%& our] why)
[~ ~]
?: =(tyl /whey)
::TODO don't special-case whey scry
::
?: &(=(%$ ren) =(tyl /whey))
=/ maz=(list mass)
=+ [known alien]=(skid ~(val by peers.ames-state) |=(^ =(%known +<-)))
:~ peers-known+&+known
peers-alien+&+alien
==
``mass+!>(maz)
?+ syd ~
%peers
?^ tyl [~ ~]
:: only respond for the local identity, %$ desk, current timestamp
::
?. ?& =(&+our why)
=([%$ %da now] lot)
=(%$ syd)
==
~
:: /ax/protocol/version @
:: /ax/peers (map ship ?(%alien %known))
:: /ax/peers/[ship] ship-state
:: /ax/peers/[ship]/forward-lane (list lane)
:: /ax/bones/[ship] [snd=(set bone) rcv=(set bone)]
:: /ax/snd-bones/[ship]/[bone] vase
::
?. ?=(%x ren) ~
?+ tyl ~
[%protocol %version ~]
``noun+!>(protocol-version)
::
[%peers ~]
:^ ~ ~ %noun
!> ^- (map ship ?(%alien %known))
(~(run by peers.ames-state) head)
::
%peer
?. ?=([@ ~] tyl) [~ ~]
=/ who (slaw %p i.tyl)
[%peers @ *]
=/ who (slaw %p i.t.tyl)
?~ who [~ ~]
?~ peer=(~(get by peers.ames-state) u.who)
[~ ~]
``noun+!>(u.peer)
?+ t.t.tyl [~ ~]
~ ``noun+!>(u.peer)
::
[%forward-lane ~]
:: find lane for u.who, or their galaxy
::
:^ ~ ~ %noun
!> ^- (list lane)
=/ ship-state (~(get by peers.ames-state) u.who)
?. ?=([~ %known *] ship-state)
~
=/ peer-state +.u.ship-state
?. =(~ route.peer-state) ::NOTE avoid tmi
[lane:(need route.peer-state)]~
|- ^- (list lane)
?: ?=(%czar (clan:title sponsor.peer-state))
[%& sponsor.peer-state]~
=/ next (~(get by peers.ames-state) sponsor.peer-state)
?. ?=([~ %known *] next)
~
$(peer-state +.u.next)
==
::
%bones
?. ?=([@ ~] tyl) [~ ~]
=/ who (slaw %p i.tyl)
[%bones @ ~]
=/ who (slaw %p i.t.tyl)
?~ who [~ ~]
=/ per (~(get by peers.ames-state) u.who)
?. ?=([~ %known *] per) [~ ~]
@ -782,11 +812,10 @@
[snd=~(key by snd) rcv=~(key by rcv)]
``noun+!>(res)
::
%snd-bone
?. ?=([@ @ ~] tyl) [~ ~]
=/ who (slaw %p i.tyl)
[%snd-bones @ @ ~]
=/ who (slaw %p i.t.tyl)
?~ who [~ ~]
=/ ost (slaw %ud i.t.tyl)
=/ ost (slaw %ud i.t.t.tyl)
?~ ost [~ ~]
=/ per (~(get by peers.ames-state) u.who)
?. ?=([~ %known *] per) [~ ~]

58
pkg/arvo/sys/vane/behn.hoon
View File

@ -75,9 +75,9 @@
:: Useful if you want to continue working after other moves finish.
::
++ huck
|= mov=vase
|= syn=sign-arvo
=< [moves state]
event-core(moves [duct %give %meta mov]~)
event-core(moves [duct %give %heck syn]~)
:: +drip: XX
::
++ drip
@ -286,7 +286,7 @@
%crud (crud:event-core [p q]:task)
%rest (rest:event-core date=p.task)
%drip (drip:event-core move=p.task)
%huck (huck:event-core move=p.task)
%huck (huck:event-core syn.task)
%trim trim:event-core
%vega vega:event-core
%wait (wait:event-core date=p.task)
@ -378,23 +378,63 @@
++ scry
|= [fur=(unit (set monk)) ren=@tas why=shop syd=desk lot=coin tyl=path]
^- (unit (unit cage))
::TODO don't special-case whey scry
::
?. ?=(%& -.why)
~
?: &(=(ren %$) =(tyl /whey))
=/ maz=(list mass)
:~ timers+&+timers.state
==
``mass+!>(maz)
?. ?=(%timers syd)
[~ ~]
=/ tiz=(list [@da duct])
:: only respond for the local identity, %$ desk, current timestamp
::
?. ?& =(&+our why)
=([%$ %da now] lot)
=(%$ syd)
==
~
:: /bx/debug/timers (list [@da duct]) all timers and their ducts
:: /bx/timers (list @da) all timer timestamps
:: /bx/timers/next (unit @da) the very next timer to fire
:: /bx/timers/[da] (list @da) all timers up to and including da
::
?. ?=(%x ren) ~
?+ tyl [~ ~]
[%debug %timers ~]
:^ ~ ~ %noun
!> ^- (list [@da duct])
%- zing
%+ turn (tap:timer-map timers)
|= [date=@da q=(qeu duct)]
%+ turn ~(tap to q)
|=(d=duct [date d])
[~ ~ %noun !>(tiz)]
::
[%timers ~]
:^ ~ ~ %noun
!> ^- (list @da)
%- zing
%+ turn (tap:timer-map timers)
|= [date=@da q=(qeu duct)]
(reap ~(wyt in q) date)
::
[%timers %next ~]
:^ ~ ~ %noun
!> ^- (unit @da)
(bind (peek:timer-map timers) head)
::
[%timers @ ~]
?~ til=(slaw %da i.t.tyl)
[~ ~]
:^ ~ ~ %noun
!> ^- (list @da)
=/ tiz=(list [date=@da q=(qeu duct)])
(tap:timer-map timers)
|- ^- (list @da)
?~ tiz ~
?: (gth date.i.tiz u.til) ~
%+ weld
(reap ~(wyt in q.i.tiz) date.i.tiz)
$(tiz t.tiz)
==
::
++ stay state
++ take

15
pkg/arvo/sys/vane/clay.hoon
View File

@ -1005,6 +1005,15 @@
=+ ezy=?~(ref ~ (~(get by haw.u.ref) mun))
?^ ezy
:_(fod.dom.red `(bind u.ezy |=(a/cage [%& a])))
?: ?=([%s [%ud *] %late *] mun)
:_ fod.dom.red
^- (unit (unit (each cage lobe)))
:^ ~ ~ %&
^- cage
:- %cass
?~ let.dom
!>([0 *@da])
!>([let.dom t:(~(got by hut.ran) (~(got by hit.dom) let.dom))])
=+ nao=(case-to-aeon case.mun)
?~(nao [~ fod.dom.red] (read-at-aeon:ze for u.nao mun))
::
@ -3469,11 +3478,7 @@
%open
``open+!>(prelude:(ford:fusion static-ford-args))
::
%late
:^ ~ ~ %cass
?~ let.dom
!>([0 *@da])
!>([let.dom t:(~(got by hut.ran) (~(got by hit.dom) let.dom))])
%late !! :: handled in +aver
==
:: +read-t: produce the list of paths within a yaki with :pax as prefix
::

234
pkg/arvo/sys/vane/eyre.hoon
View File

@ -268,9 +268,6 @@
position: absolute;
bottom: 0;
}
footer span {
font-size: 0.875rem;
}
.mono {
font-family: "Source Code Pro", monospace;
}
@ -368,10 +365,6 @@
==
;footer.absolute.w-100
;div.relative.w-100.tr.tc-ns
;span(class "absolute", style "left: 8px; bottom: 8px;")
; OS 1
;span(class "gray2", style "margin-left: 4px;"): v0.0.1
==
;p.pr2.pr0-ns.pb2
;a(href "https://bridge.urbit.org", target "_blank")
;span.dn.dib-ns.pr1:"Open"
@ -478,226 +471,6 @@
~
==
==
:: +channel-js: the urbit javascript interface
::
:: TODO: Must send 'acks' to the server.
::
++ channel-js
^- octs
%- as-octs:mimes:html
'''
class Channel {
constructor() {
// unique identifier: current time and random number
//
this.uid =
new Date().getTime().toString() +
"-" +
Math.random().toString(16).slice(-6);
this.requestId = 1;
// the currently connected EventSource
//
this.eventSource = null;
// the id of the last EventSource event we received
//
this.lastEventId = 0;
// this last event id acknowledgment sent to the server
//
this.lastAcknowledgedEventId = 0;
// a registry of requestId to successFunc/failureFunc
//
// These functions are registered during a +poke and are executed
// in the onServerEvent()/onServerError() callbacks. Only one of
// the functions will be called, and the outstanding poke will be
// removed after calling the success or failure function.
//
this.outstandingPokes = new Map();
// a registry of requestId to subscription functions.
//
// These functions are registered during a +subscribe and are
// executed in the onServerEvent()/onServerError() callbacks. The
// event function will be called whenever a new piece of data on this
// subscription is available, which may be 0, 1, or many times. The
// disconnect function may be called exactly once.
//
this.outstandingSubscriptions = new Map();
this.deleteOnUnload();
}
deleteOnUnload() {
window.addEventListener("unload", (event) => {
this.delete();
});
}
// sends a poke to an app on an urbit ship
//
poke(ship, app, mark, json, successFunc, failureFunc) {
let id = this.nextId();
this.outstandingPokes.set(
id,
{
success: successFunc,
fail: failureFunc
}
);
this.sendJSONToChannel({
id,
action: "poke",
ship,
app,
mark,
json
});
}
// subscribes to a path on an specific app and ship.
//
// Returns a subscription id, which is the same as the same internal id
// passed to your Urbit.
subscribe(
ship,
app,
path,
connectionErrFunc = () => {},
eventFunc = () => {},
quitFunc = () => {}) {
let id = this.nextId();
this.outstandingSubscriptions.set(
id,
{
err: connectionErrFunc,
event: eventFunc,
quit: quitFunc
}
);
this.sendJSONToChannel({
id,
action: "subscribe",
ship,
app,
path
});
return id;
}
// quit the channel
//
delete() {
let id = this.nextId();
navigator.sendBeacon(this.channelURL(), JSON.stringify([{
id,
action: "delete"
}]));
}
// unsubscribe to a specific subscription
//
unsubscribe(subscription) {
let id = this.nextId();
this.sendJSONToChannel({
id,
action: "unsubscribe",
subscription
});
}
// sends a JSON command command to the server.
//
sendJSONToChannel(j) {
let req = new XMLHttpRequest();
req.open("PUT", this.channelURL());
req.setRequestHeader("Content-Type", "application/json");
if (this.lastEventId == this.lastAcknowledgedEventId) {
let x = JSON.stringify([j]);
req.send(x);
} else {
// we add an acknowledgment to clear the server side queue
//
// The server side puts messages it sends us in a queue until we
// acknowledge that we received it.
//
let x = JSON.stringify(
[{action: "ack", "event-id": parseInt(this.lastEventId)}, j]
);
req.send(x);
this.lastEventId = this.lastAcknowledgedEventId;
}
this.connectIfDisconnected();
}
// connects to the EventSource if we are not currently connected
//
connectIfDisconnected() {
if (this.eventSource) {
return;
}
this.eventSource = new EventSource(this.channelURL(), {withCredentials:true});
this.eventSource.onmessage = e => {
this.lastEventId = e.lastEventId;
let obj = JSON.parse(e.data);
if (obj.response == "poke") {
let funcs = this.outstandingPokes.get(obj.id);
if (obj.hasOwnProperty("ok")) {
funcs["success"]();
} else if (obj.hasOwnProperty("err")) {
funcs["fail"](obj.err);
} else {
console.error("Invalid poke response: ", obj);
}
this.outstandingPokes.delete(obj.id);
} else if (obj.response == "subscribe") {
// on a response to a subscribe, we only notify the caller on err
//
let funcs = this.outstandingSubscriptions.get(obj.id);
if (obj.hasOwnProperty("err")) {
funcs["err"](obj.err);
this.outstandingSubscriptions.delete(obj.id);
}
} else if (obj.response == "diff") {
let funcs = this.outstandingSubscriptions.get(obj.id);
funcs["event"](obj.json);
} else if (obj.response == "quit") {
let funcs = this.outstandingSubscriptions.get(obj.id);
funcs["quit"](obj);
this.outstandingSubscriptions.delete(obj.id);
} else {
console.log("Unrecognized response: ", e);
}
}
this.eventSource.onerror = e => {
console.error("eventSource error:", e);
this.delete();
}
}
channelURL() {
return "/~/channel/" + this.uid;
}
nextId() {
return this.requestId++;
}
};
'''
:: +format-ud-as-integer: prints a number for consumption outside urbit
::
++ format-ud-as-integer
@ -1238,13 +1011,6 @@
::
=+ channel-id=i.t.t.site.request-line
::
?: ?& =('channel' channel-id)
=([~ ~.js] ext.request-line)
==
:: client is requesting the javascript shim
::
(return-static-data-on-duct 200 'text/javascript' channel-js)
::
?: =('PUT' method.request)
:: PUT methods starts/modifies a channel, and returns a result immediately
::

32
pkg/arvo/sys/vane/gall.hoon
View File

@ -199,9 +199,7 @@
(mean >mote.u.dud< tang.u.dud)
?: =(/sys/lyv wire)
(molt duct ~)
:: TODO: test this or remove and assert /sys/lyv
::
(molt duct `[duct %pass wire %b %huck !>(sign)])
(molt duct `[duct %pass wire %b %huck sign])
::
++ load
|^
@ -622,7 +620,12 @@
%+ roll nex
|= [[=care:clay =^path] cor=_mo-core]
^+ cor
?> =(%a care)
:: We throw away %z results because we only have them to guarantee
:: molting. Clay will tell us if e.g. changing hoon.hoon affects
:: the result of a particular app (usually it will).
::
?. =(%a care)
cor
=/ dap dap:;;([%app dap=@tas %hoon ~] path)
=/ rag (mo-scry-agent-cage dap p.sign-arvo)
?: ?=(%| -.rag)
@ -752,14 +755,13 @@
::
++ mo-handle-use
~/ %mo-handle-use
|= [=path hin=(hypo sign-arvo)]
|= [=path =sign-arvo]
^+ mo-core
::
?. ?=([@ @ *] path)
~& [%mo-handle-use-bad-path path]
!!
::
=/ =sign-arvo q.hin
?. ?=([?(%g %b) %unto *] sign-arvo)
=/ app
=/ =term i.path
@ -1509,7 +1511,7 @@
=. ap-core
(ap-pass wire %agent dock %leave ~)
=/ way [%out (scot %p p.dock) q.dock wire]
(ap-pass way %arvo %b %huck !>([%unto %kick ~]))
(ap-pass way %arvo %b %huck `sign-arvo`[%g %unto %kick ~])
:: +ap-mule: run virtualized with intercepted scry, preserving type
::
:: Compare +mute and +mule. Those pass through scry, which
@ -1737,7 +1739,7 @@
::
++ take
~/ %gall-take
|= [=wire =duct dud=(unit goof) hin=(hypo sign-arvo)]
|= [=wire =duct dud=(unit goof) typ=type syn=sign-arvo]
^- [(list move) _gall-payload]
?^ dud
~&(%gall-take-dud ((slog tang.u.dud) [~ gall-payload]))
@ -1745,13 +1747,11 @@
[~ gall-payload]
::
~| [%gall-take-failed wire]
::
?> ?=([?(%sys %use) *] wire)
=/ mo-core (mo-abed:mo duct)
=/ =sign-arvo q.hin
=> ?- i.wire
%sys (mo-handle-sys:mo-core t.wire sign-arvo)
%use (mo-handle-use:mo-core t.wire hin)
==
mo-abet
=< mo-abet
%. [t.wire ?:(?=([%b %heck *] syn) syn.syn syn)]
?- i.wire
%sys mo-handle-sys:(mo-abed:mo duct)
%use mo-handle-use:(mo-abed:mo duct)
==
--

31
pkg/arvo/sys/zuse.hoon
View File

@ -795,6 +795,7 @@
$% [%doze p=(unit @da)] :: next alarm
[%wake error=(unit tang)] :: wakeup or failed
[%meta p=vase]
[%heck syn=sign-arvo] :: response to %huck
==
++ task :: in request ->$
$~ [%vega ~] ::
@ -802,7 +803,7 @@
$>(%crud vane-task) :: error with trace
[%rest p=@da] :: cancel alarm
[%drip p=vase] :: give in next event
[%huck p=vase] :: give back
[%huck syn=sign-arvo] :: give back
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
[%wait p=@da] :: set alarm
@ -5295,12 +5296,26 @@
~
(some (~(run by lum) need))
:: :: ++drop-pole:unity
++ drop-pole :: unit tuple
|* but/(pole (unit))
?~ but !!
?~ +.but
u:->.but
[u:->.but (drop-pole +.but)]
++ drop-pole :: collapse to tuple
|^ |* pul=(pole (unit))
?: (test-pole pul) ~
(some (need-pole pul))
::
++ test-pole
|* pul=(pole (unit))
^- ?
?~ pul &
?| ?=(~ -.pul)
?~(+.pul | (test-pole +.pul))
==
::
++ need-pole
|* pul=(pole (unit))
?~ pul !!
?~ +.pul
u:->.pul
[u:->.pul (need-pole +.pul)]
--
--
:: ::::
:::: ++format :: (2d) common formats
@ -6553,7 +6568,7 @@
;~(pose pure pesc pold net wut col com)
:: :: ++pure:de-purl:html
++ pure :: 2396 unreserved
;~(pose aln hep dot cab sig)
;~(pose aln hep cab dot zap sig tar say lit rit)
:: :: ++psub:de-purl:html
++ psub :: 3986 sub-delims
;~ pose

9
pkg/arvo/ted/build-cast.hoon
View File

@ -5,8 +5,9 @@
|= arg=vase
=/ m (strand ,vase)
^- form:m
=+ !<([a=mark b=mark ~] arg)
;< =bowl:spider bind:m get-bowl:strandio
=/ bek=beak [our q.byk da+now]:bowl
;< =tube:clay bind:m (build-cast:strandio bek a b)
=+ !<([pax=path ~] arg)
?~ bem=(de-beam:format pax)
(strand-fail:strand %path-not-beam >pax< ~)
=/ =mars:clay [i.t i]:?>(?=([@ @ ~] s.u.bem) s.u.bem)
;< =tube:clay bind:m (build-cast:strandio -.u.bem mars)
(pure:m !>(tube))

8
pkg/arvo/ted/build-file.hoon
View File

@ -1,11 +1,11 @@
/- spider
/+ strandio
/+ strand, strandio
=, strand=strand:spider
^- thread:spider
|= arg=vase
=/ m (strand ,vase)
^- form:m
=+ !<([pax=path ~] arg)
;< =bowl:spider bind:m get-bowl:strandio
=/ bek=beak [our q.byk da+now]:bowl
(build-file:strandio bek (flop pax))
?^ bem=(de-beam:format pax)
(build-file:strandio u.bem)
(strand-fail:strand %path-not-beam >pax< ~)

9
pkg/arvo/ted/build-mark.hoon
View File

@ -5,8 +5,9 @@
|= arg=vase
=/ m (strand ,vase)
^- form:m
=+ !<([mak=mark ~] arg)
;< =bowl:spider bind:m get-bowl:strandio
=/ bek=beak [our q.byk da+now]:bowl
;< =dais:clay bind:m (build-mark:strandio bek mak)
=+ !<([pax=path ~] arg)
?~ bem=(de-beam:format pax)
(strand-fail:strand %path-not-beam >pax< ~)
=/ =mark (head s.u.bem)
;< =dais:clay bind:m (build-mark:strandio -.u.bem mark)
(pure:m !>(dais))

12
pkg/arvo/ted/glob.hoon Normal file
View File

@ -0,0 +1,12 @@
/- spider, glob
/+ strandio
=, strand=strand:spider
^- thread:spider
|= arg=vase
=/ m (strand ,vase)
^- form:m
=+ !<([hash=@uv ~] arg)
=/ url "https://bootstrap.urbit.org/glob-{(scow %uv hash)}.glob"
;< =cord bind:m (fetch-cord:strandio url)
=+ ;;(=glob:glob (cue cord))
(pure:m !>(glob))

1
pkg/hs/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
stack.yaml.lock

2
pkg/hs/proto/package.yaml
View File

@ -19,7 +19,7 @@ dependencies:
- transformers
- transformers-compat
- unordered-containers
- urbit-king
- urbit-noun
default-extensions:
- ApplicativeDo

3
pkg/hs/racquire/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/racquire/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

0
pkg/hs/urbit-king/lib/Data/RAcquire.hs → pkg/hs/racquire/lib/Data/RAcquire.hs
View File

66
pkg/hs/racquire/package.yaml Normal file
View File

@ -0,0 +1,66 @@
name: racquire
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- mtl
- unliftio-core
- resourcet
- exceptions
- rio
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

5
pkg/hs/stack.yaml
View File

@ -3,10 +3,15 @@ resolver: lts-14.21
packages:
- lmdb-static
- proto
- racquire
- terminal-progress-bar
- urbit-atom
- urbit-azimuth
- urbit-eventlog-lmdb
- urbit-king
- urbit-termsize
- urbit-noun
- urbit-noun-core
extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38

3
pkg/hs/urbit-eventlog-lmdb/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/urbit-eventlog-lmdb/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

137
pkg/hs/urbit-king/lib/Urbit/Vere/Log.hs → pkg/hs/urbit-eventlog-lmdb/lib/Urbit/EventLog/LMDB.hs
View File

@ -4,27 +4,51 @@
TODO Effects storage logic is messy.
-}
module Urbit.Vere.Log ( EventLog, identity, nextEv, lastEv
, new, existing
, streamEvents, appendEvents, trimEvents
, streamEffectsRows, writeEffectsRow
) where
module Urbit.EventLog.LMDB
( LogIdentity(..)
, EventLog
, identity
, nextEv
, lastEv
, new
, existing
, streamEvents
, appendEvents
, trimEvents
, streamEffectsRows
, writeEffectsRow
)
where
import Urbit.Prelude hiding (init)
import ClassyPrelude
import Data.Conduit
import Data.RAcquire
import Database.LMDB.Raw
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Urbit.Vere.Pier.Types
import Foreign.Storable (peek, poke, sizeOf)
import Data.Conduit (ConduitT, yield)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (peek, poke, sizeOf)
import RIO (HasLogFunc, RIO, display, logDebug, runRIO)
import Urbit.Noun (DecodeErr, Noun, Ship)
import Urbit.Noun (deriveNoun, fromNounExn, toNoun)
import Urbit.Noun (cueBS, jamBS)
import qualified Data.ByteString.Unsafe as BU
import qualified Data.Vector as V
-- Public Types ----------------------------------------------------------------
data LogIdentity = LogIdentity
{ who :: Ship
, isFake :: Bool
, lifecycleLen :: Word
} deriving (Eq, Ord, Show)
deriveNoun ''LogIdentity
-- Types -----------------------------------------------------------------------
type Env = MDB_env
@ -34,29 +58,29 @@ type Dbi = MDB_dbi
type Cur = MDB_cursor
data EventLog = EventLog
{ env :: Env
, _metaTbl :: Dbi
, eventsTbl :: Dbi
, effectsTbl :: Dbi
, identity :: LogIdentity
, numEvents :: IORef EventId
}
{ env :: Env
, _metaTbl :: Dbi
, eventsTbl :: Dbi
, effectsTbl :: Dbi
, identity :: LogIdentity
, numEvents :: TVar Word64
}
nextEv :: EventLog -> RIO e EventId
nextEv = fmap succ . readIORef . numEvents
nextEv :: EventLog -> STM Word64
nextEv = fmap (+1) . lastEv
lastEv :: EventLog -> RIO e EventId
lastEv = readIORef . numEvents
lastEv :: EventLog -> STM Word64
lastEv = readTVar . numEvents
data EventLogExn
= NoLogIdentity
| MissingEvent EventId
| BadNounInLogIdentity ByteString DecodeErr ByteString
| BadKeyInEventLog
| BadWriteLogIdentity LogIdentity
| BadWriteEvent EventId
| BadWriteEffect EventId
deriving Show
= NoLogIdentity
| MissingEvent Word64
| BadNounInLogIdentity ByteString DecodeErr ByteString
| BadKeyInEventLog
| BadWriteLogIdentity LogIdentity
| BadWriteEvent Word64
| BadWriteEffect Word64
deriving Show
-- Instances -------------------------------------------------------------------
@ -64,6 +88,12 @@ data EventLogExn
instance Exception EventLogExn where
-- Utils -----------------------------------------------------------------------
io :: MonadIO m => IO a -> m a
io = liftIO
-- Open/Close an Event Log -----------------------------------------------------
rawOpen :: MonadIO m => FilePath -> m Env
@ -82,7 +112,7 @@ create dir id = do
(m, e, f) <- createTables env
clearEvents env e
writeIdent env m id
EventLog env m e f id <$> newIORef 0
EventLog env m e f id <$> newTVarIO 0
where
createTables env =
rwith (writeTxn env) $ \txn -> io $
@ -98,7 +128,7 @@ open dir = do
id <- getIdent env m
logDebug $ display (pack @Text $ "Log Identity: " <> show id)
numEvs <- getNumEvents env e
EventLog env m e f id <$> newIORef numEvs
EventLog env m e f id <$> newTVarIO numEvs
where
openTables env =
rwith (writeTxn env) $ \txn -> io $
@ -227,10 +257,10 @@ clearEvents env eventsTbl =
appendEvents :: EventLog -> Vector ByteString -> RIO e ()
appendEvents log !events = do
numEvs <- readIORef (numEvents log)
numEvs <- atomically $ readTVar (numEvents log)
next <- pure (numEvs + 1)
doAppend $ zip [next..] $ toList events
writeIORef (numEvents log) (numEvs + word (length events))
atomically $ writeTVar (numEvents log) (numEvs + word (length events))
where
flags = compileWriteFlags [MDB_NOOVERWRITE]
doAppend = \kvs ->
@ -240,21 +270,20 @@ appendEvents log !events = do
True -> pure ()
False -> throwIO (BadWriteEvent k)
writeEffectsRow :: EventLog -> EventId -> ByteString -> RIO e ()
writeEffectsRow log k v = do
rwith (writeTxn $ env log) $ \txn ->
putBytes flags txn (effectsTbl log) k v >>= \case
True -> pure ()
False -> throwIO (BadWriteEffect k)
where
flags = compileWriteFlags []
writeEffectsRow :: MonadIO m => EventLog -> Word64 -> ByteString -> m ()
writeEffectsRow log k v = io $ runRIO () $ do
let flags = compileWriteFlags []
rwith (writeTxn $ env log) $ \txn ->
putBytes flags txn (effectsTbl log) k v >>= \case
True -> pure ()
False -> throwIO (BadWriteEffect k)
-- Read Events -----------------------------------------------------------------
trimEvents :: HasLogFunc e => EventLog -> Word64 -> RIO e ()
trimEvents log start = do
last <- lastEv log
last <- atomically (lastEv log)
rwith (writeTxn $ env log) $ \txn ->
for_ [start..last] $ \eId ->
withWordPtr eId $ \pKey -> do
@ -262,23 +291,21 @@ trimEvents log start = do
found <- io $ mdb_del txn (eventsTbl log) key Nothing
unless found $
throwIO (MissingEvent eId)
writeIORef (numEvents log) (pred start)
atomically $ writeTVar (numEvents log) (pred start)
streamEvents :: HasLogFunc e
=> EventLog -> Word64
-> ConduitT () ByteString (RIO e) ()
streamEvents :: MonadIO m => EventLog -> Word64 -> ConduitT () ByteString m ()
streamEvents log first = do
batch <- lift $ readBatch log first
unless (null batch) $ do
for_ batch yield
streamEvents log (first + word (length batch))
batch <- io $ runRIO () $ readBatch log first
unless (null batch) $ do
for_ batch yield
streamEvents log (first + word (length batch))
streamEffectsRows :: ∀e. HasLogFunc e
=> EventLog -> EventId
=> EventLog -> Word64
-> ConduitT () (Word64, ByteString) (RIO e) ()
streamEffectsRows log = go
where
go :: EventId -> ConduitT () (Word64, ByteString) (RIO e) ()
go :: Word64 -> ConduitT () (Word64, ByteString) (RIO e) ()
go next = do
batch <- lift $ readRowsBatch (env log) (effectsTbl log) next
unless (null batch) $ do
@ -294,12 +321,12 @@ readBatch :: EventLog -> Word64 -> RIO e (V.Vector ByteString)
readBatch log first = start
where
start = do
last <- lastEv log
last <- atomically (lastEv log)
if (first > last)
then pure mempty
else readRows $ fromIntegral $ min 1000 $ ((last+1) - first)
assertFound :: EventId -> Bool -> RIO e ()
assertFound :: Word64 -> Bool -> RIO e ()
assertFound id found = do
unless found $ throwIO $ MissingEvent id

71
pkg/hs/urbit-eventlog-lmdb/package.yaml Normal file
View File

@ -0,0 +1,71 @@
name: urbit-eventlog-lmdb
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- classy-prelude
- stm
- rio
- vector
- bytestring
- lmdb-static
- conduit
- racquire
- urbit-noun-core
- urbit-noun
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

119
pkg/hs/urbit-king/TODO.md Normal file
View File

@ -0,0 +1,119 @@
# New IPC Protocol
Stubbed out:
- [x] Handle replacement events (stubbed out now b/c interface can't
handle unparsed nouns)
- [x] Handle IPC errors by killing serf process.
- [x] Handle `peek` and `pack` in `swimming` flow.
- [x] Documentation for `Urbit.Vere.Serf.IPC`.
- [x] Unstub slog/stder/dead callbacks on serf config.
- [x] Remove GoodParse hack in newRunCompute.
- [x] Bring back tank printing.
- [x] Handle serf stderr message correctly.
- [x] Bring back `logEvent`.
- [x] Snapshots should block until that event is commited to disk.
- [x] Hook up error callbacks to IO Drivers.
- [x] Do something useful with error callbacks from IO Drivers.
Bugs:
- [x] In non-daemon mode, serf slogs/stderr output that happens *before*
the terminal connects should still go to stderr.
- [x] Serf stderr should also be send (along with slogs) to all connected
terminals.
- [x] `king new` should reject pier directories that already exist.
- [x] In non-daemon-mode, ^D doesn't bring down Urbit properly.
- [x] Spinner updated multiple times with the same event, and this causes
logging of events to contain duplicates.
King-Haskell specific features:
- [x] Re-implement `collectFX` flow in Serf/Pier.
- [x] Hook up `collectFX` to CLI.
- [ ] Get `collect-all-fx` flow working again.
Performance:
- [x] Batching during replay.
- [x] Batching during normal operation.
Optimization:
- [x] IO Driver Event Prioritization
Polish:
- [x] Cleanup batching flow.
- [x] Think through how to shutdown the serf on exception.
- [x] King should shutdown promptly on ^C. Always takes 2s in practice.
- [x] Bring back progress bars.
- [x] Make sure replay progress bars go to stderr.
- [x] Logging for new IPC flow.
- [x] Logging for boot sequence.
- [x] Take snapshots on clean shutdown.
# Misc Bugs
- [ ] `king run --collect-fx` flag does nothing. Remove or implement.
- [x] Handle ^C in connected terminals. It should interrupt current
event (send SIGINT to serf, which will cause the current event to
fail promptly).
- [x] The terminal driver seems to have a race condition when spinner
changed too quickly.
# Finding the Serf Executable
- [ ] Right now, `urbit-worker` is found by looking it up in the PATH. This
is wrong, but what is right?
# Take Advantage of New IPC Features
- [ ] Hook up `scry` to drivers.
- Any immediate applications of this?
- [ ] Allow scrys to go into the %work batching flow for better latency.
- Handle event errors in other cases:
- [ ] Ames packet failures should print (but not too often).
- [ ] Incoming Http requests should produce 500 responses.
- [ ] Terminal event errors should be printed in connected terminals.
- [ ] Http client responses should be retried.
# Further IO Driver Startup Flow Betterment
Implement Pier-wide process start events
- [x] Handle %vega and exit effects.
- [x] Handle %trim effect
- [x] Inject entropy event on pier start: ``[//arvo [%wack ENT]]`
- [ ] Verbose flag: `-v` injects `[%verb ~]`
- [ ] CLI event injection: `-I file-path`. The `file-path` is a jammed
noun representing an event: `[wire card]`.
1. Just parse it as an `Ev` for now.
2. Make the serf IPC code not care about the shape of events and effects.
3. Support invalid events throughout the system (use `Lenient`?)
# Polish
- [x] Goot logging output in non-verbose mode.
- [x] Command-Line flag to re-enable verbose output.
# Cleanup
- [x] ShutdownSTM action that's passed to the terminal driver should
live in `KingEnv` and should be available to all drivers.
- [ ] Break most logic from `Main.hs` out into modules.
- [ ] Simplify `Main.hs` flows.
- [ ] Cleanup Terminal Driver code.
- [x] Spin off `racquire` into it's own package.
- [x] Spin off `urbit-noun-core` and `urbit-noun` packages.
- [x] Spin off `urbit-eventlog-lmdb` into it's own package.
- [ ] Spin off `Urbit.Vere.Serf` into it's own package
- Make it care less about the shape of events and effects.
- [ ] Spin off per-pier logic into it's own package.
- Probably `urbit-pier`

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

@ -79,7 +79,10 @@ instance FromNoun H.StdMethod where
-- Http Server Configuration ---------------------------------------------------
newtype PEM = PEM { unPEM :: Wain }
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
deriving newtype (Eq, Ord, ToNoun, FromNoun)
instance Show PEM where
show _ = "\"PEM (secret)\""
type Key = PEM
type Cert = PEM

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

@ -3,8 +3,8 @@
-}
module Urbit.Arvo.Effect where
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Time
import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
@ -82,22 +82,6 @@ data SyncEf
deriveNoun ''SyncEf
-- UDP Effects -----------------------------------------------------------------
{-|
%init -- "I don't think that's something that can happen"
%west -- "Those also shouldn't happen"
%woot -- "Those also shouldn't happen"
-}
data AmesEf
= AmesEfInit Path ()
| AmesEfWest Path Ship Path Noun
| AmesEfWoot Path Ship (Maybe (Maybe (Term, [Tank])))
deriving (Eq, Ord, Show)
deriveNoun ''AmesEf
-- Timer Effects ---------------------------------------------------------------
{-|
@ -171,7 +155,6 @@ data VaneEf
| VEHttpClient HttpClientEf
| VEHttpServer HttpServerEf
| VEBehn BehnEf
| VEAmes AmesEf
| VETerm TermEf
| VEClay SyncEf
| VESync SyncEf
@ -203,3 +186,10 @@ instance FromNoun Ef where
ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value"
ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
ReOrg _ _ _ _ _ -> fail "Non-empty first path-element"
summarizeEffect :: Lenient Ef -> Text
summarizeEffect ef =
fromNoun (toNoun ef) & \case
Nothing -> "//invalid %effect"
Just (pax :: [Cord], tag :: Cord, val :: Noun) ->
"/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag

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

@ -202,9 +202,16 @@ deriveNoun ''AmesEv
-- Arvo Events -----------------------------------------------------------------
newtype Entropy = Entropy { entropyBits :: Word512 }
deriving newtype (Eq, Ord, FromNoun, ToNoun)
instance Show Entropy where
show = const "\"ENTROPY (secret)\""
data ArvoEv
= ArvoEvWhom () Ship
| ArvoEvWack () Word512
| ArvoEvWack () Entropy
| ArvoEvWarn Path Noun
| ArvoEvCrud Path Noun
| ArvoEvVeer Atom Noun
@ -350,6 +357,7 @@ instance FromNoun Ev where
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
-- Short Event Names -----------------------------------------------------------
{-
@ -374,3 +382,10 @@ getSpinnerNameForEvent = \case
where
isRet (TermEvBelt _ (Ret ())) = True
isRet _ = False
summarizeEvent :: Ev -> Text
summarizeEvent ev =
fromNoun (toNoun ev) & \case
Nothing -> "//invalid %event"
Just (pax :: [Cord], tag :: Cord, val :: Noun) ->
"/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag

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

@ -4,7 +4,14 @@
ships. Do it or strip it out.
-}
module Urbit.King.API (King(..), kingAPI, readPortsFile) where
module Urbit.King.API
( King(..)
, TermConn
, TermConnAPI
, kingAPI
, readPortsFile
)
where
import RIO.Directory
import Urbit.Prelude
@ -12,7 +19,7 @@ import Urbit.Prelude
import Network.Socket (Socket)
import Prelude (read)
import Urbit.Arvo (Belt)
import Urbit.King.App (HasConfigDir(..))
import Urbit.King.App (HasPierPath(..))
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -43,16 +50,16 @@ data King = King
{-|
Get the filepath of the urbit config directory and the ports file.
-}
portsFilePath :: HasConfigDir e => RIO e (FilePath, FilePath)
portsFilePath :: HasPierPath e => RIO e (FilePath, FilePath)
portsFilePath = do
dir <- view configDirL
dir <- view pierPathL
fil <- pure (dir </> ".king.ports")
pure (dir, fil)
{-|
Write the ports file.
-}
portsFile :: HasConfigDir e => Word -> RAcquire e (FilePath, FilePath)
portsFile :: HasPierPath e => Word -> RAcquire e (FilePath, FilePath)
portsFile por =
mkRAcquire mkFile (removeFile . snd)
where
@ -65,7 +72,7 @@ portsFile por =
{-|
Get the HTTP port for the running Urbit daemon.
-}
readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
readPortsFile :: HasPierPath e => RIO e (Maybe Word)
readPortsFile = do
(_, fil) <- portsFilePath
bs <- readFile fil
@ -86,7 +93,7 @@ kingServer is =
{-|
Start the HTTP server and write to the ports file.
-}
kingAPI :: (HasConfigDir e, HasLogFunc e)
kingAPI :: (HasPierPath e, HasLogFunc e)
=> RAcquire e King
kingAPI = do
(port, sock) <- io $ W.openFreePort

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

@ -2,139 +2,192 @@
Code for setting up the RIO environment.
-}
module Urbit.King.App
( App
, runApp
, runAppLogFile
, runAppNoLog
, runPierApp
, HasConfigDir(..)
, HasStderrLogFunc(..)
) where
( KingEnv
, runKingEnvStderr
, runKingEnvLogFile
, runKingEnvNoLog
, kingEnvKillSignal
, killKingActionL
, onKillKingSigL
, PierEnv
, runPierEnv
, killPierActionL
, onKillPierSigL
, HasStderrLogFunc(..)
, HasKingId(..)
, HasProcId(..)
, HasKingEnv(..)
, HasPierEnv(..)
, module Urbit.King.Config
)
where
import Urbit.King.Config
import Urbit.Prelude
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.Posix.Internals (c_getpid)
import System.Posix.Types (CPid(..))
import System.Random (randomIO)
import Urbit.King.App.Class (HasStderrLogFunc(..))
--------------------------------------------------------------------------------
class HasConfigDir a where
configDirL ∷ Lens' a FilePath
-- KingEnv ---------------------------------------------------------------------
class HasStderrLogFunc a where
stderrLogFuncL :: Lens' a LogFunc
class HasKingId a where
kingIdL :: Lens' a Word16
--------------------------------------------------------------------------------
class HasProcId a where
procIdL :: Lens' a Int32
data App = App
{ _appLogFunc :: !LogFunc
, _appStderrLogFunc :: !LogFunc
}
class (HasLogFunc a, HasStderrLogFunc a, HasKingId a, HasProcId a)
=> HasKingEnv a
where
kingEnvL :: Lens' a KingEnv
makeLenses ''App
data KingEnv = KingEnv
{ _kingEnvLogFunc :: !LogFunc
, _kingEnvStderrLogFunc :: !LogFunc
, _kingEnvKingId :: !Word16
, _kingEnvProcId :: !Int32
, _kingEnvKillSignal :: !(TMVar ())
}
instance HasLogFunc App where
logFuncL = appLogFunc
makeLenses ''KingEnv
instance HasStderrLogFunc App where
stderrLogFuncL = appStderrLogFunc
instance HasKingEnv KingEnv where
kingEnvL = id
runApp :: RIO App a -> IO a
runApp inner = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
instance HasLogFunc KingEnv where
logFuncL = kingEnvLogFunc
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc logFunc) inner
instance HasStderrLogFunc KingEnv where
stderrLogFuncL = kingEnvStderrLogFunc
runAppLogFile :: RIO App a -> IO a
runAppLogFile inner =
withLogFileHandle $ \h -> do
logOptions <- logOptionsHandle h True
<&> setLogUseTime True
<&> setLogUseLoc False
stderrLogOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
instance HasProcId KingEnv where
procIdL = kingEnvProcId
withLogFunc stderrLogOptions $ \stderrLogFunc ->
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc stderrLogFunc) inner
instance HasKingId KingEnv where
kingIdL = kingEnvKingId
-- Running KingEnvs ------------------------------------------------------------
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
runKingEnvStderr verb inner = do
logOptions <-
logOptionsHandle stderr verb <&> setLogUseTime True <&> setLogUseLoc False
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
runKingEnvLogFile :: Bool -> RIO KingEnv a -> IO a
runKingEnvLogFile verb inner = withLogFileHandle $ \h -> do
logOptions <-
logOptionsHandle h verb <&> setLogUseTime True <&> setLogUseLoc False
stderrLogOptions <-
logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False
withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions
$ \logFunc -> runKingEnv logFunc stderrLogFunc inner
withLogFileHandle :: (Handle -> IO a) -> IO a
withLogFileHandle act = do
home <- getHomeDirectory
let logDir = home </> ".urbit"
createDirectoryIfMissing True logDir
withFile (logDir </> "king.log") AppendMode $ \handle -> do
hSetBuffering handle LineBuffering
act handle
home <- getHomeDirectory
let logDir = home </> ".urbit"
createDirectoryIfMissing True logDir
withFile (logDir </> "king.log") AppendMode $ \handle -> do
hSetBuffering handle LineBuffering
act handle
runAppNoLog :: RIO App a -> IO a
runAppNoLog act =
withFile "/dev/null" AppendMode $ \handle -> do
logOptions <- logOptionsHandle handle True
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc logFunc) act
runKingEnvNoLog :: RIO KingEnv a -> IO a
runKingEnvNoLog act = withFile "/dev/null" AppendMode $ \handle -> do
logOptions <- logOptionsHandle handle True
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc act
--------------------------------------------------------------------------------
runKingEnv :: LogFunc -> LogFunc -> RIO KingEnv a -> IO a
runKingEnv logFunc stderr action = do
kid <- randomIO
CPid pid <- c_getpid
kil <- newEmptyTMVarIO
runRIO (KingEnv logFunc stderr kid pid kil) action
-- | A PierApp is like an App, except that it also provides a PierConfig
data PierApp = PierApp
{ _pierAppLogFunc :: !LogFunc
, _pierAppStderrLogFunc :: !LogFunc
, _pierAppPierConfig :: !PierConfig
, _pierAppNetworkConfig :: !NetworkConfig
}
makeLenses ''PierApp
-- KingEnv Utils ---------------------------------------------------------------
instance HasStderrLogFunc PierApp where
stderrLogFuncL = pierAppStderrLogFunc
onKillKingSigL :: HasKingEnv e => Getter e (STM ())
onKillKingSigL = kingEnvL . kingEnvKillSignal . to readTMVar
instance HasLogFunc PierApp where
logFuncL = pierAppLogFunc
killKingActionL :: HasKingEnv e => Getter e (STM ())
killKingActionL =
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
instance HasPierConfig PierApp where
pierConfigL = pierAppPierConfig
instance HasNetworkConfig PierApp where
networkConfigL = pierAppNetworkConfig
-- PierEnv ---------------------------------------------------------------------
instance HasConfigDir PierApp where
configDirL = pierAppPierConfig . pcPierPath
class (HasKingEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where
pierEnvL :: Lens' a PierEnv
runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
runPierApp pierConfig networkConfig daemon inner =
if daemon
then execStderr
else withLogFileHandle execFile
where
execStderr = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
data PierEnv = PierEnv
{ _pierEnvKingEnv :: !KingEnv
, _pierEnvPierConfig :: !PierConfig
, _pierEnvNetworkConfig :: !NetworkConfig
, _pierEnvKillSignal :: !(TMVar ())
}
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logFunc
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
makeLenses ''PierEnv
execFile logHandle = do
logOptions <- logOptionsHandle logHandle True
<&> setLogUseTime True
<&> setLogUseLoc False
logStderrOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
withLogFunc logStderrOptions $ \logStderr ->
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logStderr
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
go app = runRIO app inner
instance HasKingEnv PierEnv where
kingEnvL = pierEnvKingEnv
instance HasPierEnv PierEnv where
pierEnvL = id
instance HasKingId PierEnv where
kingIdL = kingEnvL . kingEnvKingId
instance HasStderrLogFunc PierEnv where
stderrLogFuncL = kingEnvL . stderrLogFuncL
instance HasLogFunc PierEnv where
logFuncL = kingEnvL . logFuncL
instance HasPierPath PierEnv where
pierPathL = pierEnvPierConfig . pierPathL
instance HasDryRun PierEnv where
dryRunL = pierEnvPierConfig . dryRunL
instance HasPierConfig PierEnv where
pierConfigL = pierEnvPierConfig
instance HasNetworkConfig PierEnv where
networkConfigL = pierEnvNetworkConfig
instance HasProcId PierEnv where
procIdL = kingEnvL . kingEnvProcId
-- PierEnv Utils ---------------------------------------------------------------
onKillPierSigL :: HasPierEnv e => Getter e (STM ())
onKillPierSigL = pierEnvL . pierEnvKillSignal . to readTMVar
killPierActionL :: HasPierEnv e => Getter e (STM ())
killPierActionL =
pierEnvL . pierEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
-- Running Pier Envs -----------------------------------------------------------
runPierEnv
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
runPierEnv pierConfig networkConfig vKill action = do
app <- ask
let pierEnv = PierEnv { _pierEnvKingEnv = app
, _pierEnvPierConfig = pierConfig
, _pierEnvNetworkConfig = networkConfig
, _pierEnvKillSignal = vKill
}
io (runRIO pierEnv action)

15
pkg/hs/urbit-king/lib/Urbit/King/App/Class.hs Normal file
View File

@ -0,0 +1,15 @@
{-|
Code for setting up the RIO environment.
-}
module Urbit.King.App.Class
( HasStderrLogFunc(..)
)
where
import Urbit.Prelude
-- KingEnv ---------------------------------------------------------------------
class HasStderrLogFunc a where
stderrLogFuncL :: Lens' a LogFunc

83
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs
View File

@ -15,6 +15,12 @@ import System.Environment (getProgName)
--------------------------------------------------------------------------------
data KingOpts = KingOpts
{ koSharedHttpPort :: Maybe Word16
, koSharedHttpsPort :: Maybe Word16
}
deriving (Show)
data Opts = Opts
{ oQuiet :: Bool
, oHashless :: Bool
@ -23,6 +29,9 @@ data Opts = Opts
, oDryFrom :: Maybe Word64
, oVerbose :: Bool
, oAmesPort :: Maybe Word16
, oNoAmes :: Bool
, oNoHttp :: Bool
, oNoHttps :: Bool
, oTrace :: Bool
, oCollectFx :: Bool
, oLocalhost :: Bool
@ -31,6 +40,7 @@ data Opts = Opts
, oHttpPort :: Maybe Word16
, oHttpsPort :: Maybe Word16
, oLoopbackPort :: Maybe Word16
, oSerfExe :: Maybe Text
}
deriving (Show)
@ -93,7 +103,7 @@ data Bug
data Cmd
= CmdNew New Opts
| CmdRun Run Opts Bool
| CmdRun KingOpts [(Run, Opts, Bool)]
| CmdBug Bug
| CmdCon FilePath
deriving (Show)
@ -221,6 +231,24 @@ opts = do
<> help "Ames port"
<> hidden
oNoAmes <-
switch
$ long "no-ames"
<> help "Run with Ames disabled."
<> hidden
oNoHttp <-
switch
$ long "no-http"
<> help "Run with HTTP disabled."
<> hidden
oNoHttps <-
switch
$ long "no-https"
<> help "Run with HTTPS disabled."
<> hidden
oHttpPort <-
optional
$ option auto
@ -245,13 +273,18 @@ opts = do
<> help "Localhost-only HTTP port"
<> hidden
-- Always disable hashboard. Right now, urbit is almost unusable with this
-- flag enabled and it is disabled in vere.
let oHashless = True
-- oHashless <- switch $ short 'S'
-- <> long "hashless"
-- <> help "Disable battery hashing"
-- <> hidden
oSerfExe <-
optional
$ strOption
$ metavar "PATH"
<> long "serf"
<> help "Path to Serf"
<> hidden
oHashless <- switch $ short 'S'
<> long "hashless"
<> help "Disable battery hashing (Ignored for now)"
<> hidden
oQuiet <- switch $ short 'q'
<> long "quiet"
@ -307,15 +340,33 @@ opts = do
newShip :: Parser Cmd
newShip = CmdNew <$> new <*> opts
runOneShip :: Parser (Run, Opts, Bool)
runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df
where
df = switch (short 'd' <> long "daemon" <> help "Daemon mode" <> hidden)
kingOpts :: Parser KingOpts
kingOpts = do
koSharedHttpPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-http-port"
<> help "HTTP port"
<> hidden
koSharedHttpsPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-https-port"
<> help "HTTPS port"
<> hidden
pure (KingOpts{..})
runShip :: Parser Cmd
runShip = do
rPierPath <- pierPath
o <- opts
daemon <- switch $ short 'd'
<> long "daemon"
<> help "Daemon mode"
<> hidden
pure (CmdRun (Run{..}) o daemon)
runShip = CmdRun <$> kingOpts <*> some runOneShip
valPill :: Parser Bug
valPill = do

38
pkg/hs/urbit-king/lib/Urbit/King/Config.hs
View File

@ -1,29 +1,40 @@
{-|
Pier Configuration
Pier Configuration
-}
module Urbit.King.Config where
import Urbit.Prelude
import qualified Urbit.Vere.Serf as Serf
{-|
All the configuration data revolving around a ship and the current
execution options.
All the configuration data revolving around a ship and the current
execution options.
-}
data PierConfig = PierConfig
{ _pcPierPath :: FilePath
, _pcDryRun :: Bool
} deriving (Show)
{ _pcPierPath :: FilePath
, _pcDryRun :: Bool
, _pcSerfExe :: Text
, _pcSerfFlags :: [Serf.Flag]
} deriving (Show)
makeLenses ''PierConfig
class HasPierConfig env where
pierConfigL :: Lens' env PierConfig
class HasPierPath a where
pierPathL :: Lens' a FilePath
pierPathL ∷ HasPierConfig a => Lens' a FilePath
pierPathL = pierConfigL . pcPierPath
class HasDryRun a where
dryRunL :: Lens' a Bool
class (HasPierPath a, HasDryRun a) => HasPierConfig a where
pierConfigL :: Lens' a PierConfig
instance HasPierPath PierConfig where
pierPathL = pcPierPath
instance HasDryRun PierConfig where
dryRunL = pcDryRun
dryRunL :: HasPierConfig a => Lens' a Bool
dryRunL = pierConfigL . pcDryRun
-------------------------------------------------------------------------------
@ -36,6 +47,9 @@ data NetMode
data NetworkConfig = NetworkConfig
{ _ncNetMode :: NetMode
, _ncAmesPort :: Maybe Word16
, _ncNoAmes :: Bool
, _ncNoHttp :: Bool
, _ncNoHttps :: Bool
, _ncHttpPort :: Maybe Word16
, _ncHttpsPort :: Maybe Word16
, _ncLocalPort :: Maybe Word16

9
pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs
View File

@ -10,14 +10,15 @@ import Urbit.Prelude
import Data.Conduit
import Urbit.Arvo
import Urbit.Time
import Urbit.Noun.Time
import Urbit.Vere.Pier.Types
import Control.Monad.Trans.Maybe (MaybeT(..))
import Urbit.Vere.Log (EventLog)
import Urbit.EventLog.LMDB (EventLog)
import qualified Data.Conduit.Combinators as C
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
--------------------------------------------------------------------------------
@ -39,7 +40,7 @@ run log = do
hSetEcho stdin False
logInfo $ displayShow (Log.identity log)
let cycle = fromIntegral $ lifecycleLen $ Log.identity log
las <- Log.lastEv log
las <- atomically (Log.lastEv log)
loop cycle las las
where
failRead cur =

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

@ -1,5 +1,25 @@
{-|
King Haskell Entry Point
{- |
# Signal Handling (SIGTERM, SIGINT)
We handle SIGTERM by causing the main thread to raise a `UserInterrupt`
exception. This is the same behavior as SIGINT (the signal sent upon
`CTRL-C`).
The main thread is therefore responsible for handling this exception
and causing everything to shut down properly.
# Crashing and Shutting Down
Rule number one: The King never crashes.
This rule is asperational at the moment, but it needs to become as
close to truth as possible. Shut down ships in extreme cases, but
never let the king go down.
-}
{-
TODO These some old scribbled notes. They don't belong here
anymore. Do something about it.
# Event Pruning
@ -62,18 +82,18 @@ import Urbit.Arvo
import Urbit.King.Config
import Urbit.Vere.Dawn
import Urbit.Vere.Pier
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..))
import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf
import Urbit.King.App
import Control.Concurrent (myThreadId)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import System.Process (system)
import Text.Show.Pretty (pPrint)
import Urbit.King.App (runApp, runAppLogFile, runAppNoLog, runPierApp)
import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..))
import Urbit.Noun.Conversions (cordToUW)
import Urbit.Time (Wen)
import Urbit.Noun.Time (Wen)
import Urbit.Vere.LockFile (lockFile)
import qualified Data.Set as Set
@ -82,18 +102,14 @@ import qualified Network.HTTP.Client as C
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.King.CLI as CLI
import qualified Urbit.King.EventBrowser as EventBrowser
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Log as Log
import qualified Urbit.Vere.Pier as Pier
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
--------------------------------------------------------------------------------
zod :: Ship
zod = 0
--------------------------------------------------------------------------------
@ -103,28 +119,33 @@ removeFileIfExists pax = do
when exists $ do
removeFile pax
--------------------------------------------------------------------------------
toSerfFlags :: CLI.Opts -> Serf.Flags
-- Compile CLI Flags to Pier Configuration -------------------------------------
{-
TODO: This is not all of the flags.
Urbit is basically useless with hashboard, so we ignore that flag.
-}
toSerfFlags :: CLI.Opts -> [Serf.Flag]
toSerfFlags CLI.Opts{..} = catMaybes m
where
-- TODO: This is not all the flags.
m = [ from oQuiet Serf.Quiet
, from oTrace Serf.Trace
, from oHashless Serf.Hashless
, from oQuiet Serf.Quiet
, from oVerbose Serf.Verbose
, from (oDryRun || isJust oDryFrom) Serf.DryRun
m = [ setFrom oQuiet Serf.Quiet
, setFrom oTrace Serf.Trace
, setFrom (oHashless || True) Serf.Hashless
, setFrom oQuiet Serf.Quiet
, setFrom oVerbose Serf.Verbose
, setFrom (oDryRun || isJust oDryFrom) Serf.DryRun
]
from True flag = Just flag
from False _ = Nothing
setFrom True flag = Just flag
setFrom False _ = Nothing
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
toPierConfig pierPath CLI.Opts {..} = PierConfig { .. }
toPierConfig pierPath o@(CLI.Opts{..}) = PierConfig { .. }
where
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
_pcSerfExe = fromMaybe "urbit-worker" oSerfExe
_pcSerfFlags = toSerfFlags o
toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
@ -143,157 +164,187 @@ toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
_ncHttpPort = oHttpPort
_ncHttpsPort = oHttpsPort
_ncLocalPort = oLoopbackPort
_ncNoAmes = oNoAmes
_ncNoHttp = oNoHttp
_ncNoHttps = oNoHttps
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e, HasStderrLogFunc e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
-> RIO e ()
tryBootFromPill oExit pill lite flags ship boot = do
mStart <- newEmptyMVar
runOrExitImmediately bootedPier oExit mStart
where
bootedPier = do
view pierPathL >>= lockFile
rio $ logTrace "Starting boot"
sls <- Pier.booted pill lite flags ship boot
rio $ logTrace "Completed boot"
pure sls
logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
logFunc <- view stderrLogFuncL
runRIO logFunc action
runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> RAcquire e (Serf e, Log.EventLog, SerfState)
-> Bool
-> MVar ()
-> RIO e ()
runOrExitImmediately getPier oExit mStart =
rwith getPier $ if oExit then shutdownImmediately else runPier
where
shutdownImmediately (serf, log, ss) = do
logTrace "Sending shutdown signal"
logTrace $ displayShow ss
logSlogs :: HasStderrLogFunc e => RIO e (TVar (Text -> IO ()))
logSlogs = logStderr $ do
env <- ask
newTVarIO (runRIO env . logOther "serf" . display . T.strip)
-- Why is this here? Do I need to force a snapshot to happen?
io $ threadDelay 500000
tryBootFromPill
:: Bool
-> Pill
-> Bool
-> Ship
-> LegacyBootEvent
-> MultiEyreApi
-> RIO PierEnv ()
tryBootFromPill oExit pill lite ship boot multi = do
mStart <- newEmptyMVar
vSlog <- logSlogs
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
where
bootedPier vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "Starting boot"
sls <- Pier.booted vSlog pill lite ship boot
rio $ logDebug "Completed boot"
pure sls
ss <- shutdown serf 0
logTrace $ displayShow ss
logTrace "Shutdown!"
runOrExitImmediately
:: TVar (Text -> IO ())
-> RAcquire PierEnv (Serf, Log.EventLog)
-> Bool
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
runOrExitImmediately vSlog getPier oExit mStart multi = do
rwith getPier (if oExit then shutdownImmediately else runPier)
where
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
shutdownImmediately (serf, log) = do
logDebug "Sending shutdown signal"
Serf.stop serf
logDebug "Shutdown!"
runPier sls = do
runRAcquire $ Pier.pier sls mStart
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
runPier serfLog = do
runRAcquire (Pier.pier serfLog vSlog mStart multi)
tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e
, HasPierConfig e, HasConfigDir e
)
=> Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
when fullReplay wipeSnapshot
runOrExitImmediately resumeShip exitImmediately mStart
where
wipeSnapshot = do
shipPath <- view pierPathL
logTrace "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
tryPlayShip
:: Bool
-> Bool
-> Maybe Word64
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
when fullReplay wipeSnapshot
vSlog <- logSlogs
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
where
wipeSnapshot = do
shipPath <- view pierPathL
logDebug "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
resumeShip = do
view pierPathL >>= lockFile
rio $ logTrace "RESUMING SHIP"
sls <- Pier.resumed playFrom flags
rio $ logTrace "SHIP RESUMED"
pure sls
resumeShip :: TVar (Text -> IO ()) -> RAcquire PierEnv (Serf, Log.EventLog)
resumeShip vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "RESUMING SHIP"
sls <- Pier.resumed vSlog playFrom
rio $ logDebug "SHIP RESUMED"
pure sls
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
=> RAcquire e a -> m e a
runRAcquire act = rwith act pure
--------------------------------------------------------------------------------
checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
checkEvs :: FilePath -> Word64 -> Word64 -> RIO KingEnv ()
checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logTrace (displayShow ident)
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logDebug (displayShow ident)
last <- Log.lastEv log <&> \lastReal -> min last lastReal
last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal
let evCount = fromIntegral (last - first)
let evCount = fromIntegral (last - first)
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
runConduit $ Log.streamEvents log first
.| showEvents pb first (fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
runConduit $ Log.streamEvents log first .| showEvents
pb
first
(fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
showEvents :: PB.ProgressBar () -> EventId -> EventId
-> ConduitT ByteString Void (RIO e) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logTrace "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ ∷ Ev) -> pure ()
showEvents pb (succ eId) cycle
showEvents
:: PB.ProgressBar ()
-> EventId
-> EventId
-> ConduitT ByteString Void (RIO KingEnv) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logDebug "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ :: Ev) -> pure ()
showEvents pb (succ eId) cycle
unpackJob :: Noun -> RIO KingEnv (Mug, Wen, Noun)
unpackJob = io . fromNounExn
unpackJob :: Noun -> RIO e (Mug, Wen, Noun)
unpackJob = io . fromNounExn
--------------------------------------------------------------------------------
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx = error "TODO"
{-
{-|
This runs the serf at `$top/.tmpdir`, but we disable snapshots,
so this should never actually be created. We just do this to avoid
letting the serf use an existing snapshot.
-}
collectAllFx :: ∀e. HasLogFunc e => FilePath -> RIO e ()
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx top = do
logTrace $ display $ pack @Text top
rwith collectedFX $ \() ->
logTrace "Done collecting effects!"
logDebug $ display $ pack @Text top
vSlog <- logSlogs
rwith (collectedFX vSlog) $ \() ->
logDebug "Done collecting effects!"
where
tmpDir :: FilePath
tmpDir = top </> ".tmpdir"
collectedFX :: RAcquire e ()
collectedFX = do
collectedFX :: TVar (Text -> IO ()) -> RAcquire KingEnv ()
collectedFX vSlog = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
serf <- Pier.runSerf vSlog tmpDir serfFlags
rio $ Serf.collectFX serf log
serfFlags :: Serf.Flags
serfFlags :: [Serf.Flag]
serfFlags = [Serf.Hashless, Serf.DryRun]
-}
--------------------------------------------------------------------------------
replayPartEvs :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
=> FilePath -> Word64 -> RIO e ()
replayPartEvs :: FilePath -> Word64 -> RIO KingEnv ()
replayPartEvs top last = do
logTrace $ display $ pack @Text top
logDebug $ display $ pack @Text top
fetchSnapshot
rwith replayedEvs $ \() ->
logTrace "Done replaying events!"
logDebug "Done replaying events!"
where
fetchSnapshot :: RIO e ()
fetchSnapshot :: RIO KingEnv ()
fetchSnapshot = do
snap <- Pier.getSnapshot top last
case snap of
@ -305,20 +356,28 @@ replayPartEvs top last = do
tmpDir :: FilePath
tmpDir = top </> ".partial-replay" </> show last
replayedEvs :: RAcquire e ()
replayedEvs :: RAcquire KingEnv ()
replayedEvs = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
let onSlog = print
let onStdr = print
let onDead = error "DIED"
let config = Serf.Config "urbit-worker" tmpDir serfFlags onSlog onStdr onDead
(serf, info) <- io (Serf.start config)
rio $ do
ss <- Serf.replay serf log $ Just last
Serf.snapshot serf ss
eSs <- Serf.execReplay serf log (Just last)
case eSs of
Left bail -> error (show bail)
Right 0 -> io (Serf.snapshot serf)
Right num -> pure ()
io $ threadDelay 500000 -- Copied from runOrExitImmediately
pure ()
serfFlags :: Serf.Flags
serfFlags :: [Serf.Flag]
serfFlags = [Serf.Hashless]
--------------------------------------------------------------------------------
{-|
@ -326,84 +385,98 @@ replayPartEvs top last = do
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
putStrLn "Reading pill file."
logDebug "Reading pill file."
pillBytes <- readFile pax
putStrLn "Cueing pill file."
logDebug "Cueing pill file."
pillNoun <- io $ cueBS pillBytes & either throwIO pure
putStrLn "Parsing pill file."
logDebug "Parsing pill file."
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
putStrLn "Using pill to generate boot sequence."
bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
logDebug "Using pill to generate boot sequence."
bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0))
putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
logDebug "Validate jam/cue and toNoun/fromNoun on pill value"
reJam <- validateNounVal pill
putStrLn "Checking if round-trip matches input file:"
logDebug "Checking if round-trip matches input file:"
unless (reJam == pillBytes) $ do
putStrLn " Our jam does not match the file...\n"
putStrLn " This is surprising, but it is probably okay."
logDebug " Our jam does not match the file...\n"
logDebug " This is surprising, but it is probably okay."
when showPil $ do
putStrLn "\n\n== Pill ==\n"
logDebug "\n\n== Pill ==\n"
io $ pPrint pill
when showSeq $ do
putStrLn "\n\n== Boot Sequence ==\n"
logDebug "\n\n== Boot Sequence ==\n"
io $ pPrint bootSeq
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
=> a -> RIO e ByteString
validateNounVal inpVal = do
putStrLn " jam"
logDebug " jam"
inpByt <- evaluate $ jamBS $ toNoun inpVal
putStrLn " cue"
logDebug " cue"
outNon <- cueBS inpByt & either throwIO pure
putStrLn " fromNoun"
logDebug " fromNoun"
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
putStrLn " toNoun"
logDebug " toNoun"
outNon <- evaluate (toNoun outVal)
putStrLn " jam"
logDebug " jam"
outByt <- evaluate $ jamBS outNon
putStrLn "Checking if: x == cue (jam x)"
logDebug "Checking if: x == cue (jam x)"
unless (inpVal == outVal) $
error "Value fails test: x == cue (jam x)"
putStrLn "Checking if: jam x == jam (cue (jam x))"
logDebug "Checking if: jam x == jam (cue (jam x))"
unless (inpByt == outByt) $
error "Value fails test: jam x == jam (cue (jam x))"
pure outByt
--------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO e Pill
pillFrom :: CLI.PillSource -> RIO KingEnv Pill
pillFrom = \case
CLI.PillSourceFile pillPath -> do
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
io (loadFile pillPath >>= either throwIO pure)
pillFrom (CLI.PillSourceFile pillPath) = do
putStrLn $ "boot: reading pill from " ++ pack pillPath
io (loadFile pillPath >>= either throwIO pure)
CLI.PillSourceURL url -> do
logDebug $ display $ "boot: retrieving pill from " ++ (pack url :: Text)
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
pillFrom (CLI.PillSourceURL url) = do
putStrLn $ "boot: retrieving pill from " ++ pack url
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
newShip :: CLI.New -> CLI.Opts -> RIO KingEnv ()
newShip CLI.New{..} opts = do
{-
TODO XXX HACK
newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
newShip CLI.New{..} opts
| CLI.BootComet <- nBootType = do
Because the "new ship" flow *may* automatically start the ship,
we need to create this, but it's not actually correct.
The right solution is to separate out the "new ship" flow from the
"run ship" flow, and possibly sequence them from the outside if
that's really needed.
-}
multi <- multiEyre (MultiEyreConf Nothing Nothing True)
case nBootType of
CLI.BootComet -> do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
@ -413,14 +486,14 @@ newShip CLI.New{..} opts
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
bootFromSeed multi pill seed
| CLI.BootFake name <- nBootType = do
CLI.BootFake name -> do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
runTryBootFromPill multi pill name ship (Fake ship)
| CLI.BootFromKeyfile keyFile <- nBootType = do
CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
@ -433,10 +506,10 @@ newShip CLI.New{..} opts
pill <- pillFrom nPillSource
bootFromSeed pill seed
bootFromSeed multi pill seed
where
shipFrom :: Text -> RIO e Ship
shipFrom :: Text -> RIO KingEnv Ship
shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
@ -446,7 +519,7 @@ newShip CLI.New{..} opts
Just x -> x
Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO e Text
nameFromShip :: Ship -> RIO KingEnv Text
nameFromShip s = name
where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@ -454,8 +527,8 @@ newShip CLI.New{..} opts
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x
bootFromSeed :: Pill -> Seed -> RIO e ()
bootFromSeed pill seed = do
bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO KingEnv ()
bootFromSeed multi pill seed = do
ethReturn <- dawnVent seed
case ethReturn of
@ -463,43 +536,51 @@ newShip CLI.New{..} opts
Right dawn -> do
let ship = sShip $ dSeed dawn
name <- nameFromShip ship
runTryBootFromPill pill name ship (Dawn dawn)
flags = toSerfFlags opts
runTryBootFromPill multi pill name ship (Dawn dawn)
-- Now that we have all the information for running an application with a
-- PierConfig, do so.
runTryBootFromPill pill name ship bootEvent = do
runTryBootFromPill multi pill name ship bootEvent = do
vKill <- view kingEnvKillSignal
let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts
io $ runPierApp pierConfig networkConfig True $
tryBootFromPill True pill nLite flags ship bootEvent
runPierEnv pierConfig networkConfig vKill $
tryBootFromPill True pill nLite ship bootEvent multi
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
runShipEnv (CLI.Run pierPath) opts vKill act = do
runPierEnv pierConfig netConfig vKill act
where
pierConfig = toPierConfig pierPath opts
netConfig = toNetworkConfig opts
runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
runShip (CLI.Run pierPath) opts daemon = do
tid <- myThreadId
let onTermExit = throwTo tid UserInterrupt
mStart <- newEmptyMVar
runShip
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon multi = do
mStart <- newEmptyMVar
if daemon
then runPier mStart
else do
-- Wait until the pier has started up, then connect a terminal. If
-- the terminal ever shuts down, ask the ship to go down.
connectionThread <- async $ do
readMVar mStart
finally (runAppNoLog $ connTerm pierPath) onTermExit
finally (runPier mStart) (cancel connectionThread)
finally (connTerm pierPath) $ do
view killPierActionL >>= atomically
-- Run the pier until it finishes, and then kill the terminal.
finally (runPier mStart) $ do
cancel connectionThread
where
runPier mStart =
runPierApp pierConfig networkConfig daemon $
tryPlayShip
(CLI.oExit opts)
(CLI.oFullReplay opts)
(CLI.oDryFrom opts)
(toSerfFlags opts)
mStart
pierConfig = toPierConfig pierPath opts
networkConfig = toNetworkConfig opts
runPier :: MVar () -> RIO PierEnv ()
runPier mStart = do
tryPlayShip
(CLI.oExit opts)
(CLI.oFullReplay opts)
(CLI.oDryFrom opts)
mStart
multi
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
@ -540,33 +621,200 @@ checkComet = do
main :: IO ()
main = do
args <- CLI.parseArgs
hSetBuffering stdout NoBuffering
setupSignalHandlers
runKingEnv args $ case args of
CLI.CmdRun ko ships -> runShips ko ships
CLI.CmdNew n o -> newShip n o
CLI.CmdBug (CLI.CollectAllFX pax ) -> collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax ) -> startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l
CLI.CmdBug (CLI.ReplayEvents pax l ) -> replayPartEvs pax l
CLI.CmdBug (CLI.CheckDawn pax ) -> checkDawn pax
CLI.CmdBug CLI.CheckComet -> checkComet
CLI.CmdCon pier -> connTerm pier
where
runKingEnv args =
let verb = verboseLogging args
in if willRunTerminal args
then runKingEnvLogFile verb
else runKingEnvStderr verb
setupSignalHandlers = do
mainTid <- myThreadId
let onKillSig = throwTo mainTid UserInterrupt
for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do
Sys.installHandler sig (Sys.Catch onKillSig) Nothing
hSetBuffering stdout NoBuffering
verboseLogging :: CLI.Cmd -> Bool
verboseLogging = \case
CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
_ -> False
let onTermSig = throwTo mainTid UserInterrupt
willRunTerminal :: CLI.Cmd -> Bool
willRunTerminal = \case
CLI.CmdCon _ -> True
CLI.CmdRun ko [(_,_,daemon)] -> not daemon
CLI.CmdRun ko _ -> False
_ -> False
Sys.installHandler Sys.sigTERM (Sys.Catch onTermSig) Nothing
CLI.parseArgs >>= \case
CLI.CmdRun r o d -> runShip r o d
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.ReplayEvents pax l) -> runApp $ replayPartEvs pax l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon pier -> runAppLogFile $ connTerm pier
{-
Runs a ship but restarts it if it crashes or shuts down on it's own.
Once `waitForKillRequ` returns, the ship will be terminated and this
routine will exit.
TODO Use logging system instead of printing.
-}
runShipRestarting
:: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
runShipRestarting r o multi = do
let pier = pack (CLI.rPierPath r)
loop = runShipRestarting r o multi
onKill <- view onKillKingSigL
vKillPier <- newEmptyTMVarIO
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi
let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill
atomically (onShipExit <|> onKillRequ) >>= \case
Left exit -> do
case exit of
Left err -> logError $ display (tshow err <> ": " <> pier)
Right () ->
logError $ display ("Ship exited on it's own. Why? " <> pier)
threadDelay 250_000
loop
Right () -> do
logTrace $ display (pier <> " shutdown requested")
race_ (wait tid) $ do
threadDelay 5_000_000
logDebug $ display (pier <> " not down after 5s, killing with fire.")
cancel tid
logTrace $ display ("Ship terminated: " <> pier)
{-
TODO This is messy and shared a lot of logic with `runShipRestarting`.
-}
runShipNoRestart
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv ()
runShipNoRestart r o d multi = do
vKill <- view kingEnvKillSignal -- killing ship same as killing king
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d multi)
onKill <- view onKillKingSigL
let pier = pack (CLI.rPierPath r)
let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill
atomically (onShipExit <|> onKillRequ) >>= \case
Left (Left err) -> do
logError $ display (tshow err <> ": " <> pier)
Left (Right ()) -> do
logError $ display (pier <> " exited on it's own. Why?")
Right () -> do
logTrace $ display (pier <> " shutdown requested")
race_ (wait tid) $ do
threadDelay 5_000_000
logTrace $ display (pier <> " not down after 5s, killing with fire.")
cancel tid
logTrace $ display (pier <> " terminated.")
runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
runShips CLI.KingOpts {..} ships = do
let meConf = MultiEyreConf
{ mecHttpPort = fromIntegral <$> koSharedHttpPort
, mecHttpsPort = fromIntegral <$> koSharedHttpsPort
, mecLocalhostOnly = False -- TODO Localhost-only needs to be
-- a king-wide option.
}
{-
TODO Need to rework RIO environment to fix this. Should have a
bunch of nested contexts:
- King has started. King has Id. Logging available.
- In running environment. MultiEyre and global config available.
- In pier environment: pier path and config available.
- In running ship environment: serf state, event queue available.
-}
multi <- multiEyre meConf
go multi ships
where
go :: MultiEyreApi -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
go me = \case
[] -> pure ()
[rod] -> runSingleShip rod me
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
-- TODO Duplicated logic.
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> MultiEyreApi -> RIO KingEnv ()
runSingleShip (r, o, d) multi = do
shipThread <- async (runShipNoRestart r o d multi)
{-
Wait for the ship to go down.
Since `waitCatch` will never throw an exception, the `onException`
block will only happen if this thread is killed with an async
exception. The one we expect is `UserInterrupt` which will be raised
on this thread upon SIGKILL or SIGTERM.
If this thread is killed, we first ask the ship to go down, wait
for the ship to actually go down, and then go down ourselves.
-}
onException (void $ waitCatch shipThread) $ do
logTrace "KING IS GOING DOWN"
atomically =<< view killKingActionL
waitCatch shipThread
pure ()
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv ()
runMultipleShips ships multi = do
shipThreads <- for ships $ \(r, o) -> do
async (runShipRestarting r o multi)
{-
Since `spin` never returns, this will run until the main
thread is killed with an async exception. The one we expect is
`UserInterrupt` which will be raised on this thread upon SIGKILL
or SIGTERM.
Once that happens, we send a shutdown signal which will cause all
ships to be shut down, and then we `wait` for them to finish before
returning.
This is different than the single-ship flow, because ships never
go down on their own in this flow. If they go down, they just bring
themselves back up.
-}
let spin = forever (threadDelay maxBound)
finally spin $ do
logTrace "KING IS GOING DOWN"
view killKingActionL >>= atomically
for_ shipThreads waitCatch
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm pier =
Term.runTerminalClient pier
connTerm = Term.runTerminalClient
--------------------------------------------------------------------------------

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

@ -1,87 +1,162 @@
{-|
Ames IO Driver -- UDP
Ames IO Driver
-}
module Urbit.Vere.Ames (ames) where
module Urbit.Vere.Ames (ames, ames', PacketOutcome(..)) where
import Urbit.Prelude
import Control.Monad.Extra hiding (mapM_)
import Network.Socket hiding (recvFrom, sendTo)
import Network.Socket.ByteString
import Urbit.Arvo hiding (Fake)
import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake)
import Urbit.King.Config
import Urbit.Vere.Pier.Types
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Urbit.Ob as Ob
import qualified Urbit.Time as Time
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
-- Constants -------------------------------------------------------------------
-- | How many unprocessed ames packets to allow in the queue before we start
-- dropping incoming packets.
queueBound :: Word
queueBound = 1000
-- | How often, measured in number of packets dropped, we should announce packet
-- loss.
packetsDroppedPerComplaint :: Word
packetsDroppedPerComplaint = 1000
-- Types -----------------------------------------------------------------------
data AmesDrv = AmesDrv
{ aTurfs :: TVar (Maybe [Turf])
, aGalaxies :: IORef (M.Map Galaxy (Async (), TQueue ByteString))
, aSocket :: TVar (Maybe Socket)
, aListener :: Async ()
, aSendingQueue :: TQueue (SockAddr, ByteString)
, aSendingThread :: Async ()
{ aTurfs :: TVar (Maybe [Turf])
, aDropped :: TVar Word
, aUdpServ :: UdpServ
, aResolvr :: ResolvServ
, aRecvTid :: Async ()
}
data NetworkMode = Fake | Localhost | Real | NoNetwork
deriving (Eq, Ord, Show)
data PacketOutcome
= Intake
| Ouster
-- Utils -----------------------------------------------------------------------
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
galaxyPort Fake (Patp g) = fromIntegral g + 31337
galaxyPort Localhost (Patp g) = fromIntegral g + 13337
galaxyPort Real (Patp g) = fromIntegral g + 13337
galaxyPort NoNetwork _ = fromIntegral 0
listenPort :: NetworkMode -> Ship -> PortNumber
listenPort m s | s < 256 = galaxyPort m (fromIntegral s)
listenPort m _ = 0
listenPort m _ = 0 -- I don't care, just give me any port.
localhost :: HostAddress
localhost = tupleToHostAddress (127,0,0,1)
localhost = tupleToHostAddress (127, 0, 0, 1)
inaddrAny :: HostAddress
inaddrAny = tupleToHostAddress (0,0,0,0)
inaddrAny = tupleToHostAddress (0, 0, 0, 0)
okayFakeAddr :: AmesDest -> Bool
okayFakeAddr = \case
EachYes _ -> True
EachNo (Jammed (AAIpv4 (Ipv4 a) _)) -> a == localhost
EachNo (Jammed (AAVoid v)) -> absurd v
modeAddress :: NetworkMode -> Maybe HostAddress
modeAddress = \case
Fake -> Just localhost
Localhost -> Just localhost
Real -> Just inaddrAny
NoNetwork -> Nothing
localhostSockAddr :: NetworkMode -> AmesDest -> SockAddr
localhostSockAddr mode = \case
EachYes g -> SockAddrInet (galaxyPort mode g) localhost
EachNo (Jammed (AAIpv4 _ p)) -> SockAddrInet (fromIntegral p) localhost
EachNo (Jammed (AAVoid v)) -> absurd v
okFakeAddr :: AmesDest -> Bool
okFakeAddr = \case
EachYes _ -> True
EachNo (Jammed (AAIpv4 (Ipv4 a) _)) -> a == localhost
EachNo (Jammed (AAVoid v )) -> absurd v
localAddr :: NetworkMode -> AmesDest -> SockAddr
localAddr mode = \case
EachYes g -> SockAddrInet (galaxyPort mode g) localhost
EachNo (Jammed (AAIpv4 _ p)) -> SockAddrInet (fromIntegral p) localhost
EachNo (Jammed (AAVoid v )) -> absurd v
bornEv :: KingId -> Ev
bornEv inst =
EvBlip $ BlipEvNewt $ NewtEvBorn (fromIntegral inst, ()) ()
bornEv inst = EvBlip $ BlipEvNewt $ NewtEvBorn (fromIntegral inst, ()) ()
hearEv :: PortNumber -> HostAddress -> ByteString -> Ev
hearEv p a bs =
EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
where
dest = EachNo $ Jammed $ AAIpv4 (Ipv4 a) (fromIntegral p)
_turfText :: Turf -> Text
_turfText = intercalate "." . reverse . fmap unCord . unTurf
renderGalaxy :: Galaxy -> Text
renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
where
dest = EachNo $ Jammed $ AAIpv4 (Ipv4 a) (fromIntegral p)
--------------------------------------------------------------------------------
netMode :: HasNetworkConfig e => Bool -> RIO e NetworkMode
netMode isFake = do
netMode <- view (networkConfigL . ncNetMode)
noAmes <- view (networkConfigL . ncNoAmes)
pure $ case (noAmes, isFake, netMode) of
(True, _ , _ ) -> NoNetwork
(_ , _ , NMNone ) -> NoNetwork
(_ , True, _ ) -> Fake
(_ , _ , NMNormal ) -> Real
(_ , _ , NMLocalhost) -> Localhost
udpPort :: HasNetworkConfig e => Bool -> Ship -> RIO e PortNumber
udpPort isFake who = do
mode <- netMode isFake
mPort <- view (networkConfigL . ncAmesPort)
pure $ maybe (listenPort mode who) fromIntegral mPort
udpServ :: (HasLogFunc e, HasNetworkConfig e) => Bool -> Ship -> RIO e UdpServ
udpServ isFake who = do
mode <- netMode isFake
port <- udpPort isFake who
case modeAddress mode of
Nothing -> fakeUdpServ
Just host -> realUdpServ port host
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
pure () -- TODO What can we do?
ames'
:: HasPierEnv e
=> Ship
-> Bool
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
ames' who isFake stderr = do
-- Unfortunately, we cannot use TBQueue because the only behavior
-- provided for when full is to block the writer. The implementation
-- below uses materially the same data structures as TBQueue, however.
ventQ :: TQueue EvErr <- newTQueueIO
avail :: TVar Word <- newTVarIO queueBound
let
enqueuePacket p = do
vail <- readTVar avail
if vail > 0
then do
modifyTVar avail (subtract 1)
writeTQueue ventQ p
pure Intake
else do
_ <- readTQueue ventQ
writeTQueue ventQ p
pure Ouster
dequeuePacket = do
pM <- tryReadTQueue ventQ
when (isJust pM) $ modifyTVar avail (+ 1)
pure pM
env <- ask
let (bornEvs, startDriver) = ames env who isFake enqueuePacket stderr
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> dequeuePacket
pure (DriverApi {..})
pure (bornEvs, runDriver)
{-|
inst -- Process instance number.
who -- Which ship are we?
@ -93,229 +168,81 @@ renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
TODO verify that the KingIds match on effects.
-}
ames :: forall e. (HasLogFunc e, HasNetworkConfig e)
=> KingId -> Ship -> Bool -> QueueEv
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (EffCb e NewtEf))
ames inst who isFake enqueueEv stderr =
(initialEvents, runAmes)
where
initialEvents :: [Ev]
initialEvents = [bornEv inst]
ames
:: forall e
. (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> e
-> Ship
-> Bool
-> (EvErr -> STM PacketOutcome)
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (NewtEf -> IO ()))
ames env who isFake enqueueEv stderr = (initialEvents, runAmes)
where
king = fromIntegral (env ^. kingIdL)
runAmes :: RAcquire e (EffCb e NewtEf)
runAmes = do
drv <- mkRAcquire start stop
pure (handleEffect drv)
initialEvents :: [Ev]
initialEvents = [bornEv king]
start :: RIO e AmesDrv
start = do
aTurfs <- newTVarIO Nothing
aGalaxies <- newIORef mempty
aSocket <- newTVarIO Nothing
bindSock aSocket
aListener <- async (waitPacket aSocket)
aSendingQueue <- newTQueueIO
aSendingThread <- async (sendingThread aSendingQueue aSocket)
pure $ AmesDrv{..}
runAmes :: RAcquire e (NewtEf -> IO ())
runAmes = do
mode <- rio (netMode isFake)
drv <- mkRAcquire start stop
pure (handleEffect drv mode)
netMode :: RIO e NetworkMode
netMode = do
if isFake
then pure Fake
else view (networkConfigL . ncNetMode) >>= \case
NMNormal -> pure Real
NMLocalhost -> pure Localhost
NMNone -> pure NoNetwork
start :: HasLogFunc e => RIO e AmesDrv
start = do
aTurfs <- newTVarIO Nothing
aDropped <- newTVarIO 0
aUdpServ <- udpServ isFake who
aRecvTid <- queuePacketsThread aDropped aUdpServ
aResolvr <- resolvServ aTurfs (usSend aUdpServ) stderr
pure (AmesDrv { .. })
stop :: AmesDrv -> RIO e ()
stop AmesDrv{..} = do
readIORef aGalaxies >>= mapM_ (cancel . fst)
hearFailed _ = pure ()
cancel aSendingThread
cancel aListener
socket <- atomically $ readTVar aSocket
io $ maybeM (pure ()) (close') (pure socket)
queuePacketsThread :: HasLogFunc e => TVar Word -> UdpServ -> RIO e (Async ())
queuePacketsThread dropCtr UdpServ {..} = async $ forever $ do
outcome <- atomically $ do
(p, a, b) <- usRecv
enqueueEv (EvErr (hearEv p a b) hearFailed)
case outcome of
Intake -> pure ()
Ouster -> do
d <- atomically $ do
d <- readTVar dropCtr
writeTVar dropCtr (d + 1)
pure d
when (d `rem` packetsDroppedPerComplaint == 0) $
logWarn "ames: queue full; dropping inbound packets"
bindSock :: TVar (Maybe Socket) -> RIO e ()
bindSock socketVar = getBindAddr >>= doBindSocket
where
getBindAddr = netMode >>= \case
Fake -> pure $ Just localhost
Localhost -> pure $ Just localhost
Real -> pure $ Just inaddrAny
NoNetwork -> pure Nothing
stop :: AmesDrv -> RIO e ()
stop AmesDrv {..} = io $ do
usKill aUdpServ
rsKill aResolvr
cancel aRecvTid
doBindSocket :: Maybe HostAddress -> RIO e ()
doBindSocket Nothing = atomically $ writeTVar socketVar Nothing
doBindSocket (Just bindAddr) = do
mode <- netMode
mPort <- view (networkConfigL . ncAmesPort)
let ourPort = maybe (listenPort mode who) fromIntegral mPort
s <- io $ socket AF_INET Datagram defaultProtocol
handleEffect :: AmesDrv -> NetworkMode -> NewtEf -> IO ()
handleEffect drv@AmesDrv {..} mode = runRIO env . \case
NewtEfTurf (_id, ()) turfs -> do
atomically $ writeTVar aTurfs (Just turfs)
logTrace $ displayShow ("(ames) Binding to port ", ourPort)
let addr = SockAddrInet ourPort bindAddr
() <- io $ bind s addr
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
atomically (readTVar aTurfs) >>= \case
Nothing -> pure ()
Just turfs -> sendPacket drv mode dest bs
atomically $ writeTVar socketVar (Just s)
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
sendPacket AmesDrv {..} mode dest byt = do
let to adr = io (usSend aUdpServ adr byt)
waitPacket :: TVar (Maybe Socket) -> RIO e ()
waitPacket socketVar = do
(atomically $ readTVar socketVar) >>= \case
Nothing -> pure ()
Just s -> do
res <- io $ tryIOError $ recvFrom s 4096
case res of
Left exn -> do
-- When we have a socket exception, we need to rebuild the
-- socket.
logTrace $ displayShow ("(ames) Socket exception. Rebinding.")
bindSock socketVar
Right (bs, addr) -> do
logTrace $ displayShow ("(ames) Received packet from ", addr)
case addr of
SockAddrInet p a -> atomically (enqueueEv $ hearEv p a bs)
_ -> pure ()
case (mode, dest) of
(NoNetwork, _ ) -> pure ()
(Fake , _ ) -> when (okFakeAddr dest) $ to (localAddr Fake dest)
(Localhost, _ ) -> to (localAddr Localhost dest)
(Real , ra) -> ra & \case
EachYes gala -> io (rsSend aResolvr gala byt)
EachNo addr -> to (ipv4Addr addr)
waitPacket socketVar
handleEffect :: AmesDrv -> NewtEf -> RIO e ()
handleEffect drv@AmesDrv{..} = \case
NewtEfTurf (_id, ()) turfs -> do
atomically $ writeTVar aTurfs (Just turfs)
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
atomically (readTVar aTurfs) >>= \case
Nothing -> pure ()
Just turfs -> do
mode <- netMode
(sendPacket drv mode dest bs)
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
sendPacket AmesDrv{..} NoNetwork dest bs = pure ()
sendPacket AmesDrv{..} Fake dest bs = do
when (okayFakeAddr dest) $ atomically $
writeTQueue aSendingQueue ((localhostSockAddr Fake dest), bs)
-- In localhost only mode, regardless of the actual destination, send it to
-- localhost.
sendPacket AmesDrv{..} Localhost dest bs = atomically $
writeTQueue aSendingQueue ((localhostSockAddr Localhost dest), bs)
sendPacket AmesDrv{..} Real (EachYes galaxy) bs = do
galaxies <- readIORef aGalaxies
queue <- case M.lookup galaxy galaxies of
Just (_, queue) -> pure queue
Nothing -> do
inQueue <- newTQueueIO
thread <- async $ galaxyResolver galaxy aTurfs inQueue aSendingQueue
modifyIORef (aGalaxies) (M.insert galaxy (thread, inQueue))
pure inQueue
atomically $ writeTQueue queue bs
sendPacket AmesDrv{..} Real (EachNo (Jammed (AAIpv4 a p))) bs = do
let addr = SockAddrInet (fromIntegral p) (unIpv4 a)
atomically $ writeTQueue aSendingQueue (addr, bs)
sendPacket AmesDrv{..} Real (EachNo (Jammed (AAVoid v))) bs = do
pure (absurd v)
-- An outbound queue of messages. We can only write to a socket from one
-- thread, so coalesce those writes here.
sendingThread :: TQueue (SockAddr, ByteString)
-> TVar (Maybe Socket)
-> RIO e ()
sendingThread queue socketVar = forever $
do
(dest, bs) <- atomically $ readTQueue queue
logTrace $ displayShow ("(ames) Sending packet to ", dest)
sendAll bs dest
where
sendAll bs dest = do
mybSocket <- atomically $ readTVar socketVar
case mybSocket of
Nothing -> pure ()
Just socket -> do
bytesSent <- io $ sendTo socket bs dest
when (bytesSent /= BS.length bs) $ do
sendAll (drop bytesSent bs) dest
-- Asynchronous thread per galaxy which handles domain resolution, and can
-- block its own queue of ByteStrings to send.
--
-- Maybe perform the resolution asynchronously, injecting into the resolver
-- queue as a message.
--
-- TODO: Figure out how the real haskell time library works.
galaxyResolver :: Galaxy -> TVar (Maybe [Turf]) -> TQueue ByteString
-> TQueue (SockAddr, ByteString)
-> RIO e ()
galaxyResolver galaxy turfVar incoming outgoing =
loop Nothing Time.unixEpoch
where
loop :: Maybe SockAddr -> Time.Wen -> RIO e ()
loop lastGalaxyIP lastLookupTime = do
packet <- atomically $ readTQueue incoming
checkIP lastGalaxyIP lastLookupTime >>= \case
(Nothing, t) -> do
-- We've failed to lookup the IP. Drop the outbound packet
-- because we have no IP for our galaxy, including possible
-- previous IPs.
logDebug $ displayShow
("(ames) Dropping packet; no ip for galaxy ", galaxy)
loop Nothing t
(Just ip, t) -> do
queueSendToGalaxy ip packet
loop (Just ip) t
checkIP :: Maybe SockAddr -> Time.Wen
-> RIO e (Maybe SockAddr, Time.Wen)
checkIP lastIP lastLookupTime = do
current <- io $ Time.now
if (Time.gap current lastLookupTime ^. Time.secs) < 300
then pure (lastIP, lastLookupTime)
else do
toCheck <- fromMaybe [] <$> atomically (readTVar turfVar)
mybIp <- resolveFirstIP lastIP toCheck
timeAfterResolution <- io $ Time.now
pure (mybIp, timeAfterResolution)
resolveFirstIP :: Maybe SockAddr -> [Turf] -> RIO e (Maybe SockAddr)
resolveFirstIP prevIP [] = do
stderr $ "ames: czar at " ++ renderGalaxy galaxy ++ ": not found"
logDebug $ displayShow
("(ames) Failed to lookup IP for ", galaxy)
pure prevIP
resolveFirstIP prevIP (x:xs) = do
hostname <- buildDNS galaxy x
let portstr = show $ galaxyPort Real galaxy
listIPs <- io $ getAddrInfo Nothing (Just hostname) (Just portstr)
case listIPs of
[] -> resolveFirstIP prevIP xs
(y:ys) -> do
let sockaddr = Just $ addrAddress y
when (sockaddr /= prevIP) $
stderr $ "ames: czar " ++ renderGalaxy galaxy ++ ": ip " ++
(tshow $ addrAddress y)
logDebug $ displayShow
("(ames) Looked up ", hostname, portstr, y)
pure sockaddr
buildDNS :: Galaxy -> Turf -> RIO e String
buildDNS (Patp g) turf = do
let nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral g
name <- case stripPrefix "~" nameWithSig of
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure (unpack x)
pure $ name ++ "." ++ (unpack $ _turfText turf)
queueSendToGalaxy :: SockAddr -> ByteString -> RIO e ()
queueSendToGalaxy inet packet = do
atomically $ writeTQueue outgoing (inet, packet)
ipv4Addr (Jammed (AAVoid v )) = absurd v
ipv4Addr (Jammed (AAIpv4 a p)) = SockAddrInet (fromIntegral p) (unIpv4 a)

217
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/DNS.hs Normal file
View File

@ -0,0 +1,217 @@
{-|
Handles sending packets to galaxies. We need to get their IP addresses
from DNS, which is more complicated.
-- Asynchronous thread per galaxy which handles domain resolution, and can
-- block its own queue of ByteStrings to send.
--
-- Maybe perform the resolution asynchronously, injecting into the resolver
-- queue as a message.
--
-- TODO: Figure out how the real haskell time library works.
-- We've failed to lookup the IP. Drop the outbound packet
-- because we have no IP for our galaxy, including possible
-- previous IPs.
{-
- Sending Packets to Galaxies.
- Each galaxy has it's own DNS resolution thread.
- Initially, no threads are started.
- To send a message to a galaxy,
- Check to see if it already has a resolution thread.
- If it does, pass the packet to that thread.
- If it doesn't, start a new thread and give it the packet.
- Galaxy resolution threads work as follows:
- First, they are given:
- They know which galaxy they are responsible for.
- They have access to the turfs TVar (shared state with Ames driver).
- They can be given packets (to be send to their galaxy).
- They must be given a way to send UDP packets.
- Next, we loop forever
- In the loop we track:
- the last-known IP address.
- the time when we last looked up the IP address.
- We wait to be given a packet.
- We get the IP address.
- If we looked up the IP address in the last 5 minute, use the
cached IP address.
- Just use the one from last time.
- Otherwise,
- Do a DNS lookup.
- Go through the turf list one item at a time.
- Try each one.
- If it resolves to one-or-more IP addresses,
- Use the first one.
- If it resolves to zero IP addresses, move on to the next turf.
- If none of the turfs can be used to resolve the IP address,
then we don't know where the galaxy is.
- Drop the packet.
-}
-}
module Urbit.Vere.Ames.DNS
( NetworkMode(..)
, ResolvServ(..)
, resolvServ
, galaxyPort
, renderGalaxy
)
where
import Urbit.Prelude
import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake)
import qualified Data.Map as M
import qualified Urbit.Noun.Time as Time
import qualified Urbit.Ob as Ob
-- Types -----------------------------------------------------------------------
data NetworkMode = Fake | Localhost | Real | NoNetwork
deriving (Eq, Ord, Show)
data ResolvServ = ResolvServ
{ rsSend :: Galaxy -> ByteString -> IO ()
, rsKill :: IO ()
}
-- Utils -----------------------------------------------------------------------
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
galaxyPort Fake (Patp g) = fromIntegral g + 31337
galaxyPort Localhost (Patp g) = fromIntegral g + 13337
galaxyPort Real (Patp g) = fromIntegral g + 13337
galaxyPort NoNetwork _ = fromIntegral 0
turfText :: Turf -> Text
turfText = intercalate "." . reverse . fmap unCord . unTurf
renderGalaxy :: Galaxy -> Text
renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
galaxyHostname :: Galaxy -> Turf -> Text
galaxyHostname g t = galaName g ++ "." ++ turfText t
where
stripSig :: Text -> Text
stripSig inp = fromMaybe inp (stripPrefix "~" inp)
galaName :: Galaxy -> Text
galaName = stripSig . renderGalaxy
resolv :: Galaxy -> [Turf] -> IO (Maybe (Turf, Text, PortNumber, SockAddr))
resolv gal = go
where
go = \case
[] -> pure Nothing
turf : turfs -> do
let host = galaxyHostname gal turf
port = galaxyPort Real gal
getAddrInfo Nothing (Just (unpack host)) (Just (show port)) >>= \case
[] -> go turfs
ip : _ -> pure $ Just (turf, host, port, addrAddress ip)
doResolv
:: HasLogFunc e
=> Galaxy
-> (Time.Wen, Maybe SockAddr)
-> [Turf]
-> (Text -> RIO e ())
-> RIO e (Maybe SockAddr, Time.Wen)
doResolv gal (prevWen, prevIP) turfs stderr = do
current <- io $ Time.now
if (Time.gap current prevWen ^. Time.secs) < 300
then pure (prevIP, prevWen)
else do
tim <- io (Time.now)
io (resolv gal turfs) >>= \case
Nothing -> do
stderr $ "ames: czar at " ++ galStr ++ ": not found"
logDebug $ displayShow ("(ames) Failed to lookup IP for ", gal)
pure (prevIP, tim)
Just (turf, host, port, addr) -> do
when (Just addr /= prevIP) (printCzar addr)
logDebug $ displayShow ("(ames) Looked up ", host, port, turf, addr)
pure (Just addr, tim)
where
galStr = renderGalaxy gal
printCzar addr = stderr $ "ames: czar " ++ galStr ++ ": ip " ++ tshow addr
resolvWorker
:: forall e
. HasLogFunc e
=> Galaxy
-> TVar (Maybe [Turf])
-> TVar (Time.Wen, Maybe SockAddr)
-> STM ByteString
-> (SockAddr -> ByteString -> IO ())
-> (Text -> RIO e ())
-> RIO e (Async ())
resolvWorker gal vTurfs vLast waitMsg send stderr = async (forever go)
where
logDrop =
logDebug $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
go :: RIO e ()
go = do
(packt, turfs, (lastTime, lastAddr)) <- atomically
((,,) <$> waitMsg <*> readTVar vTurfs <*> readTVar vLast)
(newAddr, newTime) <- doResolv gal
(lastTime, lastAddr)
(fromMaybe [] turfs)
stderr
maybe logDrop (\ip -> io (send ip packt)) newAddr
atomically $ writeTVar vLast (newTime, newAddr)
resolvServ
:: HasLogFunc e
=> TVar (Maybe [Turf])
-> (SockAddr -> ByteString -> IO ())
-> (Text -> RIO e ())
-> RIO e ResolvServ
resolvServ vTurfs send stderr = do
vGala <- newTVarIO (mempty :: Map Galaxy (Async (), TQueue ByteString))
vDead <- newTVarIO False
envir <- ask
let spawnWorker :: Galaxy -> IO (Async (), TQueue ByteString)
spawnWorker gal = runRIO envir $ do
que <- newTQueueIO
las <- newTVarIO (Time.unixEpoch, Nothing)
tid <- resolvWorker gal vTurfs las (readTQueue que) send stderr
pure (tid, que)
let getWorker :: Galaxy -> IO (Async (), TQueue ByteString)
getWorker gal = do
(fmap (lookup gal) $ atomically $ readTVar vGala) >>= \case
Just (tid, que) -> do
pure (tid, que)
Nothing -> do
(tid, que) <- spawnWorker gal
atomically $ modifyTVar' vGala (M.insert gal (tid, que))
pure (tid, que)
let doSend :: Galaxy -> ByteString -> IO ()
doSend gal byt = do
dead <- atomically (readTVar vDead)
unless dead $ do
(_, que) <- getWorker gal
atomically (writeTQueue que byt)
let doKill :: IO ()
doKill = do
galas <- atomically $ do
writeTVar vDead True
readTVar vGala
for_ galas (cancel . fst)
pure (ResolvServ doSend doKill)

243
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs Normal file
View File

@ -0,0 +1,243 @@
{- |
Raw UDP Server used by Ames driver.
1. Opens a UDP socket and makes sure that it stays open.
- If can't open the port, wait and try again repeatedly.
- If there is an error reading or writting from the open socket,
close it and open another.
2. Receives packets from the socket.
- When packets come in from the socket, they go into a bounded queue.
- If the queue is full, the packet is dropped.
- If the socket is closed, wait and try again repeatedly.
- `usRecv` gets the first packet from the queue.
3. Sends packets to the socket.
- Packets sent to `usSend` enter a bounded queue.
- If that queue is full, the packet is dropped.
- Packets are taken off the queue one at a time.
- If the socket is closed (or broken), the packet is dropped.
4. Runs until `usKill` is run, then all threads are killed and the
socket is closed.
-}
module Urbit.Vere.Ames.UDP
( UdpServ(..)
, fakeUdpServ
, realUdpServ
)
where
import Urbit.Prelude
import Network.Socket hiding (recvFrom, sendTo)
import Control.Monad.STM (retry)
import Network.Socket.ByteString (recvFrom, sendTo)
-- Types -----------------------------------------------------------------------
data UdpServ = UdpServ
{ usSend :: SockAddr -> ByteString -> IO ()
, usRecv :: STM (PortNumber, HostAddress, ByteString)
, usKill :: IO ()
}
-- Utils -----------------------------------------------------------------------
{- |
Writes to queue and returns `True` unless the queue is full, then do
nothing and return `False`.
-}
tryWriteTBQueue :: TBQueue x -> x -> STM Bool
tryWriteTBQueue q x = do
isFullTBQueue q >>= \case
True -> pure False
False -> writeTBQueue q x $> True
{- |
Open a UDP socket and bind it to a port
-}
doBind :: PortNumber -> HostAddress -> IO (Either IOError Socket)
doBind por hos = tryIOError $ do
sok <- io $ socket AF_INET Datagram defaultProtocol
() <- io $ bind sok (SockAddrInet por hos)
pure sok
{- |
Open a UDP socket and bind it to a port.
If this fails, wait 250ms and repeat forever.
-}
forceBind :: HasLogFunc e => PortNumber -> HostAddress -> RIO e Socket
forceBind por hos = go
where
go = do
logDebug (display ("AMES: UDP: Opening socket on port " <> tshow por))
io (doBind por hos) >>= \case
Right sk -> do
logDebug (display ("AMES: UDP: Opened socket on port " <> tshow por))
pure sk
Left err -> do
logDebug (display ("AMES: UDP: " <> tshow err))
logDebug ("AMES: UDP: Failed to open UDP socket. Waiting")
threadDelay 250_000
go
{- |
Attempt to send a packet to a socket.
If it fails, return `False`. Otherwise, return `True`.
-}
sendPacket :: HasLogFunc e => ByteString -> SockAddr -> Socket -> RIO e Bool
sendPacket fullBytes adr sok = do
logDebug $ displayShow ("AMES", "UDP", "Sending packet.")
res <- io $ tryIOError $ go fullBytes
case res of
Left err -> do
logError $ displayShow ("AMES", "UDP", "Failed to send packet", err)
pure False
Right () -> do
logDebug $ displayShow ("AMES", "UDP", "Packet sent.")
pure True
where
go byt = do
sent <- sendTo sok byt adr
when (sent /= length byt) $ do
go (drop sent byt)
{- |
Attempt to receive a packet from a socket.
- If an exception is throw, return `Left exn`.
- If it wasn't an IPv4 packet, return `Right Nothing`.
- Otherwise, return `Right (Just packet)`.
-}
recvPacket
:: HasLogFunc e
=> Socket
-> RIO e (Either IOError (Maybe (ByteString, PortNumber, HostAddress)))
recvPacket sok = do
io (tryIOError $ recvFrom sok 4096) <&> \case
Left exn -> Left exn
Right (b, SockAddrInet p a) -> Right (Just (b, p, a))
Right (_, _ ) -> Right Nothing
-- Fake Server for No-Networking Mode ------------------------------------------
{- |
Fake UDP API for no-networking configurations.
-}
fakeUdpServ :: HasLogFunc e => RIO e UdpServ
fakeUdpServ = do
logDebug $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
pure UdpServ { .. }
where
usSend = \_ _ -> pure ()
usRecv = retry
usKill = pure ()
-- Real Server -----------------------------------------------------------------
{- |
Real UDP server. See module-level docs.
-}
realUdpServ
:: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ
realUdpServ por hos = do
logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
env <- ask
vSock <- newTVarIO Nothing
vFail <- newEmptyTMVarIO
qSend <- newTBQueueIO 100 -- TODO Tuning
qRecv <- newTBQueueIO 100 -- TODO Tuning
{-
If reading or writing to a socket fails, unbind it and tell the
socket-open thread to close it and open another.
This is careful about edge-cases. In any of these cases, do nothing.
- If vSock isn't set to the socket we used, do nothing.
- If vFail is already set (another thread signaled failure already).
-}
let signalBrokenSocket :: Socket -> RIO e ()
signalBrokenSocket sock = do
logDebug $ displayShow ("AMES", "UDP"
, "Socket broken. Requesting new socket"
)
atomically $ do
mSock <- readTVar vSock
mFail <- tryReadTMVar vFail
when (mSock == Just sock && mFail == Nothing) $ do
putTMVar vFail sock
writeTVar vSock Nothing
enqueueRecvPacket :: PortNumber -> HostAddress -> ByteString -> RIO e ()
enqueueRecvPacket p a b = do
did <- atomically (tryWriteTBQueue qRecv (p, a, b))
when (did == False) $ do
logWarn $ displayShow $ ("AMES", "UDP",)
"Dropping inbound packet because queue is full."
enqueueSendPacket :: SockAddr -> ByteString -> RIO e ()
enqueueSendPacket a b = do
did <- atomically (tryWriteTBQueue qSend (a, b))
when (did == False) $ do
logWarn "AMES: UDP: Dropping outbound packet because queue is full."
tOpen <- async $ forever $ do
sk <- forceBind por hos
atomically (writeTVar vSock (Just sk))
broken <- atomically (takeTMVar vFail)
logWarn "AMES: UDP: Closing broken socket."
io (close broken)
tSend <- async $ forever $ join $ atomically $ do
(adr, byt) <- readTBQueue qSend
readTVar vSock <&> \case
Nothing -> pure ()
Just sk -> do
okay <- sendPacket byt adr sk
unless okay (signalBrokenSocket sk)
tRecv <- async $ forever $ do
atomically (readTVar vSock) >>= \case
Nothing -> threadDelay 100_000
Just sk -> do
recvPacket sk >>= \case
Left exn -> do
logError "AMES: UDP: Failed to receive packet"
signalBrokenSocket sk
Right Nothing -> do
logError "AMES: UDP: Dropping non-ipv4 packet"
pure ()
Right (Just (b, p, a)) -> do
logDebug "AMES: UDP: Received packet."
enqueueRecvPacket p a b
let shutdown = do
logDebug "AMES: UDP: Shutting down. (killing threads)"
cancel tOpen
cancel tSend
cancel tRecv
logDebug "AMES: UDP: Shutting down. (closing socket)"
io $ join $ atomically $ do
res <- readTVar vSock <&> maybe (pure ()) close
writeTVar vSock Nothing
pure res
pure $ UdpServ { usSend = \a b -> runRIO env (enqueueSendPacket a b)
, usRecv = readTBQueue qRecv
, usKill = runRIO env shutdown
}

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

@ -2,21 +2,33 @@
Behn: Timer Driver
-}
module Urbit.Vere.Behn (behn) where
module Urbit.Vere.Behn (behn, DriverApi(..), behn') where
import Urbit.Arvo hiding (Behn)
import Urbit.Prelude
import Urbit.Vere.Pier.Types
import Urbit.Time (Wen)
import Urbit.Timer (Timer)
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Noun.Time (Wen)
import Urbit.Timer (Timer)
import qualified Urbit.Time as Time
import qualified Urbit.Timer as Timer
import qualified Urbit.Noun.Time as Time
import qualified Urbit.Timer as Timer
-- Behn Stuff ------------------------------------------------------------------
behn' :: HasPierEnv e => RIO e ([Ev], RAcquire e (DriverApi BehnEf))
behn' = do
env <- ask
pure ([bornEv (fromIntegral (env ^. kingIdL))], runDriver env)
where
runDriver env = do
ventQ :: TQueue EvErr <- newTQueueIO
diOnEffect <- liftAcquire (behn env (writeTQueue ventQ))
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
bornEv :: KingId -> Ev
bornEv king = EvBlip $ BlipEvBehn $ BehnEvBorn (king, ()) ()
@ -25,16 +37,22 @@ wakeEv = EvBlip $ BlipEvBehn $ BehnEvWake () ()
sysTime = view Time.systemTime
behn :: KingId -> QueueEv -> ([Ev], Acquire (EffCb e BehnEf))
behn king enqueueEv =
(initialEvents, runBehn)
where
initialEvents = [bornEv king]
wakeErr :: WorkError -> IO ()
wakeErr _ = pure ()
runBehn :: Acquire (EffCb e BehnEf)
behn
:: HasKingId e
=> e
-> (EvErr -> STM ())
-> Acquire (BehnEf -> IO ())
behn env enqueueEv = runBehn
where
king = fromIntegral (env ^. kingIdL)
runBehn :: Acquire (BehnEf -> IO ())
runBehn = do
tim <- mkAcquire Timer.init Timer.stop
pure (handleEf tim)
pure (runRIO env . handleEf tim)
handleEf :: Timer -> BehnEf -> RIO e ()
handleEf b = io . \case
@ -45,4 +63,4 @@ behn king enqueueEv =
doze :: Timer -> Maybe Wen -> IO ()
doze tim = \case
Nothing -> Timer.stop tim
Just t -> Timer.start tim (sysTime t) $ atomically (enqueueEv wakeEv)
Just t -> Timer.start tim (sysTime t) $ atomically (enqueueEv (EvErr wakeEv wakeErr))

67
pkg/hs/urbit-king/lib/Urbit/Vere/Clay.hs
View File

@ -2,10 +2,14 @@
UNIX Filesystem Driver
-}
module Urbit.Vere.Clay (clay) where
module Urbit.Vere.Clay
( clay
, clay'
)
where
import Urbit.Arvo hiding (Term)
import Urbit.King.Config
import Urbit.King.App
import Urbit.Prelude
import Urbit.Vere.Pier.Types
@ -112,26 +116,52 @@ buildActionListFromDifferences fp snapshot = do
--------------------------------------------------------------------------------
clay :: forall e. (HasPierConfig e, HasLogFunc e)
=> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e SyncEf))
clay king enqueueEv =
_boatFailed :: e -> WorkError -> IO ()
_boatFailed env _ = runRIO env $ do
pure () -- TODO What can we do?
clay'
:: HasPierEnv e
=> RIO e ([Ev], RAcquire e (DriverApi SyncEf))
clay' = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = clay env (writeTQueue ventQ)
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
clay
:: forall e
. (HasPierConfig e, HasLogFunc e, HasKingId e)
=> e
-> (EvErr -> STM ())
-> ([Ev], RAcquire e (SyncEf -> IO ()))
clay env plan =
(initialEvents, runSync)
where
initialEvents = [
EvBlip $ BlipEvBoat $ BoatEvBoat () ()
-- TODO: In the case of -A, we need to read all the data from the
-- specified directory and shove it into an %into event.
]
king = fromIntegral (env ^. kingIdL)
runSync :: RAcquire e (EffCb e SyncEf)
boatEv = EvBlip $ BlipEvBoat $ BoatEvBoat () ()
-- TODO: In the case of -A, we need to read all the data from the
-- specified directory and shove it into an %into event.
initialEvents = [boatEv]
runSync :: RAcquire e (SyncEf -> IO ())
runSync = handleEffect <$> mkRAcquire start stop
start :: RIO e ClayDrv
start = ClayDrv <$> newTVarIO mempty
stop c = pure ()
handleEffect :: ClayDrv -> SyncEf -> RIO e ()
handleEffect cd = \case
handleEffect :: ClayDrv -> SyncEf -> IO ()
handleEffect cd = runRIO env . \case
SyncEfHill _ mountPoints -> do
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
pierPath <- view pierPathL
@ -151,8 +181,15 @@ clay king enqueueEv =
logDebug $ displayShow ("(clay) dirk actions: ", actions)
let !intoList = map (actionsToInto dir) actions
atomically $ enqueueEv $ EvBlip $ BlipEvSync $
SyncEvInto (Some (king, ())) desk False intoList
let syncEv = EvBlip
$ BlipEvSync
$ SyncEvInto (Some (king, ())) desk False intoList
let syncFailed _ = pure ()
atomically $ plan (EvErr syncEv syncFailed)
atomically $ modifyTVar
(cdMountPoints cd)

364
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs Normal file
View File

@ -0,0 +1,364 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre
( eyre
, eyre'
)
where
import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.King.Config
import Urbit.Vere.Eyre.Multi
import Urbit.Vere.Eyre.PortsFile
import Urbit.Vere.Eyre.Serv
import Urbit.Vere.Eyre.Service
import Urbit.Vere.Eyre.Wai
import Urbit.Vere.Pier.Types
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.PEM (pemParseBS, pemWriteBS)
import RIO.Prelude (decodeUtf8Lenient)
import System.Random (randomIO)
import Urbit.Vere.Http (convertHeaders, unconvertHeaders)
import qualified Network.HTTP.Types as H
-- Types -----------------------------------------------------------------------
type HasShipEnv e = (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
type ReqId = UD
newtype Drv = Drv (MVar (Maybe Serv))
data SockOpts = SockOpts
{ soLocalhost :: Bool
, soWhich :: ServPort
}
data PortsToTry = PortsToTry
{ pttSec :: SockOpts
, pttIns :: SockOpts
, pttLop :: SockOpts
}
data Serv = Serv
{ sServId :: ServId
, sConfig :: HttpServerConf
, sLop :: ServApi
, sIns :: ServApi
, sSec :: Maybe ServApi
, sPorts :: Ports
, sPortsFile :: FilePath
, sLiveReqs :: TVar LiveReqs
}
-- Utilities for Constructing Events -------------------------------------------
servEv :: HttpServerEv -> Ev
servEv = EvBlip . BlipEvHttpServer
bornEv :: KingId -> Ev
bornEv king = servEv $ HttpServerEvBorn (king, ()) ()
liveEv :: ServId -> Ports -> Ev
liveEv sId Ports {..} = servEv $ HttpServerEvLive (sId, ()) pHttp pHttps
cancelEv :: ServId -> ReqId -> EvErr
cancelEv sId reqId =
EvErr (servEv (HttpServerEvCancelRequest (sId, reqId, 1, ()) ())) cancelFailed
cancelFailed :: WorkError -> IO ()
cancelFailed _ = pure ()
reqEv :: ServId -> ReqId -> WhichServer -> Address -> HttpRequest -> Ev
reqEv sId reqId which addr req = case which of
Loopback -> servEv $ HttpServerEvRequestLocal (sId, reqId, 1, ())
$ HttpServerReq False addr req
_ -> servEv $ HttpServerEvRequest (sId, reqId, 1, ())
$ HttpServerReq (which == Secure) addr req
-- Based on Pier+Config, which ports should each server run? -------------------
httpServerPorts :: HasShipEnv e => Bool -> RIO e PortsToTry
httpServerPorts fak = do
ins <- view (networkConfigL . ncHttpPort . to (fmap fromIntegral))
sec <- view (networkConfigL . ncHttpsPort . to (fmap fromIntegral))
lop <- view (networkConfigL . ncLocalPort . to (fmap fromIntegral))
localMode <- view (networkConfigL . ncNetMode . to (== NMLocalhost))
let local = localMode || fak
let pttSec = case (sec, fak) of
(Just p , _ ) -> SockOpts local (SPChoices $ singleton p)
(Nothing, False) -> SockOpts local (SPChoices (443 :| [8443 .. 8453]))
(Nothing, True ) -> SockOpts local (SPChoices (8443 :| [8444 .. 8453]))
let pttIns = case (ins, fak) of
(Just p , _ ) -> SockOpts local (SPChoices $ singleton p)
(Nothing, False) -> SockOpts local (SPChoices (80 :| [8080 .. 8090]))
(Nothing, True ) -> SockOpts local (SPChoices (8080 :| [8081 .. 8090]))
let pttLop = case (lop, fak) of
(Just p , _) -> SockOpts local (SPChoices $ singleton p)
(Nothing, _) -> SockOpts local SPAnyPort
pure (PortsToTry { .. })
-- Convert Between Urbit and WAI types. ----------------------------------------
parseTlsConfig :: (Key, Cert) -> Maybe TlsConfig
parseTlsConfig (PEM key, PEM certs) = do
let (cerByt, keyByt) = (wainBytes certs, wainBytes key)
pems <- pemParseBS cerByt & either (const Nothing) Just
(cert, chain) <- case pems of
[] -> Nothing
p : ps -> pure (pemWriteBS p, pemWriteBS <$> ps)
pure $ TlsConfig keyByt cert chain
where
wainBytes :: Wain -> ByteString
wainBytes = encodeUtf8 . unWain
parseHttpEvent :: HttpEvent -> [RespAct]
parseHttpEvent = \case
Start h b True -> [RAFull (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
Start h b False -> [RAHead (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
Cancel () -> [RADone]
Continue b done -> toList (RABloc . fByt <$> b)
<> if done then [RADone] else []
where
hHdr :: ResponseHeader -> [H.Header]
hHdr = unconvertHeaders . headers
hSta :: ResponseHeader -> H.Status
hSta = toEnum . fromIntegral . statusCode
fByt :: File -> ByteString
fByt = unOcts . unFile
requestEvent :: ServId -> WhichServer -> Word64 -> ReqInfo -> Ev
requestEvent srvId which reqId ReqInfo{..} = reqEv srvId reqUd which riAdr evReq
where
evBod = bodFile riBod
evHdr = convertHeaders riHdr
evUrl = Cord (decodeUtf8Lenient riUrl)
evReq = HttpRequest riMet evUrl evHdr evBod
reqUd = fromIntegral reqId
bodFile :: ByteString -> Maybe File
bodFile "" = Nothing
bodFile bs = Just $ File $ Octs bs
-- Running Servers -------------------------------------------------------------
execRespActs :: HasLogFunc e => Drv -> Ship -> Word64 -> HttpEvent -> RIO e ()
execRespActs (Drv v) who reqId ev = readMVar v >>= \case
Nothing -> logError "Got a response to a request that does not exist."
Just sv -> do
logDebug $ displayShow ev
for_ (parseHttpEvent ev) $ \act -> do
atomically (routeRespAct who (sLiveReqs sv) reqId act)
startServ
:: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
=> MultiEyreApi
-> Ship
-> Bool
-> HttpServerConf
-> (EvErr -> STM ())
-> RIO e Serv
startServ multi who isFake conf plan = do
logDebug (displayShow ("EYRE", "startServ"))
let vLive = meaLive multi
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
let mTls = hscSecure conf >>= parseTlsConfig
mCre <- mTls & \case
Nothing -> pure Nothing
Just tc -> configCreds tc & \case
Right rs -> pure (Just (tc, rs))
Left err -> do
logError "Couldn't Load TLS Credentials."
pure Nothing
ptt <- httpServerPorts isFake
{-
TODO If configuration requests a redirect, get the HTTPS port (if
configuration specifies a specific port, use that. Otherwise, wait
for the HTTPS server to start and then use the port that it chose).
and run an HTTP server that simply redirects to the HTTPS server.
-}
let secRedi = Nothing
let soHost :: SockOpts -> ServHost
soHost so = if soLocalhost so then SHLocalhost else SHAnyHostOk
noHttp <- view (networkConfigL . ncNoHttp)
noHttps <- view (networkConfigL . ncNoHttps)
let reqEvFailed _ = pure ()
let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
onReq which _ship reqId reqInfo =
plan $ EvErr (requestEvent srvId which reqId reqInfo) reqEvFailed
let onKilReq :: Ship -> Word64 -> STM ()
onKilReq _ship = plan . cancelEv srvId . fromIntegral
logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
atomically (joinMultiEyre multi who mCre onReq onKilReq)
logDebug $ displayShow ("EYRE", "Starting loopback server")
lop <- serv vLive $ ServConf
{ scHost = soHost (pttLop ptt)
, scPort = soWhich (pttLop ptt)
, scRedi = Nothing
, scFake = False
, scType = STHttp who $ ReqApi
{ rcReq = onReq Loopback
, rcKil = onKilReq
}
}
logDebug $ displayShow ("EYRE", "Starting insecure server")
ins <- serv vLive $ ServConf
{ scHost = soHost (pttIns ptt)
, scPort = soWhich (pttIns ptt)
, scRedi = secRedi
, scFake = noHttp
, scType = STHttp who $ ReqApi
{ rcReq = onReq Insecure
, rcKil = onKilReq
}
}
mSec <- for mTls $ \tls -> do
logDebug "Starting secure server"
serv vLive $ ServConf
{ scHost = soHost (pttSec ptt)
, scPort = soWhich (pttSec ptt)
, scRedi = Nothing
, scFake = noHttps
, scType = STHttps who tls $ ReqApi
{ rcReq = onReq Secure
, rcKil = onKilReq
}
}
pierPath <- view pierPathL
lopPor <- atomically (fmap fromIntegral $ saPor lop)
insPor <- atomically (fmap fromIntegral $ saPor ins)
secPor <- for mSec (fmap fromIntegral . atomically . saPor)
let por = Ports secPor insPor lopPor
fil = pierPath <> "/.http.ports"
logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
pure (Serv srvId conf lop ins mSec por fil vLive)
-- Eyre Driver -----------------------------------------------------------------
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
pure () -- TODO What should this do?
eyre'
:: HasPierEnv e
=> MultiEyreApi
-> Ship
-> Bool
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
eyre' multi who isFake = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = eyre env multi who (writeTQueue ventQ) isFake
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
{-|
Eyre -- HTTP Server Driver
Inject born events.
Until born events succeeds, ignore effects.
Wait until born event callbacks invoked.
If success, signal success.
If failure, try again several times.
If still failure, bring down ship.
Once born event succeeds:
- Begin normal operation (start accepting requests)
-}
eyre
:: forall e
. (HasPierEnv e)
=> e
-> MultiEyreApi
-> Ship
-> (EvErr -> STM ())
-> Bool
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
eyre env multi who plan isFake = (initialEvents, runHttpServer)
where
king = fromIntegral (env ^. kingIdL)
initialEvents :: [Ev]
initialEvents = [bornEv king]
runHttpServer :: RAcquire e (HttpServerEf -> IO ())
runHttpServer = handleEf <$> mkRAcquire
(Drv <$> newMVar Nothing)
(\(Drv v) -> stopService v kill >>= fromEither)
kill :: HasLogFunc e => Serv -> RIO e ()
kill Serv{..} = do
atomically (leaveMultiEyre multi who)
atomically (saKil sLop)
atomically (saKil sIns)
for_ sSec (\sec -> atomically (saKil sec))
io (removePortsFile sPortsFile)
restart :: Drv -> HttpServerConf -> RIO e Serv
restart (Drv var) conf = do
logDebug "Restarting http server"
let startAct = startServ multi who isFake conf plan
res <- fromEither =<< restartService var startAct kill
logDebug "Done restating http server"
pure res
liveFailed _ = pure ()
handleEf :: Drv -> HttpServerEf -> IO ()
handleEf drv = runRIO env . \case
HSESetConfig (i, ()) conf -> do
logDebug (displayShow ("EYRE", "%set-config"))
Serv {..} <- restart drv conf
logDebug (displayShow ("EYRE", "%set-config", "Sending %live"))
atomically $ plan (EvErr (liveEv sServId sPorts) liveFailed)
logDebug "Write ports file"
io (writePortsFile sPortsFile sPorts)
HSEResponse (i, req, _seq, ()) ev -> do
logDebug (displayShow ("EYRE", "%response"))
execRespActs drv who (fromIntegral req) ev

131
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs Normal file
View File

@ -0,0 +1,131 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.Multi
( WhichServer(..)
, MultiEyreConf(..)
, OnMultiReq
, OnMultiKil
, MultiEyreApi(..)
, joinMultiEyre
, leaveMultiEyre
, multiEyre
)
where
import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.Vere.Eyre.Serv
import Urbit.Vere.Eyre.Wai
import Network.TLS (Credential)
-- Types -----------------------------------------------------------------------
data WhichServer = Secure | Insecure | Loopback
deriving (Eq)
data MultiEyreConf = MultiEyreConf
{ mecHttpsPort :: Maybe Port
, mecHttpPort :: Maybe Port
, mecLocalhostOnly :: Bool
}
deriving (Show)
type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
type OnMultiKil = Ship -> Word64 -> STM ()
data MultiEyreApi = MultiEyreApi
{ meaConf :: MultiEyreConf
, meaLive :: TVar LiveReqs
, meaPlan :: TVar (Map Ship OnMultiReq)
, meaCanc :: TVar (Map Ship OnMultiKil)
, meaTlsC :: TVar (Map Ship (TlsConfig, Credential))
, meaKill :: STM ()
}
-- Multi-Tenet HTTP ------------------------------------------------------------
joinMultiEyre
:: MultiEyreApi
-> Ship
-> Maybe (TlsConfig, Credential)
-> OnMultiReq
-> OnMultiKil
-> STM ()
joinMultiEyre api who mTls onReq onKil = do
modifyTVar' (meaPlan api) (insertMap who onReq)
modifyTVar' (meaCanc api) (insertMap who onKil)
for_ mTls $ \creds -> do
modifyTVar' (meaTlsC api) (insertMap who creds)
leaveMultiEyre :: MultiEyreApi -> Ship -> STM ()
leaveMultiEyre MultiEyreApi {..} who = do
modifyTVar' meaCanc (deleteMap who)
modifyTVar' meaPlan (deleteMap who)
modifyTVar' meaTlsC (deleteMap who)
multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
multiEyre conf@MultiEyreConf {..} = do
logDebug (displayShow ("EYRE", "MULTI", conf))
vLive <- io emptyLiveReqs >>= newTVarIO
vPlan <- newTVarIO mempty
vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ()))
vTlsC <- newTVarIO mempty
let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk
let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
onReq which who reqId reqInfo = do
plan <- readTVar vPlan
lookup who plan & \case
Nothing -> pure ()
Just cb -> cb which who reqId reqInfo
let onKil :: Ship -> Word64 -> STM ()
onKil who reqId = do
canc <- readTVar vCanc
lookup who canc & \case
Nothing -> pure ()
Just cb -> cb who reqId
mIns <- for mecHttpPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTP", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por
, scRedi = Nothing -- TODO
, scFake = False
, scType = STMultiHttp $ ReqApi
{ rcReq = onReq Insecure
, rcKil = onKil
}
}
mSec <- for mecHttpsPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTPS", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por
, scRedi = Nothing
, scFake = False
, scType = STMultiHttps (MTC vTlsC) $ ReqApi
{ rcReq = onReq Secure
, rcKil = onKil
}
}
pure $ MultiEyreApi
{ meaLive = vLive
, meaPlan = vPlan
, meaCanc = vCanc
, meaTlsC = vTlsC
, meaConf = conf
, meaKill = traverse_ saKil (toList mIns <> toList mSec)
}

44
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/PortsFile.hs Normal file
View File

@ -0,0 +1,44 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.PortsFile
( Ports(..)
, writePortsFile
, removePortsFile
)
where
import Urbit.Prelude
import System.Directory (doesFileExist, removeFile)
import Urbit.Arvo (Port(unPort))
-- Types -----------------------------------------------------------------------
data Ports = Ports
{ pHttps :: Maybe Port
, pHttp :: Port
, pLoop :: Port
}
deriving (Eq, Ord, Show)
-- Creating and Deleting `.http.ports` files. ----------------------------------
portsFileText :: Ports -> Text
portsFileText Ports {..} = unlines $ catMaybes
[ pHttps <&> \p -> (tshow p <> " secure public")
, Just (tshow (unPort pHttp) <> " insecure public")
, Just (tshow (unPort pLoop) <> " insecure loopback")
]
removePortsFile :: FilePath -> IO ()
removePortsFile pax = do
doesFileExist pax >>= \case
True -> removeFile pax
False -> pure ()
writePortsFile :: FilePath -> Ports -> IO ()
writePortsFile f = writeFile f . encodeUtf8 . portsFileText

356
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs Normal file
View File

@ -0,0 +1,356 @@
{-|
Runs a single HTTP (or HTTPS) server for the eyre driver.
A server is given:
- A port, or a range or ports.
- Opens a socket on one of those ports.
- If this fails, try again repeatedly.
- Once a socket is opened, runs an HTTP server on the specified port.
- Once the server is up, calls a callback with the port that was opened.
- Once we have chosen a port, we commit to that port (ignoring the
original range).
- If the socket ever goes down, keep trying to reopen that port forever.
- When the server is shutdown, make sure the socket is closed.
TODO How to detect socket closed during server run?
-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Urbit.Vere.Eyre.Serv
( ServApi(..)
, TlsConfig(..)
, MultiTlsConfig(..)
, ReqApi(..)
, ServType(..)
, ServPort(..)
, ServHost(..)
, ServConf(..)
, configCreds
, serv
, fakeServ
)
where
import Urbit.Prelude hiding (Builder)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty((:|)))
import Network.TLS (Credential, Credentials(..), ServerHooks(..))
import Network.TLS (credentialLoadX509ChainFromMemory)
import RIO.Prelude (decodeUtf8Lenient)
import qualified Control.Monad.STM as STM
import qualified Data.Char as C
import qualified Network.Socket as Net
import qualified Network.Wai as W
import qualified Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.WarpTLS as W
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Eyre.Wai as E
-- Internal Types --------------------------------------------------------------
data ServApi = ServApi
{ saKil :: STM ()
, saPor :: STM W.Port
}
data TlsConfig = TlsConfig
{ tcPrKey :: ByteString
, tcCerti :: ByteString
, tcChain :: [ByteString]
}
deriving (Show)
newtype MultiTlsConfig = MTC (TVar (Map Ship (TlsConfig, Credential)))
instance Show MultiTlsConfig where
show = const "MultiTlsConfig"
data ReqApi = ReqApi
{ rcReq :: Ship -> Word64 -> E.ReqInfo -> STM ()
, rcKil :: Ship -> Word64 -> STM ()
}
instance Show ReqApi where
show = const "ReqApi"
data ServType
= STHttp Ship ReqApi
| STHttps Ship TlsConfig ReqApi
| STMultiHttp ReqApi
| STMultiHttps MultiTlsConfig ReqApi
deriving (Show)
data ServPort
= SPAnyPort
| SPChoices (NonEmpty W.Port)
deriving (Show)
data ServHost
= SHLocalhost
| SHAnyHostOk
deriving (Show)
data ServConf = ServConf
{ scType :: ServType
, scHost :: ServHost
, scPort :: ServPort
, scRedi :: Maybe W.Port
, scFake :: Bool
}
deriving (Show)
-- Opening Sockets -------------------------------------------------------------
getBindAddr :: String -> W.Port -> IO Net.SockAddr
getBindAddr hos por =
Net.getAddrInfo Nothing (Just hos) (Just (show por)) >>= \case
[] -> error "this should never happen."
x : _ -> pure (Net.addrAddress x)
bindListenPort :: String -> W.Port -> Net.Socket -> IO Net.PortNumber
bindListenPort hos por sok = do
Net.bind sok =<< getBindAddr hos por
Net.listen sok 1
Net.socketPort sok
tcpSocket :: IO (Either IOError Net.Socket)
tcpSocket =
tryIOError (Net.socket Net.AF_INET Net.Stream Net.defaultProtocol)
tryOpen :: String -> W.Port -> IO (Either IOError (W.Port, Net.Socket))
tryOpen hos por =
tcpSocket >>= \case
Left exn -> pure (Left exn)
Right sok -> tryIOError (bindListenPort hos por sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
openFreePort :: String -> IO (Either IOError (W.Port, Net.Socket))
openFreePort hos = do
tcpSocket >>= \case
Left exn -> pure (Left exn)
Right sok -> tryIOError (doBind sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right ps -> pure (Right ps)
where
doBind sok = do
adr <- Net.inet_addr hos
Net.bind sok (Net.SockAddrInet Net.defaultPort adr)
Net.listen sok 1
port <- Net.socketPort sok
pure (fromIntegral port, sok)
retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a
retry act = act >>= \case
Right res -> pure res
Left exn -> do
logDbg ctx ("Failed to open ports. Waiting 5s, then trying again.", exn)
threadDelay 5_000_000
retry act
where
ctx = ["EYRE", "SERV", "retry"]
tryOpenChoices
:: HasLogFunc e
=> String
-> NonEmpty W.Port
-> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenChoices hos = go
where
go (p :| ps) = do
logDebug (displayShow ("EYRE", "Trying to open port.", p))
io (tryOpen hos p) >>= \case
Left err -> do
logError (displayShow ("EYRE", "Failed to open port.", p))
case ps of
[] -> pure (Left err)
q : qs -> go (q :| qs)
Right (p, s) -> do
pure (Right (p, s))
tryOpenAny
:: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenAny hos = do
let ctx = ["EYRE", "SERV", "tryOpenAny"]
logDbg ctx "Asking the OS for any free port."
io (openFreePort hos) >>= \case
Left exn -> pure (Left exn)
Right (p, s) -> do
pure (Right (p, s))
logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
logDbg ctx msg = logDebug (prefix <> suffix)
where
prefix = display (concat $ fmap (<> ": ") ctx)
suffix = displayShow msg
forceOpenSocket
:: forall e
. HasLogFunc e
=> ServHost
-> ServPort
-> RAcquire e (W.Port, Net.Socket)
forceOpenSocket hos por = mkRAcquire opn kil
where
kil = io . Net.close . snd
opn = do
let ctx = ["EYRE", "SERV", "forceOpenSocket"]
logDbg ctx (hos, por)
(p, s) <- retry $ case por of
SPAnyPort -> tryOpenAny bind
SPChoices ps -> tryOpenChoices bind ps
logDbg ctx ("Opened port.", p)
pure (p, s)
bind = case hos of
SHLocalhost -> "127.0.0.1"
SHAnyHostOk -> "0.0.0.0"
-- Starting WAI ----------------------------------------------------------------
hostShip :: Maybe ByteString -> IO Ship
hostShip Nothing = error "Request must contain HOST header."
hostShip (Just bs) = byteShip (hedLabel bs) & \case
Left err -> error ("Bad host prefix. Must be a ship name: " <> unpack err)
Right sp -> pure sp
where
byteShip = fmap (fromIntegral . Ob.fromPatp) . bytePatp
bytePatp = Ob.parsePatp . decodeUtf8Lenient
hedLabel = fst . break (== fromIntegral (C.ord '.'))
onSniHdr
:: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials
onSniHdr env (MTC mtls) mHos = do
tabl <- atomically (readTVar mtls)
runRIO env $ logDbg ctx (tabl, mHos)
ship <- hostShip (encodeUtf8 . pack <$> mHos)
runRIO env $ logDbg ctx ship
tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd)
runRIO env $ logDbg ctx tcfg
pure (Credentials [tcfg])
where
notRunning ship = error ("Ship not running: ~" <> show ship)
ctx = ["EYRE", "HTTPS", "SNI"]
startServer
:: HasLogFunc e
=> ServType
-> ServHost
-> W.Port
-> Net.Socket
-> Maybe W.Port
-> TVar E.LiveReqs
-> RIO e ()
startServer typ hos por sok red vLive = do
envir <- ask
let host = case hos of
SHLocalhost -> "127.0.0.1"
SHAnyHostOk -> "*"
let opts =
W.defaultSettings
& W.setHost host
& W.setPort (fromIntegral por)
& W.setTimeout (5 * 60)
let runAppl who = E.app envir who vLive
reqShip = hostShip . W.requestHeaderHost
case typ of
STHttp who api -> do
let app = runAppl who (rcReq api who) (rcKil api who)
io (W.runSettingsSocket opts sok app)
STHttps who TlsConfig {..} api -> do
let tls = W.tlsSettingsChainMemory tcCerti tcChain tcPrKey
let app = runAppl who (rcReq api who) (rcKil api who)
io (W.runTLSSocket tls opts sok app)
STMultiHttp api -> do
let app req resp = do
who <- reqShip req
runAppl who (rcReq api who) (rcKil api who) req resp
io (W.runSettingsSocket opts sok app)
STMultiHttps mtls api -> do
TlsConfig {..} <- atomically (getFirstTlsConfig mtls)
let sni = def { onServerNameIndication = onSniHdr envir mtls }
let tlsSing = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey)
let tlsMany = tlsSing { W.tlsServerHooks = sni }
let ctx = ["EYRE", "HTTPS", "REQ"]
let
app = \req resp -> do
runRIO envir $ logDbg ctx "Got request"
who <- reqShip req
runRIO envir $ logDbg ctx ("Parsed HOST", who)
runAppl who (rcReq api who) (rcKil api who) req resp
io (W.runTLSSocket tlsMany opts sok app)
--------------------------------------------------------------------------------
configCreds :: TlsConfig -> Either Text Credential
configCreds TlsConfig {..} =
credentialLoadX509ChainFromMemory tcCerti tcChain tcPrKey & \case
Left str -> Left (pack str)
Right rs -> Right rs
fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi
fakeServ conf = do
let por = fakePort (scPort conf)
logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por))
pure $ ServApi
{ saKil = pure ()
, saPor = pure por
}
where
fakePort :: ServPort -> W.Port
fakePort SPAnyPort = 55555
fakePort (SPChoices (x :| _)) = x
getFirstTlsConfig :: MultiTlsConfig -> STM TlsConfig
getFirstTlsConfig (MTC var) = do
map <- readTVar var
case toList map of
[] -> STM.retry
x:_ -> pure (fst x)
realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
realServ vLive conf@ServConf {..} = do
logDebug (displayShow ("EYRE", "SERV", "Running Real Server"))
kil <- newEmptyTMVarIO
por <- newEmptyTMVarIO
tid <- async (runServ por)
_ <- async (atomically (takeTMVar kil) >> cancel tid)
pure $ ServApi
{ saKil = void (tryPutTMVar kil ())
, saPor = readTMVar por
}
where
runServ vPort = do
logDebug (displayShow ("EYRE", "SERV", "runServ"))
rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
atomically (putTMVar vPort por)
startServer scType scHost por sok scRedi vLive
serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
serv vLive conf = do
if scFake conf
then fakeServ conf
else realServ vLive conf

67
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Service.hs Normal file
View File

@ -0,0 +1,67 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.Service
( restartService
, stopService
)
where
import Urbit.Prelude
-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------
{-|
Restart a running service.
This can probably be made simpler, but it
- Sets the MVar to Nothing if there was an exception while starting
or stopping the service.
- Keeps the MVar lock until the restart process finishes.
-}
restartService
:: forall e s
. HasLogFunc e
=> MVar (Maybe s)
-> RIO e s
-> (s -> RIO e ())
-> RIO e (Either SomeException s)
restartService vServ sstart kkill = do
logDebug "restartService"
modifyMVar vServ $ \case
Nothing -> doStart
Just sv -> doRestart sv
where
doRestart :: s -> RIO e (Maybe s, Either SomeException s)
doRestart serv = do
logDebug "doStart"
try (kkill serv) >>= \case
Left exn -> pure (Nothing, Left exn)
Right () -> doStart
doStart :: RIO e (Maybe s, Either SomeException s)
doStart = do
logDebug "doStart"
try sstart <&> \case
Right s -> (Just s, Right s)
Left exn -> (Nothing, Left exn)
{-|
Stop a running service. Do nothing if it's already stopped.
-}
stopService
:: HasLogFunc e
=> MVar (Maybe s)
-> (s -> RIO e ())
-> RIO e (Either SomeException ())
stopService vServ kkill = do
logDebug "stopService"
modifyMVar vServ $ \case
Nothing -> pure (Nothing, Right ())
Just sv -> do
res <- try (kkill sv)
pure (Nothing, res)

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