ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-14 08:34:25 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'release/next-vere' into jb/hashcons

Browse Source 
* release/next-vere: (346 commits)
  kh: support rendering +stub as ansi escape codes
  vere: disables sample profiling in the king
  u3: fixes -P profiling by moving alloc hints in imprison.c
  u3: corrects comments in allocate.h
  u3: refactors +reel and +stir jets, removing obsolete stack bookkeeping
  u3: const-qualifies u3_pile pointer in road-stack api (where appropriate)
  vere: restores a necessary layer of reallocation
  u3: clarifies forward-declaration comment in allocate.h
  u3: only perform road stack checks in +stir jet if necessary
  u3: removes redundant stack reads from +reel and +stir jets
  u3: adds further improvements to road-stack api
  u3: refactors road stack api, limiting overflow checks
  vere: incorporate term.c review feedback, updates comments
  vere: avoids allocations by attempting synchronous terminal writes
  vere: comments-out unused ansi input sequences
  vere: directly implements utf-32 to utf-8 conversion
  vere: refactors terminal rendering to limit utf-32->utf-8 conversions
  vere: refactors terminal jam-file blits
  vere: refactors %lin blit handling in term.c
  vere: refactors _term_it_show_cursor()
  ...
This commit is contained in:
Joe Bryan 2020-09-16 23:30:38 -07:00
commit f6589adf05
197 changed files with 10554 additions and 4043 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/ISSUE_TEMPLATE/kernel-or-runtime-bug-report.md vendored
View File

@ -30,7 +30,7 @@ If applicable, add screenshots to help explain your problem.
**System (please supply the following information, if relevant):**
- OS: [e.g. macOS, linux64, FreeBSD]
- Vere and Urbit OS versions
- Your ship's `%base` hash (use `.^(@uv %cz /=base=)` to check)
- Your ship's `%base` hash (use `+trouble` to check)
**Additional context**
Add any other context about the problem here.

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

@ -27,13 +27,13 @@ If applicable, add screenshots to help explain your problem. If possible, please
**Desktop (please complete the following information):**
- OS: [e.g. MacOS 10.15.3]
- Browser [e.g. chrome, safari]
- Base hash of your urbit ship. Run ` .^(@uv %cz /=base=)` in Dojo to see this.
- Base hash of your urbit ship. Run `+trouble` in Dojo to see this.
**Smartphone (please complete the following information):**
- Device: [e.g. iPhone6]
- OS: [e.g. iOS8.1]
- Browser [e.g. stock browser, safari]
- Base hash of your urbit ship. Run ` .^(@uv %cz /=base=)` in Dojo to see this.
- Base hash of your urbit ship. Run `+trouble` in Dojo to see this.
**Additional context**
Add any other context about the problem here.

9
MAINTAINERS.md
View File

@ -175,14 +175,15 @@ the pill to have the new files/hash. For most things, it is sufficient to run
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
`pkg/arvo/app/landscape/index.[hash].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).
`pkg/arvo/app/glob.hoon` to match the hash in the filename of the `.glob` file.
Amend `pkg/arvo/app/landscape/index.html` to import the hashed JS bundle, instead
of the unversioned index.js. 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

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:ecf3f8593815742e409008421f318b664124e672b1eecd131e4a1e49864a1c2a
size 6175676
oid sha256:6cd7246753c12c7acb757e1a6ee54c177806c20a137ad8fb4300c000ac146a0f
size 6260139

24
nix/nixcrpkgs/pkgs/libsigsegv/builder.sh
View File

@ -3,7 +3,7 @@ source $setup
tar -xf $src
cd libsigsegv-$version
patch -p1 << 'HEREDOC'
patch -p1 << 'PATCH_I386'
--- a/src/fault-linux-i386.h 2020-06-25 23:46:02.099235491 +0000
+++ b/src/fault-linux-i386.h 2020-06-25 23:45:48.679156892 +0000
@@ -18,6 +18,7 @@
@ -14,12 +14,32 @@ patch -p1 << 'HEREDOC'
#if defined __x86_64__
/* 64 bit registers */
HEREDOC
PATCH_I386
patch -p1 << 'PATCH_ARM'
--- a/src/fault-linux-arm.h
+++ b/src/fault-linux-arm.h
@@ -17,6 +17,7 @@
#include "fault-posix-ucontext.h"
+#define HAVE_STACKVMA 0
#if defined(__aarch64__) || defined(__ARM_64BIT_STATE) || defined(__ARM_PCS_AAPCS64) /* 64-bit */
/* See glibc/sysdeps/unix/sysv/linux/aarch64/sys/ucontext.h.
PATCH_ARM
cd ..
mkdir build
cd build
# Hack
if [ $host = aarch64-linux-musleabi ]
then
sed -i 's/^CFG_FAULT=$/CFG_FAULT=fault-linux-arm.h/' \
../libsigsegv-$version/configure
fi
../libsigsegv-$version/configure \
--host=$host \
--prefix=$out \

10
nix/pkgs/urbit/libsigsegv_fix.patch
View File

@ -8,3 +8,13 @@
#if defined __x86_64__
/* 64 bit registers */
--- a/src/fault-linux-arm.h
+++ b/src/fault-linux-arm.h
@@ -17,6 +17,7 @@
#include "fault-posix-ucontext.h"
+#define HAVE_STACKVMA 0
#if defined(__aarch64__) || defined(__ARM_64BIT_STATE) || defined(__ARM_PCS_AAPCS64) /* 64-bit */
/* See glibc/sysdeps/unix/sysv/linux/aarch64/sys/ucontext.h.

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

@ -72,7 +72,7 @@
+$ glyph char
++ glyphs "!@#$%^&()-=_+[]\{}'\\:\",.<>?"
::
+$ nu-security ?(%channel %village %village-with-group)
+$ nu-security ?(%channel %village)
::
+$ command
$% [%target (set target)] :: set messaging target
@ -81,7 +81,7 @@
::
::
:: create chat
[%create nu-security path (unit glyph) (unit ?)]
[%create nu-security path (unit resource) (unit glyph) (unit ?)]
[%delete path] :: delete chat
[%invite [? path] (set ship)] :: allow
[%banish [? path] (set ship)] :: disallow
@ -293,8 +293,6 @@
::
++ target-to-path
|= target
%+ weld
?:(in-group ~ /~)
[(scot %p ship) path]
:: +path-to-target: deduces a target from a mailbox path
::
@ -464,6 +462,7 @@
security
;~ plug
path
(punt ;~(pfix ace group))
(punt ;~(pfix ace glyph))
(punt ;~(pfix ace (fuss 'y' 'n')))
==
@ -535,16 +534,15 @@
:: ;~(pfix ace ;~(plug i.opt $(opt t.opt)))
:: --
::
++ group ;~((glue net) ship sym)
++ tag |*(a=@tas (cold a (jest a))) ::TODO into stdlib
++ ship ;~(pfix sig fed:ag)
++ path ;~(pfix net ;~(plug urs:ab (easy ~))) ::NOTE short only, tmp
:: +mang: un/managed indicator prefix
::
++ mang
;~ pose
(cold %| (jest '~/'))
(cold %& (easy ~))
==
:: deprecated, as sig prefix is no longer used
::
++ mang (cold %& (easy ~))
:: +tarl: local target, as /path
::
++ tarl (stag our-self path)
@ -585,7 +583,7 @@
:: +security: security mode
::
++ security
(perk %channel %village-with-group %village ~)
(perk %channel %village ~)
::
:: +glyph: shorthand character
::
@ -741,15 +739,21 @@
:: +create: new local mailbox
::
++ create
|= [security=nu-security =path gyf=(unit char) allow-history=(unit ?)]
|= $: security=nu-security
=path
ugroup=(unit resource)
gyf=(unit char)
allow-history=(unit ?)
==
^- (quip card _state)
=/ with-group=? ?=(%village-with-group security)
=/ with-group=? ?=(^ ugroup)
=/ =target [with-group our-self path]
=/ real-path=^path (target-to-path target)
=/ group-path=^path ?~(ugroup ship+real-path (en-path:resource u.ugroup))
=/ =policy
?- security
%channel *open:policy
?(%village %village-with-group) *invite:policy
%channel *open:policy
%village *invite:policy
==
?^ (scry-for (unit mailbox:store) %chat-store [%mailbox real-path])
=- [[- ~] state]
@ -767,7 +771,7 @@
(rsh 3 1 (spat path))
''
real-path :: chat
real-path :: group
group-path :: group
policy
~
(fall allow-history %.y)

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

@ -18,17 +18,19 @@
state-1
state-2
state-3
state-4
state-5
state-6
state-7
==
::
+$ state-3
$: %3
state-base
==
+$ state-7 [%7 state-base]
+$ state-6 [%6 state-base]
+$ state-5 [%5 state-base]
+$ state-4 [%4 state-base]
+$ state-3 [%3 state-base]
+$ state-2 [%2 state-base]
::
+$ state-2
$: %2
state-base
==
+$ state-1
$: %1
loaded-cards=*
@ -52,7 +54,7 @@
$% [%chat-update update:store]
==
--
=| state-3
=| state-7
=* state -
::
%- agent:dbug
@ -81,8 +83,20 @@
=/ old !<(versioned-state old-vase)
=| cards=(list card)
|-
?: ?=(%3 -.old)
?: ?=(%7 -.old)
[cards this(state old)]
?: ?=(%6 -.old)
=. cards
%+ weld cards
^- (list card)
[%pass /s %agent [our.bol %chat-hook] %poke %noun !>(%fix-out-of-sync)]~
$(-.old %7)
?: ?=(?(%3 %4 %5) -.old)
=. cards
%+ weld cards
^- (list card)
[%pass /pokeme %agent [our.bol %chat-hook] %poke %noun !>(%fix-dm)]~
$(-.old %6)
?: ?=(%2 -.old)
=. cards
%+ weld cards
@ -319,9 +333,9 @@
^- (quip card _this)
=^ cards state
?+ mark (on-poke:def mark vase)
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(action:store vase))
%noun [~ state]
%json (poke-json:cc !<(json vase))
%chat-action (poke-chat-action:cc !<(action:store vase))
%noun (poke-noun:cc !<(?(%fix-dm %fix-out-of-sync) vase))
::
%chat-hook-action
(poke-chat-hook-action:cc !<(action:hook vase))
@ -383,6 +397,81 @@
|_ bol=bowl:gall
++ grp ~(. grpl bol)
::
++ poke-noun
|= a=?(%fix-dm %fix-out-of-sync)
^- (quip card _state)
|^
:_ state
?- a
%fix-dm (fix-dm %fix-dm)
%fix-out-of-sync (fix-out-of-sync %fix-out-of-sync)
==
::
++ fix-out-of-sync
|= b=%fix-out-of-sync
^- (list card)
%- zing
%+ turn ~(tap by synced)
|= [=path host=ship]
^- (list card)
?: =(host our.bol) ~
?> ?=([@ @ ~] path)
=/ =ship (slav %p i.path)
:~ =- [%pass / %agent [our.bol %chat-hook] %poke %chat-hook-action -]
!> ^- action:hook
[%remove path]
::
=- [%pass / %agent [our.bol %chat-hook] %poke %chat-hook-action -]
!> ^- action:hook
[%add-synced ship path %.y]
==
::
++ fix-dm
|= b=%fix-dm
^- (list card)
%- zing
%+ turn
~(tap by synced)
|= [=path host=ship]
^- (list card)
?> ?=([@ @ *] path)
=/ =ship (slav %p i.path)
?: =(ship our.bol)
:: local dm, no need to do cleanup
~
?: ?=(^ (groups-of-chat path))
:: correctly initialized, no need to do cleanup
::
~
?. =((end 3 4 i.t.path) 'dm--')
~
:- =- [%pass /fixdm %agent [our.bol %chat-view] %poke %chat-view-action -]
!> ^- action:view
[%delete path]
=/ new-dm /(scot %p our.bol)/(crip (weld "dm--" (trip (scot %p ship))))
=/ mailbox=(unit mailbox:store) (chat-scry path)
?~ mailbox
~
:~ =- [%pass /fixdm %agent [our.bol %chat-view] %poke %chat-view-action -]
!> ^- action:view
:* %create
%- crip
(zing [(trip (scot %p our.bol)) " <-> " (trip (scot %p ship)) ~])
''
new-dm
ship+new-dm
[%invite (silt ~[ship])]
(silt ~[ship])
%.y
%.n
==
::
=- [%pass /fixdm %agent [our.bol %chat-store] %poke %chat-action -]
!> ^- action:store
[%messages new-dm envelopes.u.mailbox]
==
--
::
++ poke-json
|= jon=json
^- (quip card _state)

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

@ -268,7 +268,7 @@
%group-store
%group-push-hook
=/ =cage
:- %group-action
:- %group-update
!> ^- action:group-store
[%change-policy rid %invite %add-invites (sy ship ~)]
[%pass / %agent [entity.rid app] %poke cage]

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

@ -7,17 +7,20 @@
$% [%clay =path]
[%glob =glob:glob]
==
+$ state-1
$: %1
=configuration:srv
+$ state-base
$: =configuration:srv
=serving
==
+$ state-2
$: %2
state-base
==
--
::
%+ verb |
%- agent:dbug
::
=| state-1
=| state-2
=* state -
^- agent:gall
|_ =bowl:gall
@ -60,12 +63,18 @@
^- [content ?]
[[%clay clay-path] public]
==
?> ?=(%1 -.old-state)
=? old-state ?=(%1 -.old-state)
%= old-state
- %2
serving (~(del by serving.old-state) /'~landscape'/js/index)
==
?> ?=(%2 -.old-state)
[~ this(state old-state)]
::
+$ versioned-state
$% state-1
state-0
$% state-0
state-1
state-2
==
::
+$ serving-0 (map url-base=path [=clay=path public=?])
@ -74,6 +83,10 @@
=configuration:srv
=serving-0
==
+$ state-1
$: %1
state-base
==
--
::
++ on-poke
@ -169,7 +182,7 @@
?~ content [not-found:gen %.n]
?- -.content.u.content
%clay
=/ scry-path
=/ scry-path=path
:* (scot %p our.bowl)
q.byk.bowl
(scot %da now.bowl)
@ -179,10 +192,16 @@
=/ 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)
::
[~ %html]
%. file
%* . html-response:gen
cache
!=(/app/landscape/index/html (slag 3 scry-path))
==
==
::
%glob
@ -287,10 +306,9 @@
*@uv
=/ parent (scot %p ship.u.ota)
=+ .^(=cass:clay %cs /[parent]/[desk.u.ota]/1/late/foo)
%^ end 3 3
%^ end 0 25
.^(@uv %cz /[parent]/[desk.u.ota]/(scot %ud ud.cass))
--
++ on-agent on-agent:def
++ on-fail on-fail:def
--

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

@ -1,7 +1,7 @@
/- glob
/+ default-agent, verb, dbug
|%
++ hash 0v5.knd3c.vvtvt.h0gg0.8qcau.8iii4
++ hash 0v2.pbthv.gd1q2.h2ura.5esrn.d361c
+$ state-0 [%0 hash=@uv glob=(unit (each glob:glob tid=@ta))]
+$ all-states
$% state-0
@ -41,7 +41,7 @@
--
=| state=state-0
=. hash.state hash
=/ serve-path=path /'~landscape'/js/index
=/ serve-path=path /'~landscape'/js/bundle
^- agent:gall
%+ verb |
%- agent:dbug
@ -58,7 +58,6 @@
++ on-load
|= old-state=vase
^- (quip card _this)
~& > %initting
=+ !<(old=all-states old-state)
?> ?=(%0 -.old)
?~ glob.old
@ -83,9 +82,19 @@
:_ 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))
=+ .^(arch %cy (weld home /app/landscape/js/bundle))
=/ bundle=path
%- need
^- (unit path)
%- ~(rep by dir)
|= [[file=@t ~] out=(unit path)]
?^ out out
?. =((end 3 5 file) 'index')
~
`/[file]/js
=+ .^(js=@t %cx :(weld home /app/landscape/js/bundle bundle))
=+ !<(=mime (tube !>(js)))
=/ =glob:glob (~(put by *glob:glob) /js mime)
=/ =glob:glob (~(put by *glob:glob) bundle mime)
=/ =path /(cat 3 'glob-' (scot %uv (sham glob)))/glob
[%pass /make %agent [our.bowl %hood] %poke %drum-put !>([path (jam glob)])]~
::

572
pkg/arvo/app/graph-store.hoon Normal file
View File

@ -0,0 +1,572 @@
/+ store=graph-store, sigs=signatures, res=resource, default-agent, dbug
~% %graph-store-top ..is ~
|%
+$ card card:agent:gall
+$ versioned-state
$% state-0
==
::
+$ state-0 [%0 network:store]
++ orm orm:store
++ orm-log orm-log:store
--
::
=| state-0
=* state -
::
%- agent:dbug
^- agent:gall
~% %graph-store-agent ..card ~
|_ =bowl:gall
+* this .
def ~(. (default-agent this %|) bowl)
::
++ on-init [~ this]
++ on-save !>(state)
++ on-load
|= old=vase
^- (quip card _this)
[~ this(state !<(state-0 old))]
::
++ on-watch
~/ %graph-store-watch
|= =path
^- (quip card _this)
|^
?> (team:title our.bowl src.bowl)
=/ cards=(list card)
?+ path (on-watch:def path)
[%updates ~] ~
[%keys ~] (give [%keys ~(key by graphs)])
[%tags ~] (give [%tags ~(key by tag-queries)])
==
[cards this]
::
++ give
|= =update-0:store
^- (list card)
[%give %fact ~ [%graph-update !>([%0 now.bowl update-0])]]~
--
::
++ on-poke
~/ %graph-store-poke
|= [=mark =vase]
^- (quip card _this)
|^
?> (team:title our.bowl src.bowl)
=^ cards state
?+ mark (on-poke:def mark vase)
%graph-update (graph-update !<(update:store vase))
==
[cards this]
::
++ graph-update
|= =update:store
^- (quip card _state)
|^
?> ?=(%0 -.update)
?- -.q.update
%add-graph (add-graph +.q.update)
%remove-graph (remove-graph +.q.update)
%add-nodes (add-nodes p.update +.q.update)
%remove-nodes (remove-nodes p.update +.q.update)
%add-signatures (add-signatures p.update +.q.update)
%remove-signatures (remove-signatures p.update +.q.update)
%add-tag (add-tag +.q.update)
%remove-tag (remove-tag +.q.update)
%archive-graph (archive-graph +.q.update)
%unarchive-graph (unarchive-graph +.q.update)
%run-updates (run-updates +.q.update)
%keys ~|('cannot send %keys as poke' !!)
%tags ~|('cannot send %tags as poke' !!)
%tag-queries ~|('cannot send %tag-queries as poke' !!)
==
::
++ add-graph
|= [=resource:store =graph:store mark=(unit mark:store)]
^- (quip card _state)
?< (~(has by archive) resource)
?< (~(has by graphs) resource)
?> (validate-graph graph mark)
:_ %_ state
graphs (~(put by graphs) resource [graph mark])
update-logs (~(put by update-logs) resource (gas:orm-log ~ ~))
validators
?~ mark validators
(~(put in validators) u.mark)
==
%- zing
:~ (give [/updates /keys ~] [%add-graph resource graph mark])
?~ mark ~
?: (~(has in validators) u.mark) ~
=/ wire (weld /graph (en-path:res resource))
=/ =rave:clay [%sing %b [%da now.bowl] /[u.mark]]
[%pass wire %arvo %c %warp our.bowl [%home `rave]]~
==
::
++ remove-graph
|= =resource:store
^- (quip card _state)
?< (~(has by archive) resource)
?> (~(has by graphs) resource)
:- (give [/updates /keys ~] [%remove-graph resource])
%_ state
graphs (~(del by graphs) resource)
update-logs (~(del by update-logs) resource)
==
::
++ add-nodes
|= $: =time
=resource:store
nodes=(map index:store node:store)
==
^- (quip card _state)
|^
=/ [=graph:store mark=(unit mark:store)]
(~(got by graphs) resource)
=/ =update-log:store (~(got by update-logs) resource)
=. update-log
(put:orm-log update-log time [%0 time [%add-nodes resource nodes]])
::
:- (give [/updates]~ [%add-nodes resource nodes])
%_ state
update-logs (~(put by update-logs) resource update-log)
graphs
%+ ~(put by graphs)
resource
:_ mark
(add-node-list resource graph mark (sort-nodes nodes))
==
::
++ sort-nodes
|= nodes=(map index:store node:store)
^- (list [index:store node:store])
%+ sort ~(tap by nodes)
|= [p=[=index:store *] q=[=index:store *]]
^- ?
(lth (lent index.p) (lent index.q))
::
++ add-node-list
|= $: =resource:store
=graph:store
mark=(unit mark:store)
node-list=(list [index:store node:store])
==
^- graph:store
?~ node-list graph
=* index -.i.node-list
=* node +.i.node-list
%_ $
node-list t.node-list
graph (add-node-at-index graph index node mark)
==
::
++ add-node-at-index
=| parent-hash=(unit hash:store)
|= $: =graph:store
=index:store
=node:store
mark=(unit mark:store)
==
^- graph:store
?< ?=(~ index)
~| "validation of node failed using mark {<mark>}"
?> (validate-graph (gas:orm ~ [i.index node]~) mark)
=* atom i.index
%^ put:orm
graph
atom
:: add child
::
?~ t.index
=* p post.node
=/ =validated-portion:store
[parent-hash author.p time-sent.p contents.p]
=/ =hash:store `@ux`(sham validated-portion)
?~ hash.p node(signatures.post *signatures:store)
~| "signatures do not match the calculated hash"
?> (are-signatures-valid:sigs signatures.p hash now.bowl)
~| "hash of post does not match calculated hash"
?> =(hash u.hash.p)
node
:: recurse children
::
=/ parent=node:store
~| "index does not exist to add a node to!"
(need (get:orm graph atom))
%_ parent
children
^- internal-graph:store
:- %graph
%_ $
index t.index
parent-hash hash.post.parent
graph
?: ?=(%graph -.children.parent)
p.children.parent
(gas:orm ~ ~)
==
==
--
::
++ remove-nodes
|= [=time =resource:store indices=(set index:store)]
^- (quip card _state)
|^
=/ [=graph:store mark=(unit mark:store)]
(~(got by graphs) resource)
=/ =update-log:store (~(got by update-logs) resource)
=. update-log
(put:orm-log update-log time [%0 time [%remove-nodes resource indices]])
::
:- (give [/updates]~ [%remove-nodes resource indices])
%_ state
update-logs (~(put by update-logs) resource update-log)
graphs
%+ ~(put by graphs)
resource
[(remove-indices resource graph ~(tap in indices)) mark]
==
::
++ remove-indices
|= [=resource:store =graph:store indices=(list index:store)]
^- graph:store
?~ indices graph
%_ $
indices t.indices
graph (remove-index graph i.indices)
==
::
++ remove-index
|= [=graph:store =index:store]
^- graph:store
?~ index graph
=* atom i.index
:: last index in list
::
?~ t.index
+:`[* graph:store]`(del:orm graph atom)
=/ =node:store
~| "parent index does not exist to remove a node from!"
(need (get:orm graph atom))
~| "child index does not exist to remove a node from!"
?> ?=(%graph -.children.node)
%^ put:orm
graph
atom
node(p.children $(graph p.children.node, index t.index))
--
::
++ add-signatures
|= [=time =uid:store =signatures:store]
^- (quip card _state)
|^
=* resource resource.uid
=/ [=graph:store mark=(unit mark:store)]
(~(got by graphs) resource)
=/ =update-log:store (~(got by update-logs) resource)
=. update-log
(put:orm-log update-log time [%0 time [%add-signatures uid signatures]])
::
:- (give [/updates]~ [%add-signatures uid signatures])
%_ state
update-logs (~(put by update-logs) resource update-log)
graphs
%+ ~(put by graphs) resource
[(add-at-index graph index.uid signatures) mark]
==
::
++ add-at-index
|= [=graph:store =index:store =signatures:store]
^- graph:store
?~ index graph
=* atom i.index
=/ =node:store
~| "node does not exist to add signatures to!"
(need (get:orm graph atom))
:: last index in list
::
%^ put:orm
graph
atom
?~ t.index
~| "cannot add signatures to a node missing a hash"
?> ?=(^ hash.post.node)
~| "signatures did not match public keys!"
?> (are-signatures-valid:sigs signatures u.hash.post.node now.bowl)
node(signatures.post (~(uni in signatures) signatures.post.node))
~| "child graph does not exist to add signatures to!"
?> ?=(%graph -.children.node)
node(p.children $(graph p.children.node, index t.index))
--
::
++ remove-signatures
|= [=time =uid:store =signatures:store]
^- (quip card _state)
|^
=* resource resource.uid
=/ [=graph:store mark=(unit mark:store)]
(~(got by graphs) resource)
=/ =update-log:store (~(got by update-logs) resource)
=. update-log
%^ put:orm-log update-log
time
[%0 time [%remove-signatures uid signatures]]
::
:- (give [/updates]~ [%remove-signatures uid signatures])
%_ state
update-logs (~(put by update-logs) resource update-log)
graphs
%+ ~(put by graphs) resource
[(remove-at-index graph index.uid signatures) mark]
==
::
++ remove-at-index
|= [=graph:store =index:store =signatures:store]
^- graph:store
?~ index graph
=* atom i.index
=/ =node:store
~| "node does not exist to add signatures to!"
(need (get:orm graph atom))
:: last index in list
::
%^ put:orm
graph
atom
?~ t.index
node(signatures.post (~(dif in signatures) signatures.post.node))
~| "child graph does not exist to add signatures to!"
?> ?=(%graph -.children.node)
node(p.children $(graph p.children.node, index t.index))
--
::
++ add-tag
|= [=term =resource:store]
^- (quip card _state)
?> (~(has by graphs) resource)
:- (give [/updates /tags ~] [%add-tag term resource])
%_ state
tag-queries (~(put ju tag-queries) term resource)
==
::
++ remove-tag
|= [=term =resource:store]
^- (quip card _state)
?> (~(has by graphs) resource)
:- (give [/updates /tags ~] [%remove-tag term resource])
%_ state
tag-queries (~(del ju tag-queries) term resource)
==
::
++ archive-graph
|= =resource:store
^- (quip card _state)
?< (~(has by archive) resource)
?> (~(has by graphs) resource)
:- (give [/updates /keys /tags ~] [%archive-graph resource])
%_ state
archive (~(put by archive) resource (~(got by graphs) resource))
graphs (~(del by graphs) resource)
update-logs (~(del by update-logs) resource)
tag-queries
%- ~(run by tag-queries)
|= =resources:store
(~(del in resources) resource)
==
::
++ unarchive-graph
|= =resource:store
^- (quip card _state)
?> (~(has by archive) resource)
?< (~(has by graphs) resource)
:- (give [/updates /keys ~] [%unarchive-graph resource])
%_ state
archive (~(del by archive) resource)
graphs (~(put by graphs) resource (~(got by archive) resource))
update-logs (~(put by update-logs) resource (gas:orm-log ~ ~))
==
::
++ run-updates
|= [=resource:store =update-log:store]
^- (quip card _state)
?< (~(has by archive) resource)
?> (~(has by graphs) resource)
:_ state
%+ turn (tap:orm-log update-log)
|= [=time update=logged-update:store]
^- card
?> ?=(%0 -.update)
:* %pass
/run-updates/(scot %da time)
%agent
[our.bowl %graph-store]
%poke
:- %graph-update
!>
^- update:store
?- -.q.update
%add-nodes update(resource.q resource)
%remove-nodes update(resource.q resource)
%add-signatures update(resource.uid.q resource)
%remove-signatures update(resource.uid.q resource)
==
==
::
++ validate-graph
|= [=graph:store mark=(unit mark:store)]
^- ?
?~ mark %.y
?~ graph %.y
=/ =dais:clay
.^ =dais:clay
%cb
/(scot %p our.bowl)/[q.byk.bowl]/(scot %da now.bowl)/[u.mark]
==
%+ roll (tap:orm graph)
|= [[=atom =node:store] out=?]
?& out
=(%& -:(mule |.((vale:dais [atom post.node]))))
?- -.children.node
%empty %.y
%graph ^$(graph p.children.node)
==
==
::
++ give
|= [paths=(list path) update=update-0:store]
^- (list card)
[%give %fact paths [%graph-update !>([%0 now.bowl update])]]~
--
--
::
++ on-peek
~/ %graph-store-peek
|= =path
^- (unit (unit cage))
|^
?> (team:title our.bowl src.bowl)
?+ path (on-peek:def path)
[%x %keys ~] ``noun+!>(~(key by graphs))
[%x %tags ~] ``noun+!>(~(key by tag-queries))
[%x %tag-queries ~] ``noun+!>(tag-queries)
[%x %graph @ @ ~]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ result=(unit marked-graph:store)
(~(get by graphs) [ship term])
?~ result [~ ~]
``noun+!>(u.result)
::
[%x %graph-subset @ @ @ @ ~]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ start=(unit atom) (rush i.t.t.t.t.path dem:ag)
=/ end=(unit atom) (rush i.t.t.t.t.t.path dem:ag)
=/ graph=(unit marked-graph:store)
(~(get by graphs) [ship term])
?~ graph [~ ~]
``noun+!>(`graph:store`(subset:orm p.u.graph start end))
::
[%x %node @ @ @ *]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ =index:store
(turn t.t.t.t.path |=(=cord (slav %ud cord)))
=/ node=(unit node:store) (get-node ship term index)
?~ node [~ ~]
``noun+!>(u.node)
::
[%x %post @ @ @ *]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ =index:store
(turn t.t.t.t.path |=(=cord (slav %ud cord)))
=/ node=(unit node:store) (get-node ship term index)
?~ node [~ ~]
``noun+!>(post.u.node)
::
[%x %node-children @ @ @ *]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ =index:store
(turn t.t.t.t.path |=(=cord (slav %ud cord)))
=/ node=(unit node:store) (get-node ship term index)
?~ node [~ ~]
?- -.children.u.node
%empty [~ ~]
%graph ``noun+!>(p.children.u.node)
==
::
[%x %node-children-subset @ @ @ @ @ *]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ start=(unit atom) (rush i.t.t.t.t.path dem:ag)
=/ end=(unit atom) (rush i.t.t.t.t.t.path dem:ag)
=/ =index:store
(turn t.t.t.t.t.t.path |=(=cord (slav %ud cord)))
=/ node=(unit node:store) (get-node ship term index)
?~ node [~ ~]
?- -.children.u.node
%empty [~ ~]
%graph ``noun+!>(`graph:store`(subset:orm p.children.u.node start end))
==
::
[%x %update-log @ @ ~]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ update-log=(unit update-log:store) (~(get by update-logs) [ship term])
?~ update-log [~ ~]
``noun+!>(u.update-log)
::
[%x %peek-update-log @ @ ~]
=/ =ship (slav %p i.t.t.path)
=/ =term i.t.t.t.path
=/ update-log=(unit update-log:store) (~(get by update-logs) [ship term])
?~ update-log [~ ~]
=/ result=(unit [time update:store])
(peek:orm-log:store u.update-log)
?~ result [~ ~]
``noun+!>([~ -.u.result])
==
::
++ get-node
|= [=ship =term =index:store]
^- (unit node:store)
=/ parent-graph=(unit marked-graph:store)
(~(get by graphs) [ship term])
?~ parent-graph ~
=/ node=(unit node:store) ~
=/ =graph:store p.u.parent-graph
|-
?~ index
node
?~ t.index
(get:orm graph i.index)
=. node (get:orm graph i.index)
?~ node ~
?- -.children.u.node
%empty ~
%graph $(graph p.children.u.node, index t.index)
==
--
::
++ on-arvo
|= [=wire =sign-arvo]
^- (quip card _this)
?+ -.sign-arvo (on-arvo:def wire sign-arvo)
%c
:_ this
?> ?=([%graph @ *] wire)
=/ =resource:store (de-path:res t.wire)
=/ gra=(unit marked-graph:store) (~(get by graphs) resource)
?~ gra ~
?~ q.u.gra ~
=/ =rave:clay [%next %b [%da now.bowl] /[u.q.u.gra]]
[%pass wire %arvo %c %warp our.bowl [%home `rave]]~
==
::
++ on-agent on-agent:def
++ on-leave on-leave:def
++ on-fail on-fail:def
--

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

@ -2,22 +2,16 @@
/+ drum=hood-drum, helm=hood-helm, kiln=hood-kiln
|%
+$ state
$: %8
drum=state:drum
helm=state:helm
kiln=state:kiln
==
+$ state-7
$: %7
$: %9
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]
[%8 drum=state:drum helm=state:helm kiln=state:kiln]
==
+$ any-state-tuple
$: drum=any-state:drum

BIN
pkg/arvo/app/landscape/img/groups.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 693 B

BIN
pkg/arvo/app/landscape/img/icon-home.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 255 B

After

Width:  |  Height:  |  Size: 582 B

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

@ -4,7 +4,7 @@
<title>OS1</title>
<meta charset="utf-8" />
<meta name="viewport"
content="width=device-width, initial-scale=1, shrink-to-fit=no"/>
content="width=device-width, initial-scale=1, shrink-to-fit=no,maximum-scale=1"/>
<meta name="apple-mobile-web-app-capable" content="yes" />
<meta name="apple-touch-fullscreen" content="yes" />
<meta name="apple-mobile-web-app-status-bar-style" content="default" />
@ -23,7 +23,7 @@
<div id="root"/>
<script src="/~landscape/js/channel.js"></script>
<script src="/~landscape/js/session.js"></script>
<script src="/~landscape/js/index.js"></script>
<script src="/~landscape/js/bundle/index.f58fbbc4b037bb976a2a.js"></script>
<script src="https://sdk.amazonaws.com/js/aws-sdk-2.1.12.min.js"></script>
</body>
</html>

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

@ -85,15 +85,16 @@
old [%2 +.old]
::
cards
%+ turn
%+ murn
~(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)
^- (unit card)
=/ rid=(unit resource)
(de-path-soft:resource group-path)
?~ rid ~
?: =(our.bowl entity.u.rid)
`(poke-md-hook %add-owned group-path)
`(poke-md-hook %add-synced entity.u.rid group-path)
==
=/ new-state=state-one
%* . *state-one
@ -254,6 +255,11 @@
=/ =group-path (stab (slav %t i.t.t.path))
=/ =md-resource [`@tas`i.t.t.t.path (stab (slav %t i.t.t.t.t.path))]
``noun+!>((~(get by associations) [group-path md-resource]))
::
[%x %resource @ *]
=/ app=@tas i.t.t.path
=/ app-path=^path t.t.t.path
``noun+!>((~(get by resource-indices) app app-path))
==
::
++ on-agent on-agent:def

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

@ -54,6 +54,7 @@
[%3 state-three]
[%4 state-three]
[%5 state-three]
[%6 state-three]
==
::
+$ metadata-delta
@ -69,7 +70,7 @@
==
--
::
=| [%5 state-three]
=| [%6 state-three]
=* state -
%- agent:dbug
%+ verb |
@ -86,7 +87,6 @@
:_ this
:~ [%pass /view-bind %arvo %e %connect [~ /'publish-view'] %publish]
[%pass /read/paths %arvo %c %warp our.bol q.byk.bol `rav]
[%pass /permissions %agent [our.bol %permission-store] %watch /updates]
(invite-poke:main [%create /publish])
:* %pass /invites %agent [our.bol %invite-store] %watch
/invitatory/publish
@ -218,6 +218,26 @@
==
::
%5
%= $
-.p.old-state %6
cards
%+ weld cards
%+ roll ~(tap by books.p.old-state)
|= [[[who=@p book=@tas] nb=notebook] out=(list card)]
^- (list card)
?. =(who our.bol)
out
=/ rid (de-path:resource writers.nb)
=/ grp=(unit group) (scry-group:grup:main rid)
?~ grp out
?: hidden.u.grp
out
=/ =tag [%publish (cat 3 'writers-' book)]
:_ out
(group-proxy-poke entity.rid %add-tag rid tag members.u.grp)
==
::
%6
[cards this(state p.old-state)]
==
++ convert-notebook-3-4
@ -995,6 +1015,22 @@
[~ state]
:_ state
%- zing
:- ^- (list card)
%+ roll ~(tap by books)
|= [[[who=@p book=@tas] nb=notebook] out=(list card)]
^- (list card)
?. =(who our.bol)
out
?. =(writers.nb path)
out
=/ rid (de-path:resource writers.nb)
=/ grp=(unit group) (scry-group:grup rid)
?~ grp out
?: hidden.u.grp
out
=/ =tag [%publish (cat 3 'writers-' book)]
:_ out
(group-proxy-poke entity.rid %add-tag rid tag members.u.grp)
%+ turn ~(tap in ships)
|= who=@p
?. (allowed who %read u.book)
@ -1226,12 +1262,19 @@
^- [(list card) write=path read=path]
?> ?=(^ group-path.group)
=/ scry-path
;:(welp /(scot %p our.bol)/group-store/(scot %da now.bol) [%groups group-path.group] /noun)
=/ grp .^((unit ^group) %gx scry-path)
;: welp
/(scot %p our.bol)/group-store/(scot %da now.bol)
[%groups group-path.group]
/noun
==
=/ rid=resource (de-path:resource group-path.group)
=/ grp=(unit ^group) (scry-group:grup rid)
?: use-preexisting.group
?~ grp !!
?. (is-managed group-path.group) !!
`[group-path.group group-path.group]
=/ =tag [%publish (cat 3 'writers-' book)]
:_ [group-path.group group-path.group]
[(group-proxy-poke entity.rid %add-tag rid tag members.u.grp)]~
::
=/ =policy
*open:policy
@ -1684,10 +1727,9 @@
?> ?=(^ subscribers.u.book)
=/ cards=(list card)
~[(delete-dir pax)]
=/ rid=resource
(de-path:resource writers.u.book)
=? cards (is-managed:grup rid)
=? cards !(is-managed:grup rid)
[(group-poke %remove-group rid ~) cards]
[cards state]
:: %del-note:
@ -1789,8 +1831,14 @@
::
%subscribe
?> (team:title our.bol src.bol)
?: =(our.bol who.act)
[~ state]
=/ join-wire=wire
/join-group/[(scot %p who.act)]/[book.act]
=/ meta=(unit (set path))
(metadata-resource-scry %publish /(scot %p who.act)/[book.act])
?^ meta
(subscribe-notebook who.act book.act)
=/ rid=resource
[who.act book.act]
=/ =cage
@ -1811,12 +1859,16 @@
(de-path:resource writers.book)
=/ =group
(need (scry-group:grup rid))
:_ state(books (~(del by books) who.act book.act))
:~ `card`[%pass wir %agent [who.act %publish] %leave ~]
`card`[%give %fact [/primary]~ %publish-primary-delta !>(del)]
(group-proxy-poke who.act %remove-members rid (sy our.bol ~))
(group-poke %remove-group rid ~)
==
=/ cards=(list card)
:~ [%pass wir %agent [who.act %publish] %leave ~]
[%give %fact [/primary]~ %publish-primary-delta !>(del)]
==
=? cards hidden.group
%+ weld cards
:~ (group-proxy-poke who.act %remove-members rid (sy our.bol ~))
(group-poke %remove-group rid ~)
==
[cards state(books (~(del by books) who.act book.act))]
:: %read
::
%read
@ -1952,6 +2004,19 @@
/noun
==
::
++ metadata-resource-scry
|= [app=@tas app-path=path]
^- (unit (set path))
?. .^(? %gu (scot %p our.bol) %metadata-store (scot %da now.bol) ~) ~
.^ (unit (set path))
%gx
;: weld
/(scot %p our.bol)/metadata-store/(scot %da now.bol)/resource/[app]
app-path
/noun
==
==
::
++ emit-metadata
|= del=metadata-delta
^- (list card)
@ -2044,9 +2109,11 @@
(emit-updates-and-state host.del book.del data.del del sty)
=/ rid=resource
(de-path:resource writers.data.del)
=? cards !=(our.bol entity.rid)
:_ cards
(group-pull-hook-poke [%add host.del rid])
:_ state
:* (group-pull-hook-poke [%add host.del rid])
(metadata-hook-poke [%add-synced host.del writers.data.del])
:* (metadata-hook-poke [%add-synced host.del writers.data.del])
cards
==
::

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

@ -0,0 +1,10 @@
:: graph-store|add-graph: add new graph
::
/+ *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=resource mark=(unit mark) ~] ~]
==
:- %graph-update
^- update
[%0 now [%add-graph resource (gas:orm ~ ~) mark]]

20
pkg/arvo/gen/graph-store/add-post.hoon Normal file
View File

@ -0,0 +1,20 @@
:: graph-store|add-post: add post to a graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[[our=ship name=term] contents=(list content) ~] ~]
==
=/ =post *post
=: author.post our
index.post [now]~
time-sent.post now
contents.post contents
==
::
:- %graph-update
^- update
:+ %0 now
:+ %add-nodes [our name]
%- ~(gas by *(map index node))
~[[[now]~ [post [%empty ~]]]]

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

@ -0,0 +1,10 @@
:: graph-store|add-signatures: add signatures to a node at a particular uid
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[[=resource =index] =signatures ~] ~]
==
:- %graph-update
^- update
[%0 now [%add-signatures [resource index] signatures]]

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

@ -0,0 +1,10 @@
:: graph-store|add-tag: tag a particular graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=term =resource ~] ~]
==
:- %graph-update
^- update
[%0 now [%add-tag term resource]]

10
pkg/arvo/gen/graph-store/archive-graph.hoon Normal file
View File

@ -0,0 +1,10 @@
:: graph-store|archive-graph: archive graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=resource ~] ~]
==
:- %graph-update
^- update
[%0 now [%archive-graph resource]]

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

@ -0,0 +1,10 @@
:: graph-store|remove-graph: remove graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=resource ~] ~]
==
:- %graph-update
^- update
[%0 now [%remove-graph resource]]

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

@ -0,0 +1,10 @@
:: graph-store|remove-nodes: remove nodes from a graph at indices
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=resource indices=(set index) ~] ~]
==
:- %graph-update
^- update
[%0 now [%remove-nodes resource indices]]

11
pkg/arvo/gen/graph-store/remove-signatures.hoon Normal file
View File

@ -0,0 +1,11 @@
:: graph-store|remove-signatures: remove signatures from a node at a
:: particular uid
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[[=resource =index] =signatures ~] ~]
==
:- %graph-update
^- update
[%0 now [%remove-signatures [resource index] signatures]]

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

@ -0,0 +1,10 @@
:: graph-store|remove-tag: remove a tag from a particular graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=term =resource ~] ~]
==
:- %graph-update
^- update
[%0 now [%remove-tag term resource]]

10
pkg/arvo/gen/graph-store/unarchive-graph.hoon Normal file
View File

@ -0,0 +1,10 @@
:: graph-store|unarchive-graph: unarchive graph
::
/- *graph-store
:- %say
|= $: [now=@da eny=@uvJ =beak]
[[=resource ~] ~]
==
:- %graph-update
^- update
[%0 now [%unarchive-graph resource]]

2
pkg/arvo/gen/hood/moon-cycle-keys.hoon
View File

@ -36,7 +36,7 @@
public-key
=/ cub (pit:nu:crub:crypto 512 (shaz (jam mon life eny)))
=/ =seed:able:jael
[mon 1 sec:ex:cub ~]
[mon life sec:ex:cub ~]
%- %- slog
:~ leaf+"moon: {(scow %p mon)}"
leaf+(scow %uw (jam seed))

8
pkg/arvo/gen/hood/ota.hoon
View File

@ -8,7 +8,11 @@
::
:- %say
|= $: [now=@da eny=@uvJ bec=beak]
[arg=?(~ [her=@p sud=@tas ~]) ~]
[arg=?(~ [%disable ~] [her=@p sud=@tas ~]) ~]
==
?~ arg
:- %kiln-ota-info ~
:- %kiln-ota
?~(arg ~ `[her sud]:arg)
?: ?=([%disable ~] arg)
~
`[her sud]:arg

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

@ -5,5 +5,5 @@
[%tang >timers< ~]
.^ (list [date=@da =duct])
%bx
(en-beam:format [p.bec %$ r.bec] /debug/timers)
(en-beam:format [p.bec %$ r.bec] /timers/debug)
==

411
pkg/arvo/lib/graph-store.hoon Normal file
View File

@ -0,0 +1,411 @@
/- sur=graph-store, pos=post
/+ res=resource
=< [sur .]
=< [pos .]
=, sur
=, pos
|%
:: NOTE: move these functions to zuse
++ nu :: parse number as hex
|= jon/json
?> ?=({$s *} jon)
(rash p.jon hex)
::
++ re :: recursive reparsers
|* {gar/* sef/_|.(fist:dejs-soft:format)}
|= jon/json
^- (unit _gar)
=- ~! gar ~! (need -) -
((sef) jon)
::
++ dank :: tank
^- $-(json (unit tank))
=, ^? dejs-soft:format
%+ re *tank |. ~+
%- of :~
leaf+sa
palm+(ot style+(ot mid+sa cap+sa open+sa close+sa ~) lines+(ar dank) ~)
rose+(ot style+(ot mid+sa open+sa close+sa ~) lines+(ar dank) ~)
==
::
++ orm ((ordered-map atom node) gth)
++ orm-log ((ordered-map time logged-update) gth)
::
++ enjs
=, enjs:format
|%
++ update
|= upd=^update
^- json
?> ?=(%0 -.upd)
|^ (frond %graph-update (pairs ~[(encode q.upd)]))
::
++ encode
|= upd=update-0
^- [cord json]
?- -.upd
%add-graph
:- %add-graph
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%graph (graph graph.upd)]
[%mark ?~(mark.upd ~ s+u.mark.upd)]
==
::
%remove-graph
[%remove-graph (enjs:res resource.upd)]
::
%add-nodes
:- %add-nodes
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%nodes (nodes nodes.upd)]
==
::
%remove-nodes
:- %remove-nodes
%- pairs
:~ [%resource (enjs:res resource.upd)]
[%indices (indices indices.upd)]
==
::
%add-signatures
:- %add-signatures
%- pairs
:~ [%uid (uid uid.upd)]
[%signatures (signatures signatures.upd)]
==
::
%remove-signatures
:- %remove-signatures
%- pairs
:~ [%uid (uid uid.upd)]
[%signatures (signatures signatures.upd)]
==
::
%add-tag
:- %add-tag
%- pairs
:~ [%term s+term.upd]
[%resource (enjs:res resource.upd)]
==
::
%remove-tag
:- %remove-tag
%- pairs
:~ [%term s+term.upd]
[%resource (enjs:res resource.upd)]
==
::
%archive-graph
[%archive-graph (enjs:res resource.upd)]
::
%unarchive-graph
[%unarchive-graph (enjs:res resource.upd)]
::
%keys
[%keys [%a (turn ~(tap in resources.upd) enjs:res)]]
::
%tags
[%tags [%a (turn ~(tap in tags.upd) |=(=term s+term))]]
::
%run-updates
[%run-updates ~]
::
%tag-queries
:- %tag-queries
%- pairs
%+ turn ~(tap by tag-queries.upd)
|= [=term =resources]
^- [cord json]
[term [%a (turn ~(tap in resources) enjs:res)]]
==
::
++ graph
|= g=^graph
^- json
:- %a
%+ turn (tap:orm g)
|= [a=atom n=^node]
^- json
:- %a
:~ (index [a]~)
(node n)
==
::
++ index
|= i=^index
^- json
=/ j=^tape ""
|-
?~ i [%s (crip j)]
=/ k=json (numb i.i)
?> ?=(%n -.k)
%_ $
i t.i
j (weld j (weld "/" (trip +.k)))
==
::
++ node
|= n=^node
^- json
%- pairs
:~ [%post (post post.n)]
:- %children
?- -.children.n
%empty ~
%graph (graph +.children.n)
==
==
::
++ post
|= p=^post
^- json
%- pairs
:~ [%author (ship author.p)]
[%index (index index.p)]
[%time-sent (time time-sent.p)]
[%contents [%a (turn contents.p content)]]
[%hash ?~(hash.p ~ s+(scot %ux u.hash.p))]
[%signatures (signatures signatures.p)]
==
::
++ content
|= c=^content
^- json
?- -.c
%text (frond %text s+text.c)
%url (frond %url s+url.c)
%reference (frond %reference (uid uid.c))
%code
%+ frond %code
%- pairs
:- [%expression s+expression.c]
:_ ~
:- %output
:: virtualize output rendering, +tank:enjs:format might crash
::
=/ result=(each (list json) tang)
(mule |.((turn output.c tank)))
?- -.result
%& a+p.result
%| a+[a+[%s '[[output rendering error]]']~]~
==
==
::
++ nodes
|= m=(map ^index ^node)
^- json
:- %a
%+ turn ~(tap by m)
|= [n=^index o=^node]
^- json
:- %a
:~ (index n)
(node o)
==
::
++ indices
|= i=(set ^index)
^- json
[%a (turn ~(tap in i) index)]
::
++ uid
|= u=^uid
^- json
%- pairs
:~ [%resource (enjs:res resource.u)]
[%index (index index.u)]
==
::
++ signatures
|= s=^signatures
^- json
[%a (turn ~(tap in s) signature)]
::
++ signature
|= s=^signature
^- json
%- pairs
:~ [%signature s+(scot %ux p.s)]
[%ship (ship q.s)]
[%life (numb r.s)]
==
--
--
::
++ dejs
=, dejs:format
|%
++ update
|= jon=json
^- ^update
:- %0
:- *time
^- update-0
=< (decode jon)
|%
++ decode
%- of
:~ [%add-graph add-graph]
[%remove-graph remove-graph]
[%add-nodes add-nodes]
[%remove-nodes remove-nodes]
[%add-signatures add-signatures]
[%remove-signatures remove-signatures]
[%add-tag add-tag]
[%remove-tag remove-tag]
[%archive-graph archive-graph]
[%unarchive-graph unarchive-graph]
[%keys keys]
[%tags tags]
[%tag-queries tag-queries]
[%run-updates run-updates]
==
::
++ add-graph
%- ot
:~ [%resource dejs:res]
[%graph graph]
[%mark (mu so)]
==
::
++ graph
|= a=json
^- ^graph
=/ or-mp ((ordered-map atom ^node) gth)
%+ gas:or-mp ~
%+ turn ~(tap by ((om node) a))
|* [b=cord c=*]
^- [atom ^node]
=> .(+< [b c]=+<)
[(rash b dem) c]
::
++ remove-graph (ot [%resource dejs:res]~)
++ archive-graph (ot [%resource dejs:res]~)
++ unarchive-graph (ot [%resource dejs:res]~)
::
++ add-nodes
%- ot
:~ [%resource dejs:res]
[%nodes nodes]
==
::
++ nodes (op ;~(pfix net (more net dem)) node)
::
++ node
%- ot
:~ [%post post]
:: TODO: support adding nodes with children by supporting the
:: graph key
[%children (of [%empty ul]~)]
==
::
++ post
%- ot
:~ [%author (su ;~(pfix sig fed:ag))]
[%index index]
[%time-sent di]
[%contents (ar content)]
[%hash (mu nu)]
[%signatures (as signature)]
==
::
++ content
%- of
:~ [%text so]
[%url so]
[%reference uid]
[%code eval]
==
::
++ eval
|= a=^json
^- [cord (list tank)]
=, ^? dejs-soft:format
=+ exp=((ot expression+so ~) a)
%- need
?~ exp [~ '' ~]
:+ ~ u.exp
:: NOTE: when sending, if output is an empty list,
:: graph-store will evaluate
(fall ((ot output+(ar dank) ~) a) ~)
::
++ remove-nodes
%- ot
:~ [%resource dejs:res]
[%indices (as index)]
==
::
++ add-signatures
%- ot
:~ [%uid uid]
[%signatures (as signature)]
==
::
++ remove-signatures
%- ot
:~ [%uid uid]
[%signatures (as signature)]
==
::
++ signature
%- ot
:~ [%hash nu]
[%ship (su ;~(pfix sig fed:ag))]
[%life ni]
==
::
++ uid
%- ot
:~ [%resource dejs:res]
[%index index]
==
::
++ index (su ;~(pfix net (more net dem)))
::
++ add-tag
%- ot
:~ [%term so]
[%resource dejs:res]
==
::
++ remove-tag
%- ot
:~ [%term so]
[%resource dejs:res]
==
::
++ keys
|= =json
*resources
::
++ tags
|= =json
*(set term)
::
++ tag-queries
|= =json
*^tag-queries
::
++ run-updates
|= a=json
^- [resource update-log]
[*resource *update-log]
--
--
::
++ create
|_ [our=ship now=time]
++ post
|= [=index contents=(list content)]
^- ^post
:* our
index
now
contents
~
*signatures
==
--
--

24
pkg/arvo/lib/graph.hoon Normal file
View File

@ -0,0 +1,24 @@
/- *resource
/+ store=graph-store
|_ =bowl:gall
++ scry-for
|* [=mold =path]
.^ mold
%gx
(scot %p our.bowl)
%graph-store
(scot %da now.bowl)
(snoc `^path`path %noun)
==
::
++ get-graph
|= res=resource
^- marked-graph:store
%+ scry-for marked-graph:store
/graph/(scot %p entity.res)/[name.res]
::
++ peek-log
|= res=resource
^- (unit time)
(scry-for (unit time) /peek-update-log/(scot %p entity.res)/[name.res])
--

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

@ -104,6 +104,7 @@
%s3-store
%file-server
%glob
%graph-store
==
::
++ deft-fish :: default connects
@ -206,7 +207,7 @@
==
::
++ on-load
|= [hood-version=?(%1 %2 %3 %4 %5 %6 %7 %8) old=any-state]
|= [hood-version=?(%1 %2 %3 %4 %5 %6 %7 %8 %9) old=any-state]
=< se-abet =< se-view
=. sat old
=. dev (~(gut by bin) ost *source)
@ -233,6 +234,8 @@
=? ..on-load (lte hood-version %8)
=> (se-born | %home %group-push-hook)
(se-born | %home %group-pull-hook)
=? ..on-load (lte hood-version %9)
(se-born | %home %graph-store)
..on-load
::
++ reap-phat :: ack connect

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

@ -208,7 +208,7 @@
::
++ get-germ
|= =desk
=+ .^(=cass:clay %cw /(scot %p our)/home/(scot %da now))
=+ .^(=cass:clay %cw /(scot %p our)/[desk]/(scot %da now))
?- ud.cass
%0 %init
%1 %that
@ -341,13 +341,22 @@
abet:(spam (render "already syncing" [sud her syd]:hos) ~)
abet:abet:start-sync:(auto hos)
::
++ ota-info
?~ ota
"OTAs disabled"
"OTAs enabled from {<desk.u.ota>} on {<ship.u.ota>}"
::
++ poke-ota-info
|= *
=< abet %- spam
:~ [%leaf ota-info]
[%leaf "use |ota %disable or |ota ~sponsor %kids to reset it"]
==
::
++ poke-syncs :: print sync config
|= ~
=< abet %- spam
:- :- %leaf
?~ ota
"OTAs disabled"
"OTAs from {<desk.u.ota>} on {<ship.u.ota>}"
:- [%leaf ota-info]
?: =(0 ~(wyt by syn))
[%leaf "no other syncs configured"]~
%+ turn ~(tap in ~(key by syn))
@ -416,6 +425,7 @@
%kiln-merge =;(f (f !<(_+<.f vase)) poke-merge)
%kiln-mount =;(f (f !<(_+<.f vase)) poke-mount)
%kiln-ota =;(f (f !<(_+<.f vase)) poke:update)
%kiln-ota-info =;(f (f !<(_+<.f vase)) poke-ota-info)
%kiln-permission =;(f (f !<(_+<.f vase)) poke-permission)
%kiln-rm =;(f (f !<(_+<.f vase)) poke-rm)
%kiln-schedule =;(f (f !<(_+<.f vase)) poke-schedule)

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

@ -59,7 +59,6 @@
|~ [term tang]
*[(list card) _^|(..on-init)]
:: +resource-for-update: get affected resource from an update
++ resource-for-update
|~ vase
*(unit resource)

4
pkg/arvo/lib/server.hoon
View File

@ -80,9 +80,11 @@
++ max-1-wk ['cache-control' 'max-age=604800']
::
++ html-response
=| cache=?
|= =octs
^- simple-payload:http
[[200 [['content-type' 'text/html'] max-1-wk ~]] `octs]
:_ `octs
[200 [['content-type' 'text/html'] ?:(cache [max-1-wk ~] ~)]]
::
++ js-response
|= =octs

43
pkg/arvo/lib/signatures.hoon Normal file
View File

@ -0,0 +1,43 @@
/- post
^?
=< [post .]
=, post
|%
++ sign
|= [our=ship now=time =hash]
^- signature
=/ =life .^(life %j /=life/(scot %da now)/(scot %p our))
=/ =ring .^(ring %j /=vein/(scot %da now)/(scot %ud life))
:+ `@ux`(sign:as:(nol:nu:crub:crypto ring) hash)
our
life
::
++ is-signature-valid
|= [=signature =hash now=time]
^- ?
=/ deed=(unit [a=life b=pass c=(unit @ux)])
.^ (unit [life pass (unit @ux)])
%j
/=deed/(scot %da now)/(scot %p q.signature)/(scot %ud p.signature)
==
:: we do not have a public key from ship
::
?~ deed %.y
:: we do not have a public key from ship at this life
::
?. =(a.u.deed r.signature) %.y
:: verify signature from ship at life
::
=(`hash (tear:as:crub:crypto b.u.deed p.signature))
::
++ are-signatures-valid
|= [=signatures =hash now=time]
^- ?
=/ signature-list ~(tap in signatures)
|-
?~ signature-list
%.y
?: (is-signature-valid i.signature-list hash now)
$(signature-list t.signature-list)
%.n
--

13
pkg/arvo/mar/graph/update.hoon Normal file
View File

@ -0,0 +1,13 @@
/+ *graph-store
|_ upd=update
++ grow
|%
++ json (update:enjs upd)
--
::
++ grab
|%
++ noun update
++ json update:dejs
--
--

17
pkg/arvo/mar/graph/validator/chat.hoon Normal file
View File

@ -0,0 +1,17 @@
/- *post
|_ i=indexed-post
++ grow
|%
++ noun i
--
++ grab
|%
++ noun
|= p=*
=/ ip ;;(indexed-post p)
?> ?=([@ ~] index.p.ip)
ip
--
::
++ grad %noun
--

61
pkg/arvo/sur/graph-store.hoon Normal file
View File

@ -0,0 +1,61 @@
/- *post
|%
+$ graph ((mop atom node) gth)
+$ marked-graph [p=graph q=(unit mark)]
::
+$ node [=post children=internal-graph]
+$ graphs (map resource marked-graph)
::
+$ tag-queries (jug term resource)
::
+$ update-log ((mop time logged-update) gth)
+$ update-logs (map resource update-log)
::
+$ internal-graph
$~ [%empty ~]
$% [%graph p=graph]
[%empty ~]
==
::
+$ network
$: =graphs
=tag-queries
=update-logs
archive=graphs
validators=(set mark)
==
::
+$ update
$% [%0 p=time q=update-0]
==
::
+$ logged-update
$% [%0 p=time q=logged-update-0]
==
::
+$ logged-update-0
$% [%add-nodes =resource nodes=(map index node)]
[%remove-nodes =resource indices=(set index)]
[%add-signatures =uid =signatures]
[%remove-signatures =uid =signatures]
==
::
+$ update-0
$% logged-update-0
[%add-graph =resource =graph mark=(unit mark)]
[%remove-graph =resource]
::
[%add-tag =term =resource]
[%remove-tag =term =resource]
::
[%archive-graph =resource]
[%unarchive-graph =resource]
[%run-updates =resource =update-log]
::
:: NOTE: cannot be sent as pokes
::
[%keys =resources]
[%tags tags=(set term)]
[%tag-queries =tag-queries]
==
--

37
pkg/arvo/sur/post.hoon Normal file
View File

@ -0,0 +1,37 @@
/- *resource
|%
+$ index (list atom)
+$ uid [=resource =index]
::
:: +sham (half sha-256) hash of +validated-portion
+$ hash @ux
::
+$ signature [p=@ux q=ship r=life]
+$ signatures (set signature)
+$ post
$: author=ship
=index
time-sent=time
contents=(list content)
hash=(unit hash)
=signatures
==
::
+$ indexed-post [a=atom p=post]
::
+$ validated-portion
$: parent-hash=(unit hash)
author=ship
time-sent=time
contents=(list content)
==
::
+$ content
$% [%text text=cord]
[%url url=cord]
[%code expression=cord output=(list tank)]
[%reference =uid]
:: TODO: maybe use a cask?
::[%cage =cage]
==
--

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

@ -8,5 +8,4 @@
+$ update
$% [%tracking tracking=(map resource ship)]
==
::
--

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

@ -7762,11 +7762,13 @@
++ teal
|= mod/spec
^- spec
?: ?=(%& -.tik) mod
[%over [%& 3]~ mod]
::
++ tele
|= syn/skin
^- skin
?: ?=(%& -.tik) syn
[%over [%& 3]~ syn]
::
++ gray

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

@ -1121,17 +1121,32 @@
?> =(rcvr-life.shut-packet our-life.channel)
:: non-galaxy: update route with heard lane or forwarded lane
::
=? route.peer-state
?: =(%czar (clan:title her.channel))
%.n
=/ is-old-direct=? ?=([~ %& *] route.peer-state)
=/ is-new-direct=? ?=(~ origin.packet)
:: old direct takes precedence over new indirect
::
|(is-new-direct !is-old-direct)
=? route.peer-state !=(%czar (clan:title her.channel))
:: if new packet is direct, use that. otherwise, if the new new
:: and old lanes are indirect, use the new one. if the new lane
:: is indirect but the old lane is direct, then if the lanes are
:: identical, don't mark it indirect; if they're not identical,
:: use the new lane and mark it indirect.
::
?~ origin.packet
:: if you mark lane as indirect because you got an indirect
:: packet even though you already had a direct identical lane,
:: then delayed forwarded packets will come later and reset to
:: indirect, so you're unlikely to get a stable direct route
:: (unless the forwarder goes offline for a while).
::
:: conversely, if you don't accept indirect routes with different
:: lanes, then if your lane is stale and they're trying to talk
:: to you, your acks will go to the stale lane, and you'll never
:: time it out unless you reach out to them. this manifests as
:: needing to |hi or dotpost to get a response when the other
:: ship has changed lanes.
::
?: ?=(~ origin.packet)
`[direct=%.y lane]
?: ?=([~ %& *] route.peer-state)
?: =(lane.u.route.peer-state u.origin.packet)
route.peer-state
`[direct=%.n u.origin.packet]
`[direct=%.n u.origin.packet]
:: perform peer-specific handling of packet
::

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

@ -109,6 +109,10 @@
mut/(list (trel path lobe cage)) :: mutations
== ::
::
:: Over-the-wire backfill request
::
+$ fill [=desk =lobe]
::
:: Ford cache
::
+$ ford-cache
@ -214,18 +218,29 @@
:: requests, and a possible nako if we've received data from the other ship and
:: are in the process of validating it.
::
++ rind :: request manager
$: nix/@ud :: request index
bom/(map @ud {p/duct q/rave}) :: outstanding
fod/(map duct @ud) :: current requests
haw/(map mood (unit cage)) :: simple cache
== ::
+$ rind :: request manager
$: nix=@ud :: request index
bom=(map @ud update-state) :: outstanding
fod=(map duct @ud) :: current requests
haw=(map mood (unit cage)) :: simple cache
== ::
::
:: Active downloads
::
+$ update-state
$: =duct
=rave
have=(map lobe blob)
need=(list lobe)
nako=(qeu (unit nako))
busy=_|
==
::
:: Result of a subscription
::
++ sub-result
$% [%blab =mood data=(each cage lobe)]
[%bleb ins=@ud range=(unit (pair aeon aeon))]
[%bleb ver=@ud ins=@ud range=(unit (pair aeon aeon))]
[%balk cage=(unit (each cage lobe)) =mood]
[%blas moods=(set mood)]
[%blub ~]
@ -246,7 +261,7 @@
:: Generally used when we store a request in our state somewhere.
::
++ cach (unit (unit (each cage lobe))) :: cached result
+$ wove [for=(unit ship) =rove] :: stored source + req
+$ wove [for=(unit [=ship ver=@ud]) =rove] :: stored source + req
++ rove :: stored request
$% [%sing =mood] :: single request
[%next =mood aeon=(unit aeon) =cach] :: next version of one
@ -1134,13 +1149,13 @@
:: Give next step in a subscription.
::
++ bleb
|= {hen/duct ins/@ud hip/(unit (pair aeon aeon))}
|= [hen=duct ver=@ud ins=@ud hip=(unit (pair aeon aeon))]
^+ +>
%^ blab hen [%w [%ud ins] ~]
:- %&
?~ hip
[%null [%atom %n ~] ~]
[%nako !>((make-nako:ze u.hip))]
[%nako !>((make-nako:ze ver u.hip))]
::
:: Tell subscriber that subscription is done.
::
@ -1183,7 +1198,7 @@
=/ =desk p.riff
=/ =wire /warp-index/(scot %p ship)/(scot %tas desk)/(scot %ud index)
=/ =path [%question desk (scot %ud index) ~]
(emit duct %pass wire %a %plea ship %c path riff)
(emit duct %pass wire %a %plea ship %c path [[%1 ~] riff])
::
:: Create a request that cannot be filled immediately.
::
@ -1210,7 +1225,7 @@
(send-over-ames hen her inx syd `rave)
%= +>+.$
nix.u.ref +(nix.u.ref)
bom.u.ref (~(put by bom.u.ref) inx [hen rave])
bom.u.ref (~(put by bom.u.ref) inx [hen rave ~ ~ ~ |])
fod.u.ref (~(put by fod.u.ref) hen inx)
==
::
@ -2003,6 +2018,7 @@
:: bob's.
::
?: ?=(%init germ)
?> ?=(~ bob-yaki)
&+`[conflicts=~ new=|+ali-yaki lat=~]
::
=/ bob-yaki (need bob-yaki)
@ -2589,7 +2605,7 @@
:: and then waiting if the subscription range extends into the future.
::
++ start-request
|= [for=(unit ship) rav=rave]
|= [for=(unit [ship @ud]) rav=rave]
^+ ..start-request
=^ [new-sub=(unit rove) sub-results=(list sub-result)] fod.dom
(try-fill-sub for (rave-to-rove rav))
@ -2612,9 +2628,9 @@
?> ?=(^ ref)
=+ ruv=(~(get by bom.u.ref) inx)
?~ ruv +>.$
=/ rav=rave q.u.ruv
=/ rav=rave rave.u.ruv
?: ?=(%many -.rav)
(take-foreign-update inx rut)
abet:(apex:(foreign-update inx) rut)
?~ rut
:: nothing here, so cache that
::
@ -2689,36 +2705,138 @@
!>(;;(@uvI q.page))
--
::
:: A full foreign update. Validate and apply to our local cache of
:: their state.
:: Respond to backfill request
::
++ take-foreign-update
|= [inx=@ud rut=(unit rand)]
^+ ..take-foreign-update
:: Maybe should verify the requester is allowed to access this blob?
::
++ give-backfill
|= =lobe
^+ ..give-backfill
(emit hen %give %boon (~(got by lat.ran) lobe))
::
:: Ingest foreign update, requesting missing blobs if necessary
::
++ foreign-update
|= inx=@ud
?> ?=(^ ref)
=/ ruv (~(get by bom.u.ref) inx)
?~ ruv
~& [%clay-foreign-update-lost her syd inx]
..take-foreign-update
=. hen p.u.ruv
=/ =rave q.u.ruv
?> ?=(%many -.rave)
|^
?~ rut
done
=. lim ?.(?=(%da -.to.moat.rave) lim p.to.moat.rave)
?> ?=(%nako p.r.u.rut)
=/ nako ;;(nako q.r.u.rut)
=. ..take-foreign-update
=< ?>(?=(^ ref) .)
(apply-foreign-update nako)
done
=/ [sat=update-state lost=?]
=/ ruv (~(get by bom.u.ref) inx)
?~ ruv
~& [%clay-foreign-update-lost her syd inx]
[*update-state &]
[u.ruv |]
=/ done=? |
=. hen duct.sat
|%
++ abet
^+ ..foreign-update
?: lost
..foreign-update
?: done
=: bom.u.ref (~(del by bom.u.ref) inx)
fod.u.ref (~(del by fod.u.ref) hen)
==
=<(?>(?=(^ ref) .) wake)
=. bom.u.ref (~(put by bom.u.ref) inx sat)
..foreign-update
::
++ done
=: bom.u.ref (~(del by bom.u.ref) inx)
bom.u.ref (~(del by bom.u.ref) hen)
==
=<(?>(?=(^ ref) .) wake)
++ apex
|= rut=(unit rand)
^+ ..abet
?: lost ..abet
?~ rut
=. nako.sat (~(put to nako.sat) ~)
work
?> ?=(%nako p.r.u.rut)
=/ nako ;;(nako q.r.u.rut)
=/ missing (missing-blobs nako)
=. need.sat `(list lobe)`(welp need.sat ~(tap in missing))
=. nako.sat (~(put to nako.sat) ~ nako)
work
::
++ missing-blobs
|= =nako
^- (set lobe)
=/ yakis ~(tap in lar.nako)
|- ^- (set lobe)
=* yaki-loop $
?~ yakis
~
=/ lobes=(list [=path =lobe]) ~(tap by q.i.yakis)
|- ^- (set lobe)
=* blob-loop $
?~ lobes
yaki-loop(yakis t.yakis)
?: (~(has by lat.ran) lobe.i.lobes)
blob-loop(lobes t.lobes)
(~(put in blob-loop(lobes t.lobes)) lobe.i.lobes)
::
:: Receive backfill response
::
++ take-backfill
|= =blob
^+ ..abet
?: lost ..abet
=? need.sat
?& ?=(%delta -.blob)
!(~(has by lat.ran) q.q.blob)
!(~(has by have.sat) q.q.blob)
==
[q.q.blob need.sat]
:: We can't put a blob in lat.ran if its parent isn't already
:: there. Unions are in reverse order so we don't overwrite
:: existing blobs.
::
=. ..abet
?: &(?=(%delta -.blob) !(~(has by lat.ran) q.q.blob))
..abet(have.sat (~(uni by (malt [p.blob `^blob`blob] ~)) have.sat))
..abet(lat.ran (~(uni by (malt [p.blob blob] ~)) lat.ran))
work(busy.sat |)
::
:: Fetch next blob
::
++ work
^+ ..abet
?: busy.sat
..abet
|- ^+ ..abet
?: =(~ need.sat)
:: NB: if you change to release nakos as we get enough blobs
:: for them instead of all at the end, you *must* store the
:: `lim` that should be applied after the nako is complete and
:: not use the one in the rave, since that will apply to the
:: end of subscription.
::
=. lat.ran (~(uni by have.sat) lat.ran)
|- ^+ ..abet
?: =(~ nako.sat)
..abet
=^ next=(unit nako) nako.sat ~(get to nako.sat)
?~ next
..abet(done &)
=. ..abet (apply-foreign-update u.next)
=. ..foreign-update =<(?>(?=(^ ref) .) wake)
$
?> ?=(^ need.sat)
:: This is what removes an item from `need`. This happens every
:: time we take a backfill response, but it could happen more than
:: once if we somehow got this data in the meantime (maybe from
:: another desk updating concurrently, or a previous update on this
:: same desk).
::
?: ?| (~(has by lat.ran) i.need.sat)
(~(has by have.sat) i.need.sat)
==
$(need.sat t.need.sat)
:: Otherwise, fetch the next blob
::
=/ =fill [syd i.need.sat]
=/ =wire /back-index/(scot %p her)/[syd]/(scot %ud inx)
=/ =path [%backfill syd (scot %ud inx) ~]
=. ..foreign-update
=< ?>(?=(^ ref) .)
(emit hen %pass wire %a %plea her %c path fill)
..abet(busy.sat &)
::
:: When we get a %w foreign update, store this in our state.
::
@ -2728,7 +2846,7 @@
::
++ apply-foreign-update
|= =nako
^+ ..take-foreign-update
^+ ..abet
:: hit: updated commit-hashes by @ud case
:: nut: new commit-hash/commit pairs
:: hut: updated commits by hash
@ -2765,12 +2883,19 @@
$(aeon +(aeon))
:: produce updated state
::
=/ =rave rave:(~(got by bom.u.ref) inx)
?> ?=(%many -.rave)
=: let.dom (max let.nako let.dom)
hit.dom hit
hut.ran hut
lat.ran lat
:: Is this correct? Seeems like it should only go to `to` if
:: we've gotten all the way to the end. Leaving this
:: behavior unchanged for now, but I believe it's wrong.
::
lim ?.(?=(%da -.to.moat.rave) lim p.to.moat.rave)
==
..take-foreign-update
..abet
--
::
:: fire function if request is in future
@ -2862,8 +2987,9 @@
:: Try to fill a subscription
::
++ try-fill-sub
|= [for=(unit ship) rov=rove]
|= [far=(unit [=ship ver=@ud]) rov=rove]
^- [[new-sub=(unit rove) (list sub-result)] ford-cache]
=/ for=(unit ship) ?~(far ~ `ship.u.far)
?- -.rov
%sing
=/ cache-value=(unit (unit cage))
@ -3075,6 +3201,7 @@
::
[`rov ~]
=/ to-aeon (case-to-aeon to.moat.rov)
=/ ver ?~(far %1 ver.u.far)
?~ to-aeon
:: we're in the middle of the range, so produce what we can,
:: but don't end the subscription
@ -3092,7 +3219,7 @@
~
:: else changes, so produce them
::
[%bleb let.dom ?:(track.rov ~ `[u.from-aeon let.dom])]~
[%bleb ver let.dom ?:(track.rov ~ `[u.from-aeon let.dom])]~
:: we're past the end of the range, so end subscription
::
:- ~
@ -3103,7 +3230,7 @@
=/ bleb=(list sub-result)
?: =(lobes.rov new-lobes)
~
[%bleb +(u.from-aeon) ?:(track.rov ~ `[u.from-aeon u.to-aeon])]~
[%bleb ver +(u.from-aeon) ?:(track.rov ~ `[u.from-aeon u.to-aeon])]~
:: end subscription
::
=/ blub=(list sub-result)
@ -3111,17 +3238,6 @@
(weld bleb blub)
==
::
++ drop-me
^+ .
~| %clay-drop-me-not-implemented
!!
:: ?~ mer
:: .
:: %- emit(mer ~) ^- move :*
:: hen.u.mer %give %mere %| %user-interrupt
:: >sor.u.mer< >our< >cas.u.mer< >gem.u.mer< ~
:: ==
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: This core has no additional state, and the distinction exists purely for
@ -3209,7 +3325,7 @@
:: Creates a nako of all the changes between a and b.
::
++ make-nako
|= {a/aeon b/aeon}
|= [ver=@ud a=aeon b=aeon]
^- nako
:+ ?> (lte b let.dom)
|-
@ -3219,7 +3335,7 @@
b
?: =(0 b)
[~ ~]
(data-twixt-takos (~(get by hit.dom) a) (aeon-to-tako b))
(data-twixt-takos =(0 ver) (~(get by hit.dom) a) (aeon-to-tako b))
::
:: Traverse parentage and find all ancestor hashes
::
@ -3245,16 +3361,21 @@
:: ones we found before `a`. Then convert the takos to yakis and also get
:: all the data in all the yakis.
::
:: What happens if you run an %init merge on a desk that already
:: had a commit?
::
++ data-twixt-takos
|= {a/(unit tako) b/tako}
^- {(set yaki) (set plop)}
|= [plops=? a=(unit tako) b=tako]
^- [(set yaki) (set plop)]
=+ old=?~(a ~ (reachable-takos u.a))
=/ yal/(set tako)
=/ yal=(set tako)
%- silt
%+ skip
~(tap in (reachable-takos b))
|=(tak/tako (~(has in old) tak))
|=(tak=tako (~(has in old) tak))
:- (silt (turn ~(tap in yal) tako-to-yaki))
?. plops
~
(silt (turn ~(tap in (new-lobes (new-lobes ~ old) yal)) lobe-to-blob))
::
:: Get all the lobes that are referenced in `a` except those that are
@ -3728,7 +3849,7 @@
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
=| :: instrument state
$: ver=%3 :: vane version
$: ver=%4 :: vane version
ruf=raft :: revision tree
== ::
|= [our=ship now=@da eny=@uvJ ski=sley] :: current invocation
@ -3939,7 +4060,14 @@
=^ for req
?: ?=(%warp -.req)
[~ req]
:- ?:(=(our who.req) ~ `who.req)
:: ?: =(our who.req)
:: [~ [%warp wer.req rif.req]]
=^ ver rif.req
?@ -.rif.req
[%0 rif.req]
[-<.rif.req +.rif.req]
?> ?=(@ -.rif.req)
:- ?:(=(our who.req) ~ `[who.req ver])
[%warp wer.req rif.req]
::
?> ?=(%warp -.req)
@ -3957,8 +4085,14 @@
=* pax path.plea.req
=* res payload.plea.req
::
?> ?=({%question *} pax)
=+ ryf=;;(riff res)
?: ?=([%backfill *] pax)
=+ ;;(=fill res)
=^ mos ruf
=/ den ((de our now ski hen ruf) our desk.fill)
abet:(give-backfill:den +.fill)
[[[hen %give %done ~] mos] ..^$]
?> ?=([%question *] pax)
=+ ryf=;;(riff-any res)
:_ ..^$
:~ [hen %give %done ~]
=/ =wire
@ -3971,11 +4105,58 @@
!:
|^
|= old=any-state
~! [old=old new=*state-3]
~! [old=old new=*state-4]
=? old ?=(%2 -.old) (load-2-to-3 old)
?> ?=(%3 -.old)
=? old ?=(%3 -.old) (load-3-to-4 old)
?> ?=(%4 -.old)
..^^$(ruf +.old)
::
++ load-3-to-4
|= =state-3
^- state-4
|^
=- state-3(- %4, hoy hoy.-, rom (room-3-to-4 rom.state-3))
^- hoy=(map ship rung)
%- ~(run by hoy.state-3)
|= =rung-3
^- rung
%- ~(run by rus.rung-3)
|= =rede-3
^- rede
=- rede-3(ref ref.-, qyx (cult-3-to-4 qyx.rede-3))
^- ref=(unit rind)
?~ ref.rede-3
~
=- `u.ref.rede-3(bom bom.-)
^- bom=(map @ud update-state)
%- ~(run by bom.u.ref.rede-3)
|= [=duct =rave]
^- update-state
[duct rave ~ ~ ~ |]
::
++ room-3-to-4
|= =room-3
^- room
=- room-3(dos dos.-)
^- dos=(map desk dojo)
%- ~(run by dos.room-3)
|= =dojo-3
^- dojo
dojo-3(qyx (cult-3-to-4 qyx.dojo-3))
::
++ cult-3-to-4
|= =cult-3
^- cult
%- malt
%+ turn ~(tap by cult-3)
|= [=wove-3 ducts=(set duct)]
^- [wove (set duct)]
:_ ducts :_ rove.wove-3
?~ for.wove-3
~
`[u.for.wove-3 %0]
--
::
++ load-2-to-3
|= =state-2
^- state-3
@ -4005,11 +4186,11 @@
:- %ford-fusion
[leaf+"queued merge canceled due to upgrade to ford fusion" ~]
`[duct %slip %b %drip !>([%mere %| err])]
^- rom=room
^- rom=room-3
:- hun.rom.state-2
%- ~(urn by dos.rom.state-2)
|= [=desk =dojo-2]
^- dojo
^- dojo-3
=- dojo-2(dom -)
^- dome
=/ fer=(unit reef-cache)
@ -4019,23 +4200,22 @@
(~(got by hut.ran.state-2) (~(got by hit.dom.dojo-2) let.dom.dojo-2))
`(build-reef desk q.yaki)
[ank let hit lab mim fod=*ford-cache fer=fer]:[dom.dojo-2 .]
^- hoy=(map ship rung)
^- hoy=(map ship rung-3)
%- ~(run by hoy.state-2)
|= =rung-2
^- rung
^- rung-3
%- ~(run by rus.rung-2)
|= =rede-2
^- rede
^- rede-3
=- rede-2(ref ref.-, dom dom.-)
:- ^- dom=dome
[ank let hit lab mim fod=*ford-cache fer=~]:[dom.rede-2 .]
^- ref=(unit rind)
^- ref=(unit rind-3)
?~ ref.rede-2
~
:: TODO: somehow call +wake later to notify subscribers
:- ~
^- rind
=/ rin=rind [nix bom fod haw]:u.ref.rede-2
^- rind-3
=/ rin=rind-3 [nix bom fod haw]:u.ref.rede-2
=. rin
=/ pur=(list [inx=@ud =rand *]) ~(tap by pur.u.ref.rede-2)
|- ^+ rin
@ -4138,8 +4318,46 @@
--
--
::
+$ any-state $%(state-3 state-2)
+$ state-3 [%3 raft]
+$ any-state $%(state-4 state-3 state-2)
+$ state-4 [%4 raft]
+$ state-3
$: %3
rom=room-3
hoy=(map ship rung-3)
ran=rang
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
pun=(list move)
==
+$ rung-3 rus=(map desk rede-3)
+$ rede-3
$: lim/@da
ref/(unit rind-3)
qyx/cult-3
dom/dome
per/regs
pew/regs
==
+$ rind-3
$: nix/@ud
bom/(map @ud {p/duct q/rave})
fod/(map duct @ud)
haw/(map mood (unit cage))
==
+$ room-3
$: hun/duct
dos/(map desk dojo-3)
==
++ dojo-3
$: qyx/cult-3
dom/dome
per/regs
pew/regs
==
+$ cult-3 (jug wove-3 duct)
+$ wove-3 [for=(unit ship) =rove]
+$ state-2
$: %2
rom=room-2 :: domestic
@ -4156,7 +4374,7 @@
dos/(map desk dojo-2) :: native desk
== ::
+$ dojo-2
$: qyx/cult :: subscribers
$: qyx/cult-3 :: subscribers
dom/dome-2 :: desk state
per/regs :: read perms per path
pew/regs :: write perms per path
@ -4172,7 +4390,7 @@
+$ rede-2
$: lim/@da :: complete to
ref/(unit rind-2) :: outgoing requests
qyx/cult :: subscribers
qyx/cult-3 :: subscribers
dom/dome-2 :: revision state
per/regs :: read perms per path
pew/regs :: write perms per path
@ -4303,6 +4521,35 @@
[mos ..^$]
==
::
?: ?=([%back-index @ @ @ ~] tea)
?+ +<.q.hin ~| %clay-backfill-index-strange !!
%done
?~ error.q.hin
[~ ..^$]
:: TODO better error handling
::
~& %clay-take-backfill-index-error^our^tea^tag.u.error.q.hin
%- (slog tang.u.error.q.hin)
[~ ..^$]
::
%lost
~| %clay-take-backfill-lost^our
:: TODO better error handling
!!
::
%boon
=+ ;; =blob payload.q.hin
::
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=/ index=@ud (slav %ud i.t.t.t.tea)
::
=^ mos ruf
=/ den ((de our now ski hen ruf) her desk)
abet:abet:(take-backfill:(foreign-update:den index) blob)
[mos ..^$]
==
::
?: ?=([%sinks ~] tea)
?> ?=(%public-keys +<.q.hin)
?. ?=(%breach -.public-keys-result.q.hin)
@ -4396,7 +4643,9 @@
:+ desk %|
:~ ankh+&+ank.dom.dojo
mime+&+mim.dom.dojo
ford+&+fod.dom.dojo
ford-vases+&+vases.fod.dom.dojo
ford-marks+&+marks.fod.dom.dojo
ford-casts+&+casts.fod.dom.dojo
==
:~ domestic+|+domestic
foreign+&+hoy.ruf

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

@ -861,7 +861,7 @@
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
{$warp wer/ship rif/riff} :: internal file req
{$werp who/ship wer/ship rif/riff} :: external file req
{$werp who/ship wer/ship rif/riff-any} :: external file req
$>(%plea vane-task) :: ames request
== ::
-- ::able
@ -967,7 +967,10 @@
who/(pair (set ship) (map @ta crew)) ::
== ::
++ regs (map path rule) :: rules for paths
++ riff {p/desk q/(unit rave)} :: request+desist
+$ riff [p=desk q=(unit rave)] :: request+desist
+$ riff-any
$^ [[%1 ~] riff]
riff
++ rite :: new permissions
$% {$r red/(unit rule)} :: for read
{$w wit/(unit rule)} :: for write

6
pkg/arvo/ted/ph/breach-multiple.hoon
View File

@ -11,14 +11,14 @@
;< ~ bind:m (spawn az ~marbud)
;< ~ bind:m (real-ship az ~bud)
;< ~ bind:m (real-ship az ~marbud)
;< file=@t bind:m (touch-file ~bud %base %foo)
;< file=@t bind:m (touch-file ~bud %kids %foo)
;< ~ bind:m (check-file-touched ~marbud %home file)
;< ~ bind:m (breach-and-hear az ~bud ~marbud)
;< ~ bind:m (real-ship az ~bud)
;< ~ bind:m (breach-and-hear az ~marbud ~bud)
;< ~ bind:m (real-ship az ~marbud)
;< file=@t bind:m (touch-file ~bud %base %bar)
;< file=@t bind:m (touch-file ~bud %base %baz)
;< file=@t bind:m (touch-file ~bud %kids %bar)
;< file=@t bind:m (touch-file ~bud %kids %baz)
;< ~ bind:m (check-file-touched ~marbud %home file)
;< ~ bind:m end-azimuth
(pure:m *vase)

8
pkg/arvo/ted/ph/breach-sudden.hoon
View File

@ -13,13 +13,13 @@
;< ~ bind:m (spawn az ~marbud)
;< ~ bind:m (real-ship az ~bud)
;< ~ bind:m (real-ship az ~marbud)
;< file=@t bind:m (touch-file ~bud %base %foo)
;< file=@t bind:m (touch-file ~bud %kids %foo)
;< ~ bind:m (check-file-touched ~marbud %home file)
;< ~ bind:m (breach az ~bud)
;< ~ bind:m (real-ship az ~bud)
;< ~ bind:m (dojo ~bud "|merge %base ~marbud %kids, =gem %this")
;< file=@t bind:m (touch-file ~bud %base %bar)
;< file=@t bind:m (touch-file ~bud %base %baz)
;< ~ bind:m (dojo ~bud "|merge %home ~marbud %kids, =gem %this")
;< file=@t bind:m (touch-file ~bud %kids %bar)
;< file=@t bind:m (touch-file ~bud %kids %baz)
;< ~ bind:m (check-file-touched ~marbud %home file)
;< ~ bind:m end-azimuth
(pure:m *vase)

4
pkg/arvo/ted/ph/breach-sync.hoon
View File

@ -13,6 +13,10 @@
;< ~ bind:m (real-ship az ~marbud)
;< file=@t bind:m (touch-file ~bud %kids %foo)
;< ~ bind:m (check-file-touched ~marbud %home file)
:: Merge so that when we unify history with the %this merge later, we
:: don't get a spurious conflict in %home
::
;< ~ bind:m (dojo ~marbud "|merge %kids our %home")
;< ~ bind:m (breach-and-hear az ~bud ~marbud)
;< ~ bind:m (real-ship az ~bud)
;< ~ bind:m (dojo ~bud "|merge %kids ~marbud %kids, =gem %this")

3
pkg/arvo/ted/ph/child-sync.hoon
View File

@ -7,7 +7,8 @@
;< ~ bind:m start-simple
;< ~ bind:m (raw-ship ~bud ~)
;< ~ bind:m (raw-ship ~marbud ~)
;< file=@t bind:m (touch-file ~bud %base %foo)
;< file=@t bind:m (touch-file ~bud %home %foo)
;< ~ bind:m (dojo ~bud "|merge %kids our %home")
;< ~ bind:m (check-file-touched ~marbud %home file)
;< ~ bind:m end-simple
(pure:m *vase)

6
pkg/arvo/ted/ph/child-update.hoon
View File

@ -29,15 +29,15 @@
%^ cat 3 (get-val /mar/js/hoon)
' ~& > new-val=new-val .'
=/ js-contents
%^ cat 3 (get-val /app/publish/js/index/js)
%^ cat 3 (get-val /app/landscape/js/channel/js)
'extra'
=/ files
:~ [/sys/zuse/hoon zuse-contents]
[/mar/js/hoon mar-contents]
[/app/publish/js/index/js js-contents]
[/app/landscape/js/channel/js js-contents]
==
;< ~ bind:m (send-events (insert-files:util her desk files))
(pure:m /app/publish/js/index/js js-contents)
(pure:m /app/landscape/js/channel/js js-contents)
::
++ aqua-path
|= =path

26
pkg/hs/natpmp-static/LICENSE Normal file
View File

@ -0,0 +1,26 @@
Copyright (c) 2007-2011, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

5
pkg/hs/natpmp-static/README.txt Normal file
View File

@ -0,0 +1,5 @@
This is a vendored copy of libnatpmp-20150609, along with haskell bindings to
the library. Only the C code which was needed for these bindings was copied out
of the distribution.
Original code: http://miniupnp.free.fr/libnatpmp.html

2
pkg/hs/natpmp-static/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

77
pkg/hs/natpmp-static/cbits/binding.c Normal file
View File

@ -0,0 +1,77 @@
/* $Id: natpmpc.c,v 1.13 2012/08/21 17:23:38 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2011, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include "natpmp.h"
// Additional binding code in C to make this more convenient to call from
// Haskell. libnatpmp expects that code which uses it to select() on an
// internal socket, which we don't want to expose to the Haskell bindings user.
//
// This is mostly an adaptation of the code in the demo natpmpc.c to use the
// select() loop.
int readNatResponseSynchronously(natpmp_t* natpmp, natpmpresp_t * response)
{
fd_set fds;
struct timeval timeout;
int r;
int sav_errno;
do {
FD_ZERO(&fds);
FD_SET(natpmp->s, &fds);
getnatpmprequesttimeout(natpmp, &timeout);
r = select(FD_SETSIZE, &fds, NULL, NULL, &timeout);
sav_errno = errno;
if(r<0) {
/* fprintf(stderr, "select(): errno=%d '%s'\n", */
/* sav_errno, strerror(sav_errno)); */
return 1;
}
r = readnatpmpresponseorretry(natpmp, response);
sav_errno = errno;
/* printf("readnatpmpresponseorretry returned %d (%s)\n", */
/* r, r==0?"OK":(r==NATPMP_TRYAGAIN?"TRY AGAIN":"FAILED")); */
/* if(r<0 && r!=NATPMP_TRYAGAIN) { */
/* #ifdef ENABLE_STRNATPMPERR */
/* fprintf(stderr, "readnatpmpresponseorretry() failed : %s\n", */
/* strnatpmperr(r)); */
/* #endif */
/* fprintf(stderr, " errno=%d '%s'\n", */
/* sav_errno, strerror(sav_errno)); */
/* } */
} while(r==NATPMP_TRYAGAIN);
return r;
}

8
pkg/hs/natpmp-static/cbits/binding.h Normal file
View File

@ -0,0 +1,8 @@
#ifndef __NATPMP_BINDING_H__
#define __NATPMP_BINDING_H__
#include "natpmp.h"
int readNatResponseSynchronously(natpmp_t* natpmp, natpmpresp_t * response);
#endif

573
pkg/hs/natpmp-static/cbits/getgateway.c Normal file
View File

@ -0,0 +1,573 @@
/* $Id: getgateway.c,v 1.25 2014/04/22 10:28:57 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <ctype.h>
#ifndef WIN32
#include <netinet/in.h>
#endif
#if !defined(_MSC_VER)
#include <sys/param.h>
#endif
/* There is no portable method to get the default route gateway.
* So below are four (or five ?) differents functions implementing this.
* Parsing /proc/net/route is for linux.
* sysctl is the way to access such informations on BSD systems.
* Many systems should provide route information through raw PF_ROUTE
* sockets.
* In MS Windows, default gateway is found by looking into the registry
* or by using GetBestRoute(). */
#ifdef __linux__
#define USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#if defined(BSD) || defined(__FreeBSD_kernel__)
#undef USE_PROC_NET_ROUTE
#define USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#ifdef __APPLE__
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#define USE_SYSCTL_NET_ROUTE
#endif
#if (defined(sun) && defined(__SVR4))
#undef USE_PROC_NET_ROUTE
#define USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#ifdef WIN32
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
//#define USE_WIN32_CODE
#define USE_WIN32_CODE_2
#endif
#ifdef __CYGWIN__
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#define USE_WIN32_CODE
#include <stdarg.h>
#include <w32api/windef.h>
#include <w32api/winbase.h>
#include <w32api/winreg.h>
#endif
#ifdef __HAIKU__
#include <stdlib.h>
#include <unistd.h>
#include <net/if.h>
#include <sys/sockio.h>
#define USE_HAIKU_CODE
#endif
#ifdef USE_SYSCTL_NET_ROUTE
#include <stdlib.h>
#include <sys/sysctl.h>
#include <sys/socket.h>
#include <net/route.h>
#endif
#ifdef USE_SOCKET_ROUTE
#include <unistd.h>
#include <string.h>
#include <sys/socket.h>
#include <net/if.h>
#include <net/route.h>
#endif
#ifdef USE_WIN32_CODE
#include <unknwn.h>
#include <winreg.h>
#define MAX_KEY_LENGTH 255
#define MAX_VALUE_LENGTH 16383
#endif
#ifdef USE_WIN32_CODE_2
#include <windows.h>
#include <iphlpapi.h>
#endif
#include "getgateway.h"
#ifndef WIN32
#define SUCCESS (0)
#define FAILED (-1)
#endif
#ifdef USE_PROC_NET_ROUTE
/*
parse /proc/net/route which is as follow :
Iface Destination Gateway Flags RefCnt Use Metric Mask MTU Window IRTT
wlan0 0001A8C0 00000000 0001 0 0 0 00FFFFFF 0 0 0
eth0 0000FEA9 00000000 0001 0 0 0 0000FFFF 0 0 0
wlan0 00000000 0101A8C0 0003 0 0 0 00000000 0 0 0
eth0 00000000 00000000 0001 0 0 1000 00000000 0 0 0
One header line, and then one line by route by route table entry.
*/
int getdefaultgateway(in_addr_t * addr)
{
unsigned long d, g;
char buf[256];
int line = 0;
FILE * f;
char * p;
f = fopen("/proc/net/route", "r");
if(!f)
return FAILED;
while(fgets(buf, sizeof(buf), f)) {
if(line > 0) { /* skip the first line */
p = buf;
/* skip the interface name */
while(*p && !isspace(*p))
p++;
while(*p && isspace(*p))
p++;
if(sscanf(p, "%lx%lx", &d, &g)==2) {
if(d == 0 && g != 0) { /* default */
*addr = g;
fclose(f);
return SUCCESS;
}
}
}
line++;
}
/* default route not found ! */
if(f)
fclose(f);
return FAILED;
}
#endif /* #ifdef USE_PROC_NET_ROUTE */
#ifdef USE_SYSCTL_NET_ROUTE
#define ROUNDUP(a) \
((a) > 0 ? (1 + (((a) - 1) | (sizeof(long) - 1))) : sizeof(long))
int getdefaultgateway(in_addr_t * addr)
{
#if 0
/* net.route.0.inet.dump.0.0 ? */
int mib[] = {CTL_NET, PF_ROUTE, 0, AF_INET,
NET_RT_DUMP, 0, 0/*tableid*/};
#endif
/* net.route.0.inet.flags.gateway */
int mib[] = {CTL_NET, PF_ROUTE, 0, AF_INET,
NET_RT_FLAGS, RTF_GATEWAY};
size_t l;
char * buf, * p;
struct rt_msghdr * rt;
struct sockaddr * sa;
struct sockaddr * sa_tab[RTAX_MAX];
int i;
int r = FAILED;
if(sysctl(mib, sizeof(mib)/sizeof(int), 0, &l, 0, 0) < 0) {
return FAILED;
}
if(l>0) {
buf = malloc(l);
if(sysctl(mib, sizeof(mib)/sizeof(int), buf, &l, 0, 0) < 0) {
free(buf);
return FAILED;
}
for(p=buf; p<buf+l; p+=rt->rtm_msglen) {
rt = (struct rt_msghdr *)p;
sa = (struct sockaddr *)(rt + 1);
for(i=0; i<RTAX_MAX; i++) {
if(rt->rtm_addrs & (1 << i)) {
sa_tab[i] = sa;
sa = (struct sockaddr *)((char *)sa + ROUNDUP(sa->sa_len));
} else {
sa_tab[i] = NULL;
}
}
if( ((rt->rtm_addrs & (RTA_DST|RTA_GATEWAY)) == (RTA_DST|RTA_GATEWAY))
&& sa_tab[RTAX_DST]->sa_family == AF_INET
&& sa_tab[RTAX_GATEWAY]->sa_family == AF_INET) {
if(((struct sockaddr_in *)sa_tab[RTAX_DST])->sin_addr.s_addr == 0) {
*addr = ((struct sockaddr_in *)(sa_tab[RTAX_GATEWAY]))->sin_addr.s_addr;
r = SUCCESS;
}
}
}
free(buf);
}
return r;
}
#endif /* #ifdef USE_SYSCTL_NET_ROUTE */
#ifdef USE_SOCKET_ROUTE
/* Thanks to Darren Kenny for this code */
#define NEXTADDR(w, u) \
if (rtm_addrs & (w)) {\
l = sizeof(struct sockaddr); memmove(cp, &(u), l); cp += l;\
}
#define rtm m_rtmsg.m_rtm
struct {
struct rt_msghdr m_rtm;
char m_space[512];
} m_rtmsg;
int getdefaultgateway(in_addr_t *addr)
{
int s, seq, l, rtm_addrs, i;
pid_t pid;
struct sockaddr so_dst, so_mask;
char *cp = m_rtmsg.m_space;
struct sockaddr *gate = NULL, *sa;
struct rt_msghdr *msg_hdr;
pid = getpid();
seq = 0;
rtm_addrs = RTA_DST | RTA_NETMASK;
memset(&so_dst, 0, sizeof(so_dst));
memset(&so_mask, 0, sizeof(so_mask));
memset(&rtm, 0, sizeof(struct rt_msghdr));
rtm.rtm_type = RTM_GET;
rtm.rtm_flags = RTF_UP | RTF_GATEWAY;
rtm.rtm_version = RTM_VERSION;
rtm.rtm_seq = ++seq;
rtm.rtm_addrs = rtm_addrs;
so_dst.sa_family = AF_INET;
so_mask.sa_family = AF_INET;
NEXTADDR(RTA_DST, so_dst);
NEXTADDR(RTA_NETMASK, so_mask);
rtm.rtm_msglen = l = cp - (char *)&m_rtmsg;
s = socket(PF_ROUTE, SOCK_RAW, 0);
if (write(s, (char *)&m_rtmsg, l) < 0) {
close(s);
return FAILED;
}
do {
l = read(s, (char *)&m_rtmsg, sizeof(m_rtmsg));
} while (l > 0 && (rtm.rtm_seq != seq || rtm.rtm_pid != pid));
close(s);
msg_hdr = &rtm;
cp = ((char *)(msg_hdr + 1));
if (msg_hdr->rtm_addrs) {
for (i = 1; i; i <<= 1)
if (i & msg_hdr->rtm_addrs) {
sa = (struct sockaddr *)cp;
if (i == RTA_GATEWAY )
gate = sa;
cp += sizeof(struct sockaddr);
}
} else {
return FAILED;
}
if (gate != NULL ) {
*addr = ((struct sockaddr_in *)gate)->sin_addr.s_addr;
return SUCCESS;
} else {
return FAILED;
}
}
#endif /* #ifdef USE_SOCKET_ROUTE */
#ifdef USE_WIN32_CODE
LIBSPEC int getdefaultgateway(in_addr_t * addr)
{
HKEY networkCardsKey;
HKEY networkCardKey;
HKEY interfacesKey;
HKEY interfaceKey;
DWORD i = 0;
DWORD numSubKeys = 0;
TCHAR keyName[MAX_KEY_LENGTH];
DWORD keyNameLength = MAX_KEY_LENGTH;
TCHAR keyValue[MAX_VALUE_LENGTH];
DWORD keyValueLength = MAX_VALUE_LENGTH;
DWORD keyValueType = REG_SZ;
TCHAR gatewayValue[MAX_VALUE_LENGTH];
DWORD gatewayValueLength = MAX_VALUE_LENGTH;
DWORD gatewayValueType = REG_MULTI_SZ;
int done = 0;
//const char * networkCardsPath = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
//const char * interfacesPath = "SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#ifdef UNICODE
LPCTSTR networkCardsPath = L"SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
LPCTSTR interfacesPath = L"SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#define STR_SERVICENAME L"ServiceName"
#define STR_DHCPDEFAULTGATEWAY L"DhcpDefaultGateway"
#define STR_DEFAULTGATEWAY L"DefaultGateway"
#else
LPCTSTR networkCardsPath = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
LPCTSTR interfacesPath = "SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#define STR_SERVICENAME "ServiceName"
#define STR_DHCPDEFAULTGATEWAY "DhcpDefaultGateway"
#define STR_DEFAULTGATEWAY "DefaultGateway"
#endif
// The windows registry lists its primary network devices in the following location:
// HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards
//
// Each network device has its own subfolder, named with an index, with various properties:
// -NetworkCards
// -5
// -Description = Broadcom 802.11n Network Adapter
// -ServiceName = {E35A72F8-5065-4097-8DFE-C7790774EE4D}
// -8
// -Description = Marvell Yukon 88E8058 PCI-E Gigabit Ethernet Controller
// -ServiceName = {86226414-5545-4335-A9D1-5BD7120119AD}
//
// The above service name is the name of a subfolder within:
// HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces
//
// There may be more subfolders in this interfaces path than listed in the network cards path above:
// -Interfaces
// -{3a539854-6a70-11db-887c-806e6f6e6963}
// -DhcpIPAddress = 0.0.0.0
// -[more]
// -{E35A72F8-5065-4097-8DFE-C7790774EE4D}
// -DhcpIPAddress = 10.0.1.4
// -DhcpDefaultGateway = 10.0.1.1
// -[more]
// -{86226414-5545-4335-A9D1-5BD7120119AD}
// -DhcpIpAddress = 10.0.1.5
// -DhcpDefaultGateay = 10.0.1.1
// -[more]
//
// In order to extract this information, we enumerate each network card, and extract the ServiceName value.
// This is then used to open the interface subfolder, and attempt to extract a DhcpDefaultGateway value.
// Once one is found, we're done.
//
// It may be possible to simply enumerate the interface folders until we find one with a DhcpDefaultGateway value.
// However, the technique used is the technique most cited on the web, and we assume it to be more correct.
if(ERROR_SUCCESS != RegOpenKeyEx(HKEY_LOCAL_MACHINE, // Open registry key or predifined key
networkCardsPath, // Name of registry subkey to open
0, // Reserved - must be zero
KEY_READ, // Mask - desired access rights
&networkCardsKey)) // Pointer to output key
{
// Unable to open network cards keys
return -1;
}
if(ERROR_SUCCESS != RegOpenKeyEx(HKEY_LOCAL_MACHINE, // Open registry key or predefined key
interfacesPath, // Name of registry subkey to open
0, // Reserved - must be zero
KEY_READ, // Mask - desired access rights
&interfacesKey)) // Pointer to output key
{
// Unable to open interfaces key
RegCloseKey(networkCardsKey);
return -1;
}
// Figure out how many subfolders are within the NetworkCards folder
RegQueryInfoKey(networkCardsKey, NULL, NULL, NULL, &numSubKeys, NULL, NULL, NULL, NULL, NULL, NULL, NULL);
//printf( "Number of subkeys: %u\n", (unsigned int)numSubKeys);
// Enumrate through each subfolder within the NetworkCards folder
for(i = 0; i < numSubKeys && !done; i++)
{
keyNameLength = MAX_KEY_LENGTH;
if(ERROR_SUCCESS == RegEnumKeyEx(networkCardsKey, // Open registry key
i, // Index of subkey to retrieve
keyName, // Buffer that receives the name of the subkey
&keyNameLength, // Variable that receives the size of the above buffer
NULL, // Reserved - must be NULL
NULL, // Buffer that receives the class string
NULL, // Variable that receives the size of the above buffer
NULL)) // Variable that receives the last write time of subkey
{
if(RegOpenKeyEx(networkCardsKey, keyName, 0, KEY_READ, &networkCardKey) == ERROR_SUCCESS)
{
keyValueLength = MAX_VALUE_LENGTH;
if(ERROR_SUCCESS == RegQueryValueEx(networkCardKey, // Open registry key
STR_SERVICENAME, // Name of key to query
NULL, // Reserved - must be NULL
&keyValueType, // Receives value type
(LPBYTE)keyValue, // Receives value
&keyValueLength)) // Receives value length in bytes
{
// printf("keyValue: %s\n", keyValue);
if(RegOpenKeyEx(interfacesKey, keyValue, 0, KEY_READ, &interfaceKey) == ERROR_SUCCESS)
{
gatewayValueLength = MAX_VALUE_LENGTH;
if(ERROR_SUCCESS == RegQueryValueEx(interfaceKey, // Open registry key
STR_DHCPDEFAULTGATEWAY, // Name of key to query
NULL, // Reserved - must be NULL
&gatewayValueType, // Receives value type
(LPBYTE)gatewayValue, // Receives value
&gatewayValueLength)) // Receives value length in bytes
{
// Check to make sure it's a string
if((gatewayValueType == REG_MULTI_SZ || gatewayValueType == REG_SZ) && (gatewayValueLength > 1))
{
//printf("gatewayValue: %s\n", gatewayValue);
done = 1;
}
}
else if(ERROR_SUCCESS == RegQueryValueEx(interfaceKey, // Open registry key
STR_DEFAULTGATEWAY, // Name of key to query
NULL, // Reserved - must be NULL
&gatewayValueType, // Receives value type
(LPBYTE)gatewayValue,// Receives value
&gatewayValueLength)) // Receives value length in bytes
{
// Check to make sure it's a string
if((gatewayValueType == REG_MULTI_SZ || gatewayValueType == REG_SZ) && (gatewayValueLength > 1))
{
//printf("gatewayValue: %s\n", gatewayValue);
done = 1;
}
}
RegCloseKey(interfaceKey);
}
}
RegCloseKey(networkCardKey);
}
}
}
RegCloseKey(interfacesKey);
RegCloseKey(networkCardsKey);
if(done)
{
#if UNICODE
char tmp[32];
for(i = 0; i < 32; i++) {
tmp[i] = (char)gatewayValue[i];
if(!tmp[i])
break;
}
tmp[31] = '\0';
*addr = inet_addr(tmp);
#else
*addr = inet_addr(gatewayValue);
#endif
return 0;
}
return -1;
}
#endif /* #ifdef USE_WIN32_CODE */
#ifdef USE_WIN32_CODE_2
int getdefaultgateway(in_addr_t *addr)
{
MIB_IPFORWARDROW ip_forward;
memset(&ip_forward, 0, sizeof(ip_forward));
if(GetBestRoute(inet_addr("0.0.0.0"), 0, &ip_forward) != NO_ERROR)
return -1;
*addr = ip_forward.dwForwardNextHop;
return 0;
}
#endif /* #ifdef USE_WIN32_CODE_2 */
#ifdef USE_HAIKU_CODE
int getdefaultgateway(in_addr_t *addr)
{
int fd, ret = -1;
struct ifconf config;
void *buffer = NULL;
struct ifreq *interface;
if ((fd = socket(AF_INET, SOCK_DGRAM, 0)) < 0) {
return -1;
}
if (ioctl(fd, SIOCGRTSIZE, &config, sizeof(config)) != 0) {
goto fail;
}
if (config.ifc_value < 1) {
goto fail; /* No routes */
}
if ((buffer = malloc(config.ifc_value)) == NULL) {
goto fail;
}
config.ifc_len = config.ifc_value;
config.ifc_buf = buffer;
if (ioctl(fd, SIOCGRTTABLE, &config, sizeof(config)) != 0) {
goto fail;
}
for (interface = buffer;
(uint8_t *)interface < (uint8_t *)buffer + config.ifc_len; ) {
struct route_entry route = interface->ifr_route;
int intfSize;
if (route.flags & (RTF_GATEWAY | RTF_DEFAULT)) {
*addr = ((struct sockaddr_in *)route.gateway)->sin_addr.s_addr;
ret = 0;
break;
}
intfSize = sizeof(route) + IF_NAMESIZE;
if (route.destination != NULL) {
intfSize += route.destination->sa_len;
}
if (route.mask != NULL) {
intfSize += route.mask->sa_len;
}
if (route.gateway != NULL) {
intfSize += route.gateway->sa_len;
}
interface = (struct ifreq *)((uint8_t *)interface + intfSize);
}
fail:
free(buffer);
close(fd);
return ret;
}
#endif /* #ifdef USE_HAIKU_CODE */
#if !defined(USE_PROC_NET_ROUTE) && !defined(USE_SOCKET_ROUTE) && !defined(USE_SYSCTL_NET_ROUTE) && !defined(USE_WIN32_CODE) && !defined(USE_WIN32_CODE_2) && !defined(USE_HAIKU_CODE)
int getdefaultgateway(in_addr_t * addr)
{
return -1;
}
#endif

49
pkg/hs/natpmp-static/cbits/getgateway.h Normal file
View File

@ -0,0 +1,49 @@
/* $Id: getgateway.h,v 1.8 2014/04/22 09:15:40 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifndef __GETGATEWAY_H__
#define __GETGATEWAY_H__
#ifdef WIN32
#if !defined(_MSC_VER) || _MSC_VER >= 1600
#include <stdint.h>
#else
typedef unsigned long uint32_t;
typedef unsigned short uint16_t;
#endif
#define in_addr_t uint32_t
#endif
/* #include "declspec.h" */
/* getdefaultgateway() :
* return value :
* 0 : success
* -1 : failure */
/* LIBSPEC */int getdefaultgateway(in_addr_t * addr);
#endif

387
pkg/hs/natpmp-static/cbits/natpmp.c Normal file
View File

@ -0,0 +1,387 @@
/* $Id: natpmp.c,v 1.20 2015/05/27 12:43:15 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2015, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifdef __linux__
#define _BSD_SOURCE 1
#endif
#include <string.h>
#include <time.h>
#if !defined(_MSC_VER)
#include <sys/time.h>
#endif
#ifdef WIN32
#include <errno.h>
#include <winsock2.h>
#include <ws2tcpip.h>
#include <io.h>
#define EWOULDBLOCK WSAEWOULDBLOCK
#define ECONNREFUSED WSAECONNREFUSED
#include "wingettimeofday.h"
#define gettimeofday natpmp_gettimeofday
#else
#include <errno.h>
#include <unistd.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/socket.h>
#define closesocket close
#endif
#include "natpmp.h"
#include "getgateway.h"
#include <stdio.h>
LIBSPEC int initnatpmp(natpmp_t * p, int forcegw, in_addr_t forcedgw)
{
#ifdef WIN32
u_long ioctlArg = 1;
#else
int flags;
#endif
struct sockaddr_in addr;
if(!p)
return NATPMP_ERR_INVALIDARGS;
memset(p, 0, sizeof(natpmp_t));
p->s = socket(PF_INET, SOCK_DGRAM, 0);
if(p->s < 0)
return NATPMP_ERR_SOCKETERROR;
#ifdef WIN32
if(ioctlsocket(p->s, FIONBIO, &ioctlArg) == SOCKET_ERROR)
return NATPMP_ERR_FCNTLERROR;
#else
if((flags = fcntl(p->s, F_GETFL, 0)) < 0)
return NATPMP_ERR_FCNTLERROR;
if(fcntl(p->s, F_SETFL, flags | O_NONBLOCK) < 0)
return NATPMP_ERR_FCNTLERROR;
#endif
if(forcegw) {
p->gateway = forcedgw;
} else {
if(getdefaultgateway(&(p->gateway)) < 0)
return NATPMP_ERR_CANNOTGETGATEWAY;
}
memset(&addr, 0, sizeof(addr));
addr.sin_family = AF_INET;
addr.sin_port = htons(NATPMP_PORT);
addr.sin_addr.s_addr = p->gateway;
if(connect(p->s, (struct sockaddr *)&addr, sizeof(addr)) < 0)
return NATPMP_ERR_CONNECTERR;
return 0;
}
LIBSPEC int closenatpmp(natpmp_t * p)
{
if(!p)
return NATPMP_ERR_INVALIDARGS;
if(closesocket(p->s) < 0)
return NATPMP_ERR_CLOSEERR;
return 0;
}
int sendpendingrequest(natpmp_t * p)
{
int r;
/* struct sockaddr_in addr;*/
if(!p)
return NATPMP_ERR_INVALIDARGS;
/* memset(&addr, 0, sizeof(addr));
addr.sin_family = AF_INET;
addr.sin_port = htons(NATPMP_PORT);
addr.sin_addr.s_addr = p->gateway;
r = (int)sendto(p->s, p->pending_request, p->pending_request_len, 0,
(struct sockaddr *)&addr, sizeof(addr));*/
r = (int)send(p->s, (const char *)p->pending_request, p->pending_request_len, 0);
return (r<0) ? NATPMP_ERR_SENDERR : r;
}
int sendnatpmprequest(natpmp_t * p)
{
int n;
if(!p)
return NATPMP_ERR_INVALIDARGS;
/* TODO : check if no request is already pending */
p->has_pending_request = 1;
p->try_number = 1;
n = sendpendingrequest(p);
gettimeofday(&p->retry_time, NULL); // check errors !
p->retry_time.tv_usec += 250000; /* add 250ms */
if(p->retry_time.tv_usec >= 1000000) {
p->retry_time.tv_usec -= 1000000;
p->retry_time.tv_sec++;
}
return n;
}
LIBSPEC int getnatpmprequesttimeout(natpmp_t * p, struct timeval * timeout)
{
struct timeval now;
if(!p || !timeout)
return NATPMP_ERR_INVALIDARGS;
if(!p->has_pending_request)
return NATPMP_ERR_NOPENDINGREQ;
if(gettimeofday(&now, NULL) < 0)
return NATPMP_ERR_GETTIMEOFDAYERR;
timeout->tv_sec = p->retry_time.tv_sec - now.tv_sec;
timeout->tv_usec = p->retry_time.tv_usec - now.tv_usec;
if(timeout->tv_usec < 0) {
timeout->tv_usec += 1000000;
timeout->tv_sec--;
}
return 0;
}
LIBSPEC int sendpublicaddressrequest(natpmp_t * p)
{
if(!p)
return NATPMP_ERR_INVALIDARGS;
//static const unsigned char request[] = { 0, 0 };
p->pending_request[0] = 0;
p->pending_request[1] = 0;
p->pending_request_len = 2;
// TODO: return 0 instead of sizeof(request) ??
return sendnatpmprequest(p);
}
LIBSPEC int sendnewportmappingrequest(natpmp_t * p, int protocol,
uint16_t privateport, uint16_t publicport,
uint32_t lifetime)
{
if(!p || (protocol!=NATPMP_PROTOCOL_TCP && protocol!=NATPMP_PROTOCOL_UDP))
return NATPMP_ERR_INVALIDARGS;
p->pending_request[0] = 0;
p->pending_request[1] = protocol;
p->pending_request[2] = 0;
p->pending_request[3] = 0;
/* break strict-aliasing rules :
*((uint16_t *)(p->pending_request + 4)) = htons(privateport); */
p->pending_request[4] = (privateport >> 8) & 0xff;
p->pending_request[5] = privateport & 0xff;
/* break stric-aliasing rules :
*((uint16_t *)(p->pending_request + 6)) = htons(publicport); */
p->pending_request[6] = (publicport >> 8) & 0xff;
p->pending_request[7] = publicport & 0xff;
/* break stric-aliasing rules :
*((uint32_t *)(p->pending_request + 8)) = htonl(lifetime); */
p->pending_request[8] = (lifetime >> 24) & 0xff;
p->pending_request[9] = (lifetime >> 16) & 0xff;
p->pending_request[10] = (lifetime >> 8) & 0xff;
p->pending_request[11] = lifetime & 0xff;
p->pending_request_len = 12;
return sendnatpmprequest(p);
}
LIBSPEC int readnatpmpresponse(natpmp_t * p, natpmpresp_t * response)
{
unsigned char buf[16];
struct sockaddr_in addr;
socklen_t addrlen = sizeof(addr);
int n;
if(!p)
return NATPMP_ERR_INVALIDARGS;
n = recvfrom(p->s, (char *)buf, sizeof(buf), 0,
(struct sockaddr *)&addr, &addrlen);
if(n<0)
#ifdef WIN32
switch(WSAGetLastError()) {
#else
switch(errno) {
#endif
/*case EAGAIN:*/
case EWOULDBLOCK:
n = NATPMP_TRYAGAIN;
break;
case ECONNREFUSED:
n = NATPMP_ERR_NOGATEWAYSUPPORT;
break;
default:
n = NATPMP_ERR_RECVFROM;
}
/* check that addr is correct (= gateway) */
else if(addr.sin_addr.s_addr != p->gateway)
n = NATPMP_ERR_WRONGPACKETSOURCE;
else {
response->resultcode = ntohs(*((uint16_t *)(buf + 2)));
response->epoch = ntohl(*((uint32_t *)(buf + 4)));
if(buf[0] != 0)
n = NATPMP_ERR_UNSUPPORTEDVERSION;
else if(buf[1] < 128 || buf[1] > 130)
n = NATPMP_ERR_UNSUPPORTEDOPCODE;
else if(response->resultcode != 0) {
switch(response->resultcode) {
case 1:
n = NATPMP_ERR_UNSUPPORTEDVERSION;
break;
case 2:
n = NATPMP_ERR_NOTAUTHORIZED;
break;
case 3:
n = NATPMP_ERR_NETWORKFAILURE;
break;
case 4:
n = NATPMP_ERR_OUTOFRESOURCES;
break;
case 5:
n = NATPMP_ERR_UNSUPPORTEDOPCODE;
break;
default:
n = NATPMP_ERR_UNDEFINEDERROR;
}
} else {
response->type = buf[1] & 0x7f;
if(buf[1] == 128)
//response->publicaddress.addr = *((uint32_t *)(buf + 8));
response->pnu.publicaddress.addr.s_addr = *((uint32_t *)(buf + 8));
else {
response->pnu.newportmapping.privateport = ntohs(*((uint16_t *)(buf + 8)));
response->pnu.newportmapping.mappedpublicport = ntohs(*((uint16_t *)(buf + 10)));
response->pnu.newportmapping.lifetime = ntohl(*((uint32_t *)(buf + 12)));
}
n = 0;
}
}
return n;
}
int readnatpmpresponseorretry(natpmp_t * p, natpmpresp_t * response)
{
int n;
if(!p || !response)
return NATPMP_ERR_INVALIDARGS;
if(!p->has_pending_request)
return NATPMP_ERR_NOPENDINGREQ;
n = readnatpmpresponse(p, response);
if(n<0) {
if(n==NATPMP_TRYAGAIN) {
struct timeval now;
gettimeofday(&now, NULL); // check errors !
if(timercmp(&now, &p->retry_time, >=)) {
int delay, r;
// NOTE: This used to be 9, and was changed for the haskell
// bindings to be 5.
if(p->try_number >= 5) {
return NATPMP_ERR_NOGATEWAYSUPPORT;
}
/*printf("retry! %d\n", p->try_number);*/
// NOTE: Changed how delays are calculated. Waiting up to four
// minutes for a packet that might never get a response is not
// a good user experience. Instead, retry up to 2 seconds.
//
// delay = 250 * (1<<p->try_number); // ms
delay = 250 * p->try_number; // ms
/*for(i=0; i<p->try_number; i++)
delay += delay;*/
p->retry_time.tv_sec += (delay / 1000);
p->retry_time.tv_usec += (delay % 1000) * 1000;
if(p->retry_time.tv_usec >= 1000000) {
p->retry_time.tv_usec -= 1000000;
p->retry_time.tv_sec++;
}
p->try_number++;
r = sendpendingrequest(p);
if(r<0)
return r;
}
}
} else {
p->has_pending_request = 0;
}
return n;
}
#ifdef ENABLE_STRNATPMPERR
LIBSPEC const char * strnatpmperr(int r)
{
const char * s;
switch(r) {
case NATPMP_ERR_INVALIDARGS:
s = "invalid arguments";
break;
case NATPMP_ERR_SOCKETERROR:
s = "socket() failed";
break;
case NATPMP_ERR_CANNOTGETGATEWAY:
s = "cannot get default gateway ip address";
break;
case NATPMP_ERR_CLOSEERR:
#ifdef WIN32
s = "closesocket() failed";
#else
s = "close() failed";
#endif
break;
case NATPMP_ERR_RECVFROM:
s = "recvfrom() failed";
break;
case NATPMP_ERR_NOPENDINGREQ:
s = "no pending request";
break;
case NATPMP_ERR_NOGATEWAYSUPPORT:
s = "the gateway does not support nat-pmp";
break;
case NATPMP_ERR_CONNECTERR:
s = "connect() failed";
break;
case NATPMP_ERR_WRONGPACKETSOURCE:
s = "packet not received from the default gateway";
break;
case NATPMP_ERR_SENDERR:
s = "send() failed";
break;
case NATPMP_ERR_FCNTLERROR:
s = "fcntl() failed";
break;
case NATPMP_ERR_GETTIMEOFDAYERR:
s = "gettimeofday() failed";
break;
case NATPMP_ERR_UNSUPPORTEDVERSION:
s = "unsupported nat-pmp version error from server";
break;
case NATPMP_ERR_UNSUPPORTEDOPCODE:
s = "unsupported nat-pmp opcode error from server";
break;
case NATPMP_ERR_UNDEFINEDERROR:
s = "undefined nat-pmp server error";
break;
case NATPMP_ERR_NOTAUTHORIZED:
s = "not authorized";
break;
case NATPMP_ERR_NETWORKFAILURE:
s = "network failure";
break;
case NATPMP_ERR_OUTOFRESOURCES:
s = "nat-pmp server out of resources";
break;
default:
s = "Unknown libnatpmp error";
}
return s;
}
#endif

221
pkg/hs/natpmp-static/cbits/natpmp.h Normal file
View File

@ -0,0 +1,221 @@
/* $Id: natpmp.h,v 1.20 2014/04/22 09:15:40 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifndef __NATPMP_H__
#define __NATPMP_H__
/* NAT-PMP Port as defined by the NAT-PMP draft */
#define NATPMP_PORT (5351)
#define ENABLE_STRNATPMPERR
#include <time.h>
#if !defined(_MSC_VER)
#include <sys/time.h>
#endif /* !defined(_MSC_VER) */
#ifdef WIN32
#include <winsock2.h>
#if !defined(_MSC_VER) || _MSC_VER >= 1600
#include <stdint.h>
#else /* !defined(_MSC_VER) || _MSC_VER >= 1600 */
typedef unsigned long uint32_t;
typedef unsigned short uint16_t;
#endif /* !defined(_MSC_VER) || _MSC_VER >= 1600 */
#define in_addr_t uint32_t
#include "declspec.h"
#else /* WIN32 */
#define LIBSPEC
#include <netinet/in.h>
#endif /* WIN32 */
/* causes problem when installing. Maybe should it be inlined ? */
/* #include "declspec.h" */
typedef struct {
int s; /* socket */
in_addr_t gateway; /* default gateway (IPv4) */
int has_pending_request;
unsigned char pending_request[12];
int pending_request_len;
int try_number;
struct timeval retry_time;
} natpmp_t;
typedef struct {
uint16_t type; /* NATPMP_RESPTYPE_* */
uint16_t resultcode; /* NAT-PMP response code */
uint32_t epoch; /* Seconds since start of epoch */
union {
struct {
//in_addr_t addr;
struct in_addr addr;
} publicaddress;
struct {
uint16_t privateport;
uint16_t mappedpublicport;
uint32_t lifetime;
} newportmapping;
} pnu;
} natpmpresp_t;
/* possible values for type field of natpmpresp_t */
#define NATPMP_RESPTYPE_PUBLICADDRESS (0)
#define NATPMP_RESPTYPE_UDPPORTMAPPING (1)
#define NATPMP_RESPTYPE_TCPPORTMAPPING (2)
/* Values to pass to sendnewportmappingrequest() */
#define NATPMP_PROTOCOL_UDP (1)
#define NATPMP_PROTOCOL_TCP (2)
/* return values */
/* NATPMP_ERR_INVALIDARGS : invalid arguments passed to the function */
#define NATPMP_ERR_INVALIDARGS (-1)
/* NATPMP_ERR_SOCKETERROR : socket() failed. check errno for details */
#define NATPMP_ERR_SOCKETERROR (-2)
/* NATPMP_ERR_CANNOTGETGATEWAY : can't get default gateway IP */
#define NATPMP_ERR_CANNOTGETGATEWAY (-3)
/* NATPMP_ERR_CLOSEERR : close() failed. check errno for details */
#define NATPMP_ERR_CLOSEERR (-4)
/* NATPMP_ERR_RECVFROM : recvfrom() failed. check errno for details */
#define NATPMP_ERR_RECVFROM (-5)
/* NATPMP_ERR_NOPENDINGREQ : readnatpmpresponseorretry() called while
* no NAT-PMP request was pending */
#define NATPMP_ERR_NOPENDINGREQ (-6)
/* NATPMP_ERR_NOGATEWAYSUPPORT : the gateway does not support NAT-PMP */
#define NATPMP_ERR_NOGATEWAYSUPPORT (-7)
/* NATPMP_ERR_CONNECTERR : connect() failed. check errno for details */
#define NATPMP_ERR_CONNECTERR (-8)
/* NATPMP_ERR_WRONGPACKETSOURCE : packet not received from the network gateway */
#define NATPMP_ERR_WRONGPACKETSOURCE (-9)
/* NATPMP_ERR_SENDERR : send() failed. check errno for details */
#define NATPMP_ERR_SENDERR (-10)
/* NATPMP_ERR_FCNTLERROR : fcntl() failed. check errno for details */
#define NATPMP_ERR_FCNTLERROR (-11)
/* NATPMP_ERR_GETTIMEOFDAYERR : gettimeofday() failed. check errno for details */
#define NATPMP_ERR_GETTIMEOFDAYERR (-12)
/* */
#define NATPMP_ERR_UNSUPPORTEDVERSION (-14)
#define NATPMP_ERR_UNSUPPORTEDOPCODE (-15)
/* Errors from the server : */
#define NATPMP_ERR_UNDEFINEDERROR (-49)
#define NATPMP_ERR_NOTAUTHORIZED (-51)
#define NATPMP_ERR_NETWORKFAILURE (-52)
#define NATPMP_ERR_OUTOFRESOURCES (-53)
/* NATPMP_TRYAGAIN : no data available for the moment. try again later */
#define NATPMP_TRYAGAIN (-100)
#ifdef __cplusplus
extern "C" {
#endif
/* initnatpmp()
* initialize a natpmp_t object
* With forcegw=1 the gateway is not detected automaticaly.
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SOCKETERROR
* NATPMP_ERR_FCNTLERROR
* NATPMP_ERR_CANNOTGETGATEWAY
* NATPMP_ERR_CONNECTERR */
LIBSPEC int initnatpmp(natpmp_t * p, int forcegw, in_addr_t forcedgw);
/* closenatpmp()
* close resources associated with a natpmp_t object
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_CLOSEERR */
LIBSPEC int closenatpmp(natpmp_t * p);
/* sendpublicaddressrequest()
* send a public address NAT-PMP request to the network gateway
* Return values :
* 2 = OK (size of the request)
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SENDERR */
LIBSPEC int sendpublicaddressrequest(natpmp_t * p);
/* sendnewportmappingrequest()
* send a new port mapping NAT-PMP request to the network gateway
* Arguments :
* protocol is either NATPMP_PROTOCOL_TCP or NATPMP_PROTOCOL_UDP,
* lifetime is in seconds.
* To remove a port mapping, set lifetime to zero.
* To remove all port mappings to the host, set lifetime and both ports
* to zero.
* Return values :
* 12 = OK (size of the request)
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SENDERR */
LIBSPEC int sendnewportmappingrequest(natpmp_t * p, int protocol,
uint16_t privateport, uint16_t publicport,
uint32_t lifetime);
/* getnatpmprequesttimeout()
* fills the timeval structure with the timeout duration of the
* currently pending NAT-PMP request.
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_GETTIMEOFDAYERR
* NATPMP_ERR_NOPENDINGREQ */
LIBSPEC int getnatpmprequesttimeout(natpmp_t * p, struct timeval * timeout);
/* readnatpmpresponseorretry()
* fills the natpmpresp_t structure if possible
* Return values :
* 0 = OK
* NATPMP_TRYAGAIN
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_NOPENDINGREQ
* NATPMP_ERR_NOGATEWAYSUPPORT
* NATPMP_ERR_RECVFROM
* NATPMP_ERR_WRONGPACKETSOURCE
* NATPMP_ERR_UNSUPPORTEDVERSION
* NATPMP_ERR_UNSUPPORTEDOPCODE
* NATPMP_ERR_NOTAUTHORIZED
* NATPMP_ERR_NETWORKFAILURE
* NATPMP_ERR_OUTOFRESOURCES
* NATPMP_ERR_UNSUPPORTEDOPCODE
* NATPMP_ERR_UNDEFINEDERROR */
LIBSPEC int readnatpmpresponseorretry(natpmp_t * p, natpmpresp_t * response);
#ifdef ENABLE_STRNATPMPERR
LIBSPEC const char * strnatpmperr(int t);
#endif
#ifdef __cplusplus
}
#endif
#endif

266
pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc Normal file
View File

@ -0,0 +1,266 @@
{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
-- | This module is a thin wrapper above libnatpmp.h and getgateway.h.
module Network.NatPmp (Error(..),
NatPmpResponse(..),
ProtocolType(..),
NatPmpHandle,
Port,
LifetimeSeconds,
initNatPmp,
closeNatPmp,
getDefaultGateway,
getPublicAddress,
setPortMapping) where
#include <netinet/in.h>
#include <getgateway.h>
#include <natpmp.h>
#include <binding.h>
import Prelude
import Foreign
import Foreign.C
import Network.Socket
import Control.Monad.IO.Unlift (MonadIO(..))
-- Opaque type for the internals of nat pmp
data NatPmpStruct
type NatPmpHandle = Ptr NatPmpStruct
type Port = Word16
type LifetimeSeconds = Word32
-- The response type, in its internal form. This struct is a C tagged union
-- with additional data, but we need to read and write from its C form.
data NatPmpResponse
= NatPmpResponsePublicAddress HostAddress
| NatPmpResponseUdpPortMapping Port Port LifetimeSeconds
| NatPmpResponseTcpPortMapping Port Port LifetimeSeconds
deriving (Show)
instance Storable NatPmpResponse where
sizeOf _ = #{size natpmpresp_t}
alignment _ = alignment (undefined :: CString)
peek p = do
t <- uintToEnum <$> (#{peek natpmpresp_t, type} p)
case t of
RTPublicAddress ->
NatPmpResponsePublicAddress <$>
(#{peek natpmpresp_t, pnu.publicaddress.addr} p)
RTUdpPortMapping ->
NatPmpResponseUdpPortMapping
<$> (#{peek natpmpresp_t, pnu.newportmapping.privateport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.mappedpublicport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.lifetime} p)
RTTcpPortMapping ->
NatPmpResponseTcpPortMapping
<$> (#{peek natpmpresp_t, pnu.newportmapping.privateport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.mappedpublicport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.lifetime} p)
poke _ _ = error "Responses are an output data structure; poke makes no sense"
type NatPmpResponseHandle = Ptr NatPmpResponse
foreign import ccall unsafe "getgateway.h getdefaultgateway" _get_default_gateway :: Ptr CUInt -> IO CInt
foreign import ccall unsafe "natpmp.h initnatpmp" _init_nat_pmp :: NatPmpHandle -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "natpmp.h closenatpmp" _close_nat_pmp :: NatPmpHandle -> IO CInt
foreign import ccall unsafe "natpmp.h sendpublicaddressrequest" sendPublicAddressRequest :: NatPmpHandle -> IO CInt
foreign import ccall unsafe "natpmp.h sendnewportmappingrequest" sendNewPortMappingRequest :: NatPmpHandle -> CInt -> CUShort -> CUShort -> CUInt -> IO CInt
foreign import ccall unsafe "binding.h readNatResponseSynchronously" readNatResponseSynchronously :: NatPmpHandle -> NatPmpResponseHandle -> IO CInt
-- Give the type system some help
_peekCUInt :: Ptr CUInt -> IO CUInt
_peekCUInt = peek
uintToEnum :: Enum e => CUInt -> e
uintToEnum = toEnum . fromIntegral
intToEnum :: Enum e => CInt -> e
intToEnum = toEnum . fromIntegral
-- Fetches the default gateway as an ipv4 address
getDefaultGateway :: IO (Maybe HostAddress)
getDefaultGateway =
alloca $ \(pReturnAddr :: Ptr CUInt) -> do
_get_default_gateway pReturnAddr >>= \case
0 -> (Just . fromIntegral) <$> _peekCUInt pReturnAddr
_ -> pure Nothing
data RespType
= RTPublicAddress
| RTUdpPortMapping
| RTTcpPortMapping
deriving (Eq, Show)
instance Enum RespType where
fromEnum RTPublicAddress = 0
fromEnum RTUdpPortMapping = 1
fromEnum RTTcpPortMapping = 2
toEnum 0 = RTPublicAddress
toEnum 1 = RTUdpPortMapping
toEnum 2 = RTTcpPortMapping
toEnum unmatched = error ("RespType.toEnum: Cannot match " ++ show unmatched)
data ProtocolType
= PTUdp
| PTTcp
deriving (Eq, Show)
instance Enum ProtocolType where
fromEnum PTUdp = 1
fromEnum PTTcp = 2
toEnum 1 = PTUdp
toEnum 2 = PTTcp
toEnum x = error ("ProtocolType.toEnum: Cannot match " ++ show x)
data Error
= ErrInvalidArgs
| ErrSocketError
| ErrCannotGetGateway
| ErrCloseErr
| ErrRecvFrom
| ErrNoPendingReq
| ErrNoGatewaySupport
| ErrConnectErr
| ErrWrongPacketSource
| ErrSendErr
| ErrFcntlError
| ErrGetTimeOfDayError
--
| ErrUnsuportedVersion
| ErrUnsupportedOpcode
--
| ErrUndefinedError
| ErrNotAuthorized
| ErrNetworkFailure
| ErrOutOfResources
--
| ErrTryAgain
| ErrHaskellBindings
deriving (Eq, Show)
instance Enum Error where
fromEnum ErrInvalidArgs = -1
fromEnum ErrSocketError = -2
fromEnum ErrCannotGetGateway = -3
fromEnum ErrCloseErr = -4
fromEnum ErrRecvFrom = -5
fromEnum ErrNoPendingReq = -6
fromEnum ErrNoGatewaySupport = -7
fromEnum ErrConnectErr = -8
fromEnum ErrWrongPacketSource = -9
fromEnum ErrSendErr = -10
fromEnum ErrFcntlError = -11
fromEnum ErrGetTimeOfDayError = -12
--
fromEnum ErrUnsuportedVersion = -14
fromEnum ErrUnsupportedOpcode = -15
--
fromEnum ErrUndefinedError = -49
fromEnum ErrNotAuthorized = -51
fromEnum ErrNetworkFailure = -52
fromEnum ErrOutOfResources = -53
--
fromEnum ErrTryAgain = -100
fromEnum ErrHaskellBindings = -200
toEnum (-1) = ErrInvalidArgs
toEnum (-2) = ErrSocketError
toEnum (-3) = ErrCannotGetGateway
toEnum (-4) = ErrCloseErr
toEnum (-5) = ErrRecvFrom
toEnum (-6) = ErrNoPendingReq
toEnum (-7) = ErrNoGatewaySupport
toEnum (-8) = ErrConnectErr
toEnum (-9) = ErrWrongPacketSource
toEnum (-10) = ErrSendErr
toEnum (-11) = ErrFcntlError
toEnum (-12) = ErrGetTimeOfDayError
--
toEnum (-14) = ErrUnsuportedVersion
toEnum (-15) = ErrUnsupportedOpcode
--
toEnum (-49) = ErrUndefinedError
toEnum (-51) = ErrNotAuthorized
toEnum (-52) = ErrNetworkFailure
toEnum (-53) = ErrOutOfResources
--
toEnum (-100) = ErrTryAgain
toEnum (-200) = ErrHaskellBindings
toEnum unmatched = error ("Error.toEnum: Cannot match " ++ show unmatched)
initNatPmp :: MonadIO m => m (Either Error NatPmpHandle)
initNatPmp = liftIO do
natpmp <- mallocBytes #{size natpmp_t}
ret <- _init_nat_pmp natpmp 0 0
case ret of
0 -> pure $ Right natpmp
_ -> do
free natpmp
pure $ Left $ intToEnum ret
closeNatPmp :: MonadIO m => NatPmpHandle -> m (Either Error ())
closeNatPmp handle = liftIO do
ret <- _close_nat_pmp handle
free handle
case ret of
0 -> pure $ Right ()
_ -> pure $ Left $ intToEnum ret
-- | Public interface for getting the public IPv4 address
getPublicAddress :: MonadIO m => NatPmpHandle -> m (Either Error HostAddress)
getPublicAddress natpmp = liftIO do
sendRetcode <- sendPublicAddressRequest natpmp
case sendRetcode of
2 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
respRetcode <- readNatResponseSynchronously natpmp pResponse
case respRetcode of
0 -> peek pResponse >>= \case
NatPmpResponsePublicAddress addr -> pure $ Right addr
_ -> pure $ Left ErrHaskellBindings
_ -> pure $ Left $ intToEnum respRetcode
_ -> pure $ Left $ intToEnum sendRetcode
-- | Requests that the router maps the privatePort on our local computer in our
-- private network to publicPort on the public internet.
setPortMapping :: MonadIO m
=> NatPmpHandle
-> ProtocolType
-> Port
-> Port
-> LifetimeSeconds
-> m (Either Error ())
setPortMapping natpmp protocol privatePort publicPort lifetime = liftIO do
let protocolNum = fromEnum protocol
sendResp <-
sendNewPortMappingRequest natpmp
(fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort)
(CUInt lifetime)
case sendResp of
12 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
respRetcode <- readNatResponseSynchronously natpmp pResponse
case respRetcode of
0 -> peek pResponse >>= \case
NatPmpResponseUdpPortMapping _ _ _ -> pure $ Right ()
NatPmpResponseTcpPortMapping _ _ _ -> pure $ Right ()
_ -> pure $ Left ErrHaskellBindings
_ -> pure $ Left $ intToEnum respRetcode
x -> pure $ Left $ intToEnum x

89
pkg/hs/natpmp-static/natpmp-static.cabal Normal file
View File

@ -0,0 +1,89 @@
cabal-version: >=1.10
-- Initial package description 'natpmp-static.cabal' generated by 'cabal
-- init'. For further documentation, see
-- http://haskell.org/cabal/users-guide/
name: natpmp-static
version: 0.1.0.0
synopsis: Haskell bindings to libnatpmp
description:
libnatpmp is a C library to communicate with routers and request
that they port forward traffic from the outside internet to your
program.
.
natpmp-static has Haskell bindings to libnatpmp to allow Haskell
programs to punch NAT holes in routers, containing a vendored copy
of the libnatpmp code so that we build Urbit's "almost static"
builds which we distribute.
.
See <http://miniupnp.free.fr/libnatpmp.html> for upstream source.
-- bug-reports:
license: BSD3
license-file: LICENSE
author: Elliot Glaysher
maintainer: elliot@tlon.io
copyright: (c) 2020 Tlon.
stability: experimental
build-type: Simple
library
hs-Source-Dirs: hsrc_lib
default-language: Haskell2010
build-depends: base
, network
, unliftio-core
build-tools: hsc2hs
Include-dirs: cbits
Includes: natpmp.h getgateway.h
C-Sources: cbits/natpmp.c cbits/getgateway.c cbits/binding.c
cc-options: -Wall -Os -g -fPIC
ghc-options: -Wall -fprof-auto -fPIC
exposed-modules: Network.NatPmp
-- other-modules:
-- other-extensions:
default-extensions: ApplicativeDo
, BangPatterns
, BlockArguments
, DataKinds
, DefaultSignatures
, DeriveAnyClass
, DeriveDataTypeable
, DeriveFoldable
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, EmptyCase
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, GeneralizedNewtypeDeriving
, LambdaCase
, MagicHash
, MultiParamTypeClasses
, NamedFieldPuns
, NoImplicitPrelude
, NumericUnderscores
, OverloadedStrings
, PartialTypeSignatures
, PatternSynonyms
, QuasiQuotes
, Rank2Types
, RankNTypes
, RecordWildCards
, ScopedTypeVariables
, StandaloneDeriving
, TemplateHaskell
, TupleSections
, TypeApplications
, TypeFamilies
, TypeOperators
, UnboxedTuples
, UnicodeSyntax
, ViewPatterns

3
pkg/hs/stack.yaml
View File

@ -2,6 +2,7 @@ resolver: lts-14.21
packages:
- lmdb-static
- natpmp-static
- proto
- racquire
- terminal-progress-bar
@ -17,8 +18,8 @@ extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38
- base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00
- urbit-hob-0.3.1@sha256:afbdc7ad071eefc6ca85f5b598b6c62ed49079d15d1840dac27438a3b3150303
- para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81
- urbit-hob-0.3.3@sha256:ff8dae3844881cd979fee96bcb3ab3d5ea95f7c3ad2302dbc4b2dc417ff6595b
# This allows building on NixOS.
nix:

6
pkg/hs/urbit-king/TODO.md
View File

@ -63,12 +63,6 @@ Polish:
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.

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

@ -112,6 +112,7 @@ data Blit
= Bel ()
| Clr ()
| Hop Word64
| Klr Stub
| Lin [Char]
| Mor ()
| Sag Path Noun
@ -119,12 +120,84 @@ data Blit
| Url Cord
deriving (Eq, Ord)
data Deco
= DecoBl
| DecoBr
| DecoUn
| DecoNull
deriving (Eq, Ord, Show)
data Tint
= TintR
| TintG
| TintB
| TintC
| TintM
| TintY
| TintK
| TintW
| TintNull
deriving (Eq, Ord, Show)
data Stye = Stye
{ deco :: (HoonSet Deco)
, back :: Tint
, fore :: Tint
}
deriving (Eq, Ord, Show)
newtype Stub = Stub [(Stye, [Char])]
deriving (Eq, Ord, Show)
instance ToNoun Deco where
toNoun = \case
DecoBl -> toNoun $ Cord "bl"
DecoBr -> toNoun $ Cord "br"
DecoUn -> toNoun $ Cord "un"
DecoNull -> Atom 0
instance FromNoun Deco where
parseNoun = named "Deco" . \case
Atom 0 -> pure DecoNull
n -> parseNoun @Cord n <&> unCord >>= \case
"bl" -> pure DecoBl
"br" -> pure DecoBr
"un" -> pure DecoUn
t -> fail ("invalid: " <> unpack t)
instance ToNoun Tint where
toNoun = \case
TintR -> toNoun $ Cord "r"
TintG -> toNoun $ Cord "g"
TintB -> toNoun $ Cord "b"
TintC -> toNoun $ Cord "c"
TintM -> toNoun $ Cord "m"
TintY -> toNoun $ Cord "y"
TintK -> toNoun $ Cord "k"
TintW -> toNoun $ Cord "w"
TintNull -> Atom 0
instance FromNoun Tint where
parseNoun = named "Tint" . \case
Atom 0 -> pure TintNull
n -> parseNoun @Cord n <&> unCord >>= \case
"r" -> pure TintR
"g" -> pure TintG
"b" -> pure TintB
"c" -> pure TintC
"m" -> pure TintM
"y" -> pure TintY
"k" -> pure TintK
"w" -> pure TintW
t -> fail ("invalid: " <> unpack t)
-- Manual instance to not save the noun/atom in Sag/Sav, because these can be
-- megabytes and makes king hang.
instance Show Blit where
show (Bel ()) = "Bel ()"
show (Clr ()) = "Clr ()"
show (Hop x) = "Hop " ++ (show x)
show (Klr s) = "Klr " ++ (show s)
show (Lin c) = "Lin " ++ (show c)
show (Mor ()) = "Mor ()"
show (Sag path _) = "Sag " ++ (show path)
@ -144,6 +217,8 @@ data TermEf
| TermEfMass Path Noun -- Irrelevant
deriving (Eq, Ord, Show)
deriveNoun ''Stye
deriveNoun ''Stub
deriveNoun ''Blit
deriveNoun ''TermEf

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

@ -9,6 +9,8 @@ module Urbit.King.App
, kingEnvKillSignal
, killKingActionL
, onKillKingSigL
, HostEnv
, runHostEnv
, PierEnv
, runPierEnv
, killPierActionL
@ -17,6 +19,8 @@ module Urbit.King.App
, HasKingId(..)
, HasProcId(..)
, HasKingEnv(..)
, HasMultiEyreApi(..)
, HasHostEnv(..)
, HasPierEnv(..)
, module Urbit.King.Config
)
@ -25,11 +29,16 @@ where
import Urbit.King.Config
import Urbit.Prelude
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.Directory ( createDirectoryIfMissing
, getXdgDirectory
, XdgDirectory(XdgCache)
)
import System.Posix.Internals (c_getpid)
import System.Posix.Types (CPid(..))
import System.Random (randomIO)
import Urbit.King.App.Class (HasStderrLogFunc(..))
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
import Urbit.Vere.Ports (PortControlApi, HasPortControlApi(..))
-- KingEnv ---------------------------------------------------------------------
@ -70,39 +79,50 @@ instance HasProcId KingEnv where
instance HasKingId KingEnv where
kingIdL = kingEnvKingId
-- Running KingEnvs ------------------------------------------------------------
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
runKingEnvStderr verb inner = do
runKingEnvStderr :: Bool -> LogLevel -> RIO KingEnv a -> IO a
runKingEnvStderr verb lvl inner = do
logOptions <-
logOptionsHandle stderr verb <&> setLogUseTime True <&> setLogUseLoc False
logOptionsHandle stderr verb
<&> setLogUseTime True
<&> setLogUseLoc False
<&> setLogMinLevel lvl
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
runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a
runKingEnvLogFile verb lvl fileM inner = do
logFile <- case fileM of
Just f -> pure f
Nothing -> defaultLogFile
withLogFileHandle logFile $ \h -> do
logOptions <-
logOptionsHandle h verb
<&> setLogUseTime True
<&> setLogUseLoc False
<&> setLogMinLevel lvl
stderrLogOptions <-
logOptionsHandle stderr verb
<&> setLogUseTime False
<&> setLogUseLoc False
<&> setLogMinLevel lvl
withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions
$ \logFunc -> runKingEnv logFunc stderrLogFunc inner
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
withLogFileHandle :: FilePath -> (Handle -> IO a) -> IO a
withLogFileHandle f act =
withFile f AppendMode $ \handle -> do
hSetBuffering handle LineBuffering
act handle
defaultLogFile :: IO FilePath
defaultLogFile = do
logDir <- getXdgDirectory XdgCache "urbit"
createDirectoryIfMissing True logDir
pure (logDir </> "king.log")
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
runKingEnvNoLog act = runKingEnv mempty mempty act
runKingEnv :: LogFunc -> LogFunc -> RIO KingEnv a -> IO a
runKingEnv logFunc stderr action = do
@ -121,14 +141,69 @@ killKingActionL :: HasKingEnv e => Getter e (STM ())
killKingActionL =
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
-- HostEnv ------------------------------------------------------------------
-- The host environment is everything in King, eyre configuration shared
-- across ships, and nat punching data.
class HasMultiEyreApi a where
multiEyreApiL :: Lens' a MultiEyreApi
class (HasKingEnv a, HasMultiEyreApi a, HasPortControlApi a) =>
HasHostEnv a where
hostEnvL :: Lens' a HostEnv
data HostEnv = HostEnv
{ _hostEnvKingEnv :: !KingEnv
, _hostEnvMultiEyreApi :: !MultiEyreApi
, _hostEnvPortControlApi :: !PortControlApi
}
makeLenses ''HostEnv
instance HasKingEnv HostEnv where
kingEnvL = hostEnvKingEnv
instance HasLogFunc HostEnv where
logFuncL = kingEnvL . logFuncL
instance HasStderrLogFunc HostEnv where
stderrLogFuncL = kingEnvL . stderrLogFuncL
instance HasProcId HostEnv where
procIdL = kingEnvL . procIdL
instance HasKingId HostEnv where
kingIdL = kingEnvL . kingEnvKingId
instance HasMultiEyreApi HostEnv where
multiEyreApiL = hostEnvMultiEyreApi
instance HasPortControlApi HostEnv where
portControlApiL = hostEnvPortControlApi
-- Running Running Envs --------------------------------------------------------
runHostEnv :: MultiEyreApi -> PortControlApi -> RIO HostEnv a
-> RIO KingEnv a
runHostEnv multi ports action = do
king <- ask
let hostEnv = HostEnv { _hostEnvKingEnv = king
, _hostEnvMultiEyreApi = multi
, _hostEnvPortControlApi = ports
}
io (runRIO hostEnv action)
-- PierEnv ---------------------------------------------------------------------
class (HasKingEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where
class (HasKingEnv a, HasHostEnv a, HasPierConfig a, HasNetworkConfig a) =>
HasPierEnv a where
pierEnvL :: Lens' a PierEnv
data PierEnv = PierEnv
{ _pierEnvKingEnv :: !KingEnv
{ _pierEnvHostEnv :: !HostEnv
, _pierEnvPierConfig :: !PierConfig
, _pierEnvNetworkConfig :: !NetworkConfig
, _pierEnvKillSignal :: !(TMVar ())
@ -137,7 +212,16 @@ data PierEnv = PierEnv
makeLenses ''PierEnv
instance HasKingEnv PierEnv where
kingEnvL = pierEnvKingEnv
kingEnvL = pierEnvHostEnv . kingEnvL
instance HasHostEnv PierEnv where
hostEnvL = pierEnvHostEnv
instance HasMultiEyreApi PierEnv where
multiEyreApiL = pierEnvHostEnv . multiEyreApiL
instance HasPortControlApi PierEnv where
portControlApiL = pierEnvHostEnv . portControlApiL
instance HasPierEnv PierEnv where
pierEnvL = id
@ -180,11 +264,11 @@ killPierActionL =
-- Running Pier Envs -----------------------------------------------------------
runPierEnv
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO HostEnv a
runPierEnv pierConfig networkConfig vKill action = do
app <- ask
host <- ask
let pierEnv = PierEnv { _pierEnvKingEnv = app
let pierEnv = PierEnv { _pierEnvHostEnv = host
, _pierEnvPierConfig = pierConfig
, _pierEnvNetworkConfig = networkConfig
, _pierEnvKillSignal = vKill

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

@ -6,21 +6,24 @@
-}
module Urbit.King.CLI where
import ClassyPrelude
import ClassyPrelude hiding (log)
import Options.Applicative
import Options.Applicative.Help.Pretty
import Data.Word (Word16)
import RIO (LogLevel(..))
import System.Environment (getProgName)
--------------------------------------------------------------------------------
data KingOpts = KingOpts
{ koSharedHttpPort :: Maybe Word16
, koSharedHttpsPort :: Maybe Word16
data Host = Host
{ hSharedHttpPort :: Maybe Word16
, hSharedHttpsPort :: Maybe Word16
, hUseNatPmp :: Nat
}
deriving (Show)
-- | Options for each running pier.
data Opts = Opts
{ oQuiet :: Bool
, oHashless :: Bool
@ -44,6 +47,19 @@ data Opts = Opts
}
deriving (Show)
-- | Options for the logging subsystem.
data Log = Log
{ lTarget :: Maybe (LogTarget FilePath)
, lLevel :: LogLevel
}
deriving (Show)
data LogTarget a
= LogOff
| LogStderr
| LogFile a
deriving (Show)
data BootType
= BootComet
| BootFake Text
@ -55,6 +71,12 @@ data PillSource
| PillSourceURL String
deriving (Show)
data Nat
= NatAlways
| NatWhenPrivateNetwork
| NatNever
deriving (Show)
data New = New
{ nPillSource :: PillSource
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
@ -102,8 +124,8 @@ data Bug
deriving (Show)
data Cmd
= CmdNew New Opts
| CmdRun KingOpts [(Run, Opts, Bool)]
= CmdNew New Opts
| CmdRun Host [(Run, Opts, Bool)]
| CmdBug Bug
| CmdCon FilePath
deriving (Show)
@ -135,7 +157,7 @@ footNote exe = string $ intercalate "\n"
--------------------------------------------------------------------------------
parseArgs :: IO Cmd
parseArgs :: IO (Cmd, Log)
parseArgs = do
nm <- getProgName
@ -293,7 +315,7 @@ opts = do
oVerbose <- switch $ short 'v'
<> long "verbose"
<> help "Verbose"
<> help "Puts the serf and king into verbose mode"
<> hidden
oExit <- switch $ short 'x'
@ -332,22 +354,69 @@ opts = do
oFullReplay <- switch
$ long "full-log-replay"
<> help "Ignores the snapshot and recomputes state from log"
<> help "Ignores snapshot and recomputes state from event log"
<> hidden
pure (Opts{..})
newShip :: Parser Cmd
newShip = CmdNew <$> new <*> opts
log :: Parser Log
log = do
lTarget <-
optional
$ ( flag' LogStderr
$ long "log-to-stderr"
<> long "stderr"
<> help "Display logs on stderr"
<> hidden
)
<|> ( fmap LogFile . strOption
$ long "log-to"
<> metavar "LOG_FILE"
<> help "Append logs to the given file"
<> hidden
)
<|> ( flag' LogOff
$ long "no-logging"
<> help "Disable logging entirely"
<> hidden
)
lLevel <-
( flag' LevelDebug
$ long "log-debug"
<> help "Log errors, warnings, info, and debug messages"
<> hidden
)
<|> ( flag' LevelInfo
$ long "log-info"
<> help "Log errors, warnings, and info"
<> hidden
)
<|> ( flag' LevelWarn
$ long "log-warn"
<> help "Log errors and warnings (default)"
<> hidden
)
<|> ( flag' LevelError
$ long "log-error"
<> help "Log errors only"
<> hidden
)
<|> pure LevelWarn
pure (Log{..})
newShip :: Parser (Cmd, Log)
newShip = (,) <$> (CmdNew <$> new <*> opts) <*> log
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 <-
host :: Parser Host
host = do
hSharedHttpPort <-
optional
$ option auto
$ metavar "PORT"
@ -355,7 +424,7 @@ kingOpts = do
<> help "HTTP port"
<> hidden
koSharedHttpsPort <-
hSharedHttpsPort <-
optional
$ option auto
$ metavar "PORT"
@ -363,10 +432,29 @@ kingOpts = do
<> help "HTTPS port"
<> hidden
pure (KingOpts{..})
hUseNatPmp <-
( flag' NatAlways
$ long "port-forwarding"
<> help "Always try to search for a router to forward ames ports"
<> hidden
) <|>
( flag' NatNever
$ long "no-port-forwarding"
<> help "Disable trying to ask the router to forward ames ports"
<> hidden
) <|>
( flag' NatWhenPrivateNetwork
$ long "port-forwarding-when-internal"
<> help ("Try asking the router to forward when ip is 192.168.0.0/16, " <>
"172.16.0.0/12 or 10.0.0.0/8 (default).")
<> hidden
) <|>
(pure $ NatWhenPrivateNetwork)
runShip :: Parser Cmd
runShip = CmdRun <$> kingOpts <*> some runOneShip
pure (Host{..})
runShip :: Parser (Cmd, Log)
runShip = (,) <$> (CmdRun <$> host <*> some runOneShip) <*> log
valPill :: Parser Bug
valPill = do
@ -410,8 +498,8 @@ browseEvs = EventBrowser <$> pierPath
checkDawn :: Parser Bug
checkDawn = CheckDawn <$> keyfilePath
bugCmd :: Parser Cmd
bugCmd = fmap CmdBug
bugCmd :: Parser (Cmd, Log)
bugCmd = (flip (,) <$> log <*>) $ fmap CmdBug
$ subparser
$ command "validate-pill"
( info (valPill <**> helper)
@ -446,15 +534,15 @@ bugCmd = fmap CmdBug
$ progDesc "Shows the list of stars accepting comets"
)
conCmd :: Parser Cmd
conCmd = CmdCon <$> pierPath
conCmd :: Parser (Cmd, Log)
conCmd = (,) <$> (CmdCon <$> pierPath) <*> log
allFx :: Parser Bug
allFx = do
bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
pure CollectAllFX{..}
cmd :: Parser Cmd
cmd :: Parser (Cmd, Log)
cmd = subparser
$ command "new" ( info (newShip <**> helper)
$ progDesc "Boot a new ship."

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

@ -14,7 +14,7 @@ import qualified Urbit.Vere.Serf as Serf
data PierConfig = PierConfig
{ _pcPierPath :: FilePath
, _pcDryRun :: Bool
, _pcSerfExe :: Text
, _pcSerfExe :: Maybe Text
, _pcSerfFlags :: [Serf.Flag]
} deriving (Show)

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

@ -82,7 +82,8 @@ 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.Ports
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreConf(..))
import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf
import Urbit.King.App
@ -91,6 +92,7 @@ import Control.Concurrent (myThreadId)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import System.Process (system)
import System.IO (hPutStrLn)
import Text.Show.Pretty (pPrint)
import Urbit.Noun.Conversions (cordToUW)
import Urbit.Noun.Time (Wen)
@ -144,7 +146,7 @@ toPierConfig pierPath o@(CLI.Opts{..}) = PierConfig { .. }
where
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
_pcSerfExe = fromMaybe "urbit-worker" oSerfExe
_pcSerfExe = oSerfExe
_pcSerfFlags = toSerfFlags o
toNetworkConfig :: CLI.Opts -> NetworkConfig
@ -184,18 +186,17 @@ tryBootFromPill
-> Bool
-> Ship
-> LegacyBootEvent
-> MultiEyreApi
-> RIO PierEnv ()
tryBootFromPill oExit pill lite ship boot multi = do
tryBootFromPill oExit pill lite ship boot = do
mStart <- newEmptyMVar
vSlog <- logSlogs
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart
where
bootedPier vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "Starting boot"
rio $ logInfo "Starting boot"
sls <- Pier.booted vSlog pill lite ship boot
rio $ logDebug "Completed boot"
rio $ logInfo "Completed boot"
pure sls
runOrExitImmediately
@ -203,38 +204,36 @@ runOrExitImmediately
-> RAcquire PierEnv (Serf, Log.EventLog)
-> Bool
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
runOrExitImmediately vSlog getPier oExit mStart multi = do
runOrExitImmediately vSlog getPier oExit mStart = do
rwith getPier (if oExit then shutdownImmediately else runPier)
where
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
shutdownImmediately (serf, log) = do
logDebug "Sending shutdown signal"
logInfo "Sending shutdown signal"
Serf.stop serf
logDebug "Shutdown!"
logInfo "Shutdown!"
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
runPier serfLog = do
runRAcquire (Pier.pier serfLog vSlog mStart multi)
runRAcquire (Pier.pier serfLog vSlog mStart)
tryPlayShip
:: Bool
-> Bool
-> Maybe Word64
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
tryPlayShip exitImmediately fullReplay playFrom mStart = do
when fullReplay wipeSnapshot
vSlog <- logSlogs
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart
where
wipeSnapshot = do
shipPath <- view pierPathL
logDebug "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
logInfo "wipeSnapshot"
logInfo $ display $ pack @Text ("Wiping " <> north shipPath)
logInfo $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
@ -244,9 +243,9 @@ tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
resumeShip :: TVar (Text -> IO ()) -> RAcquire PierEnv (Serf, Log.EventLog)
resumeShip vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "RESUMING SHIP"
rio $ logInfo "RESUMING SHIP"
sls <- Pier.resumed vSlog playFrom
rio $ logDebug "SHIP RESUMED"
rio $ logInfo "SHIP RESUMED"
pure sls
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
@ -261,7 +260,7 @@ checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logDebug (displayShow ident)
logInfo (displayShow ident)
last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal
@ -286,7 +285,7 @@ checkEvs pierPath first last = do
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logDebug "Everything checks out."
lift $ logInfo "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
@ -315,10 +314,10 @@ collectAllFx = error "TODO"
-}
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx top = do
logDebug $ display $ pack @Text top
logInfo $ display $ pack @Text top
vSlog <- logSlogs
rwith (collectedFX vSlog) $ \() ->
logDebug "Done collecting effects!"
logInfo "Done collecting effects!"
where
tmpDir :: FilePath
tmpDir = top </> ".tmpdir"
@ -339,10 +338,10 @@ collectAllFx top = do
replayPartEvs :: FilePath -> Word64 -> RIO KingEnv ()
replayPartEvs top last = do
logDebug $ display $ pack @Text top
logInfo $ display $ pack @Text top
fetchSnapshot
rwith replayedEvs $ \() ->
logDebug "Done replaying events!"
logInfo "Done replaying events!"
where
fetchSnapshot :: RIO KingEnv ()
fetchSnapshot = do
@ -385,57 +384,57 @@ replayPartEvs top last = do
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
logDebug "Reading pill file."
logInfo "Reading pill file."
pillBytes <- readFile pax
logDebug "Cueing pill file."
logInfo "Cueing pill file."
pillNoun <- io $ cueBS pillBytes & either throwIO pure
logDebug "Parsing pill file."
logInfo "Parsing pill file."
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
logDebug "Using pill to generate boot sequence."
logInfo "Using pill to generate boot sequence."
bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0))
logDebug "Validate jam/cue and toNoun/fromNoun on pill value"
logInfo "Validate jam/cue and toNoun/fromNoun on pill value"
reJam <- validateNounVal pill
logDebug "Checking if round-trip matches input file:"
logInfo "Checking if round-trip matches input file:"
unless (reJam == pillBytes) $ do
logDebug " Our jam does not match the file...\n"
logDebug " This is surprising, but it is probably okay."
logInfo " Our jam does not match the file...\n"
logInfo " This is surprising, but it is probably okay."
when showPil $ do
logDebug "\n\n== Pill ==\n"
logInfo "\n\n== Pill ==\n"
io $ pPrint pill
when showSeq $ do
logDebug "\n\n== Boot Sequence ==\n"
logInfo "\n\n== Boot Sequence ==\n"
io $ pPrint bootSeq
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
=> a -> RIO e ByteString
validateNounVal inpVal = do
logDebug " jam"
logInfo " jam"
inpByt <- evaluate $ jamBS $ toNoun inpVal
logDebug " cue"
logInfo " cue"
outNon <- cueBS inpByt & either throwIO pure
logDebug " fromNoun"
logInfo " fromNoun"
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
logDebug " toNoun"
logInfo " toNoun"
outNon <- evaluate (toNoun outVal)
logDebug " jam"
logInfo " jam"
outByt <- evaluate $ jamBS outNon
logDebug "Checking if: x == cue (jam x)"
logInfo "Checking if: x == cue (jam x)"
unless (inpVal == outVal) $
error "Value fails test: x == cue (jam x)"
logDebug "Checking if: jam x == jam (cue (jam x))"
logInfo "Checking if: jam x == jam (cue (jam x))"
unless (inpByt == outByt) $
error "Value fails test: jam x == jam (cue (jam x))"
@ -444,14 +443,14 @@ validateNounVal inpVal = do
--------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO KingEnv Pill
pillFrom :: CLI.PillSource -> RIO HostEnv Pill
pillFrom = \case
CLI.PillSourceFile pillPath -> do
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
logInfo $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
io (loadFile pillPath >>= either throwIO pure)
CLI.PillSourceURL url -> do
logDebug $ display $ "boot: retrieving pill from " ++ (pack url :: Text)
logInfo $ 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
@ -475,7 +474,12 @@ newShip CLI.New{..} opts = do
-}
multi <- multiEyre (MultiEyreConf Nothing Nothing True)
case nBootType of
-- TODO: We hit the same problem as above: we need a host env to boot a ship
-- because it may autostart the ship, so build an inactive port configuration.
let ports = buildInactivePorts
-- here we are with a king env, and we now need a multi env.
runHostEnv multi ports $ case nBootType of
CLI.BootComet -> do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
@ -486,12 +490,12 @@ newShip CLI.New{..} opts = do
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed multi pill seed
bootFromSeed pill seed
CLI.BootFake name -> do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill multi pill name ship (Fake ship)
runTryBootFromPill pill name ship (Fake ship)
CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile
@ -506,10 +510,10 @@ newShip CLI.New{..} opts = do
pill <- pillFrom nPillSource
bootFromSeed multi pill seed
bootFromSeed pill seed
where
shipFrom :: Text -> RIO KingEnv Ship
shipFrom :: Text -> RIO HostEnv Ship
shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
@ -519,7 +523,7 @@ newShip CLI.New{..} opts = do
Just x -> x
Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO KingEnv Text
nameFromShip :: HasKingEnv e => Ship -> RIO e Text
nameFromShip s = name
where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@ -527,8 +531,8 @@ newShip CLI.New{..} opts = do
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x
bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO KingEnv ()
bootFromSeed multi pill seed = do
bootFromSeed :: Pill -> Seed -> RIO HostEnv ()
bootFromSeed pill seed = do
ethReturn <- dawnVent seed
case ethReturn of
@ -536,19 +540,23 @@ newShip CLI.New{..} opts = do
Right dawn -> do
let ship = sShip $ dSeed dawn
name <- nameFromShip ship
runTryBootFromPill multi pill name ship (Dawn dawn)
runTryBootFromPill pill name ship (Dawn dawn)
-- Now that we have all the information for running an application with a
-- PierConfig, do so.
runTryBootFromPill multi pill name ship bootEvent = do
vKill <- view kingEnvKillSignal
runTryBootFromPill :: Pill
-> Text
-> Ship
-> LegacyBootEvent
-> RIO HostEnv ()
runTryBootFromPill pill name ship bootEvent = do
vKill <- view (kingEnvL . kingEnvKillSignal)
let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts
runPierEnv pierConfig networkConfig vKill $
tryBootFromPill True pill nLite ship bootEvent multi
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
tryBootFromPill True pill nLite ship bootEvent
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO HostEnv a
runShipEnv (CLI.Run pierPath) opts vKill act = do
runPierEnv pierConfig netConfig vKill act
where
@ -556,8 +564,8 @@ runShipEnv (CLI.Run pierPath) opts vKill act = do
netConfig = toNetworkConfig opts
runShip
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon multi = do
:: CLI.Run -> CLI.Opts -> Bool -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon = do
mStart <- newEmptyMVar
if daemon
then runPier mStart
@ -580,9 +588,17 @@ runShip (CLI.Run pierPath) opts daemon multi = do
(CLI.oFullReplay opts)
(CLI.oDryFrom opts)
mStart
multi
buildPortHandler :: HasLogFunc e => CLI.Nat -> RIO e PortControlApi
buildPortHandler CLI.NatNever = pure buildInactivePorts
-- TODO: Figure out what to do about logging here. The "port: " messages are
-- the sort of thing that should be put on the muxed terminal log, but we don't
-- have that at this layer.
buildPortHandler CLI.NatAlways = buildNatPorts (io . hPutStrLn stderr . unpack)
buildPortHandler CLI.NatWhenPrivateNetwork =
buildNatPortsWhenPrivate (io . hPutStrLn stderr . unpack)
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
startBrowser pierPath = runRAcquire $ do
-- lockFile pierPath
@ -621,12 +637,12 @@ checkComet = do
main :: IO ()
main = do
args <- CLI.parseArgs
(args, log) <- CLI.parseArgs
hSetBuffering stdout NoBuffering
setupSignalHandlers
runKingEnv args $ case args of
runKingEnv args log $ case args of
CLI.CmdRun ko ships -> runShips ko ships
CLI.CmdNew n o -> newShip n o
CLI.CmdBug (CLI.CollectAllFX pax ) -> collectAllFx pax
@ -640,11 +656,14 @@ main = do
CLI.CmdCon pier -> connTerm pier
where
runKingEnv args =
let verb = verboseLogging args
in if willRunTerminal args
then runKingEnvLogFile verb
else runKingEnvStderr verb
runKingEnv args log =
let
verb = verboseLogging args
CLI.Log {..} = log
in case logTarget lTarget args of
CLI.LogFile f -> runKingEnvLogFile verb lLevel f
CLI.LogStderr -> runKingEnvStderr verb lLevel
CLI.LogOff -> runKingEnvNoLog
setupSignalHandlers = do
mainTid <- myThreadId
@ -657,12 +676,23 @@ main = do
CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
_ -> False
willRunTerminal :: CLI.Cmd -> Bool
willRunTerminal = \case
CLI.CmdCon _ -> True
CLI.CmdRun ko [(_,_,daemon)] -> not daemon
CLI.CmdRun ko _ -> False
_ -> False
-- If the user hasn't specified where to log, what we do depends on what
-- command she has issued. Notably, the LogFile Nothing outcome means that
-- runKingEnvLogFile should run an IO action to get the official app data
-- directory and open a canonically named log file there.
logTarget :: Maybe (CLI.LogTarget FilePath)
-> CLI.Cmd
-> CLI.LogTarget (Maybe FilePath)
logTarget = \case
Just (CLI.LogFile f) -> const $ CLI.LogFile (Just f)
Just CLI.LogStderr -> const $ CLI.LogStderr
Just CLI.LogOff -> const $ CLI.LogOff
Nothing -> \case
CLI.CmdCon _ -> CLI.LogFile Nothing
CLI.CmdRun ko [(_,_,daemon)] | daemon -> CLI.LogStderr
| otherwise -> CLI.LogFile Nothing
CLI.CmdRun ko _ -> CLI.LogStderr
_ -> CLI.LogStderr
{-
@ -674,15 +704,15 @@ main = do
TODO Use logging system instead of printing.
-}
runShipRestarting
:: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
runShipRestarting r o multi = do
:: CLI.Run -> CLI.Opts -> RIO HostEnv ()
runShipRestarting r o = do
let pier = pack (CLI.rPierPath r)
loop = runShipRestarting r o multi
loop = runShipRestarting r o
onKill <- view onKillKingSigL
vKillPier <- newEmptyTMVarIO
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True
let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill
@ -699,7 +729,7 @@ runShipRestarting r o multi = do
logTrace $ display (pier <> " shutdown requested")
race_ (wait tid) $ do
threadDelay 5_000_000
logDebug $ display (pier <> " not down after 5s, killing with fire.")
logInfo $ display (pier <> " not down after 5s, killing with fire.")
cancel tid
logTrace $ display ("Ship terminated: " <> pier)
@ -707,10 +737,11 @@ runShipRestarting r o multi = do
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)
:: CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv ()
runShipNoRestart r o d = do
-- killing ship same as killing king
vKill <- view (kingEnvL . kingEnvKillSignal)
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d)
onKill <- view onKillKingSigL
let pier = pack (CLI.rPierPath r)
@ -731,40 +762,32 @@ runShipNoRestart r o d multi = do
cancel tid
logTrace $ display (pier <> " terminated.")
runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
runShips CLI.KingOpts {..} ships = do
runShips :: CLI.Host -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
runShips CLI.Host {..} ships = do
let meConf = MultiEyreConf
{ mecHttpPort = fromIntegral <$> koSharedHttpPort
, mecHttpsPort = fromIntegral <$> koSharedHttpsPort
{ mecHttpPort = fromIntegral <$> hSharedHttpPort
, mecHttpsPort = fromIntegral <$> hSharedHttpsPort
, 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
ports <- buildPortHandler hUseNatPmp
runHostEnv multi ports (go ships)
where
go :: MultiEyreApi -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
go me = \case
go :: [(CLI.Run, CLI.Opts, Bool)] -> RIO HostEnv ()
go = \case
[] -> pure ()
[rod] -> runSingleShip rod me
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
[rod] -> runSingleShip rod
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o))
-- 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)
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> RIO HostEnv ()
runSingleShip (r, o, d) = do
shipThread <- async (runShipNoRestart r o d)
{-
Wait for the ship to go down.
@ -784,10 +807,10 @@ runSingleShip (r, o, d) multi = do
pure ()
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv ()
runMultipleShips ships multi = do
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> RIO HostEnv ()
runMultipleShips ships = do
shipThreads <- for ships $ \(r, o) -> do
async (runShipRestarting r o multi)
async (runShipRestarting r o)
{-
Since `spin` never returns, this will run until the main

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

@ -34,10 +34,9 @@ import Text.Show.Pretty (pPrint, ppShow)
import RIO (RIO, runRIO)
import RIO (Utf8Builder, display, displayShow)
import RIO (threadDelay)
import RIO (HasLogFunc, LogFunc, logDebug, logError, logFuncL, logInfo,
logOptionsHandle, logOther, logWarn, mkLogFunc, setLogUseLoc,
setLogUseTime, withLogFunc)
import RIO (HasLogFunc, LogFunc, LogLevel(..), logDebug, logError, logFuncL,
logInfo, logOptionsHandle, logOther, logWarn, mkLogFunc,
setLogMinLevel, setLogUseLoc, setLogUseTime, withLogFunc)
io :: MonadIO m => IO a -> m a
io = liftIO

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

@ -10,6 +10,7 @@ import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake)
import Urbit.King.Config
import Urbit.Vere.Pier.Types
import Urbit.Vere.Ports
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
@ -105,7 +106,10 @@ udpPort isFake who = do
mPort <- view (networkConfigL . ncAmesPort)
pure $ maybe (listenPort mode who) fromIntegral mPort
udpServ :: (HasLogFunc e, HasNetworkConfig e) => Bool -> Ship -> RIO e UdpServ
udpServ :: (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e)
=> Bool
-> Ship
-> RIO e UdpServ
udpServ isFake who = do
mode <- netMode isFake
port <- udpPort isFake who
@ -170,7 +174,7 @@ ames' who isFake stderr = do
-}
ames
:: forall e
. (HasLogFunc e, HasNetworkConfig e, HasKingId e)
. (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e, HasKingId e)
=> e
-> Ship
-> Bool
@ -229,7 +233,7 @@ ames env who isFake enqueueEv stderr = (initialEvents, runAmes)
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
atomically (readTVar aTurfs) >>= \case
Nothing -> pure ()
Nothing -> stderr "ames: send before turfs" >> pure ()
Just turfs -> sendPacket drv mode dest bs
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()

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

@ -131,11 +131,11 @@ doResolv gal (prevWen, prevIP) turfs stderr = do
io (resolv gal turfs) >>= \case
Nothing -> do
stderr $ "ames: czar at " ++ galStr ++ ": not found"
logDebug $ displayShow ("(ames) Failed to lookup IP for ", gal)
logInfo $ 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)
logInfo $ displayShow ("(ames) Looked up ", host, port, turf, addr)
pure (Just addr, tim)
where
galStr = renderGalaxy gal
@ -155,7 +155,7 @@ resolvWorker
resolvWorker gal vTurfs vLast waitMsg send stderr = async (forever go)
where
logDrop =
logDebug $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
logInfo $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
go :: RIO e ()
go = do

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

@ -33,6 +33,7 @@ module Urbit.Vere.Ames.UDP
where
import Urbit.Prelude
import Urbit.Vere.Ports
import Network.Socket hiding (recvFrom, sendTo)
@ -79,14 +80,14 @@ 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))
logInfo (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))
logInfo (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")
logInfo (display ("AMES: UDP: " <> tshow err))
logInfo ("AMES: UDP: Failed to open UDP socket. Waiting")
threadDelay 250_000
go
@ -137,7 +138,7 @@ recvPacket sok = do
-}
fakeUdpServ :: HasLogFunc e => RIO e UdpServ
fakeUdpServ = do
logDebug $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
logInfo $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
pure UdpServ { .. }
where
usSend = \_ _ -> pure ()
@ -151,9 +152,13 @@ fakeUdpServ = do
Real UDP server. See module-level docs.
-}
realUdpServ
:: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ
:: forall e
. (HasLogFunc e, HasPortControlApi e)
=> PortNumber
-> HostAddress
-> RIO e UdpServ
realUdpServ por hos = do
logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
logInfo $ displayShow ("AMES", "UDP", "Starting real UDP server.")
env <- ask
@ -173,7 +178,7 @@ realUdpServ por hos = do
-}
let signalBrokenSocket :: Socket -> RIO e ()
signalBrokenSocket sock = do
logDebug $ displayShow ("AMES", "UDP"
logInfo $ displayShow ("AMES", "UDP"
, "Socket broken. Requesting new socket"
)
atomically $ do
@ -197,11 +202,21 @@ realUdpServ por hos = 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)
sk <- forceBind por hos
sn <- io $ getSocketName sk
let waitForRelease = do
atomically (writeTVar vSock (Just sk))
broken <- atomically (takeTMVar vFail)
logWarn "AMES: UDP: Closing broken socket."
io (close broken)
case sn of
(SockAddrInet boundPort _) ->
-- When we're on IPv4, maybe port forward at the NAT.
rwith (requestPortAccess $ fromIntegral boundPort) $
\() -> waitForRelease
_ -> waitForRelease
tSend <- async $ forever $ join $ atomically $ do
(adr, byt) <- readTBQueue qSend
@ -227,11 +242,11 @@ realUdpServ por hos = do
enqueueRecvPacket p a b
let shutdown = do
logDebug "AMES: UDP: Shutting down. (killing threads)"
logInfo "AMES: UDP: Shutting down. (killing threads)"
cancel tOpen
cancel tSend
cancel tRecv
logDebug "AMES: UDP: Shutting down. (closing socket)"
logInfo "AMES: UDP: Shutting down. (closing socket)"
io $ join $ atomically $ do
res <- readTVar vSock <&> maybe (pure ()) close
writeTVar vSock Nothing

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

@ -163,7 +163,7 @@ clay env plan =
handleEffect :: ClayDrv -> SyncEf -> IO ()
handleEffect cd = runRIO env . \case
SyncEfHill _ mountPoints -> do
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
logInfo $ displayShow ("(clay) known mount points:", mountPoints)
pierPath <- view pierPathL
mountPairs <- flip mapM mountPoints $ \desk -> do
ss <- takeFilesystemSnapshot (pierPath </> (deskToPath desk))
@ -171,14 +171,14 @@ clay env plan =
atomically $ writeTVar (cdMountPoints cd) (M.fromList mountPairs)
SyncEfDirk p desk -> do
logDebug $ displayShow ("(clay) dirk:", p, desk)
logInfo $ displayShow ("(clay) dirk:", p, desk)
m <- atomically $ readTVar (cdMountPoints cd)
let snapshot = M.findWithDefault M.empty desk m
pierPath <- view pierPathL
let dir = pierPath </> deskToPath desk
actions <- buildActionListFromDifferences dir snapshot
logDebug $ displayShow ("(clay) dirk actions: ", actions)
logInfo $ displayShow ("(clay) dirk actions: ", actions)
let !intoList = map (actionsToInto dir) actions
@ -196,7 +196,7 @@ clay env plan =
(applyActionsToMountPoints desk actions)
SyncEfErgo p desk actions -> do
logDebug $ displayShow ("(clay) ergo:", p, desk, actions)
logInfo $ displayShow ("(clay) ergo:", p, desk, actions)
m <- atomically $ readTVar (cdMountPoints cd)
let mountPoint = M.findWithDefault M.empty desk m
@ -211,7 +211,7 @@ clay env plan =
(applyActionsToMountPoints desk hashedActions)
SyncEfOgre p desk -> do
logDebug $ displayShow ("(clay) ogre:", p, desk)
logInfo $ displayShow ("(clay) ogre:", p, desk)
pierPath <- view pierPathL
removeDirectoryRecursive $ pierPath </> deskToPath desk
atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
@ -229,13 +229,13 @@ clay env plan =
performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int))
-> RIO e ()
performAction m (fp, Nothing) = do
logDebug $ displayShow ("(clay) deleting file ", fp)
logInfo $ displayShow ("(clay) deleting file ", fp)
removeFile fp
performAction m (fp, Just ((Mime _ (File (Octs bs)), hash)))
| skip = logDebug $
| skip = logInfo $
displayShow ("(clay) skipping unchanged file update " , fp)
| otherwise = do
logDebug $ displayShow ("(clay) updating file " , fp)
logInfo $ displayShow ("(clay) updating file " , fp)
createDirectoryIfMissing True $ takeDirectory fp
writeFile fp bs
where

456
pkg/hs/urbit-king/lib/Urbit/Vere/Dawn.hs
View File

@ -2,54 +2,60 @@
Use etherium to access PKI information.
-}
module Urbit.Vere.Dawn where
module Urbit.Vere.Dawn ( dawnVent
, dawnCometList
, renderShip
, mineComet
-- Used only in testing
, mix
, shas
, shaf
, cometFingerprintBS
, cometFingerprint
) where
import Urbit.Arvo.Common
import Urbit.Arvo.Event hiding (Address)
import Urbit.Prelude hiding (Call, rights, to)
import Urbit.Prelude hiding (Call, rights, to, (.=))
import Data.Bifunctor (bimap)
import Data.Bits (xor)
import Data.List (nub)
import Data.Text (splitOn)
import Network.Ethereum.Account
import Network.Ethereum.Api.Eth
import Network.Ethereum.Api.Provider
import Network.Ethereum.Api.Types hiding (blockNumber)
import Network.Ethereum.Web3
import Network.HTTP.Client.TLS
import Data.Aeson
import Data.HexString
import Numeric (showHex)
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Hash.SHA512 as SHA512
import qualified Crypto.Sign.Ed25519 as Ed
import qualified Data.Binary as B
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import qualified Network.Ethereum.Ens as Ens
import qualified Data.ByteString.Lazy as L
import qualified Network.HTTP.Client as C
import qualified Urbit.Azimuth as AZ
import qualified Urbit.Ob as Ob
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Types as HT
-- During boot, use the infura provider
provider = HttpProvider
"https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"
provider :: String
provider = "http://eth-mainnet.urbit.org:8545"
-- The address of the azimuth contract as a string.
azimuthAddr :: Text
azimuthAddr = "0x223c067f8cf28ae173ee5cafea60ca44c335fecb"
-- Conversion Utilities --------------------------------------------------------
-- Takes the web3's bytes representation and changes the endianness.
bytes32ToBS :: BytesN 32 -> ByteString
bytes32ToBS = reverse . BA.pack . BA.unpack
passFromBS :: ByteString -> ByteString -> ByteString -> Pass
passFromBS enc aut sut
| bytesAtom sut /= 1 = Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
| otherwise = Pass (Ed.PublicKey aut) (Ed.PublicKey enc)
toBloq :: Quantity -> Bloq
toBloq = fromIntegral . unQuantity
passFromEth :: BytesN 32 -> BytesN 32 -> UIntN 32 -> Pass
passFromEth enc aut sut | sut /= 1 =
Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
passFromEth enc aut sut =
Pass (decode aut) (decode enc)
where
decode = Ed.PublicKey . bytes32ToBS
bsToBool :: ByteString -> Bool
bsToBool bs = bytesAtom bs == 1
clanFromShip :: Ship -> Ob.Class
clanFromShip = Ob.clan . Ob.patp . fromIntegral
@ -60,6 +66,13 @@ shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
renderShip :: Ship -> Text
renderShip = Ob.renderPatp . Ob.patp . fromIntegral
hexStrToAtom :: Text -> Atom
hexStrToAtom =
bytesAtom . reverse . toBytes . hexString . removePrefix . encodeUtf8
onLeft :: (a -> b) -> Either a c -> Either b c
onLeft fun = bimap fun id
-- Data Validation -------------------------------------------------------------
-- Derive public key structure from the key derivation seed structure
@ -73,85 +86,261 @@ ringToPass Ring{..} = Pass{..}
Nothing -> error "Invalid seed passed to createKeypairFromSeed"
Just x -> x
-- JSONRPC Functions -----------------------------------------------------------
-- The big problem here is that we can't really use the generated web3 wrappers
-- around the azimuth contracts, especially for the galaxy table request. They
-- make multiple rpc invocations per galaxy request (which aren't even
-- batched!), while Vere built a single batched rpc call to fetch the entire
-- galaxy table.
--
-- The included Network.JsonRpc.TinyClient that Network.Web3 embeds can't do
-- batches, so calling that directly is out.
--
-- Network.JSONRPC appears to not like something about the JSON that Infura
-- returns; it's just hanging? Also no documentation.
--
-- So, like with Vere, we roll our own.
dawnSendHTTP :: String -> L.ByteString -> RIO e (Either Int L.ByteString)
dawnSendHTTP endpoint requestData = liftIO do
manager <- C.newManager TLS.tlsManagerSettings
initialRequest <- C.parseRequest endpoint
let request = initialRequest
{ C.method = "POST"
, C.requestBody = C.RequestBodyLBS $ requestData
, C.requestHeaders = [("Accept", "application/json"),
("Content-Type", "application/json"),
("Charsets", "utf-8")]
}
response <- C.httpLbs request manager
-- Return body if 200.
let code = HT.statusCode $ C.responseStatus response
case code of
200 -> pure $ Right $ C.responseBody response
_ -> pure $ Left code
class RequestMethod m where
getRequestMethod :: m -> Text
data RawResponse = RawResponse
{ rrId :: Int
, rrResult :: Text
}
deriving (Show)
instance FromJSON RawResponse where
parseJSON = withObject "Response" $ \v -> do
rrId <- v .: "id"
rrResult <- v .: "result"
pure RawResponse{..}
-- Given a list of methods and parameters, return a list of decoded responses.
dawnPostRequests :: forall req e resp
. (ToJSON req, RequestMethod req)
=> String
-> (req -> Text -> resp)
-> [req]
-> RIO e [resp]
dawnPostRequests endpoint responseBuilder requests = do
-- Encode our input requests
let requestPayload =
encode $ Array $ fromList $ fmap toFullRequest $ zip [0..] requests
-- Send to the server
responses <- dawnSendHTTP endpoint requestPayload >>= \case
Left err -> error $ "error fetching " <> provider <> ": HTTP " <> (show err)
Right x -> pure x
-- Get a list of the result texts in the order of the submitted requests
rawSorted <- case decode responses of
Nothing -> error $ "couldn't decode json"
Just x -> pure $ map rrResult $ sortOn rrId x
-- Build the final result structure by calling the passed in builder with the
-- request (some outputs need data from the request structure, eitherwise,
-- we'd lean on FromJSON).
let results = map (uncurry responseBuilder) (zip requests rawSorted)
pure results
where
toFullRequest :: (Int, req) -> Value
toFullRequest (rid, req) = object [ "jsonrpc" .= ("2.0" :: Text)
, "method" .= getRequestMethod req
, "params" .= req
, "id" .= rid
]
-- Azimuth JSON Requests -------------------------------------------------------
-- Not a full implementation of the Ethereum ABI, but just the ability to call
-- a method by encoded id (like 0x63fa9a87 for `points(uint32)`), and a single
-- UIntN 32 parameter.
encodeCall :: Text -> Int -> Text
encodeCall method idx = method <> leadingZeroes <> renderedNumber
where
renderedNumber = pack $ showHex idx ""
leadingZeroes = replicate (64 - length renderedNumber) '0'
data BlockRequest = BlockRequest
deriving (Show, Eq)
instance RequestMethod BlockRequest where
getRequestMethod BlockRequest = "eth_blockNumber"
instance ToJSON BlockRequest where
toJSON BlockRequest = Array $ fromList []
-- No need to parse, it's already in the format we'll pass as an argument to
-- eth calls which take a block number.
parseBlockRequest :: BlockRequest -> Text -> TextBlockNum
parseBlockRequest _ txt = txt
type TextBlockNum = Text
data PointRequest = PointRequest
{ grqHexBlockNum :: TextBlockNum
, grqPointId :: Int
} deriving (Show, Eq)
instance RequestMethod PointRequest where
getRequestMethod PointRequest{..} = "eth_call"
instance ToJSON PointRequest where
-- 0x63fa9a87 is the points(uint32) call.
toJSON PointRequest{..} =
Array $ fromList [object [ "to" .= azimuthAddr
, "data" .= encodeCall "0x63fa9a87" grqPointId],
String grqHexBlockNum
]
parseAndChunkResultToBS :: Text -> [ByteString]
parseAndChunkResultToBS result =
map reverse $
chunkBytestring 32 $
toBytes $
hexString $
removePrefix $
encodeUtf8 result
-- The incoming result is a text bytestring. We need to take that text, and
-- spit out the parsed data.
--
-- We're sort of lucky here. After removing the front "0x", we can just chop
-- the incoming text string into 10 different 64 character chunks and then
-- parse them as numbers.
parseEthPoint :: PointRequest -> Text -> EthPoint
parseEthPoint PointRequest{..} result = EthPoint{..}
where
[rawEncryptionKey,
rawAuthenticationKey,
rawHasSponsor,
rawActive,
rawEscapeRequested,
rawSponsor,
rawEscapeTo,
rawCryptoSuite,
rawKeyRevision,
rawContinuityNum] = parseAndChunkResultToBS result
escapeState = if bsToBool rawEscapeRequested
then Just $ Ship $ fromIntegral $ bytesAtom rawEscapeTo
else Nothing
-- Vere doesn't set ownership information, neither did the old Dawn.hs
-- implementation.
epOwn = (0, 0, 0, 0)
epNet = if not $ bsToBool rawActive
then Nothing
else Just
( fromIntegral $ bytesAtom rawKeyRevision
, passFromBS rawEncryptionKey rawAuthenticationKey rawCryptoSuite
, fromIntegral $ bytesAtom rawContinuityNum
, (bsToBool rawHasSponsor,
Ship (fromIntegral $ bytesAtom rawSponsor))
, escapeState
)
-- I don't know what this is supposed to be, other than the old Dawn.hs and
-- dawn.c do the same thing.
epKid = case clanFromShip (Ship $ fromIntegral grqPointId) of
Ob.Galaxy -> Just (0, setToHoonSet mempty)
Ob.Star -> Just (0, setToHoonSet mempty)
_ -> Nothing
-- Preprocess data from a point request into the form used in the galaxy table.
parseGalaxyTableEntry :: PointRequest -> Text -> (Ship, (Rift, Life, Pass))
parseGalaxyTableEntry PointRequest{..} result = (ship, (rift, life, pass))
where
[rawEncryptionKey,
rawAuthenticationKey,
_, _, _, _, _,
rawCryptoSuite,
rawKeyRevision,
rawContinuityNum] = parseAndChunkResultToBS result
ship = Ship $ fromIntegral grqPointId
rift = fromIntegral $ bytesAtom rawContinuityNum
life = fromIntegral $ bytesAtom rawKeyRevision
pass = passFromBS rawEncryptionKey rawAuthenticationKey rawCryptoSuite
removePrefix :: ByteString -> ByteString
removePrefix withOhEx
| prefix == "0x" = suffix
| otherwise = error "not prefixed with 0x"
where
(prefix, suffix) = splitAt 2 withOhEx
chunkBytestring :: Int -> ByteString -> [ByteString]
chunkBytestring size bs
| null rest = [cur]
| otherwise = (cur : chunkBytestring size rest)
where
(cur, rest) = splitAt size bs
data TurfRequest = TurfRequest
{ trqHexBlockNum :: TextBlockNum
, trqTurfId :: Int
} deriving (Show, Eq)
instance RequestMethod TurfRequest where
getRequestMethod TurfRequest{..} = "eth_call"
instance ToJSON TurfRequest where
-- 0xeccc8ff1 is the dnsDomains(uint32) call.
toJSON TurfRequest{..} =
Array $ fromList [object [ "to" .= azimuthAddr
, "data" .= encodeCall "0xeccc8ff1" trqTurfId],
String trqHexBlockNum
]
-- This is another hack instead of a full Ethereum ABI response.
parseTurfResponse :: TurfRequest -> Text -> Turf
parseTurfResponse a raw = turf
where
without0x = removePrefix $ encodeUtf8 raw
(_, blRest) = splitAt 64 without0x
(utfLenStr, utfStr) = splitAt 64 blRest
utfLen = fromIntegral $ bytesAtom $ reverse $ toBytes $ hexString utfLenStr
dnsStr = decodeUtf8 $ BS.take utfLen $ toBytes $ hexString utfStr
turf = Turf $ fmap Cord $ reverse $ splitOn "." dnsStr
-- Azimuth Functions -----------------------------------------------------------
-- Perform a request to azimuth at a certain block number
withAzimuth :: Quantity
-> Address
-> DefaultAccount Web3 a
-> Web3 a
withAzimuth bloq azimuth action =
withAccount () $
withParam (to .~ azimuth) $
withParam (block .~ BlockWithNumber bloq)
action
retrievePoint :: String -> TextBlockNum -> Ship -> RIO e EthPoint
retrievePoint endpoint block ship =
dawnPostRequests provider parseEthPoint
[PointRequest block (fromIntegral ship)] >>= \case
[x] -> pure x
_ -> error "JSON server returned multiple return values."
-- Retrieves the EthPoint information for an individual point.
retrievePoint :: Quantity -> Address -> Ship -> Web3 EthPoint
retrievePoint bloq azimuth ship =
withAzimuth bloq azimuth $ do
(encryptionKey,
authenticationKey,
hasSponsor,
active,
escapeRequested,
sponsor,
escapeTo,
cryptoSuite,
keyRevision,
continuityNum) <- AZ.points (fromIntegral ship)
let escapeState = if escapeRequested
then Just $ Ship $ fromIntegral escapeTo
else Nothing
-- The hoon version also sets this to all 0s and then does nothing with it.
let epOwn = (0, 0, 0, 0)
let epNet = if not active
then Nothing
else Just
( fromIntegral keyRevision
, passFromEth encryptionKey authenticationKey cryptoSuite
, fromIntegral continuityNum
, (hasSponsor, Ship (fromIntegral sponsor))
, escapeState
)
-- TODO: wtf?
let epKid = case clanFromShip ship of
Ob.Galaxy -> Just (0, setToHoonSet mempty)
Ob.Star -> Just (0, setToHoonSet mempty)
_ -> Nothing
pure EthPoint{..}
-- Retrieves information about all the galaxies from Ethereum.
retrieveGalaxyTable :: Quantity -> Address -> Web3 (Map Ship (Rift, Life, Pass))
retrieveGalaxyTable bloq azimuth =
withAzimuth bloq azimuth $ mapFromList <$> mapM getRow [0..255]
where
getRow idx = do
(encryptionKey, authenticationKey, _, _, _, _, _, cryptoSuite,
keyRev, continuity) <- AZ.points idx
pure ( fromIntegral idx
, ( fromIntegral continuity
, fromIntegral keyRev
, passFromEth encryptionKey authenticationKey cryptoSuite
)
)
-- Reads the three Ames domains from Ethereum, removing duplicates
readAmesDomains :: Quantity -> Address -> Web3 [Turf]
readAmesDomains bloq azimuth =
withAzimuth bloq azimuth $ nub <$> mapM getTurf [0..2]
where
getTurf idx =
Turf . fmap Cord . reverse . splitOn "." <$> AZ.dnsDomains idx
validateShipAndGetImmediateSponsor :: Quantity -> Address -> Seed -> Web3 Ship
validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
validateShipAndGetSponsor :: String -> TextBlockNum -> Seed -> RIO e Ship
validateShipAndGetSponsor endpoint block (Seed ship life ring oaf) =
case clanFromShip ship of
Ob.Comet -> validateComet
Ob.Moon -> validateMoon
@ -161,7 +350,7 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
-- A comet address is the fingerprint of the keypair
let shipFromPass = cometFingerprint $ ringToPass ring
when (ship /= shipFromPass) $
fail ("comet name doesn't match fingerprint " ++ show ship ++ " vs " ++
fail ("comet name doesn't match fingerprint " <> show ship <> " vs " <>
show shipFromPass)
when (life /= 1) $
fail ("comet can never be re-keyed")
@ -174,15 +363,15 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
pure $ shipSein ship
validateRest = do
putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys")
putStrLn ("boot: retrieving " <> renderShip ship <> "'s public keys")
whoP <- retrievePoint block azimuth ship
whoP <- retrievePoint endpoint block ship
case epNet whoP of
Nothing -> fail "ship not keyed"
Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
when (netLife /= life) $
fail ("keyfile life mismatch; keyfile claims life " ++
show life ++ ", but Azimuth claims life " ++
fail ("keyfile life mismatch; keyfile claims life " <>
show life <> ", but Azimuth claims life " <>
show netLife)
when ((ringToPass ring) /= pass) $
fail "keyfile does not match blockchain"
@ -193,62 +382,67 @@ validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
-- Walk through the sponsorship chain retrieving the actual sponsorship chain
-- as it exists on Ethereum.
getSponsorshipChain :: Quantity -> Address -> Ship -> Web3 [(Ship,EthPoint)]
getSponsorshipChain block azimuth = loop
getSponsorshipChain :: String -> TextBlockNum -> Ship -> RIO e [(Ship,EthPoint)]
getSponsorshipChain endpoint block = loop
where
loop ship = do
putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship)
ethPoint <- retrievePoint block azimuth ship
putStrLn ("boot: retrieving keys for sponsor " <> renderShip ship)
ethPoint <- retrievePoint endpoint block ship
case (clanFromShip ship, epNet ethPoint) of
(Ob.Comet, _) -> fail "Comets cannot be sponsors"
(Ob.Moon, _) -> fail "Moons cannot be sponsors"
(_, Nothing) ->
fail $ unpack ("Ship " ++ renderShip ship ++ " not booted")
fail $ unpack ("Ship " <> renderShip ship <> " not booted")
(Ob.Galaxy, Just _) -> pure [(ship, ethPoint)]
(_, Just (_, _, _, (False, _), _)) ->
fail $ unpack ("Ship " ++ renderShip ship ++ " has no sponsor")
fail $ unpack ("Ship " <> renderShip ship <> " has no sponsor")
(_, Just (_, _, _, (True, sponsor), _)) -> do
chain <- loop sponsor
pure $ chain ++ [(ship, ethPoint)]
pure $ chain <> [(ship, ethPoint)]
-- Produces either an error or a validated boot event structure.
dawnVent :: Seed -> RIO e (Either Text Dawn)
dawnVent dSeed@(Seed ship life ring oaf) = do
ret <- runWeb3' provider $ do
block <- blockNumber
putStrLn ("boot: ethereum block #" ++ tshow block)
dawnVent :: HasLogFunc e => Seed -> RIO e (Either Text Dawn)
dawnVent dSeed@(Seed ship life ring oaf) =
-- The type checker can't figure this out on its own.
(onLeft tshow :: Either SomeException Dawn -> Either Text Dawn) <$> try do
blockResponses
<- dawnPostRequests provider parseBlockRequest [BlockRequest]
putStrLn "boot: retrieving azimuth contract"
azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
hexStrBlock <- case blockResponses of
[num] -> pure num
x -> error "Unexpected multiple returns from block # request"
immediateSponsor <- validateShipAndGetImmediateSponsor block azimuth dSeed
dSponsor <- getSponsorshipChain block azimuth immediateSponsor
let dBloq = hexStrToAtom hexStrBlock
putStrLn ("boot: ethereum block #" <> tshow dBloq)
immediateSponsor <- validateShipAndGetSponsor provider hexStrBlock dSeed
dSponsor <- getSponsorshipChain provider hexStrBlock immediateSponsor
putStrLn "boot: retrieving galaxy table"
dCzar <- mapToHoonMap <$> retrieveGalaxyTable block azimuth
dCzar <- (mapToHoonMap . mapFromList) <$>
(dawnPostRequests provider parseGalaxyTableEntry $
map (PointRequest hexStrBlock) [0..255])
putStrLn "boot: retrieving network domains"
dTurf <- readAmesDomains block azimuth
dTurf <- nub <$> (dawnPostRequests provider parseTurfResponse $
map (TurfRequest hexStrBlock) [0..2])
let dBloq = toBloq block
let dNode = Nothing
pure $ MkDawn{..}
case ret of
Left x -> pure $ Left $ tshow x
Right y -> pure $ Right y
-- Comet List ------------------------------------------------------------------
dawnCometList :: RIO e [Ship]
dawnCometList = do
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
manager <- io $ C.newManager TLS.tlsManagerSettings
request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam"
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response

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

@ -11,7 +11,7 @@ where
import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.King.App (HasKingId(..), HasMultiEyreApi(..), HasPierEnv(..))
import Urbit.King.Config
import Urbit.Vere.Eyre.Multi
import Urbit.Vere.Eyre.PortsFile
@ -170,15 +170,17 @@ execRespActs (Drv v) who reqId ev = readMVar v >>= \case
atomically (routeRespAct who (sLiveReqs sv) reqId act)
startServ
:: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
=> MultiEyreApi
-> Ship
:: (HasPierConfig e, HasLogFunc e, HasMultiEyreApi e, HasNetworkConfig e)
=> Ship
-> Bool
-> HttpServerConf
-> (EvErr -> STM ())
-> (Text -> RIO e ())
-> RIO e Serv
startServ multi who isFake conf plan = do
logDebug (displayShow ("EYRE", "startServ"))
startServ who isFake conf plan stderr = do
logInfo (displayShow ("EYRE", "startServ"))
multi <- view multiEyreApiL
let vLive = meaLive multi
@ -219,11 +221,11 @@ startServ multi who isFake conf plan = do
let onKilReq :: Ship -> Word64 -> STM ()
onKilReq _ship = plan . cancelEv srvId . fromIntegral
logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
logInfo (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
atomically (joinMultiEyre multi who mCre onReq onKilReq)
logDebug $ displayShow ("EYRE", "Starting loopback server")
logInfo $ displayShow ("EYRE", "Starting loopback server")
lop <- serv vLive $ ServConf
{ scHost = soHost (pttLop ptt)
, scPort = soWhich (pttLop ptt)
@ -235,7 +237,7 @@ startServ multi who isFake conf plan = do
}
}
logDebug $ displayShow ("EYRE", "Starting insecure server")
logInfo $ displayShow ("EYRE", "Starting insecure server")
ins <- serv vLive $ ServConf
{ scHost = soHost (pttIns ptt)
, scPort = soWhich (pttIns ptt)
@ -248,7 +250,7 @@ startServ multi who isFake conf plan = do
}
mSec <- for mTls $ \tls -> do
logDebug "Starting secure server"
logInfo "Starting secure server"
serv vLive $ ServConf
{ scHost = soHost (pttSec ptt)
, scPort = soWhich (pttSec ptt)
@ -269,7 +271,11 @@ startServ multi who isFake conf plan = do
let por = Ports secPor insPor lopPor
fil = pierPath <> "/.http.ports"
logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
logInfo $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
for secPor $ \p ->
stderr ("http: secure web interface live on https://localhost:" <> tshow p)
stderr ("http: web interface live on http://localhost:" <> tshow insPor)
stderr ("http: loopback live on http://localhost:" <> tshow lopPor)
pure (Serv srvId conf lop ins mSec por fil vLive)
@ -281,16 +287,18 @@ _bornFailed env _ = runRIO env $ do
pure () -- TODO What should this do?
eyre'
:: HasPierEnv e
=> MultiEyreApi
-> Ship
:: (HasPierEnv e, HasMultiEyreApi e)
=> Ship
-> Bool
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
eyre' multi who isFake = do
eyre' who isFake stderr = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = eyre env multi who (writeTQueue ventQ) isFake
let (bornEvs, startDriver) =
eyre env who (writeTQueue ventQ) isFake stderr
let runDriver = do
diOnEffect <- startDriver
@ -315,14 +323,15 @@ eyre
:: forall e
. (HasPierEnv e)
=> e
-> MultiEyreApi
-> Ship
-> (EvErr -> STM ())
-> Bool
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
eyre env multi who plan isFake = (initialEvents, runHttpServer)
eyre env who plan isFake stderr = (initialEvents, runHttpServer)
where
king = fromIntegral (env ^. kingIdL)
multi = env ^. multiEyreApiL
initialEvents :: [Ev]
initialEvents = [bornEv king]
@ -342,10 +351,10 @@ eyre env multi who plan isFake = (initialEvents, runHttpServer)
restart :: Drv -> HttpServerConf -> RIO e Serv
restart (Drv var) conf = do
logDebug "Restarting http server"
let startAct = startServ multi who isFake conf plan
logInfo "Restarting http server"
let startAct = startServ who isFake conf plan stderr
res <- fromEither =<< restartService var startAct kill
logDebug "Done restating http server"
logInfo "Done restating http server"
pure res
liveFailed _ = pure ()
@ -353,11 +362,11 @@ eyre env multi who plan isFake = (initialEvents, runHttpServer)
handleEf :: Drv -> HttpServerEf -> IO ()
handleEf drv = runRIO env . \case
HSESetConfig (i, ()) conf -> do
logDebug (displayShow ("EYRE", "%set-config"))
logInfo (displayShow ("EYRE", "%set-config"))
Serv {..} <- restart drv conf
logDebug (displayShow ("EYRE", "%set-config", "Sending %live"))
logInfo (displayShow ("EYRE", "%set-config", "Sending %live"))
atomically $ plan (EvErr (liveEv sServId sPorts) liveFailed)
logDebug "Write ports file"
logInfo "Write ports file"
io (writePortsFile sPortsFile sPorts)
HSEResponse (i, req, _seq, ()) ev -> do
logDebug (displayShow ("EYRE", "%response"))

6
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs
View File

@ -72,7 +72,7 @@ leaveMultiEyre MultiEyreApi {..} who = do
multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
multiEyre conf@MultiEyreConf {..} = do
logDebug (displayShow ("EYRE", "MULTI", conf))
logInfo (displayShow ("EYRE", "MULTI", conf))
vLive <- io emptyLiveReqs >>= newTVarIO
vPlan <- newTVarIO mempty
@ -96,7 +96,7 @@ multiEyre conf@MultiEyreConf {..} = do
Just cb -> cb who reqId
mIns <- for mecHttpPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTP", por))
logInfo (displayShow ("EYRE", "MULTI", "HTTP", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por
@ -109,7 +109,7 @@ multiEyre conf@MultiEyreConf {..} = do
}
mSec <- for mecHttpsPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTPS", por))
logInfo (displayShow ("EYRE", "MULTI", "HTTPS", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por

10
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs
View File

@ -164,7 +164,7 @@ tryOpenChoices
tryOpenChoices hos = go
where
go (p :| ps) = do
logDebug (displayShow ("EYRE", "Trying to open port.", p))
logInfo (displayShow ("EYRE", "Trying to open port.", p))
io (tryOpen hos p) >>= \case
Left err -> do
logError (displayShow ("EYRE", "Failed to open port.", p))
@ -185,7 +185,7 @@ tryOpenAny hos = do
pure (Right (p, s))
logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
logDbg ctx msg = logDebug (prefix <> suffix)
logDbg ctx msg = logInfo (prefix <> suffix)
where
prefix = display (concat $ fmap (<> ": ") ctx)
suffix = displayShow msg
@ -312,7 +312,7 @@ configCreds TlsConfig {..} =
fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi
fakeServ conf = do
let por = fakePort (scPort conf)
logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por))
logInfo (displayShow ("EYRE", "SERV", "Running Fake Server", por))
pure $ ServApi
{ saKil = pure ()
, saPor = pure por
@ -331,7 +331,7 @@ getFirstTlsConfig (MTC var) = do
realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
realServ vLive conf@ServConf {..} = do
logDebug (displayShow ("EYRE", "SERV", "Running Real Server"))
logInfo (displayShow ("EYRE", "SERV", "Running Real Server"))
kil <- newEmptyTMVarIO
por <- newEmptyTMVarIO
@ -344,7 +344,7 @@ realServ vLive conf@ServConf {..} = do
}
where
runServ vPort = do
logDebug (displayShow ("EYRE", "SERV", "runServ"))
logInfo (displayShow ("EYRE", "SERV", "runServ"))
rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
atomically (putTMVar vPort por)
startServer scType scHost por sok scRedi vLive

8
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Service.hs
View File

@ -31,21 +31,21 @@ restartService
-> (s -> RIO e ())
-> RIO e (Either SomeException s)
restartService vServ sstart kkill = do
logDebug "restartService"
logInfo "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"
logInfo "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"
logInfo "doStart"
try sstart <&> \case
Right s -> (Just s, Right s)
Left exn -> (Nothing, Left exn)
@ -59,7 +59,7 @@ stopService
-> (s -> RIO e ())
-> RIO e (Either SomeException ())
stopService vServ kkill = do
logDebug "stopService"
logInfo "stopService"
modifyMVar vServ $ \case
Nothing -> pure (Nothing, Right ())
Just sv -> do

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

@ -179,7 +179,7 @@ streamBlocks env init getAct = send init >> loop
send "" = pure ()
send c = do
runRIO env (logTrace (display ("sending chunk " <> tshow c)))
runRIO env (logDebug (display ("sending chunk " <> tshow c)))
yield $ Chunk $ fromByteString c
yield Flush

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

@ -140,7 +140,7 @@ client env plan = (initialEvents, runHttpClient)
runReq HttpClientDrv{..} id req = async $
case cvtReq req of
Nothing -> do
logDebug $ displayShow ("(malformed http client request)", id, req)
logInfo $ displayShow ("(malformed http client request)", id, req)
planEvent id (Cancel ())
Just r -> do
logDebug $ displayShow ("(http client request)", id, req)

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

@ -226,7 +226,7 @@ readRowsBatch :: ∀e. HasLogFunc e
readRowsBatch env dbi first = readRows
where
readRows = do
logDebug $ display ("(readRowsBatch) From: " <> tshow first)
logInfo $ display ("(readRowsBatch) From: " <> tshow first)
withWordPtr first $ \pIdx ->
withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
rwith (readTxn env) $ \txn ->

10
pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs
View File

@ -82,7 +82,7 @@ wsConn pre inp out wsc = do
flip finally cleanup $ do
res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
logDebug $ displayShow (res :: Either SomeException ())
logInfo $ displayShow (res :: Either SomeException ())
--------------------------------------------------------------------------------
@ -95,7 +95,7 @@ wsClient pax por = do
out <- io $ newTBMChanIO 5
con <- pure (mkConn inp out)
logDebug "NOUNSERV (wsClie) Trying to connect"
logInfo "NOUNSERV (wsClie) Trying to connect"
tid <- io $ async
$ WS.runClient "127.0.0.1" por (unpack pax)
@ -111,7 +111,7 @@ wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
-> WS.PendingConnection
-> RIO e ()
wsServApp cb pen = do
logDebug "NOUNSERV (wsServer) Got connection!"
logInfo "NOUNSERV (wsServer) Got connection!"
wsc <- io $ WS.acceptRequest pen
inp <- io $ newTBMChanIO 5
out <- io $ newTBMChanIO 5
@ -125,10 +125,10 @@ wsServer = do
tid <- async $ do
env <- ask
logDebug "NOUNSERV (wsServer) Starting server"
logInfo "NOUNSERV (wsServer) Starting server"
io $ WS.runServer "127.0.0.1" 9999
$ runRIO env . wsServApp (writeTBMChan con)
logDebug "NOUNSERV (wsServer) Server died"
logInfo "NOUNSERV (wsServer) Server died"
atomically $ closeTBMChan con
pure $ Server (readTBMChan con) tid 9999

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

@ -25,12 +25,13 @@ import Urbit.King.App
import Urbit.Vere.Pier.Types
import Control.Monad.STM (retry)
import System.Environment (getExecutablePath)
import System.FilePath (splitFileName, (</>))
import System.Posix.Files (ownerModes, setFileMode)
import Urbit.EventLog.LMDB (EventLog)
import Urbit.King.API (TermConn)
import Urbit.Noun.Time (Wen)
import Urbit.TermSize (TermSize(..))
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
import Urbit.Vere.Serf (Serf)
import qualified Data.Text as T
@ -122,17 +123,25 @@ runSerf
-> RAcquire e Serf
runSerf vSlog pax = do
env <- ask
Serf.withSerf (config env)
serfProg <- io getSerfProg
Serf.withSerf (config env serfProg)
where
slog txt = atomically (readTVar vSlog) >>= (\f -> f txt)
config env = Serf.Config
{ scSerf = env ^. pierConfigL . pcSerfExe . to unpack
config env serfProg = Serf.Config
{ scSerf = env ^. pierConfigL . pcSerfExe . to (maybe serfProg unpack)
, scPier = pax
, scFlag = env ^. pierConfigL . pcSerfFlags
, scSlog = \(pri, tank) -> printTank slog pri tank
, scStdr = \txt -> slog (txt <> "\r\n")
, scDead = pure () -- TODO: What can be done?
}
getSerfProg :: IO FilePath
getSerfProg = do
(path, filename) <- splitFileName <$> getExecutablePath
pure $ case filename of
"urbit" -> path </> "urbit-worker"
"urbit-king" -> path </> "urbit-worker"
_ -> "urbit-worker"
-- Boot a new ship. ------------------------------------------------------------
@ -169,21 +178,21 @@ bootNewShip
-> RIO e ()
bootNewShip pill lite ship bootEv = do
seq@(BootSeq ident x y) <- genBootSeq ship pill lite bootEv
logDebug "BootSeq Computed"
logInfo "BootSeq Computed"
pierPath <- view pierPathL
rio (setupPierDirectory pierPath)
logDebug "Directory setup."
logInfo "Directory setup."
let logPath = (pierPath </> ".urb/log")
rwith (Log.new logPath ident) $ \log -> do
logDebug "Event log onitialized."
logInfo "Event log onitialized."
jobs <- (\now -> bootSeqJobs now seq) <$> io Time.now
writeJobs log (fromList jobs)
logDebug "Finsihed populating event log with boot sequence"
logInfo "Finsihed populating event log with boot sequence"
-- Resume an existing ship. ----------------------------------------------------
@ -207,16 +216,16 @@ resumed vSlog replayUntil = do
serf <- runSerf vSlog tap
rio $ do
logDebug "Replaying events"
logInfo "Replaying events"
Serf.execReplay serf log replayUntil >>= \case
Left err -> error (show err)
Right 0 -> do
logDebug "No work during replay so no snapshot"
logInfo "No work during replay so no snapshot"
pure ()
Right _ -> do
logDebug "Taking snapshot"
logInfo "Taking snapshot"
io (Serf.snapshot serf)
logDebug "SNAPSHOT TAKEN"
logInfo "SNAPSHOT TAKEN"
pure (serf, log)
@ -242,14 +251,14 @@ acquireWorker :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
acquireWorker nam act = mkRAcquire (async act) kill
where
kill tid = do
logDebug ("Killing worker thread: " <> display nam)
logInfo ("Killing worker thread: " <> display nam)
cancel tid
acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
where
kill tid = do
logDebug ("Killing worker thread: " <> display nam)
logInfo ("Killing worker thread: " <> display nam)
cancel tid
@ -260,9 +269,8 @@ pier
:: (Serf, EventLog)
-> TVar (Text -> IO ())
-> MVar ()
-> MultiEyreApi
-> RAcquire PierEnv ()
pier (serf, log) vSlog startedSig multi = do
pier (serf, log) vSlog startedSig = do
let logId = Log.identity log :: LogIdentity
let ship = who logId :: Ship
@ -285,11 +293,11 @@ pier (serf, log) vSlog startedSig multi = do
pure (res, Term.useDemux res)
void $ acquireWorker "TERMSERV Listener" $ forever $ do
logDebug "TERMSERV Waiting for external terminal."
logInfo "TERMSERV Waiting for external terminal."
atomically $ do
ext <- Term.connClient <$> readTQueue termApiQ
Term.addDemux ext demux
logDebug "TERMSERV External terminal connected."
logInfo "TERMSERV External terminal connected."
-- Slogs go to both stderr and to the terminal.
env <- ask
@ -311,7 +319,7 @@ pier (serf, log) vSlog startedSig multi = do
let err = atomically . Term.trace muxed . (<> "\r\n")
let siz = TermSize { tsWide = 80, tsTall = 24 }
let fak = isFake logId
drivers env multi ship fak compute (siz, muxed) err sigint
drivers env ship fak compute (siz, muxed) err sigint
scrySig <- newEmptyTMVarIO
onKill <- view onKillPierSigL
@ -369,7 +377,7 @@ pier (serf, log) vSlog startedSig multi = do
threadDelay 15_000_000
wen <- io Time.now
let kal = \mTermNoun -> runRIO env $ do
logDebug $ displayShow ("scry result: ", mTermNoun)
logInfo $ displayShow ("scry result: ", mTermNoun)
let nkt = MkKnot $ tshow $ Time.MkDate wen
let pax = Path ["j", "~zod", "life", nkt, "~zod"]
atomically $ putTMVar scrySig (wen, Nothing, pax, kal)
@ -412,7 +420,6 @@ data Drivers = Drivers
drivers
:: HasPierEnv e
=> e
-> MultiEyreApi
-> Ship
-> Bool
-> (RunReq -> STM ())
@ -420,11 +427,11 @@ drivers
-> (Text -> RIO e ())
-> IO ()
-> RAcquire e ([Ev], RAcquire e Drivers)
drivers env multi who isFake plan termSys stderr serfSIGINT = do
drivers env who isFake plan termSys stderr serfSIGINT = do
(behnBorn, runBehn) <- rio Behn.behn'
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
(httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake)
(httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr)
(clayBorn, runClay) <- rio Clay.clay'
(irisBorn, runIris) <- rio Iris.client'
@ -494,7 +501,7 @@ router slog waitFx Drivers {..} = do
logEvent :: HasLogFunc e => Ev -> RIO e ()
logEvent ev = do
logTrace $ "<- " <> display (summarizeEvent ev)
--logInfo $ "<- " <> display (summarizeEvent ev)
logDebug $ "[EVENT]\n" <> display pretty
where
pretty :: Text
@ -502,7 +509,7 @@ logEvent ev = do
logEffect :: HasLogFunc e => Lenient Ef -> RIO e ()
logEffect ef = do
logTrace $ " -> " <> display (summarizeEffect ef)
--logInfo $ " -> " <> display (summarizeEffect ef)
logDebug $ display $ "[EFFECT]\n" <> pretty ef
where
pretty :: Lenient Ef -> Text

314
pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs Normal file
View File

@ -0,0 +1,314 @@
module Urbit.Vere.Ports (HasPortControlApi(..),
PortControlApi,
buildInactivePorts,
buildNatPortsWhenPrivate,
buildNatPorts,
requestPortAccess) where
import Control.Monad.STM (check)
import Urbit.Prelude
import Network.NatPmp
import Data.Time.Clock.POSIX
import Network.Socket
import qualified Data.Heap as DH
-- This module deals with ports and port requests. When a component wants to
-- ensure that it is externally reachable, possibly from outside a NAT, it
-- makes a request to this module to hole-punch.
class HasPortControlApi a where
portControlApiL :: Lens' a PortControlApi
data PortControlApi = PortControlApi
{ pAddPortRequest :: Word16 -> IO ()
, pRemovePortRequest :: Word16 -> IO ()
}
-- | Builds a PortControlApi struct which does nothing when called.
buildInactivePorts :: PortControlApi
buildInactivePorts = PortControlApi noop noop
where
noop x = pure ()
-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
-- NAT gateway over NAT-PMP iff we are on a private network ip.
buildNatPortsWhenPrivate :: (HasLogFunc e)
=> (Text -> RIO e ())
-> RIO e PortControlApi
buildNatPortsWhenPrivate stderr = do
behind <- likelyBehindRouter
if behind
then buildNatPorts stderr
else pure buildInactivePorts
-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
-- NAT gateway over NAT-PMP.
buildNatPorts :: (HasLogFunc e)
=> (Text -> RIO e ())
-> RIO e PortControlApi
buildNatPorts stderr = do
q <- newTQueueIO
async $ portThread q stderr
let addRequest port = do
resp <- newEmptyTMVarIO
atomically $
writeTQueue q (PTMOpen port (putTMVar resp True))
atomically $ takeTMVar resp
pure ()
let removeRequest port = atomically $ writeTQueue q (PTMClose port)
pure $ PortControlApi addRequest removeRequest
portLeaseLifetime :: Word32
portLeaseLifetime = 15 * 60
-- Be paranoid and renew leases a full minute before they would naturally expire.
portRenewalTime :: Word32
portRenewalTime = portLeaseLifetime - 60
-- Number of retries before we give up on performing nat operations.
maxRetries :: Int
maxRetries = 3
-- How long to wait between retries.
networkRetryDelay :: Int
networkRetryDelay = 5 * 1_000_000
-- Messages sent from the main thread to the port mapping communication thread.
data PortThreadMsg
= PTMOpen Word16 (STM ())
-- ^ Does the open request, and then runs the passed in stm action to
-- signal completion to the main thread. We want to block on the initial
-- setting opening because we want the forwarding set up before we actually
-- start using the port.
| PTMClose Word16
-- ^ Close command. No synchronization because there's nothing we can do if
-- it fails.
-- We get requests to acquire a port as an RAII condition, but the actual APIs
-- are timeout based, so we have to maintain a heap of the next timer to
-- rerequest port access.
data RenewAction = RenewAction Word16
-- The port thread is an async which reads commands from an STM queue and then
-- executes them. This thread is here to bind the semantics that we want to how
-- NAT-PMP sees the world. We want for an RAcquire to be able to start a
-- request for port forwarding and then to release it when it goes out of
-- scope. OTOH, NAT-PMP is all timeout based, and we want that timeout to be
-- fairly short, such as 15 minutes, so the portThread needs to keep track of
-- the time of the next port request.
portThread :: forall e. (HasLogFunc e)
=> TQueue PortThreadMsg
-> (Text -> RIO e ())
-> RIO e ()
portThread q stderr = do
initNatPmp >>= \case
Left ErrCannotGetGateway -> do
assumeOnPublicInternet
Left err -> do
likelyIPAddress >>= \case
Just ip@(192, 168, _, _) -> warnBehindRouterAndErr ip err
Just ip@(172, x, _, _)
| (x >= 16 && x <= 31) -> warnBehindRouterAndErr ip err
Just ip@(10, _, _, _) -> warnBehindRouterAndErr ip err
_ -> assumeOnPublicInternet
Right pmp -> foundRouter pmp
where
warnBehindRouterAndErr (a, b, c, d) err = do
stderr $ "port: you appear to be behind a router since your ip " ++
"is " ++ (tshow a) ++ "." ++ (tshow b) ++ "." ++ (tshow c) ++
"." ++ (tshow d) ++ ", but " ++
"we could not request port forwarding (NAT-PMP error: " ++
(tshow err) ++ ")"
stderr $ "port: urbit performance will be degregaded unless you " ++
"manually forward your ames port."
loopErr q
assumeOnPublicInternet = do
stderr $ "port: couldn't find router; assuming on public internet"
loopErr q
foundRouter :: NatPmpHandle -> RIO e ()
foundRouter pmp = do
getPublicAddress pmp >>= \case
Left ErrCannotGetGateway -> assumeOnPublicInternet
Left ErrNoGatewaySupport -> assumeOnPublicInternet
Left err -> do
stderr $ "port: received error when asking router for public ip: " ++
(tshow err)
loopErr q
Right addr -> do
let (a, b, c, d) = hostAddressToTuple addr
stderr $ "port: router reports that our public IP is " ++ (tshow a) ++
"." ++ (tshow b) ++ "." ++ (tshow c) ++ "." ++ (tshow d)
loop pmp mempty
loop :: NatPmpHandle -> DH.MinPrioHeap POSIXTime RenewAction -> RIO e ()
loop pmp nextRenew = do
now <- io $ getPOSIXTime
delay <- case DH.viewHead nextRenew of
Nothing -> newTVarIO False
Just (fireTime, _) -> do
let timeTo = fireTime - now
let ms = round $ timeTo * 1000000
registerDelay ms
command <- atomically $
(Left <$> fini delay) <|> (Right <$> readTQueue q)
case command of
Left () -> handleRenew pmp nextRenew
Right msg -> handlePTM pmp msg nextRenew
handlePTM :: NatPmpHandle
-> PortThreadMsg
-> DH.MinPrioHeap POSIXTime RenewAction
-> RIO e ()
handlePTM pmp msg nextRenew = case msg of
PTMOpen p notifyComplete -> do
logInfo $
displayShow ("port: sending initial request to NAT-PMP for port ", p)
setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case
Left err | isResetAndRetry err -> do
closeNatPmp pmp
attemptReestablishNatPmpThen (\pmp -> handlePTM pmp msg nextRenew)
Left err -> do
logError $
displayShow ("port: failed to request NAT-PMP for port ", p,
":", err, ", disabling NAT-PMP")
loopErr q
Right _ -> do
-- Filter any existing references to this port on the heap to ensure
-- we don't double up on tasks.
let filteredHeap = filterPort p nextRenew
now <- io $ getPOSIXTime
let withRenew =
DH.insert (now + fromIntegral portRenewalTime, RenewAction p)
filteredHeap
atomically notifyComplete
loop pmp withRenew
PTMClose p -> do
logInfo $
displayShow ("port: releasing lease for ", p)
setPortMapping pmp PTUdp p p 0
let removed = filterPort p nextRenew
loop pmp removed
handleRenew :: NatPmpHandle
-> DH.MinPrioHeap POSIXTime RenewAction
-> RIO e ()
handleRenew pmp nextRenew = do
case (DH.view nextRenew) of
Nothing -> error "Internal heap managing error."
Just ((_, RenewAction p), rest) -> do
logInfo $
displayShow ("port: sending renewing request to NAT-PMP for port ",
p)
setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case
Left err | isResetAndRetry err -> do
closeNatPmp pmp
attemptReestablishNatPmpThen (\pmp -> handleRenew pmp nextRenew)
Left err -> do
logError $
displayShow ("port: failed to request NAT-PMP for port ", p,
":", err, ". disabling NAT-PMP")
loopErr q
Right _ -> do
-- We don't need to filter the port because we just did.
now <- io $ getPOSIXTime
let withRenew =
DH.insert (now + fromIntegral portRenewalTime, RenewAction p)
rest
loop pmp withRenew
-- If the internal natpmp socket is closed (laptop lid closed, network
-- change, etc), attempt to reestablish a connection.
attemptReestablishNatPmpThen :: (NatPmpHandle -> RIO e ())
-> RIO e ()
attemptReestablishNatPmpThen andThen = do
logInfo $
displayShow ("port: network changed. Attempting NAT reconnect");
loop 0
where
loop :: Int -> RIO e ()
loop tryNum = do
initNatPmp >>= \case
Left err -> do
if tryNum == maxRetries
then do
stderr $ "port: failed to reestablish a connection to your router"
loopErr q
else do
threadDelay networkRetryDelay
loop (tryNum + 1)
Right pmp -> do
andThen pmp
filterPort :: Word16
-> DH.MinPrioHeap POSIXTime RenewAction
-> DH.MinPrioHeap POSIXTime RenewAction
filterPort p = DH.filter okPort
where
okPort (_, RenewAction x) = p /= x
-- block (retry) until the delay TVar is set to True
fini :: TVar Bool -> STM ()
fini = check <=< readTVar
-- The NAT system is considered "off" but we still need to signal back to
-- the main thread that blocking actions are complete.
loopErr q = forever $ do
(atomically $ readTQueue q) >>= \case
PTMOpen _ onComplete -> atomically onComplete
PTMClose _ -> pure ()
-- When we were unable to connect to a router, get the ip address on the
-- default ipv4 interface to check if we look like we're on an internal network
-- or not.
likelyIPAddress :: MonadIO m => m (Maybe (Word8, Word8, Word8, Word8))
likelyIPAddress = liftIO do
-- Try opening a socket to 1.1.1.1 to get our own IP address. Since UDP is
-- stateless and we aren't sending anything, we aren't actually contacting
-- them in any way.
sock <- socket AF_INET Datagram 0
connect sock (SockAddrInet 53 (tupleToHostAddress (1, 1, 1, 1)))
sockAddr <- getSocketName sock
case sockAddr of
SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr
_ -> pure $ Nothing
likelyBehindRouter :: MonadIO m => m Bool
likelyBehindRouter = do
likelyIPAddress >>= \case
Just ip@(192, 168, _, _) -> pure True
Just ip@(172, x, _, _)
| (x >= 16 && x <= 31) -> pure True
Just ip@(10, _, _, _) -> pure True
_ -> pure False
-- Some of the errors that we encounter happen when the underlying sockets have
-- closed out from under us. When this happens, we want to wait a short time
-- and reset the system.
isResetAndRetry :: Error -> Bool
isResetAndRetry ErrRecvFrom = True
isResetAndRetry ErrSendErr = True
isResetAndRetry _ = False
-- Acquire a port for the duration of the RAcquire.
requestPortAccess :: forall e. (HasPortControlApi e) => Word16 -> RAcquire e ()
requestPortAccess port = do
mkRAcquire request release
where
request :: RIO e ()
request = do
api <- view portControlApiL
io $ pAddPortRequest api port
release :: () -> RIO e ()
release _ = do
api <- view portControlApiL
io $ pRemovePortRequest api port

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

@ -40,7 +40,7 @@ withSerf config = mkRAcquire startup kill
where
startup = do
(serf, st) <- io $ start config
logDebug (displayShow ("serf state", st))
logInfo (displayShow ("serf state", st))
pure serf
kill serf = do
void $ rio $ stop serf
@ -58,7 +58,7 @@ execReplay serf log last = do
where
doBoot :: RIO e (Either PlayBail Word)
doBoot = do
logDebug "Beginning boot sequence"
logInfo "Beginning boot sequence"
let bootSeqLen = lifecycleLen (Log.identity log)
@ -72,14 +72,14 @@ execReplay serf log last = do
when (numEvs /= bootSeqLen) $ do
throwIO (MissingBootEventsInEventLog numEvs bootSeqLen)
logDebug $ display ("Sending " <> tshow numEvs <> " boot events to serf")
logInfo $ display ("Sending " <> tshow numEvs <> " boot events to serf")
io (boot serf evs) >>= \case
Just err -> do
logDebug "Error on replay, exiting"
logInfo "Error on replay, exiting"
pure (Left err)
Nothing -> do
logDebug "Finished boot events, moving on to more events from log."
logInfo "Finished boot events, moving on to more events from log."
doReplay <&> \case
Left err -> Left err
Right num -> Right (num + numEvs)

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

@ -30,6 +30,7 @@ import Urbit.King.API (readPortsFile)
import Urbit.TermSize (TermSize(TermSize))
import Urbit.Vere.Term.API (Client(Client))
import qualified Data.Set as S
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.UTF8 as BS
import qualified System.Console.ANSI as ANSI
@ -342,6 +343,8 @@ localClient doneSignal = fst <$> mkRAcquire start stop
Clr () -> do T.clearScreen
termRefreshLine ls
Hop w -> termShowCursor ls (fromIntegral w)
Klr s -> do ls2 <- termShowClear ls
termShowStub ls2 s
Lin c -> do ls2 <- termShowClear ls
termShowLine ls2 (pack c)
Mor () -> termShowMore ls
@ -349,6 +352,55 @@ localClient doneSignal = fst <$> mkRAcquire start stop
Sav path atom -> pure ls
Url url -> pure ls
termRenderDeco :: Deco -> Char
termRenderDeco = \case
DecoBr -> '1'
DecoUn -> '4'
DecoBl -> '5'
DecoNull -> '0'
termRenderTint :: Tint -> Char
termRenderTint = \case
TintK -> '0'
TintR -> '1'
TintG -> '2'
TintY -> '3'
TintB -> '4'
TintM -> '5'
TintC -> '6'
TintW -> '7'
TintNull -> '9'
-- Wraps the appropriate escape sequence around a piece of styled text
termRenderStubSegment :: Stye -> [Char] -> [Char]
termRenderStubSegment Stye {..} tape =
case (S.null decoset, back, fore) of
(True, TintNull, TintNull) -> tape
_ -> styled
where
decoset = setFromHoonSet deco
escape = [chr 27, '[']
styles = intercalate ";" $ filter (not . null)
[ intersperse ';' $ fmap termRenderDeco $ toList decoset
, case back of
TintNull -> []
tint -> ['4', termRenderTint tint]
, case fore of
TintNull -> []
tint -> ['3', termRenderTint tint]
]
styled = mconcat [escape, styles, "m", tape, escape, "0m"]
-- Displays and sets styled text as the current line
termShowStub :: LineState -> Stub -> RIO e LineState
termShowStub ls (Stub s) = do
let visualLength = sum $ fmap (length . snd) s
let outText = pack $ mconcat $ fmap (uncurry termRenderStubSegment) s
putStr outText
pure ls { lsLine = outText, lsCurPos = visualLength }
-- Moves the cursor to the requested position
termShowCursor :: LineState -> Int -> RIO e LineState
termShowCursor ls@LineState{..} {-line pos)-} newPos = do
@ -472,7 +524,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
loop rd
else if w == 3 then do
-- ETX (^C)
logDebug $ displayShow "Ctrl-c interrupt"
logInfo $ displayShow "Ctrl-c interrupt"
atomically $ do
writeTQueue wq [Term.Trace "interrupt\r\n"]
writeTQueue rq $ Ctl $ Cord "c"

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

@ -50,6 +50,8 @@ dependencies:
- Glob
- hashable
- hashtables
- heap
- hexstring
- http-client
- http-client-tls
- http-types
@ -64,6 +66,7 @@ dependencies:
- mtl
- multimap
- murmur3
- natpmp-static
- network
- optparse-applicative
- para
@ -99,7 +102,6 @@ dependencies:
- unliftio-core
- unordered-containers
- urbit-atom
- urbit-azimuth
- urbit-eventlog-lmdb
- urbit-hob
- urbit-noun
@ -112,7 +114,6 @@ dependencies:
- wai-websockets
- warp
- warp-tls
- web3
- websockets
default-extensions:

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

@ -15,6 +15,7 @@ import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Vere.Ames
import Urbit.Vere.Pier.Types
import Urbit.Vere.Ports
import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..))
@ -27,7 +28,11 @@ import qualified Urbit.EventLog.LMDB as Log
--------------------------------------------------------------------------------
type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e)
type HasAmes e =
( HasLogFunc e
, HasNetworkConfig e
, HasKingId e
, HasPortControlApi e)
-- Utils -----------------------------------------------------------------------
@ -41,9 +46,10 @@ sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs
data NetworkTestApp = NetworkTestApp
{ _ntaLogFunc :: !LogFunc
, _ntaNetworkConfig :: !NetworkConfig
, _ntaKingId :: !Word16
{ _ntaLogFunc :: !LogFunc
, _ntaNetworkConfig :: !NetworkConfig
, _ntaPortControlApi :: !PortControlApi
, _ntaKingId :: !Word16
}
makeLenses ''NetworkTestApp
@ -57,20 +63,25 @@ instance HasNetworkConfig NetworkTestApp where
instance HasKingId NetworkTestApp where
kingIdL = ntaKingId
instance HasPortControlApi NetworkTestApp where
portControlApiL = ntaPortControlApi
runNetworkApp :: RIO NetworkTestApp a -> IO a
runNetworkApp = runRIO NetworkTestApp
{ _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ())
, _ntaKingId = 34
, _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal
, _ncAmesPort = Nothing
, _ncNoAmes = False
, _ncNoHttp = False
, _ncNoHttps = False
, _ncHttpPort = Nothing
, _ncHttpsPort = Nothing
, _ncLocalPort = Nothing
}
}
runNetworkApp =
runRIO NetworkTestApp
{ _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ())
, _ntaKingId = 34
, _ntaPortControlApi = buildInactivePorts
, _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal
, _ncAmesPort = Nothing
, _ncNoAmes = False
, _ncNoHttp = False
, _ncNoHttps = False
, _ncHttpPort = Nothing
, _ncHttpsPort = Nothing
, _ncLocalPort = Nothing
}
}
runGala
:: forall e
@ -110,8 +121,7 @@ sendThread cb (to, val) = void $ mkRAcquire start cancel
zodSelfMsg :: Property
zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where
runTest
:: (HasLogFunc e, HasNetworkConfig e, HasKingId e) => Bytes -> RIO e Bool
runTest :: (HasAmes e) => Bytes -> RIO e Bool
runTest val = runRAcquire $ do
env <- ask
(zodQ, zod) <- runGala 0
@ -121,15 +131,13 @@ zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
twoTalk :: Property
twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where
runTest :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> (Word8, Word8, Bytes) -> RIO e Bool
runTest :: (HasAmes e) => (Word8, Word8, Bytes) -> RIO e Bool
runTest (aliceShip, bobShip, val) =
if aliceShip == bobShip
then pure True
else go aliceShip bobShip val
go :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> Word8 -> Word8 -> Bytes -> RIO e Bool
go :: (HasAmes e) => Word8 -> Word8 -> Bytes -> RIO e Bool
go aliceShip bobShip val = runRAcquire $ do
(aliceQ, alice) <- runGala aliceShip
(bobQ, bob) <- runGala bobShip

186
pkg/interface/.eslintrc.js Normal file
View File

@ -0,0 +1,186 @@
const env = {
"browser": true,
"es6": true,
"node": true
};
const rules = {
"array-bracket-spacing": ["error", "never"],
"arrow-parens": [
"error",
"as-needed",
{
"requireForBlockBody": true
}
],
"arrow-spacing": "error",
"block-spacing": ["error", "always"],
"brace-style": ["error", "1tbs"],
"camelcase": [
"error",
{
"properties": "never"
}
],
"comma-dangle": ["error", "never"],
"eol-last": ["error", "always"],
"func-name-matching": "error",
"indent": [
"off",
2,
{
"ArrayExpression": "off",
"SwitchCase": 1,
"CallExpression": {
"arguments": "off"
},
"FunctionDeclaration": {
"parameters": "off"
},
"FunctionExpression": {
"parameters": "off"
},
"MemberExpression": "off",
"ObjectExpression": "off",
"ImportDeclaration": "off"
}
],
"handle-callback-err": "off",
"linebreak-style": ["error", "unix"],
"max-lines": [
"error",
{
"max": 300,
"skipBlankLines": true,
"skipComments": true
}
],
"max-lines-per-function": [
"warn",
{
"skipBlankLines": true,
"skipComments": true
}
],
"max-statements-per-line": [
"error",
{
"max": 1
}
],
"new-cap": [
"error",
{
"newIsCap": true,
"capIsNew": false
}
],
"new-parens": "error",
"no-buffer-constructor": "error",
"no-console": "off",
"no-extra-semi": "off",
"no-fallthrough": "off",
"no-func-assign": "off",
"no-implicit-coercion": "error",
"no-multi-assign": "error",
"no-multiple-empty-lines": [
"error",
{
"max": 1
}
],
"no-nested-ternary": "error",
"no-param-reassign": "off",
"no-return-assign": "error",
"no-return-await": "off",
"no-shadow-restricted-names": "error",
"no-tabs": "error",
"no-trailing-spaces": "error",
"no-unused-vars": [
"error",
{
"vars": "all",
"args": "none",
"ignoreRestSiblings": false
}
],
"no-use-before-define": [
"error",
{
"functions": false,
"classes": false
}
],
"no-useless-escape": "off",
"no-var": "error",
"nonblock-statement-body-position": ["error", "below"],
"object-curly-spacing": ["error", "always"],
"padded-blocks": ["error", "never"],
"prefer-arrow-callback": "error",
"prefer-const": [
"error",
{
"destructuring": "all",
"ignoreReadBeforeAssign": true
}
],
"prefer-template": "off",
"quotes": ["error", "single"],
"semi": ["error", "always"],
"spaced-comment": [
"error",
"always",
{
"exceptions": ["!"]
}
],
"space-before-blocks": "error",
"unicode-bom": ["error", "never"],
"valid-jsdoc": "error",
"wrap-iife": ["error", "inside"],
"react/jsx-closing-bracket-location": 1,
"react/jsx-tag-spacing": 1,
"react/jsx-max-props-per-line": ["error", { "maximum": 2, "when": "multiline" }],
"react/prop-types": 0
};
module.exports = {
"env": env,
"extends": [
"plugin:react/recommended",
"eslint:recommended",
],
"settings": {
"react": {
"version": "^16.5.2"
}
},
"parser": "babel-eslint",
"parserOptions": {
"ecmaVersion": 10,
"requireConfigFile": false,
"sourceType": "module"
},
"root": true,
"rules": rules,
"overrides": [
{
"files": ["**/*.ts", "**/*.tsx"],
"env": env,
"extends": [
"eslint:recommended",
"plugin:@typescript-eslint/eslint-recommended",
"plugin:@typescript-eslint/recommended"
],
"parser": "@typescript-eslint/parser",
"parserOptions": {
"ecmaFeatures": { "jsx": true },
"ecmaVersion": 10,
"requireConfigFile": false,
"sourceType": "module"
},
"plugins": ["@typescript-eslint"],
"rules": rules
}
]
};

147
pkg/interface/.eslintrc.json
View File

@ -1,147 +0,0 @@
{
"env": {
"browser": true,
"es6": true,
"node": true
},
"extends": [
"eslint:recommended",
"plugin:react/recommended"
],
"settings": {
"react": {
"version": "^16.5.2"
}
},
"parser": "babel-eslint",
"parserOptions": {
"ecmaVersion": 10,
"requireConfigFile": false,
"sourceType": "module"
},
"root": true,
"rules": {
"array-bracket-spacing": ["error", "never"],
"arrow-parens": [
"error",
"as-needed",
{
"requireForBlockBody": true
}
],
"arrow-spacing": "error",
"block-spacing": ["error", "always"],
"brace-style": ["error", "1tbs"],
"camelcase": [
"error",
{
"properties": "never"
}
],
"comma-dangle": ["error", "never"],
"eol-last": ["error", "always"],
"func-name-matching": "error",
"indent": [
"off",
2,
{
"ArrayExpression": "off",
"SwitchCase": 1,
"CallExpression": {
"arguments": "off"
},
"FunctionDeclaration": {
"parameters": "off"
},
"FunctionExpression": {
"parameters": "off"
},
"MemberExpression": "off",
"ObjectExpression": "off",
"ImportDeclaration": "off"
}
],
"handle-callback-err": "off",
"linebreak-style": ["error", "unix"],
"max-statements-per-line": [
"error",
{
"max": 1
}
],
"new-cap": [
"error",
{
"newIsCap": true,
"capIsNew": false
}
],
"new-parens": "error",
"no-buffer-constructor": "error",
"no-console": "off",
"no-extra-semi": "off",
"no-fallthrough": "off",
"no-func-assign": "off",
"no-implicit-coercion": "error",
"no-multi-assign": "error",
"no-multiple-empty-lines": [
"error",
{
"max": 1
}
],
"no-nested-ternary": "error",
"no-param-reassign": "off",
"no-return-assign": "error",
"no-return-await": "off",
"no-shadow-restricted-names": "error",
"no-tabs": "error",
"no-trailing-spaces": "error",
"no-unused-vars": [
"error",
{
"vars": "all",
"args": "none",
"ignoreRestSiblings": false
}
],
"no-use-before-define": [
"error",
{
"functions": false,
"classes": false
}
],
"no-useless-escape": "off",
"no-var": "error",
"nonblock-statement-body-position": ["error", "below"],
"object-curly-spacing": ["error", "always"],
"padded-blocks": ["error", "never"],
"prefer-arrow-callback": "error",
"prefer-const": [
"error",
{
"destructuring": "all",
"ignoreReadBeforeAssign": true
}
],
"prefer-template": "off",
"quotes": ["error", "single"],
"semi": ["error", "always"],
"spaced-comment": [
"error",
"always",
{
"exceptions": ["!"]
}
],
"space-before-blocks": "error",
"unicode-bom": ["error", "never"],
"valid-jsdoc": "error",
"wrap-iife": ["error", "inside"],
"react/jsx-closing-bracket-location": 1,
"react/jsx-tag-spacing": 1,
"react/jsx-max-props-per-line": ["error", { "maximum": 2, "when": "multiline" }],
"react/prop-types": 0
}
}

2
pkg/interface/config/webpack.dev.js
View File

@ -52,7 +52,7 @@ if(urbitrc.URL) {
...devServer,
index: '',
proxy: {
'/~landscape/js/index.js': {
'/~landscape/js/bundle/index.*.js': {
target: 'http://localhost:9000',
pathRewrite: (req, path) => '/index.js'
},

11
pkg/interface/config/webpack.prod.js
View File

@ -1,6 +1,6 @@
const path = require('path');
// const HtmlWebpackPlugin = require('html-webpack-plugin');
// const { CleanWebpackPlugin } = require('clean-webpack-plugin');
const { CleanWebpackPlugin } = require('clean-webpack-plugin');
module.exports = {
mode: 'production',
@ -49,17 +49,16 @@ module.exports = {
// historyApiFallback: true
// },
plugins: [
// new CleanWebpackPlugin(),
new CleanWebpackPlugin(),
// new HtmlWebpackPlugin({
// title: 'Hot Module Replacement',
// template: './public/index.html',
// }),
],
output: {
filename: 'index.js',
chunkFilename: 'index.js',
path: path.resolve(__dirname, '../../arvo/app/landscape/js'),
publicPath: '/'
filename: 'index.[contenthash].js',
path: path.resolve(__dirname, '../../arvo/app/landscape/js/bundle'),
publicPath: '/',
},
optimization: {
minimize: true,

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

@ -1393,6 +1393,42 @@
"tslib": "^1.11.1"
}
},
"@reach/disclosure": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/disclosure/-/disclosure-0.10.5.tgz",
"integrity": "sha512-DCae28vcL7wXJNt8hySI2uaowEJ6KPDJ9U14xQMkMs0/lH7Tz8PoAO3llf7csEXk/4kzjnDpkyobDiEV3pz05g==",
"requires": {
"@reach/auto-id": "0.10.5",
"@reach/utils": "0.10.5",
"tslib": "^2.0.0"
},
"dependencies": {
"@reach/auto-id": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/auto-id/-/auto-id-0.10.5.tgz",
"integrity": "sha512-we4/bwjFxJ3F+2eaddQ1HltbKvJ7AB8clkN719El7Zugpn/vOjfPMOVUiBqTmPGLUvkYrq4tpuFwLvk2HyOVHg==",
"requires": {
"@reach/utils": "0.10.5",
"tslib": "^2.0.0"
}
},
"@reach/utils": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/utils/-/utils-0.10.5.tgz",
"integrity": "sha512-5E/xxQnUbmpI/LrufBAOXjunl96DnqX6B4zC2MO2KH/dRzLug5gM5VuOwV26egsp0jvsSPxojwciOhS43px3qw==",
"requires": {
"@types/warning": "^3.0.0",
"tslib": "^2.0.0",
"warning": "^4.0.3"
}
},
"tslib": {
"version": "2.0.0",
"resolved": "https://registry.npmjs.org/tslib/-/tslib-2.0.0.tgz",
"integrity": "sha512-lTqkx847PI7xEDYJntxZH89L2/aXInsyF2luSafe/+0fHOMjlBNXdH6th7f70qxLDhul7KZK0zC8V5ZIyHl0/g=="
}
}
},
"@reach/menu-button": {
"version": "0.10.1",
"resolved": "https://registry.npmjs.org/@reach/menu-button/-/menu-button-0.10.1.tgz",
@ -1443,6 +1479,53 @@
"tslib": "^1.11.1"
}
},
"@reach/tabs": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/tabs/-/tabs-0.10.5.tgz",
"integrity": "sha512-oQJxQ9FwFsXo2HxEzJxFU/wP31bPVh4VU54NlhHW9f49uofyYkIKBbAhdF0Zb3TnaFp4cGKPHX39pXBYGPDkAQ==",
"requires": {
"@reach/auto-id": "0.10.5",
"@reach/descendants": "0.10.5",
"@reach/utils": "0.10.5",
"prop-types": "^15.7.2",
"tslib": "^2.0.0"
},
"dependencies": {
"@reach/auto-id": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/auto-id/-/auto-id-0.10.5.tgz",
"integrity": "sha512-we4/bwjFxJ3F+2eaddQ1HltbKvJ7AB8clkN719El7Zugpn/vOjfPMOVUiBqTmPGLUvkYrq4tpuFwLvk2HyOVHg==",
"requires": {
"@reach/utils": "0.10.5",
"tslib": "^2.0.0"
}
},
"@reach/descendants": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/descendants/-/descendants-0.10.5.tgz",
"integrity": "sha512-8HhN4DwS/HsPQ+Ym/Ft/XJ1spXBYdE8hqpnbYR9UcU7Nx3oDbTIdhjA6JXXt23t5avYIx2jRa8YHCtVKSHuiwA==",
"requires": {
"@reach/utils": "0.10.5",
"tslib": "^2.0.0"
}
},
"@reach/utils": {
"version": "0.10.5",
"resolved": "https://registry.npmjs.org/@reach/utils/-/utils-0.10.5.tgz",
"integrity": "sha512-5E/xxQnUbmpI/LrufBAOXjunl96DnqX6B4zC2MO2KH/dRzLug5gM5VuOwV26egsp0jvsSPxojwciOhS43px3qw==",
"requires": {
"@types/warning": "^3.0.0",
"tslib": "^2.0.0",
"warning": "^4.0.3"
}
},
"tslib": {
"version": "2.0.0",
"resolved": "https://registry.npmjs.org/tslib/-/tslib-2.0.0.tgz",
"integrity": "sha512-lTqkx847PI7xEDYJntxZH89L2/aXInsyF2luSafe/+0fHOMjlBNXdH6th7f70qxLDhul7KZK0zC8V5ZIyHl0/g=="
}
}
},
"@reach/utils": {
"version": "0.10.1",
"resolved": "https://registry.npmjs.org/@reach/utils/-/utils-0.10.1.tgz",
@ -1555,15 +1638,15 @@
"@styled-system/css": "^5.1.5"
}
},
"@tlon/indigo-light": {
"version": "1.0.3",
"resolved": "https://registry.npmjs.org/@tlon/indigo-light/-/indigo-light-1.0.3.tgz",
"integrity": "sha512-3OPSdf9cejP/TSzWXuBaYbzLtAfBzQnc75SlPLkoPfwpxnv1Bvy9hiWngLY0WnKRR6lMOldnkYQCCuNWeDibYQ=="
},
"@tlon/indigo-react": {
"version": "1.1.12",
"resolved": "https://registry.npmjs.org/@tlon/indigo-react/-/indigo-react-1.1.12.tgz",
"integrity": "sha512-XBJjHwaslEwZA2r09qnoh84BeVLnd/jwZRkhq71KNABnRD+QRtg/dYNvtswueML4Km89Vx9QBtCIEIeujzrblw==",
"requires": {
"@reach/menu-button": "^0.10.0",
"@styled-system/css": "^5.1.5",
"@types/styled-system__css": "^5.0.5"
}
"version": "1.1.15",
"resolved": "https://registry.npmjs.org/@tlon/indigo-react/-/indigo-react-1.1.15.tgz",
"integrity": "sha512-Ao+1hAJjN5y1gDyT7GIUgXORPXTIpZKVVtrS++ZGYBemYMSq3oJFMIZertsSZbDHuh/TsVPenJrMUZBpV60law=="
},
"@types/anymatch": {
"version": "1.3.1",
@ -1577,6 +1660,12 @@
"integrity": "sha512-rr+OQyAjxze7GgWrSaJwydHStIhHq2lvY3BOC2Mj7KnzI7XK0Uw1TOOdI9lDoajEbSWLiYgoo4f1R51erQfhPQ==",
"dev": true
},
"@types/eslint-visitor-keys": {
"version": "1.0.0",
"resolved": "https://registry.npmjs.org/@types/eslint-visitor-keys/-/eslint-visitor-keys-1.0.0.tgz",
"integrity": "sha512-OCutwjDZ4aFS6PB1UZ988C4YgwlBHJd6wCeQqaLdmadZ/7e+w79+hbMUFC1QXDNCmdyoRfAFdm0RypzwR+Qpag==",
"dev": true
},
"@types/events": {
"version": "3.0.0",
"resolved": "https://registry.npmjs.org/@types/events/-/events-3.0.0.tgz",
@ -1606,6 +1695,12 @@
"integrity": "sha512-iYCgjm1dGPRuo12+BStjd1HiVQqhlRhWDOQigNxn023HcjnhsiFz9pc6CzJj4HwDCSQca9bxTL4PxJDbkdm3PA==",
"dev": true
},
"@types/json-schema": {
"version": "7.0.5",
"resolved": "https://registry.npmjs.org/@types/json-schema/-/json-schema-7.0.5.tgz",
"integrity": "sha512-7+2BITlgjgDhH0vvwZU/HZJVyk+2XUlvxXe8dFMedNX/aMkaOq++rMAFXc0tM7ij15QaWlbdQASBR9dihi+bDQ==",
"dev": true
},
"@types/lodash": {
"version": "4.14.155",
"resolved": "https://registry.npmjs.org/@types/lodash/-/lodash-4.14.155.tgz",
@ -1667,14 +1762,6 @@
"integrity": "sha512-K5K+yml8LTo9bWJI/rECfIPrGgxdpeNbj+d53lwN4QjW1MCwlkhUms+gtdzigTeUyBr09+u8BwOIY3MXvHdcsA==",
"dev": true
},
"@types/styled-system__css": {
"version": "5.0.8",
"resolved": "https://registry.npmjs.org/@types/styled-system__css/-/styled-system__css-5.0.8.tgz",
"integrity": "sha512-skv+daDje8vWQ8wnqVV0GCzgWVKx4gI9lJpAxWE77s52Ne6k/SCPP8HGE4BFbWDvK+qi5O3p89BGWVOQ1VHjMg==",
"requires": {
"csstype": "^2.6.6"
}
},
"@types/tapable": {
"version": "1.0.5",
"resolved": "https://registry.npmjs.org/@types/tapable/-/tapable-1.0.5.tgz",
@ -1720,6 +1807,93 @@
"source-map": "^0.6.1"
}
},
"@typescript-eslint/eslint-plugin": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/eslint-plugin/-/eslint-plugin-3.8.0.tgz",
"integrity": "sha512-lFb4VCDleFSR+eo4Ew+HvrJ37ZH1Y9ZyE+qyP7EiwBpcCVxwmUc5PAqhShCQ8N8U5vqYydm74nss+a0wrrCErw==",
"dev": true,
"requires": {
"@typescript-eslint/experimental-utils": "3.8.0",
"debug": "^4.1.1",
"functional-red-black-tree": "^1.0.1",
"regexpp": "^3.0.0",
"semver": "^7.3.2",
"tsutils": "^3.17.1"
},
"dependencies": {
"semver": {
"version": "7.3.2",
"resolved": "https://registry.npmjs.org/semver/-/semver-7.3.2.tgz",
"integrity": "sha512-OrOb32TeeambH6UrhtShmF7CRDqhL6/5XpPNp2DuRH6+9QLw/orhp72j87v8Qa1ScDkvrrBNpZcDejAirJmfXQ==",
"dev": true
}
}
},
"@typescript-eslint/experimental-utils": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/experimental-utils/-/experimental-utils-3.8.0.tgz",
"integrity": "sha512-o8T1blo1lAJE0QDsW7nSyvZHbiDzQDjINJKyB44Z3sSL39qBy5L10ScI/XwDtaiunoyKGLiY9bzRk4YjsUZl8w==",
"dev": true,
"requires": {
"@types/json-schema": "^7.0.3",
"@typescript-eslint/types": "3.8.0",
"@typescript-eslint/typescript-estree": "3.8.0",
"eslint-scope": "^5.0.0",
"eslint-utils": "^2.0.0"
}
},
"@typescript-eslint/parser": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/parser/-/parser-3.8.0.tgz",
"integrity": "sha512-u5vjOBaCsnMVQOvkKCXAmmOhyyMmFFf5dbkM3TIbg3MZ2pyv5peE4gj81UAbTHwTOXEwf7eCQTUMKrDl/+qGnA==",
"dev": true,
"requires": {
"@types/eslint-visitor-keys": "^1.0.0",
"@typescript-eslint/experimental-utils": "3.8.0",
"@typescript-eslint/types": "3.8.0",
"@typescript-eslint/typescript-estree": "3.8.0",
"eslint-visitor-keys": "^1.1.0"
}
},
"@typescript-eslint/types": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/types/-/types-3.8.0.tgz",
"integrity": "sha512-8kROmEQkv6ss9kdQ44vCN1dTrgu4Qxrd2kXr10kz2NP5T8/7JnEfYNxCpPkArbLIhhkGLZV3aVMplH1RXQRF7Q==",
"dev": true
},
"@typescript-eslint/typescript-estree": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/typescript-estree/-/typescript-estree-3.8.0.tgz",
"integrity": "sha512-MTv9nPDhlKfclwnplRNDL44mP2SY96YmPGxmMbMy6x12I+pERcxpIUht7DXZaj4mOKKtet53wYYXU0ABaiXrLw==",
"dev": true,
"requires": {
"@typescript-eslint/types": "3.8.0",
"@typescript-eslint/visitor-keys": "3.8.0",
"debug": "^4.1.1",
"glob": "^7.1.6",
"is-glob": "^4.0.1",
"lodash": "^4.17.15",
"semver": "^7.3.2",
"tsutils": "^3.17.1"
},
"dependencies": {
"semver": {
"version": "7.3.2",
"resolved": "https://registry.npmjs.org/semver/-/semver-7.3.2.tgz",
"integrity": "sha512-OrOb32TeeambH6UrhtShmF7CRDqhL6/5XpPNp2DuRH6+9QLw/orhp72j87v8Qa1ScDkvrrBNpZcDejAirJmfXQ==",
"dev": true
}
}
},
"@typescript-eslint/visitor-keys": {
"version": "3.8.0",
"resolved": "https://registry.npmjs.org/@typescript-eslint/visitor-keys/-/visitor-keys-3.8.0.tgz",
"integrity": "sha512-gfqQWyVPpT9NpLREXNR820AYwgz+Kr1GuF3nf1wxpHD6hdxI62tq03ToomFnDxY0m3pUB39IF7sil7D5TQexLA==",
"dev": true,
"requires": {
"eslint-visitor-keys": "^1.1.0"
}
},
"@webassemblyjs/ast": {
"version": "1.9.0",
"resolved": "https://registry.npmjs.org/@webassemblyjs/ast/-/ast-1.9.0.tgz",
@ -1918,9 +2092,9 @@
}
},
"acorn": {
"version": "7.1.1",
"resolved": "https://registry.npmjs.org/acorn/-/acorn-7.1.1.tgz",
"integrity": "sha512-add7dgA5ppRPxCFJoAGfMDi7PIBXq1RtGo7BhbLaxwrXPOmw8gq48Y9ozT01hUKy9byMjlR20EJhu5zlkErEkg==",
"version": "7.4.0",
"resolved": "https://registry.npmjs.org/acorn/-/acorn-7.4.0.tgz",
"integrity": "sha512-+G7P8jJmCHr+S+cLfQxygbWhXy+8YTVGzAkpEbcLo2mLoL7tij/VG41QSHACSf5QgYRhMZYHuNc6drJaO0Da+w==",
"dev": true
},
"acorn-jsx": {
@ -2856,9 +3030,9 @@
}
},
"cli-width": {
"version": "2.2.1",
"resolved": "https://registry.npmjs.org/cli-width/-/cli-width-2.2.1.tgz",
"integrity": "sha512-GRMWDxpOB6Dgk2E5Uo+3eEBvtOOlimMmpbFiKuLFnQzYDavtLFY3K5ona41jgN/WdRZtG7utuVSVTL4HbZHGkw==",
"version": "3.0.0",
"resolved": "https://registry.npmjs.org/cli-width/-/cli-width-3.0.0.tgz",
"integrity": "sha512-FxqpkPPwu1HjuN93Omfm4h8uIanXofW0RxVEW3k5RKx+mJJYSthzNhp32Kzxxy3YAEZ/Dc/EWN1vZRY0+kOhbw==",
"dev": true
},
"cliui": {
@ -3328,7 +3502,8 @@
"csstype": {
"version": "2.6.10",
"resolved": "https://registry.npmjs.org/csstype/-/csstype-2.6.10.tgz",
"integrity": "sha512-D34BqZU4cIlMCY93rZHbrq9pjTAQJ3U8S8rfBqjwHxkGPThWFjzZDQpgMJY0QViLxth6ZKYiwFBo14RdN44U/w=="
"integrity": "sha512-D34BqZU4cIlMCY93rZHbrq9pjTAQJ3U8S8rfBqjwHxkGPThWFjzZDQpgMJY0QViLxth6ZKYiwFBo14RdN44U/w==",
"dev": true
},
"cyclist": {
"version": "1.0.1",
@ -3884,6 +4059,15 @@
}
}
},
"eslint-utils": {
"version": "1.4.3",
"resolved": "https://registry.npmjs.org/eslint-utils/-/eslint-utils-1.4.3.tgz",
"integrity": "sha512-fbBN5W2xdY45KulGXmLHZ3c3FHfVYmKg0IrAKGOkT/464PQsx2UeIzfz1RmEci+KLm1bBaAzZAh8+/E+XAeZ8Q==",
"dev": true,
"requires": {
"eslint-visitor-keys": "^1.1.0"
}
},
"globals": {
"version": "12.4.0",
"resolved": "https://registry.npmjs.org/globals/-/globals-12.4.0.tgz",
@ -3899,6 +4083,12 @@
"integrity": "sha1-QRyttXTFoUDTpLGRDUDYDMn0C0A=",
"dev": true
},
"regexpp": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/regexpp/-/regexpp-2.0.1.tgz",
"integrity": "sha512-lv0M6+TkDVniA3aD1Eg0DVpfU/booSu7Eev3TDO/mZKHBfVjgCGTV4t4buppESEYDtkArYFOxTJWv6S5C+iaNw==",
"dev": true
},
"shebang-command": {
"version": "1.2.0",
"resolved": "https://registry.npmjs.org/shebang-command/-/shebang-command-1.2.0.tgz",
@ -3957,9 +4147,9 @@
}
},
"eslint-scope": {
"version": "5.0.0",
"resolved": "https://registry.npmjs.org/eslint-scope/-/eslint-scope-5.0.0.tgz",
"integrity": "sha512-oYrhJW7S0bxAFDvWqzvMPRm6pcgcnWc4QnofCAqRTRfQC0JcwenzGglTtsLyIuuWFfkqDG9vz67cnttSd53djw==",
"version": "5.1.0",
"resolved": "https://registry.npmjs.org/eslint-scope/-/eslint-scope-5.1.0.tgz",
"integrity": "sha512-iiGRvtxWqgtx5m8EyQUJihBloE4EnYeGE/bz1wSPwJE6tZuJUtHlhqDM4Xj2ukE8Dyy1+HCZ4hE0fzIVMzb58w==",
"dev": true,
"requires": {
"esrecurse": "^4.1.0",
@ -3967,9 +4157,9 @@
}
},
"eslint-utils": {
"version": "1.4.3",
"resolved": "https://registry.npmjs.org/eslint-utils/-/eslint-utils-1.4.3.tgz",
"integrity": "sha512-fbBN5W2xdY45KulGXmLHZ3c3FHfVYmKg0IrAKGOkT/464PQsx2UeIzfz1RmEci+KLm1bBaAzZAh8+/E+XAeZ8Q==",
"version": "2.1.0",
"resolved": "https://registry.npmjs.org/eslint-utils/-/eslint-utils-2.1.0.tgz",
"integrity": "sha512-w94dQYoauyvlDc43XnGB8lU3Zt713vNChgt4EWwhXAP2XkBvndfxF0AgIqKOOasjPIPzj9JqgwkwbCYD0/V3Zg==",
"dev": true,
"requires": {
"eslint-visitor-keys": "^1.1.0"
@ -4008,9 +4198,9 @@
},
"dependencies": {
"estraverse": {
"version": "5.1.0",
"resolved": "https://registry.npmjs.org/estraverse/-/estraverse-5.1.0.tgz",
"integrity": "sha512-FyohXK+R0vE+y1nHLoBM7ZTyqRpqAlhdZHCWIWEviFLiGB8b04H6bQs8G+XTthacvT8VuwvteiP7RJSxMs8UEw==",
"version": "5.2.0",
"resolved": "https://registry.npmjs.org/estraverse/-/estraverse-5.2.0.tgz",
"integrity": "sha512-BxbNGGNm0RyRYvUdHpIwv9IWzeM9XClbOxwoATuFdOE7ZE6wHL+HQ5T8hoPM+zHvmKzzsEqhgy0GrQ5X13afiQ==",
"dev": true
}
}
@ -5333,21 +5523,21 @@
"dev": true
},
"inquirer": {
"version": "7.1.0",
"resolved": "https://registry.npmjs.org/inquirer/-/inquirer-7.1.0.tgz",
"integrity": "sha512-5fJMWEmikSYu0nv/flMc475MhGbB7TSPd/2IpFV4I4rMklboCH2rQjYY5kKiYGHqUF9gvaambupcJFFG9dvReg==",
"version": "7.3.3",
"resolved": "https://registry.npmjs.org/inquirer/-/inquirer-7.3.3.tgz",
"integrity": "sha512-JG3eIAj5V9CwcGvuOmoo6LB9kbAYT8HXffUl6memuszlwDC/qvFAJw49XJ5NROSFNPxp3iQg1GqkFhaY/CR0IA==",
"dev": true,
"requires": {
"ansi-escapes": "^4.2.1",
"chalk": "^3.0.0",
"chalk": "^4.1.0",
"cli-cursor": "^3.1.0",
"cli-width": "^2.0.0",
"cli-width": "^3.0.0",
"external-editor": "^3.0.3",
"figures": "^3.0.0",
"lodash": "^4.17.15",
"lodash": "^4.17.19",
"mute-stream": "0.0.8",
"run-async": "^2.4.0",
"rxjs": "^6.5.3",
"rxjs": "^6.6.0",
"string-width": "^4.1.0",
"strip-ansi": "^6.0.0",
"through": "^2.3.6"
@ -5364,9 +5554,9 @@
}
},
"chalk": {
"version": "3.0.0",
"resolved": "https://registry.npmjs.org/chalk/-/chalk-3.0.0.tgz",
"integrity": "sha512-4D3B6Wf41KOYRFdszmDqMCGq5VV/uMAB273JILmO+3jAlh8X4qDtdtgCR3fxtbLEMzSx22QdhnDcJvu2u1fVwg==",
"version": "4.1.0",
"resolved": "https://registry.npmjs.org/chalk/-/chalk-4.1.0.tgz",
"integrity": "sha512-qwx12AxXe2Q5xQ43Ac//I6v5aXTipYrSESdOgzrN+9XjgEpyjpKuvSGaN4qE93f7TQTlerQQ8S+EQ0EyDoVL1A==",
"dev": true,
"requires": {
"ansi-styles": "^4.1.0",
@ -5394,6 +5584,12 @@
"integrity": "sha512-EykJT/Q1KjTWctppgIAgfSO0tKVuZUjhgMr17kqTumMl6Afv3EISleU7qZUzoXDFTAHTDC4NOoG/ZxU3EvlMPQ==",
"dev": true
},
"lodash": {
"version": "4.17.19",
"resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.19.tgz",
"integrity": "sha512-JNvd8XER9GQX0v2qJgsaN/mzFCNA5BRe/j8JN9d+tWyGLSodKQHKFicdwNYzWwI3wjRnaKPsGj1XkBjx/F96DQ==",
"dev": true
},
"strip-ansi": {
"version": "6.0.0",
"resolved": "https://registry.npmjs.org/strip-ansi/-/strip-ansi-6.0.0.tgz",
@ -5716,9 +5912,9 @@
"integrity": "sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ=="
},
"js-yaml": {
"version": "3.13.1",
"resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-3.13.1.tgz",
"integrity": "sha512-YfbcO7jXDdyj0DGxYVSlSeQNHbD7XPWvrVWeVUujrQEoZzWJIRrCPoyk6kL6IAjAG2IolMK4T0hNUe0HOUs5Jw==",
"version": "3.14.0",
"resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-3.14.0.tgz",
"integrity": "sha512-/4IbIeHcD9VMHFqDR/gQ7EdZdLimOvW2DdcxFjdyyZ9NsbS+ccrXqVWDtab/lRl5AlUqmpBx8EhPaWR+OtY17A==",
"dev": true,
"requires": {
"argparse": "^1.0.7",
@ -5949,6 +6145,15 @@
"resolved": "https://registry.npmjs.org/markdown-escapes/-/markdown-escapes-1.0.4.tgz",
"integrity": "sha512-8z4efJYk43E0upd0NbVXwgSTQs6cT3T06etieCMEg7dRbzCbxUCK/GHlX8mhHRDcp+OLlHkPKsvqQTCvsRl2cg=="
},
"markdown-to-jsx": {
"version": "6.11.4",
"resolved": "https://registry.npmjs.org/markdown-to-jsx/-/markdown-to-jsx-6.11.4.tgz",
"integrity": "sha512-3lRCD5Sh+tfA52iGgfs/XZiw33f7fFX9Bn55aNnVNUd2GzLDkOWyKYYD8Yju2B1Vn+feiEdgJs8T6Tg0xNokPw==",
"requires": {
"prop-types": "^15.6.2",
"unquote": "^1.1.0"
}
},
"md5.js": {
"version": "1.3.5",
"resolved": "https://registry.npmjs.org/md5.js/-/md5.js-1.3.5.tgz",
@ -5985,6 +6190,11 @@
"p-is-promise": "^2.0.0"
}
},
"memoize-one": {
"version": "5.1.1",
"resolved": "https://registry.npmjs.org/memoize-one/-/memoize-one-5.1.1.tgz",
"integrity": "sha512-HKeeBpWvqiVJD57ZUAsJNm71eHTykffzcLZVYWiVfQeI1rJtuEaS7hQiEpWfVVk18donPwJEcFKIkCmPJNOhHA=="
},
"memory-fs": {
"version": "0.4.1",
"resolved": "https://registry.npmjs.org/memory-fs/-/memory-fs-0.4.1.tgz",
@ -6290,6 +6500,11 @@
"resolved": "https://registry.npmjs.org/mousetrap/-/mousetrap-1.6.5.tgz",
"integrity": "sha512-QNo4kEepaIBwiT8CDhP98umTetp+JNfQYBWvC1pc6/OAibuXtRcxZ58Qz8skvEHYvURne/7R8T5VoOI7rDsEUA=="
},
"mousetrap-global-bind": {
"version": "1.1.0",
"resolved": "https://registry.npmjs.org/mousetrap-global-bind/-/mousetrap-global-bind-1.1.0.tgz",
"integrity": "sha1-zX3pIivQZG+i4BDVTISnTCaojt0="
},
"move-concurrently": {
"version": "1.0.1",
"resolved": "https://registry.npmjs.org/move-concurrently/-/move-concurrently-1.0.1.tgz",
@ -6684,9 +6899,9 @@
}
},
"onetime": {
"version": "5.1.0",
"resolved": "https://registry.npmjs.org/onetime/-/onetime-5.1.0.tgz",
"integrity": "sha512-5NcSkPHhwTVFIQN+TUqXoS5+dlElHXdpAWu9I0HP20YOtIi+aZ0Ct82jdlILDxjLEAWwvm+qj1m6aEtsDVmm6Q==",
"version": "5.1.1",
"resolved": "https://registry.npmjs.org/onetime/-/onetime-5.1.1.tgz",
"integrity": "sha512-ZpZpjcJeugQfWsfyQlshVoowIIQ1qBGSVll4rfDq6JJVO//fesjoX808hXWfBjY+ROZgpKDI5TRSRBSoJiZ8eg==",
"dev": true,
"requires": {
"mimic-fn": "^2.1.0"
@ -7491,6 +7706,15 @@
"tiny-warning": "^1.0.0"
}
},
"react-window": {
"version": "1.8.5",
"resolved": "https://registry.npmjs.org/react-window/-/react-window-1.8.5.tgz",
"integrity": "sha512-HeTwlNa37AFa8MDZFZOKcNEkuF2YflA0hpGPiTT9vR7OawEt+GZbfM6wqkBahD3D3pUjIabQYzsnY/BSJbgq6Q==",
"requires": {
"@babel/runtime": "^7.0.0",
"memoize-one": ">=3.1.1 <6"
}
},
"readable-stream": {
"version": "3.6.0",
"resolved": "https://registry.npmjs.org/readable-stream/-/readable-stream-3.6.0.tgz",
@ -7562,9 +7786,9 @@
}
},
"regexpp": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/regexpp/-/regexpp-2.0.1.tgz",
"integrity": "sha512-lv0M6+TkDVniA3aD1Eg0DVpfU/booSu7Eev3TDO/mZKHBfVjgCGTV4t4buppESEYDtkArYFOxTJWv6S5C+iaNw==",
"version": "3.1.0",
"resolved": "https://registry.npmjs.org/regexpp/-/regexpp-3.1.0.tgz",
"integrity": "sha512-ZOIzd8yVsQQA7j8GCSlPGXwg5PfmA1mrq0JP4nGhh54LaKN3xdai/vHUDu74pKwV8OxseMS65u2NImosQcSD0Q==",
"dev": true
},
"regexpu-core": {
@ -7883,9 +8107,9 @@
}
},
"rxjs": {
"version": "6.5.5",
"resolved": "https://registry.npmjs.org/rxjs/-/rxjs-6.5.5.tgz",
"integrity": "sha512-WfQI+1gohdf0Dai/Bbmk5L5ItH5tYqm3ki2c5GdWhKjalzjg93N3avFjVStyZZz+A2Em+ZxKH5bNghw9UeylGQ==",
"version": "6.6.2",
"resolved": "https://registry.npmjs.org/rxjs/-/rxjs-6.6.2.tgz",
"integrity": "sha512-BHdBMVoWC2sL26w//BCu3YzKT4s2jip/WhwsGEDmeKYBhKDZeYezVUnHatYB7L85v5xs0BAQmg6BEYJEKxBabg==",
"dev": true,
"requires": {
"tslib": "^1.9.0"
@ -8727,9 +8951,9 @@
"dev": true
},
"strip-json-comments": {
"version": "3.1.0",
"resolved": "https://registry.npmjs.org/strip-json-comments/-/strip-json-comments-3.1.0.tgz",
"integrity": "sha512-e6/d0eBu7gHtdCqFt0xJr642LdToM5/cN4Qb9DbHjVx1CP5RyeM+zH7pbecEmDv/lBqb0QH+6Uqq75rxFPkM0w==",
"version": "3.1.1",
"resolved": "https://registry.npmjs.org/strip-json-comments/-/strip-json-comments-3.1.1.tgz",
"integrity": "sha512-6fPc+R4ihwqP6N/aIv2f1gMH8lOVtWQHoqC4yK6oSDVVocumAsfCqjkXnqiYMhmMwS/mEHLp7Vehlt3ql6lEig==",
"dev": true
},
"style-loader": {
@ -9088,6 +9312,15 @@
"resolved": "https://registry.npmjs.org/tslib/-/tslib-1.11.1.tgz",
"integrity": "sha512-aZW88SY8kQbU7gpV19lN24LtXh/yD4ZZg6qieAJDDg+YBsJcSmLGK9QpnUjAKVG/xefmvJGd1WUmfpT/g6AJGA=="
},
"tsutils": {
"version": "3.17.1",
"resolved": "https://registry.npmjs.org/tsutils/-/tsutils-3.17.1.tgz",
"integrity": "sha512-kzeQ5B8H3w60nFY2g8cJIuH7JDpsALXySGtwGJ0p2LSjLgay3NdIpqq5SoOBe46bKDW2iq25irHCr8wjomUS2g==",
"dev": true,
"requires": {
"tslib": "^1.8.1"
}
},
"tty-browserify": {
"version": "0.0.0",
"resolved": "https://registry.npmjs.org/tty-browserify/-/tty-browserify-0.0.0.tgz",
@ -9125,6 +9358,12 @@
"integrity": "sha1-hnrHTjhkGHsdPUfZlqeOxciDB3c=",
"dev": true
},
"typescript": {
"version": "3.9.7",
"resolved": "https://registry.npmjs.org/typescript/-/typescript-3.9.7.tgz",
"integrity": "sha512-BLbiRkiBzAwsjut4x/dsibSTB6yWpwT5qWmC2OfuCg3GgVQCSgMs4vEctYPhsaGtd0AeuuHMkjZ2h2WG8MSzRw==",
"dev": true
},
"unherit": {
"version": "1.1.3",
"resolved": "https://registry.npmjs.org/unherit/-/unherit-1.1.3.tgz",
@ -9257,6 +9496,11 @@
"integrity": "sha1-sr9O6FFKrmFltIF4KdIbLvSZBOw=",
"dev": true
},
"unquote": {
"version": "1.1.1",
"resolved": "https://registry.npmjs.org/unquote/-/unquote-1.1.1.tgz",
"integrity": "sha1-j97XMk7G6IoP+LkF58CYzcCG1UQ="
},
"unset-value": {
"version": "0.1.2",
"resolved": "https://registry.npmjs.org/unset-value/-/unset-value-0.1.2.tgz",
@ -9393,9 +9637,9 @@
"dev": true
},
"v8-compile-cache": {
"version": "2.1.0",
"resolved": "https://registry.npmjs.org/v8-compile-cache/-/v8-compile-cache-2.1.0.tgz",
"integrity": "sha512-usZBT3PW+LOjM25wbqIlZwPeJV+3OSz3M1k1Ws8snlW39dZyYL9lOGC5FgPVHfk0jKmjiDV8Z0mIbVQPiwFs7g==",
"version": "2.1.1",
"resolved": "https://registry.npmjs.org/v8-compile-cache/-/v8-compile-cache-2.1.1.tgz",
"integrity": "sha512-8OQ9CL+VWyt3JStj7HX7/ciTL2V3Rl1Wf5OL+SNTm0yK1KvtReVulksyeRnCANHHuUxHlQig+JJDlUhBt1NQDQ==",
"dev": true
},
"value-equal": {
@ -9565,7 +9809,8 @@
"ansi-regex": {
"version": "2.1.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"aproba": {
"version": "1.2.0",
@ -9586,12 +9831,14 @@
"balanced-match": {
"version": "1.0.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"brace-expansion": {
"version": "1.1.11",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"balanced-match": "^1.0.0",
"concat-map": "0.0.1"
@ -9606,17 +9853,20 @@
"code-point-at": {
"version": "1.1.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"concat-map": {
"version": "0.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"console-control-strings": {
"version": "1.1.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"core-util-is": {
"version": "1.0.2",
@ -9733,7 +9983,8 @@
"inherits": {
"version": "2.0.4",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"ini": {
"version": "1.3.5",
@ -9745,6 +9996,7 @@
"version": "1.0.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"number-is-nan": "^1.0.0"
}
@ -9759,6 +10011,7 @@
"version": "3.0.4",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"brace-expansion": "^1.1.7"
}
@ -9766,12 +10019,14 @@
"minimist": {
"version": "1.2.5",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"minipass": {
"version": "2.9.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"safe-buffer": "^5.1.2",
"yallist": "^3.0.0"
@ -9790,6 +10045,7 @@
"version": "0.5.3",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"minimist": "^1.2.5"
}
@ -9851,7 +10107,8 @@
"npm-normalize-package-bin": {
"version": "1.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"npm-packlist": {
"version": "1.4.8",
@ -9879,7 +10136,8 @@
"number-is-nan": {
"version": "1.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"object-assign": {
"version": "4.1.1",
@ -9891,6 +10149,7 @@
"version": "1.4.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"wrappy": "1"
}
@ -9968,7 +10227,8 @@
"safe-buffer": {
"version": "5.1.2",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"safer-buffer": {
"version": "2.1.2",
@ -10004,6 +10264,7 @@
"version": "1.0.2",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"code-point-at": "^1.0.0",
"is-fullwidth-code-point": "^1.0.0",
@ -10023,6 +10284,7 @@
"version": "3.0.1",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"ansi-regex": "^2.0.0"
}
@ -10066,12 +10328,14 @@
"wrappy": {
"version": "1.0.2",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"yallist": {
"version": "3.1.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
}
}
},
@ -10552,7 +10816,8 @@
"ansi-regex": {
"version": "2.1.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"aproba": {
"version": "1.2.0",
@ -10573,12 +10838,14 @@
"balanced-match": {
"version": "1.0.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"brace-expansion": {
"version": "1.1.11",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"balanced-match": "^1.0.0",
"concat-map": "0.0.1"
@ -10593,17 +10860,20 @@
"code-point-at": {
"version": "1.1.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"concat-map": {
"version": "0.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"console-control-strings": {
"version": "1.1.0",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"core-util-is": {
"version": "1.0.2",
@ -10720,7 +10990,8 @@
"inherits": {
"version": "2.0.4",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"ini": {
"version": "1.3.5",
@ -10732,6 +11003,7 @@
"version": "1.0.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"number-is-nan": "^1.0.0"
}
@ -10746,6 +11018,7 @@
"version": "3.0.4",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"brace-expansion": "^1.1.7"
}
@ -10753,12 +11026,14 @@
"minimist": {
"version": "1.2.5",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"minipass": {
"version": "2.9.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"safe-buffer": "^5.1.2",
"yallist": "^3.0.0"
@ -10777,6 +11052,7 @@
"version": "0.5.3",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"minimist": "^1.2.5"
}
@ -10838,7 +11114,8 @@
"npm-normalize-package-bin": {
"version": "1.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"npm-packlist": {
"version": "1.4.8",
@ -10866,7 +11143,8 @@
"number-is-nan": {
"version": "1.0.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"object-assign": {
"version": "4.1.1",
@ -10878,6 +11156,7 @@
"version": "1.4.0",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"wrappy": "1"
}
@ -10955,7 +11234,8 @@
"safe-buffer": {
"version": "5.1.2",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"safer-buffer": {
"version": "2.1.2",
@ -10991,6 +11271,7 @@
"version": "1.0.2",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"code-point-at": "^1.0.0",
"is-fullwidth-code-point": "^1.0.0",
@ -11010,6 +11291,7 @@
"version": "3.0.1",
"bundled": true,
"dev": true,
"optional": true,
"requires": {
"ansi-regex": "^2.0.0"
}
@ -11053,12 +11335,14 @@
"wrappy": {
"version": "1.0.2",
"bundled": true,
"dev": true
"dev": true,
"optional": true
},
"yallist": {
"version": "3.1.1",
"bundled": true,
"dev": true
"dev": true,
"optional": true
}
}
},

13
pkg/interface/package.json
View File

@ -5,21 +5,27 @@
"main": "index.js",
"dependencies": {
"@babel/runtime": "^7.10.5",
"@reach/disclosure": "^0.10.5",
"@reach/menu-button": "^0.10.1",
"@tlon/indigo-react": "^1.1.10",
"@reach/tabs": "^0.10.5",
"@tlon/indigo-light": "^1.0.3",
"@tlon/indigo-react": "^1.1.15",
"classnames": "^2.2.6",
"codemirror": "^5.51.0",
"css-loader": "^3.5.3",
"formik": "^2.1.4",
"lodash": "^4.17.15",
"markdown-to-jsx": "^6.11.4",
"moment": "^2.20.1",
"mousetrap": "^1.6.5",
"mousetrap-global-bind": "^1.1.0",
"prop-types": "^15.7.2",
"react": "^16.5.2",
"react-codemirror2": "^6.0.1",
"react-dom": "^16.8.6",
"react-markdown": "^4.3.1",
"react-router-dom": "^5.0.0",
"react-window": "^1.8.5",
"remark-disable-tokenizers": "^1.0.24",
"style-loader": "^1.2.1",
"styled-components": "^5.1.0",
@ -40,6 +46,8 @@
"@types/lodash": "^4.14.155",
"@types/react": "^16.9.38",
"@types/react-router-dom": "^5.1.5",
"@typescript-eslint/eslint-plugin": "^3.8.0",
"@typescript-eslint/parser": "^3.8.0",
"babel-eslint": "^10.1.0",
"babel-loader": "^8.1.0",
"clean-webpack-plugin": "^3.0.0",
@ -51,12 +59,13 @@
"react-hot-loader": "^4.12.21",
"sass": "^1.26.5",
"sass-loader": "^8.0.2",
"typescript": "^3.9.7",
"webpack": "^4.43.0",
"webpack-cli": "^3.3.11",
"webpack-dev-server": "^3.10.3"
},
"scripts": {
"lint": "eslint ./**/*.js",
"lint": "eslint ./src/**/*.{js,ts,tsx}",
"lint-file": "eslint",
"tsc": "tsc",
"tsc:watch": "tsc --watch",

192
pkg/interface/src/App.js
View File

@ -3,10 +3,15 @@ import 'react-hot-loader';
import * as React from 'react';
import { BrowserRouter as Router, Route, withRouter, Switch } from 'react-router-dom';
import styled, { ThemeProvider, createGlobalStyle } from 'styled-components';
import { sigil as sigiljs, stringRenderer } from 'urbit-sigil-js';
import Mousetrap from 'mousetrap';
import 'mousetrap-global-bind';
import './css/indigo-static.css';
import './css/fonts.css';
import { light, dark, inverted, paperDark } from '@tlon/indigo-react';
import light from './themes/light';
import dark from './themes/old-dark';
import LaunchApp from './apps/launch/app';
import ChatApp from './apps/chat/app';
@ -16,11 +21,14 @@ import LinksApp from './apps/links/app';
import PublishApp from './apps/publish/app';
import StatusBar from './components/StatusBar';
import NotFound from './components/404';
import Omnibox from './components/Omnibox';
import ErrorComponent from './components/Error';
import GlobalStore from './store/store';
import GlobalSubscription from './subscription/global';
import GlobalApi from './api/global';
import { uxToHex } from './lib/util';
import { Sigil } from './lib/sigil';
// const Style = createGlobalStyle`
// ${cssReset}
@ -61,6 +69,7 @@ class App extends React.Component {
new GlobalSubscription(this.store, this.api, this.appChannel);
this.updateTheme = this.updateTheme.bind(this);
this.setFavicon = this.setFavicon.bind(this);
}
componentDidMount() {
@ -69,99 +78,149 @@ class App extends React.Component {
this.api.local.setDark(this.themeWatcher.matches);
this.themeWatcher.addListener(this.updateTheme);
this.api.local.getBaseHash();
Mousetrap.bindGlobal(['command+/', 'ctrl+/'], (e) => {
e.preventDefault();
this.api.local.setOmnibox();
});
this.setFavicon();
}
componentWillUnmount() {
this.themeWatcher.removeListener(this.updateTheme);
}
componentDidUpdate(prevProps, prevState, snapshot) {
this.setFavicon();
}
updateTheme(e) {
this.api.local.setDark(e.matches);
}
setFavicon() {
if (window.ship.length < 14) {
let background = '#ffffff';
if (this.state.contacts.hasOwnProperty('/~/default')) {
background = `#${uxToHex(this.state.contacts['/~/default'][window.ship].color)}`;
}
const foreground = Sigil.foregroundFromBackground(background);
const svg = sigiljs({
patp: window.ship,
renderer: stringRenderer,
size: 16,
colors: [background, foreground]
});
const dataurl = 'data:image/svg+xml;base64,' + btoa(svg);
const favicon = document.querySelector('[rel=icon]');
favicon.href = dataurl;
favicon.type = 'image/svg+xml';
}
}
render() {
const channel = window.channel;
const associations = this.state.associations ? this.state.associations : { contacts: {} };
const selectedGroups = this.state.selectedGroups ? this.state.selectedGroups : [];
const { state } = this;
const theme = state.dark ? paperDark : light;
const theme = state.dark ? dark : light;
return (
<ThemeProvider theme={theme}>
<Root>
<Router>
<StatusBarWithRouter props={this.props}
associations={associations}
invites={this.state.invites}
api={this.api}
connection={this.state.connection}
subscription={this.subscription}
<StatusBarWithRouter
props={this.props}
associations={associations}
invites={this.state.invites}
api={this.api}
connection={this.state.connection}
subscription={this.subscription}
/>
<Omnibox
associations={state.associations}
apps={state.launch}
api={this.api}
dark={state.dark}
show={state.omniboxShown}
/>
<Content>
<Switch>
<Route exact path="/"
render={ p => (
<LaunchApp
ship={this.ship}
api={this.api}
{...state}
{...p}
<Switch>
<Route
exact
path='/'
render={p => (
<LaunchApp
ship={this.ship}
api={this.api}
{...state}
{...p}
/>
)}
/>
)}
/>
<Route path="/~chat" render={ p => (
<ChatApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
<Route
path='/~chat'
render={p => (
<ChatApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
/>
)}
/>
)}
/>
<Route path="/~dojo" render={ p => (
<DojoApp
ship={this.ship}
channel={channel}
selectedGroups={selectedGroups}
subscription={this.subscription}
{...p}
<Route
path='/~dojo'
render={p => (
<DojoApp
ship={this.ship}
channel={channel}
subscription={this.subscription}
{...p}
/>
)}
/>
)}
/>
<Route path="/~groups" render={ p => (
<GroupsApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
<Route
path='/~groups'
render={p => (
<GroupsApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
/>
)}
/>
)}
/>
<Route path="/~link" render={ p => (
<LinksApp
ship={this.ship}
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
<Route
path='/~link'
render={p => (
<LinksApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
/>
)}
/>
)}
/>
<Route path="/~publish" render={ p => (
<PublishApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
<Route
path='/~publish'
render={p => (
<PublishApp
ship={this.ship}
api={this.api}
subscription={this.subscription}
{...state}
{...p}
/>
)}
/>
)}
<Route
render={props => (
<ErrorComponent {...props} code={404} description="Not Found" />
)}
/>
<Route component={NotFound} />
</Switch>
</Content>
</Router>
@ -171,5 +230,6 @@ class App extends React.Component {
}
}
export default process.env.NODE_ENV === 'production' ? App : hot(App);

21
pkg/interface/src/api/local.ts
View File

@ -1,6 +1,5 @@
import BaseApi from "./base";
import { StoreState } from "../store/type";
import { SelectedGroup } from "../types/local-update";
export default class LocalApi extends BaseApi<StoreState> {
getBaseHash() {
@ -9,16 +8,6 @@ export default class LocalApi extends BaseApi<StoreState> {
});
}
setSelected(selected: SelectedGroup[]) {
this.store.handleEvent({
data: {
local: {
selected
}
}
})
}
sidebarToggle() {
this.store.handleEvent({
data: {
@ -39,4 +28,14 @@ export default class LocalApi extends BaseApi<StoreState> {
});
}
setOmnibox() {
this.store.handleEvent({
data: {
local: {
omniboxShown: true
},
},
});
}
}

49
pkg/interface/src/apps/chat/app.tsx
View File

@ -53,7 +53,6 @@ export default class ChatApp extends React.Component<ChatAppProps, {}> {
const unreads = {};
let totalUnreads = 0;
const selectedGroups = props.selectedGroups ? props.selectedGroups : [];
const associations = props.associations
? props.associations
: { chat: {}, contacts: {} };
@ -74,14 +73,7 @@ export default class ChatApp extends React.Component<ChatAppProps, {}> {
unreads[stat] = Boolean(unread);
if (
unread &&
stat in associations.chat &&
(selectedGroups.length === 0 ||
selectedGroups
.map((e) => {
return e[0];
})
.includes(associations.chat?.[stat]?.['group-path']) ||
props.groups[associations.chat?.[stat]?.['group-path']]?.hidden)
stat in associations.chat
) {
totalUnreads += unread;
}
@ -111,7 +103,6 @@ export default class ChatApp extends React.Component<ChatAppProps, {}> {
inbox={inbox}
messagePreviews={messagePreviews}
associations={associations}
selectedGroups={selectedGroups}
contacts={contacts}
invites={invites['/chat'] || {}}
unreads={unreads}
@ -286,44 +277,6 @@ export default class ChatApp extends React.Component<ChatAppProps, {}> {
);
}}
/>
<Route
exact
path="/~chat/(popout)?/members/(~)?/:ship/:station+"
render={(props) => {
let station = `/${props.match.params.ship}/${props.match.params.station}`;
const popout = props.match.url.includes('/popout/');
const association =
station in associations['chat'] ? associations.chat[station] : {};
const groupPath = association['group-path'];
const group = groups[groupPath] || {};
return (
<Skeleton
associations={associations}
invites={invites}
sidebarHideOnMobile={true}
sidebarShown={sidebarShown}
popout={popout}
sidebar={renderChannelSidebar(props, station)}
>
<MemberScreen
{...props}
api={api}
group={group}
groups={groups}
associations={associations}
station={station}
association={association}
contacts={contacts}
popout={popout}
sidebarShown={sidebarShown}
/>
</Skeleton>
);
}}
/>
<Route
exact
path="/~chat/(popout)?/settings/(~)?/:ship/:station+"

570
pkg/interface/src/apps/chat/components/chat.tsx
View File

@ -1,16 +1,11 @@
import React, { Component, Fragment } from "react";
import _ from "lodash";
import moment from "moment";
import { Link, RouteComponentProps } from "react-router-dom";
import { ResubscribeElement } from "./lib/resubscribe-element";
import { BacklogElement } from "./lib/backlog-element";
import { Message } from "./lib/message";
import { SidebarSwitcher } from "../../../components/SidebarSwitch";
import { ChatTabBar } from "./lib/chat-tabbar";
import { ChatWindow } from './lib/chat-window';
import { ChatHeader } from './lib/chat-header';
import { ChatInput } from "./lib/chat-input";
import { UnreadNotice } from "./lib/unread-notice";
import { deSig } from "../../../lib/util";
import { ChatHookUpdate } from "../../../types/chat-hook-update";
import ChatApi from "../../../api/chat";
@ -21,52 +16,6 @@ import GlobalApi from "../../../api/global";
import { Association } from "../../../types/metadata-update";
import {Group} from "../../../types/group-update";
function getNumPending(props: any) {
const result = props.pendingMessages.has(props.station)
? props.pendingMessages.get(props.station).length
: 0;
return result;
}
const ACTIVITY_TIMEOUT = 60000; // a minute
const DEFAULT_BACKLOG_SIZE = 300;
const MAX_BACKLOG_SIZE = 1000;
function scrollIsAtTop(container) {
if (
(navigator.userAgent.includes("Safari") &&
navigator.userAgent.includes("Chrome")) ||
navigator.userAgent.includes("Firefox")
) {
return container.scrollTop === 0;
} else if (navigator.userAgent.includes("Safari")) {
return (
container.scrollHeight + Math.round(container.scrollTop) <=
container.clientHeight + 10
);
} else {
return false;
}
}
function scrollIsAtBottom(container) {
if (
(navigator.userAgent.includes("Safari") &&
navigator.userAgent.includes("Chrome")) ||
navigator.userAgent.includes("Firefox")
) {
return (
container.scrollHeight - Math.round(container.scrollTop) <=
container.clientHeight + 10
);
} else if (navigator.userAgent.includes("Safari")) {
return container.scrollTop === 0;
} else {
return false;
}
}
type IMessage = Envelope & { pending?: boolean };
type ChatScreenProps = RouteComponentProps<{
ship: Patp;
@ -90,45 +39,20 @@ type ChatScreenProps = RouteComponentProps<{
};
interface ChatScreenState {
numPages: number;
scrollLocked: boolean;
read: number;
active: boolean;
lastScrollHeight: number | null;
messages: Map<string, string>;
}
export class ChatScreen extends Component<ChatScreenProps, ChatScreenState> {
hasAskedForMessages = false;
lastNumPending = 0;
scrollContainer: HTMLElement | null = null;
unreadMarker = null;
scrolledToMarker = false;
activityTimeout: NodeJS.Timeout | null = null;
scrollElement: HTMLElement | null = null;
constructor(props) {
super(props);
this.state = {
numPages: 1,
scrollLocked: false,
read: props.read,
active: true,
// only for FF
lastScrollHeight: null,
messages: new Map(),
};
this.onScroll = this.onScroll.bind(this);
this.setUnreadMarker = this.setUnreadMarker.bind(this);
this.handleActivity = this.handleActivity.bind(this);
this.setInactive = this.setInactive.bind(this);
moment.updateLocale("en", {
calendar: {
sameDay: "[Today]",
@ -141,450 +65,68 @@ export class ChatScreen extends Component<ChatScreenProps, ChatScreenState> {
});
}
componentDidMount() {
document.addEventListener("mousemove", this.handleActivity, false);
document.addEventListener("mousedown", this.handleActivity, false);
document.addEventListener("keypress", this.handleActivity, false);
document.addEventListener("touchmove", this.handleActivity, false);
this.activityTimeout = setTimeout(this.setInactive, ACTIVITY_TIMEOUT);
}
componentWillUnmount() {
document.removeEventListener("mousemove", this.handleActivity, false);
document.removeEventListener("mousedown", this.handleActivity, false);
document.removeEventListener("keypress", this.handleActivity, false);
document.removeEventListener("touchmove", this.handleActivity, false);
if (this.activityTimeout) {
clearTimeout(this.activityTimeout);
}
}
handleActivity() {
if (!this.state.active) {
this.setState({ active: true });
}
if (this.activityTimeout) {
clearTimeout(this.activityTimeout);
}
this.activityTimeout = setTimeout(this.setInactive, ACTIVITY_TIMEOUT);
}
setInactive() {
this.activityTimeout = null;
this.setState({ active: false, scrollLocked: true });
}
receivedNewChat() {
const { props } = this;
this.hasAskedForMessages = false;
this.unreadMarker = null;
this.scrolledToMarker = false;
this.setState({ read: props.read });
const unread = props.length - props.read;
const unreadUnloaded = unread - props.envelopes.length;
const excessUnread = unreadUnloaded > MAX_BACKLOG_SIZE;
if (!excessUnread && unreadUnloaded + 20 > DEFAULT_BACKLOG_SIZE) {
this.askForMessages(unreadUnloaded + 20);
} else {
this.askForMessages(DEFAULT_BACKLOG_SIZE);
}
if (excessUnread || props.read === props.length) {
this.scrolledToMarker = true;
this.setState(
{
scrollLocked: false,
},
() => {
this.scrollToBottom();
}
);
} else {
this.setState({ scrollLocked: true, numPages: Math.ceil(unread / 100) });
}
}
componentDidUpdate(prevProps, prevState) {
const { props, state } = this;
if (
prevProps.match.params.station !== props.match.params.station ||
prevProps.match.params.ship !== props.match.params.ship
) {
this.receivedNewChat();
} else if (
props.chatInitialized &&
!(props.station in props.inbox) &&
Boolean(props.chatSynced) &&
!(props.station in props.chatSynced)
) {
props.history.push("/~chat");
} else if (props.envelopes.length >= prevProps.envelopes.length + 10) {
this.hasAskedForMessages = false;
} else if (
props.length !== prevProps.length &&
prevProps.length === prevState.read &&
state.active
) {
this.setState({ read: props.length });
this.props.api.chat.read(this.props.station);
}
if (!prevProps.chatInitialized && props.chatInitialized) {
this.receivedNewChat();
}
if (
props.length !== prevProps.length ||
props.envelopes.length !== prevProps.envelopes.length ||
getNumPending(props) !== this.lastNumPending ||
state.numPages !== prevState.numPages
) {
this.scrollToBottom();
if (navigator.userAgent.includes("Firefox")) {
this.recalculateScrollTop();
}
this.lastNumPending = getNumPending(props);
}
}
askForMessages(size) {
const { props, state } = this;
if (
props.envelopes.length >= props.length ||
this.hasAskedForMessages ||
props.length <= 0
) {
return;
}
const start =
props.length - props.envelopes[props.envelopes.length - 1].number;
if (start > 0) {
const end = start + size < props.length ? start + size : props.length;
this.hasAskedForMessages = true;
props.api.chat.fetchMessages(start + 1, end, props.station);
}
}
scrollToBottom() {
if (!this.state.scrollLocked && this.scrollElement) {
this.scrollElement.scrollIntoView();
}
}
// Restore chat position on FF when new messages come in
recalculateScrollTop() {
const { lastScrollHeight } = this.state;
if (!this.scrollContainer || !lastScrollHeight) {
return;
}
const target = this.scrollContainer;
const newScrollTop = this.scrollContainer.scrollHeight - lastScrollHeight;
if (target.scrollTop !== 0 || newScrollTop === target.scrollTop) {
return;
}
target.scrollTop = target.scrollHeight - lastScrollHeight;
}
onScroll(e) {
if (scrollIsAtTop(e.target)) {
// Save scroll position for FF
if (navigator.userAgent.includes("Firefox")) {
this.setState({
lastScrollHeight: e.target.scrollHeight,
});
}
this.setState(
{
numPages: this.state.numPages + 1,
scrollLocked: true,
},
() => {
this.askForMessages(DEFAULT_BACKLOG_SIZE);
}
);
} else if (scrollIsAtBottom(e.target)) {
this.dismissUnread();
this.setState({
numPages: 1,
scrollLocked: false,
});
}
}
setUnreadMarker(ref) {
if (ref && !this.scrolledToMarker) {
this.setState({ scrollLocked: true }, () => {
ref.scrollIntoView({ block: "center" });
if (ref.offsetParent && scrollIsAtBottom(ref.offsetParent)) {
this.dismissUnread();
this.setState({
numPages: 1,
scrollLocked: false,
});
}
});
this.scrolledToMarker = true;
}
this.unreadMarker = ref;
}
dismissUnread() {
this.props.api.chat.read(this.props.station);
}
chatWindow(unread) {
// Replace with just the "not Firefox" implementation
// when Firefox #1042151 is patched.
const { props, state } = this;
let messages: IMessage[] = props.envelopes.slice(0);
const lastMsgNum = messages.length > 0 ? messages.length : 0;
if (messages.length > 100 * state.numPages) {
messages = messages.slice(0, 100 * state.numPages);
}
const pendingMessages: IMessage[] = (
props.pendingMessages.get(props.station) || []
).map((value) => ({ ...value, pending: true }));
if(unread !== 0) {
unread += pendingMessages.length;
}
messages = pendingMessages.concat(messages);
const messageElements = messages.map((msg, i) => {
// Render sigil if previous message is not by the same sender
const aut = ["author"];
const renderSigil =
_.get(messages[i + 1], aut) !== _.get(msg, aut, msg.author);
const paddingTop = renderSigil;
const paddingBot =
_.get(messages[i - 1], aut) !== _.get(msg, aut, msg.author);
const when = ["when"];
const dayBreak =
moment(_.get(messages[i + 1], when)).format("YYYY.MM.DD") !==
moment(_.get(messages[i], when)).format("YYYY.MM.DD");
const messageElem = (
<Message
key={msg.uid}
msg={msg}
contacts={props.contacts}
renderSigil={renderSigil}
paddingTop={paddingTop}
paddingBot={paddingBot}
pending={Boolean(msg.pending)}
group={props.group}
association={props.association}
/>
);
if (unread > 0 && i === unread - 1) {
return (
<Fragment key={msg.uid}>
{messageElem}
<div
ref={this.setUnreadMarker}
className="mv2 green2 flex items-center f9"
>
<hr className="dn-s ma0 w2 b--green2 bt-0" />
<p className="mh4">New messages below</p>
<hr className="ma0 flex-grow-1 b--green2 bt-0" />
{dayBreak && (
<p className="gray2 mh4">
{moment(_.get(messages[i], when)).calendar()}
</p>
)}
<hr
style={{ width: "calc(50% - 48px)" }}
className="b--green2 ma0 bt-0"
/>
</div>
</Fragment>
);
} else if (dayBreak) {
return (
<Fragment key={msg.uid}>
{messageElem}
<div
className="pv3 gray2 b--gray2 flex items-center justify-center f9 "
>
<p>{moment(_.get(messages[i], when)).calendar()}</p>
</div>
</Fragment>
);
} else {
return messageElem;
}
});
if (navigator.userAgent.includes("Firefox")) {
return (
<div
className="relative overflow-y-scroll h-100"
onScroll={this.onScroll}
ref={(e) => {
this.scrollContainer = e;
}}
>
<div
className="bg-white bg-gray0-d pt3 pb2 flex flex-column-reverse"
style={{ resize: "vertical" }}
>
<div
ref={(el) => {
this.scrollElement = el;
}}
></div>
{props.chatInitialized && !(props.station in props.inbox) && (
<BacklogElement />
)}
{props.chatSynced &&
!(props.station in props.chatSynced) &&
messages.length > 0 ? (
<ResubscribeElement
api={props.api}
host={props.match.params.ship}
station={props.station}
/>
) : (
<div />
)}
{messageElements}
</div>
</div>
);
} else {
return (
<div
className="overflow-y-scroll bg-white bg-gray0-d pt3 pb2 flex flex-column-reverse relative"
style={{ height: "100%", resize: "vertical" }}
onScroll={this.onScroll}
>
<div
ref={(el) => {
this.scrollElement = el;
}}
></div>
{props.chatInitialized && !(props.station in props.inbox) && (
<BacklogElement />
)}
{props.chatSynced &&
!(props.station in props.chatSynced) &&
messages.length > 0 ? (
<ResubscribeElement
api={props.api}
host={props.match.params.ship}
station={props.station}
/>
) : (
<div />
)}
{messageElements}
</div>
);
}
}
render() {
const { props, state } = this;
const messages = props.envelopes.slice(0);
const lastMsgNum = messages.length > 0 ? messages.length : 0;
const group = Array.from(props.group.members);
const isinPopout = props.popout ? "popout/" : "";
const lastMsgNum = props.envelopes.length > 0 ? props.envelopes.length : 0;
const ownerContact =
window.ship in props.contacts ? props.contacts[window.ship] : false;
let title = props.station.substr(1);
const pendingMessages = (props.pendingMessages.get(props.station) || [])
.map((value) => ({
...value,
pending: true
}));
if (props.association && "metadata" in props.association) {
title =
props.association.metadata.title !== ""
? props.association.metadata.title
: props.station.substr(1);
}
const isChatMissing =
props.chatInitialized &&
!(props.station in props.inbox) &&
props.chatSynced &&
!(props.station in props.chatSynced);
const unread = props.length - state.read;
const isChatLoading =
props.chatInitialized &&
!(props.station in props.inbox) &&
props.chatSynced &&
(props.station in props.chatSynced);
const unreadMsg = unread > 0 && messages[unread - 1];
const isChatUnsynced =
props.chatSynced &&
!(props.station in props.chatSynced) &&
props.envelopes.length > 0;
const showUnreadNotice =
props.length !== props.read && props.read === state.read;
const unreadCount = props.length - props.read;
const unreadMsg = unreadCount > 0 && props.envelopes[unreadCount - 1];
return (
<div
key={props.station}
className="h-100 w-100 overflow-hidden flex flex-column relative"
>
<div
className="w-100 dn-m dn-l dn-xl inter pt4 pb6 pl3 f8"
style={{ height: "1rem" }}
>
<Link to="/~chat/">{"⟵ All Chats"}</Link>
</div>
<div
className={
"pl4 pt2 bb b--gray4 b--gray1-d bg-gray0-d flex relative " +
"overflow-x-auto overflow-y-hidden flex-shrink-0 "
}
style={{ height: 48 }}
>
<SidebarSwitcher
sidebarShown={props.sidebarShown}
popout={props.popout}
api={props.api}
/>
<Link
to={"/~chat/" + isinPopout + "room" + props.station}
className="pt2 white-d"
>
<h2
className={
"dib f9 fw4 lh-solid v-top " +
(title === props.station.substr(1) ? "mono" : "")
}
style={{ width: "max-content" }}
>
{title}
</h2>
</Link>
<ChatTabBar
{...props}
station={props.station}
numPeers={group.length}
isOwner={deSig(props.match.params.ship) === window.ship}
popout={props.popout}
api={props.api}
/>
</div>
{!!unreadMsg && showUnreadNotice && (
<UnreadNotice
unread={unread}
unreadMsg={unreadMsg}
onRead={() => this.dismissUnread()}
/>
)}
{this.chatWindow(unread)}
className="h-100 w-100 overflow-hidden flex flex-column relative">
<ChatHeader
match={props.match}
location={props.location}
api={props.api}
group={props.group}
association={props.association}
station={props.station}
sidebarShown={props.sidebarShown}
popout={props.popout} />
<ChatWindow
history={props.history}
isChatMissing={isChatMissing}
isChatLoading={isChatLoading}
isChatUnsynced={isChatUnsynced}
unreadCount={unreadCount}
unreadMsg={unreadMsg}
pendingMessages={pendingMessages}
messages={props.envelopes}
length={props.length}
contacts={props.contacts}
association={props.association}
group={props.group}
ship={props.match.params.ship}
station={props.station}
api={props.api} />
<ChatInput
api={props.api}
numMsgs={lastMsgNum}
@ -593,9 +135,15 @@ export class ChatScreen extends Component<ChatScreenProps, ChatScreenState> {
ownerContact={ownerContact}
envelopes={props.envelopes}
contacts={props.contacts}
onEnter={() => this.setState({ scrollLocked: false })}
onUnmount={(msg: string) => this.setState({
messages: this.state.messages.set(props.station, msg)
})}
s3={props.s3}
placeholder="Message..."
message={this.state.messages.get(props.station) || ""}
deleteMessage={() => this.setState({
messages: this.state.messages.set(props.station, "")
})}
/>
</div>
);

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