mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-26 00:12:28 +03:00
mall: age -> app
This commit is contained in:
Philip Monk
parent
7837d51aba
commit
9862dccc0e
@ -1,325 +0,0 @@
|
||||
:: eth-watcher: ethereum event log collector
|
||||
::
|
||||
/- *eth-watcher, spider
|
||||
/+ default-agent, verb
|
||||
=, ethereum-types
|
||||
=, able:jael
|
||||
::
|
||||
=> |%
|
||||
++ refresh-rate ~m5 :: ~m5
|
||||
--
|
||||
::
|
||||
=> |%
|
||||
+$ card card:agent:mall
|
||||
+$ app-state
|
||||
$: %0
|
||||
dogs=(map path watchdog)
|
||||
==
|
||||
::
|
||||
+$ context [=path dog=watchdog]
|
||||
+$ watchdog
|
||||
$: config
|
||||
running=(unit =tid:spider)
|
||||
=number:block
|
||||
=pending-logs
|
||||
=history
|
||||
blocks=(list block)
|
||||
==
|
||||
::
|
||||
:: history: newest block first, oldest event first
|
||||
+$ history (list loglist)
|
||||
--
|
||||
::
|
||||
:: Helpers
|
||||
::
|
||||
=> |%
|
||||
++ wait
|
||||
|= now=@da
|
||||
^- card
|
||||
[%pass /timer %arvo %b %wait (add now refresh-rate)]
|
||||
::
|
||||
++ wait-shortcut
|
||||
|= now=@da
|
||||
^- card
|
||||
[%pass /shortcut %arvo %b %wait now]
|
||||
::
|
||||
++ poke-spider
|
||||
|= [=path our=@p =cage]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %poke cage]
|
||||
::
|
||||
++ watch-spider
|
||||
|= [=path our=@p =sub=path]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %watch sub-path]
|
||||
::
|
||||
++ leave-spider
|
||||
|= [=path our=@p]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %leave ~]
|
||||
--
|
||||
::
|
||||
:: Main
|
||||
::
|
||||
^- agent:mall
|
||||
=| state=app-state
|
||||
%+ verb &
|
||||
|_ =bowl:mall
|
||||
+* this .
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
:: start update timer loop
|
||||
[[(wait now.bowl) ~] this]
|
||||
::
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
=+ !<(old-state=app-state old)
|
||||
`this(state old-state)
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
?: ?=(%noun mark)
|
||||
~& state
|
||||
`this
|
||||
?. ?=(%eth-watcher-poke mark)
|
||||
(on-poke:def mark vase)
|
||||
::
|
||||
=+ !<(=poke vase)
|
||||
?- -.poke
|
||||
%watch
|
||||
:: fully restart the watchdog if it doesn't exist yet,
|
||||
:: or if the new config changes more than just the url.
|
||||
=/ restart=?
|
||||
?| !(~(has by dogs.state) path.poke)
|
||||
?! .= ->:(~(got by dogs.state) path.poke)
|
||||
+.config.poke
|
||||
==
|
||||
~? &((~(has by dogs.state) path.poke) restart)
|
||||
[dap.bowl 'overwriting existing watchdog on' path.poke]
|
||||
=/ restart-cards
|
||||
=/ dog (~(get by dogs.state) path.poke)
|
||||
?. ?& restart
|
||||
?=(^ dog)
|
||||
?=(^ running.u.dog)
|
||||
==
|
||||
~
|
||||
=/ =cage [%spider-stop !>([u.running.u.dog &])]
|
||||
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
|
||||
=/ new-dog
|
||||
=/ dog=watchdog
|
||||
?: restart *watchdog
|
||||
(~(got by dogs.state) path.poke)
|
||||
%_ dog
|
||||
- config.poke
|
||||
number from.config.poke
|
||||
==
|
||||
=. dogs.state (~(put by dogs.state) path.poke new-dog)
|
||||
[[(wait-shortcut now.bowl) ~] this]
|
||||
::
|
||||
%clear
|
||||
=. dogs.state (~(del by dogs.state) path.poke)
|
||||
[~ this]
|
||||
==
|
||||
::
|
||||
:: +on-watch: subscribe & get initial subscription data
|
||||
::
|
||||
:: /logs/some-path:
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card agent:mall)
|
||||
?. ?=([%logs ^] path)
|
||||
~| [%invalid-subscription-path path]
|
||||
!!
|
||||
:_ this :_ ~
|
||||
:* %give %fact ~ %eth-watcher-diff !>
|
||||
:- %history
|
||||
^- loglist
|
||||
%- zing
|
||||
%- flop
|
||||
=< history
|
||||
(~(gut by dogs.state) t.path *watchdog)
|
||||
==
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
::
|
||||
:: +on-peek: get diagnostics data
|
||||
::
|
||||
:: /block/some-path: get next block number to check for /some-path
|
||||
::
|
||||
++ on-peek
|
||||
|= =path
|
||||
^- (unit (unit cage))
|
||||
?. ?=([%x %block ^] path) ~
|
||||
?. (~(has by dogs.state) t.t.path) ~
|
||||
:+ ~ ~
|
||||
:- %atom
|
||||
!>(number:(~(got by dogs.state) t.t.path))
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:mall]
|
||||
|^
|
||||
^- (quip card agent:mall)
|
||||
?. ?=([%running *] wire)
|
||||
(on-agent:def wire sign)
|
||||
?- -.sign
|
||||
%poke-ack
|
||||
?~ p.sign
|
||||
[~ this]
|
||||
%- (slog leaf+"eth-watcher couldn't start thread" u.p.sign)
|
||||
:_ (clear-running t.wire) :_ ~
|
||||
(leave-spider t.wire our.bowl)
|
||||
::
|
||||
%watch-ack
|
||||
?~ p.sign
|
||||
[~ this]
|
||||
%- (slog leaf+"eth-watcher couldn't start listen to thread" u.p.sign)
|
||||
[~ (clear-running t.wire)]
|
||||
::
|
||||
%kick [~ (clear-running t.wire)]
|
||||
%fact
|
||||
=* path t.wire
|
||||
=/ dog (~(get by dogs.state) path)
|
||||
?~ dog
|
||||
[~ this]
|
||||
?+ p.cage.sign (on-agent:def wire sign)
|
||||
%thread-fail
|
||||
=+ !<([=term =tang] q.cage.sign)
|
||||
%- (slog leaf+"eth-watcher failed; will retry" leaf+<term> tang)
|
||||
[~ this(dogs.state (~(put by dogs.state) path u.dog(running ~)))]
|
||||
::
|
||||
%thread-done
|
||||
=+ !<([vows=disavows pup=watchpup] q.cage.sign)
|
||||
=. u.dog
|
||||
%_ u.dog
|
||||
- -.pup
|
||||
number number.pup
|
||||
blocks blocks.pup
|
||||
pending-logs pending-logs.pup
|
||||
==
|
||||
=^ cards-1 u.dog (disavow path u.dog vows)
|
||||
=^ cards-2 u.dog (release-logs path u.dog)
|
||||
=. dogs.state (~(put by dogs.state) path u.dog(running ~))
|
||||
[(weld cards-1 cards-2) this]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ clear-running
|
||||
|= =path
|
||||
=/ dog (~(get by dogs.state) path)
|
||||
?~ dog
|
||||
this
|
||||
this(dogs.state (~(put by dogs.state) path u.dog(running ~)))
|
||||
::
|
||||
++ disavow
|
||||
|= [=path dog=watchdog vows=disavows]
|
||||
^- (quip card watchdog)
|
||||
=/ history-ids=(list [id:block loglist])
|
||||
%+ murn history.dog
|
||||
|= logs=loglist
|
||||
^- (unit [id:block loglist])
|
||||
?~ logs
|
||||
~
|
||||
`[[block-hash block-number]:(need mined.i.logs) logs]
|
||||
=/ actual-vows=disavows
|
||||
%+ skim vows
|
||||
|= =id:block
|
||||
(lien history-ids |=([=history=id:block *] =(id history-id)))
|
||||
=/ actual-history=history
|
||||
%+ murn history-ids
|
||||
|= [=id:block logs=loglist]
|
||||
^- (unit loglist)
|
||||
?: (lien actual-vows |=(=vow=id:block =(id vow-id)))
|
||||
~
|
||||
`logs
|
||||
:_ dog(history actual-history)
|
||||
%+ turn actual-vows
|
||||
|= =id:block
|
||||
[%give %fact `[%logs path] %eth-watcher-diff !>([%disavow id])]
|
||||
::
|
||||
++ release-logs
|
||||
|= [=path dog=watchdog]
|
||||
^- (quip card watchdog)
|
||||
?: (lth number.dog 30)
|
||||
`dog
|
||||
=/ rel-number (sub number.dog 30)
|
||||
=/ numbers=(list number:block) ~(tap in ~(key by pending-logs.dog))
|
||||
=. numbers (sort numbers lth)
|
||||
|- ^- (quip card watchdog)
|
||||
?~ numbers
|
||||
`dog
|
||||
?: (gth i.numbers rel-number)
|
||||
$(numbers t.numbers)
|
||||
=^ cards-1 dog
|
||||
=/ =loglist (~(get ja pending-logs.dog) i.numbers)
|
||||
=. pending-logs.dog (~(del by pending-logs.dog) i.numbers)
|
||||
?~ loglist
|
||||
`dog
|
||||
=. history.dog [loglist history.dog]
|
||||
:_ dog
|
||||
%+ turn loglist
|
||||
|= =event-log:rpc:ethereum
|
||||
^- card
|
||||
[%give %fact `[%logs path] %eth-watcher-diff !>([%log event-log])]
|
||||
=^ cards-2 dog $(numbers t.numbers)
|
||||
[(weld cards-1 cards-2) dog]
|
||||
--
|
||||
::
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- (quip card agent:mall)
|
||||
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
|
||||
%wake
|
||||
=; rest
|
||||
?. =(/timer wire)
|
||||
rest
|
||||
[[(wait now.bowl) -.rest] +.rest]
|
||||
?^ error.sign-arvo
|
||||
:: failed, try again. maybe should tell user if fails more than
|
||||
:: 5 times.
|
||||
::
|
||||
[[(wait now.bowl) ~] this]
|
||||
:: start all updates in parallel
|
||||
::
|
||||
=/ dogs=(list [=path dog=watchdog]) ~(tap by dogs.state)
|
||||
=| cards=(list card)
|
||||
=/ tid-gen ~(. og eny.bowl)
|
||||
^- (quip card agent:mall)
|
||||
=- [(flop -<) ->]
|
||||
|- ^- (quip card agent:mall)
|
||||
=* loop $
|
||||
?~ dogs
|
||||
[cards this]
|
||||
=, i.dogs
|
||||
?^ running.dog.i.dogs
|
||||
:: if still running, kill it and restart
|
||||
::
|
||||
%- (slog leaf+"eth-watcher still running; will restart" ~)
|
||||
=/ =cage [%spider-stop !>([u.running.dog |])]
|
||||
=. cards
|
||||
:* [%pass [%starting path] %agent [our.bowl %spider] %poke cage]
|
||||
(leave-spider path our.bowl)
|
||||
cards
|
||||
==
|
||||
loop(i.dogs i.dogs(running.dog ~))
|
||||
::
|
||||
=^ rand tid-gen (raws:tid-gen 128)
|
||||
=/ new-tid (cat 3 'eth-watcher--' (scot %uv rand))
|
||||
=> .(running.dog.i.dogs `new-tid)
|
||||
=/ args
|
||||
:^ ~ `new-tid %eth-watcher
|
||||
!>(`watchpup`[- number pending-logs blocks]:dog)
|
||||
=. cards
|
||||
:* (watch-spider path our.bowl /thread-result/[new-tid])
|
||||
(poke-spider path our.bowl %spider-start !>(args))
|
||||
cards
|
||||
==
|
||||
=. dogs.state (~(put by dogs.state) path dog)
|
||||
loop(dogs t.dogs)
|
||||
==
|
||||
::
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
@ -1,214 +0,0 @@
|
||||
/- lens, *sole
|
||||
/+ base64, *server, default-agent
|
||||
/= lens-mark /: /===/mar/lens/command
|
||||
/!noun/
|
||||
=, format
|
||||
|%
|
||||
:: +lens-out: json or named octet-stream
|
||||
::
|
||||
+$ lens-out
|
||||
$% [%json =json]
|
||||
[%mime =mime]
|
||||
==
|
||||
+$ state
|
||||
$% $: %0
|
||||
job=(unit [eyre-id=@ta com=command:lens])
|
||||
==
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
=| =state
|
||||
|_ =bowl:mall
|
||||
+* this .
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init on-init:def
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
`this(state !<(^state old))
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card:agent:mall _this)
|
||||
?. ?=(%handle-http-request mark)
|
||||
(on-poke:def mark vase)
|
||||
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
|
||||
?> ?=(~ job.state)
|
||||
::
|
||||
=/ request-line (parse-request-line url.request.inbound-request)
|
||||
=/ site (flop site.request-line)
|
||||
::
|
||||
=/ jon=json
|
||||
(need (de-json:html q:(need body.request.inbound-request)))
|
||||
=/ com=command:lens
|
||||
(json:grab:lens-mark jon)
|
||||
::
|
||||
?: ?=(%export -.source.com)
|
||||
~& [%export app.source.com]
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /export %agent [our.bowl app.source.com] %watch /export]~
|
||||
::
|
||||
?: ?=(%import -.source.com)
|
||||
?~ enc=(de:base64 base64-jam.source.com)
|
||||
!!
|
||||
::
|
||||
=/ c=* (cue q.u.enc)
|
||||
::
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /import %agent [our.bowl app.source.com] %poke %import !>(c)]~
|
||||
::
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /sole %agent [our.bowl %dojo] %watch /sole/[eyre-id]]~
|
||||
::
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card:agent:mall _this)
|
||||
?: ?=([%http-response *] path)
|
||||
`this
|
||||
(on-watch:def path)
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:mall]
|
||||
^- (quip card:agent:mall _this)
|
||||
|^
|
||||
?+ wire (on-agent:def wire sign)
|
||||
[%import ~]
|
||||
?> ?=(%poke-ack -.sign)
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
[[200 ~] `(as-octt:mimes:html "\"Imported data\"")]
|
||||
::
|
||||
[%export ~]
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%watch-ack
|
||||
?~ p.sign
|
||||
`this
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
|
||||
::
|
||||
%fact
|
||||
=^ cards this (take-export !<(* q.cage.sign))
|
||||
:_ this :_ cards
|
||||
?> ?=(^ job.state)
|
||||
?> ?=(%export -.source.com.u.job.state)
|
||||
[%pass /export %agent [our.bowl app.source.com.u.job.state] %leave ~]
|
||||
==
|
||||
::
|
||||
[%sole ~]
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%watch-ack
|
||||
?> ?=(^ job.state)
|
||||
?^ p.sign
|
||||
:_ this(job.state ~)
|
||||
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
|
||||
:_ this :_ ~
|
||||
:* %pass /sole
|
||||
%agent [our.bowl %dojo]
|
||||
%poke %lens-command !>
|
||||
[eyre-id.u.job.state com.u.job.state]
|
||||
==
|
||||
::
|
||||
%fact
|
||||
?> ?=(%sole-effect p.cage.sign)
|
||||
=^ cards this (take-sole-effect !<(sole-effect q.cage.sign))
|
||||
[[[%pass /sole %agent [our.bowl %dojo] %leave ~] cards] this]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ take-export
|
||||
|= data=*
|
||||
^- (quip card:agent:mall _this)
|
||||
?> ?=(^ job.state)
|
||||
?> ?=(%export -.source.com.u.job.state)
|
||||
=/ app-name=tape (trip app.source.com.u.job.state)
|
||||
=/ output=@t (crip "/{app-name}/jam")
|
||||
::
|
||||
=/ jon=json
|
||||
=/ =atom (jam data)
|
||||
=/ =octs [(met 3 atom) atom]
|
||||
=/ enc (en:base64 octs)
|
||||
(pairs:enjs:format file+s+output data+s+enc ~)
|
||||
::
|
||||
:_ this(job.state ~)
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
(json-response:gen (json-to-octs jon))
|
||||
::
|
||||
++ take-sole-effect
|
||||
|= fec=sole-effect
|
||||
^- (quip card:agent:mall _this)
|
||||
=/ out
|
||||
|- ^- (unit lens-out)
|
||||
=* loop $
|
||||
?+ -.fec
|
||||
~
|
||||
::
|
||||
%tan
|
||||
%- some
|
||||
:- %json
|
||||
%- wall:enjs:format
|
||||
(turn (flop p.fec) |=(=tank ~(ram re tank)))
|
||||
::
|
||||
%txt
|
||||
(some %json s+(crip p.fec))
|
||||
::
|
||||
%sag
|
||||
%- some
|
||||
[%mime p.fec (as-octs:mimes:html (jam q.fec))]
|
||||
::
|
||||
%sav
|
||||
:: XX use +en:base64 or produce %mime a la %sag
|
||||
::
|
||||
%- some
|
||||
:- %json
|
||||
%- pairs:enjs:format
|
||||
:~ file+s+(crip <`path`p.fec>)
|
||||
data+s+(crip (en-base64:mimes:html q.fec))
|
||||
==
|
||||
::
|
||||
%mor
|
||||
=/ all `(list lens-out)`(murn p.fec |=(a=sole-effect loop(fec a)))
|
||||
?~ all ~
|
||||
~| [%multiple-effects all]
|
||||
?> ?=(~ t.all)
|
||||
(some i.all)
|
||||
==
|
||||
::
|
||||
?~ out
|
||||
[~ this]
|
||||
::
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
?- -.u.out
|
||||
%json
|
||||
(json-response:gen (json-to-octs json.u.out))
|
||||
::
|
||||
%mime
|
||||
=/ headers
|
||||
:~ ['content-type' 'application/octet-stream']
|
||||
?> ?=([@ @ ~] p.mime.u.out)
|
||||
:- 'content-disposition'
|
||||
^- @t
|
||||
%^ cat 3
|
||||
'attachment; filename='
|
||||
(rap 3 '"' i.p.mime.u.out '.' i.t.p.mime.u.out '"' ~)
|
||||
==
|
||||
[[200 headers] (some q.mime.u.out)]
|
||||
==
|
||||
--
|
||||
::
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- (quip card:agent:mall _this)
|
||||
?. ?=(%bound +<.sign-arvo)
|
||||
(on-arvo:def wire sign-arvo)
|
||||
[~ this]
|
||||
::
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
@ -391,7 +391,7 @@
|
||||
[%swap-files ~]
|
||||
=. userspace-ova.pil
|
||||
=/ slim-dirs=(list path)
|
||||
~[/app /age /ted /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
|
||||
~[/app /ted /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys]
|
||||
:_ ~
|
||||
%- unix-event
|
||||
%- %*(. file-ovum:pill-lib directories slim-dirs)
|
||||
@ -1,408 +0,0 @@
|
||||
:: chat-hook:
|
||||
:: mirror chat data from foreign to local based on read permissions
|
||||
:: allow sending chat messages to foreign paths based on write perms
|
||||
::
|
||||
/- *permission-store, *chat-hook, *invite-store
|
||||
/+ *chat-json
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff [%chat-update chat-update]]
|
||||
[%quit ~]
|
||||
[%poke wire dock poke]
|
||||
[%pull wire dock ~]
|
||||
[%peer wire dock path]
|
||||
==
|
||||
::
|
||||
+$ state-both
|
||||
$% state-zero
|
||||
state-one
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: %0
|
||||
synced=(map path ship)
|
||||
boned=(map wire (list bone))
|
||||
==
|
||||
::
|
||||
+$ state-one
|
||||
$: %1
|
||||
synced=(map path ship)
|
||||
boned=(map wire (list bone))
|
||||
invite-created=_|
|
||||
==
|
||||
::
|
||||
+$ poke
|
||||
$% [%chat-action chat-action]
|
||||
[%permission-action permission-action]
|
||||
[%invite-action invite-action]
|
||||
[%chat-view-action chat-view-action]
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state-one]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state-both)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
:_ this(invite-created %.y)
|
||||
:~ (invite-poke [%create /chat])
|
||||
[ost.bol %peer /invites [our.bol %invite-store] /invitatory/chat]
|
||||
[ost.bol %peer /permissions [our.bol %permission-store] /updates]
|
||||
==
|
||||
?- -.u.old
|
||||
%1 [~ this(+<+ u.old)]
|
||||
::
|
||||
%0
|
||||
=/ sta *state-one
|
||||
=: boned.sta boned.u.old
|
||||
synced.sta synced.u.old
|
||||
invite-created %.y
|
||||
==
|
||||
:_ this(+<+ sta)
|
||||
:~ (invite-poke [%create /chat])
|
||||
[ost.bol %peer /invites [our.bol %invite-store] /invitatory/chat]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ poke-json
|
||||
|= jon=json
|
||||
^- (quip move _this)
|
||||
(poke-chat-action (json-to-action jon))
|
||||
::
|
||||
++ poke-chat-action
|
||||
|= act=chat-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%message -.act)
|
||||
:: local
|
||||
:_ this
|
||||
?: (team:title our.bol src.bol)
|
||||
?. (~(has by synced) path.act)
|
||||
~
|
||||
=/ ship (~(got by synced) path.act)
|
||||
=/ appl ?:(=(ship our.bol) %chat-store %chat-hook)
|
||||
[ost.bol %poke / [ship appl] [%chat-action act]]~
|
||||
:: foreign
|
||||
=/ ship (~(get by synced) path.act)
|
||||
?~ ship
|
||||
~
|
||||
?. =(u.ship our.bol)
|
||||
~
|
||||
:: scry permissions to check if write is permitted
|
||||
?. (permitted-scry [(scot %p src.bol) %chat (weld path.act /write)])
|
||||
~
|
||||
=: author.envelope.act src.bol
|
||||
when.envelope.act now.bol
|
||||
==
|
||||
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]~
|
||||
::
|
||||
++ poke-chat-hook-action
|
||||
|= act=chat-hook-action
|
||||
^- (quip move _this)
|
||||
?- -.act
|
||||
%add-owned
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ chat-path [%mailbox path.act]
|
||||
?: (~(has by synced) path.act)
|
||||
[~ this]
|
||||
=. synced (~(put by synced) path.act our.bol)
|
||||
:_ (track-bone chat-path)
|
||||
%+ weld
|
||||
[ost.bol %peer chat-path [our.bol %chat-store] chat-path]~
|
||||
(create-permission [%chat path.act] security.act)
|
||||
::
|
||||
%add-synced
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ chat-path [%mailbox (scot %p ship.act) path.act]
|
||||
?: (~(has by synced) [(scot %p ship.act) path.act])
|
||||
[~ this]
|
||||
=. synced (~(put by synced) [(scot %p ship.act) path.act] ship.act)
|
||||
:_ (track-bone chat-path)
|
||||
[ost.bol %peer chat-path [ship.act %chat-hook] chat-path]~
|
||||
::
|
||||
%remove
|
||||
=/ ship (~(get by synced) path.act)
|
||||
?~ ship
|
||||
[~ this]
|
||||
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
|
||||
:: delete one of our.bol own paths
|
||||
:_ %_ this
|
||||
synced (~(del by synced) path.act)
|
||||
boned (~(del by boned) [%mailbox path.act])
|
||||
==
|
||||
%- zing
|
||||
:~ (pull-wire [%mailbox path.act])
|
||||
(delete-permission [%chat path.act])
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib [%mailbox path.act] bol)
|
||||
|= [=bone *]
|
||||
[bone %quit ~]
|
||||
==
|
||||
?. |(=(u.ship src.bol) (team:title our.bol src.bol))
|
||||
:: if neither ship = source or source = us, do nothing
|
||||
[~ this]
|
||||
:: delete a foreign ship's path
|
||||
:- (pull-wire [%mailbox path.act])
|
||||
%_ this
|
||||
synced (~(del by synced) path.act)
|
||||
boned (~(del by boned) [%mailbox path.act])
|
||||
==
|
||||
==
|
||||
::
|
||||
++ peer-mailbox
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> ?=([* ^] pax)
|
||||
?> (~(has by synced) pax)
|
||||
:: scry permissions to check if read is permitted
|
||||
?> (permitted-scry [(scot %p src.bol) %chat (weld pax /read)])
|
||||
=/ box (chat-scry pax)
|
||||
?~ box !!
|
||||
:_ this
|
||||
[ost.bol %diff %chat-update [%create (slav %p i.pax) pax]]~
|
||||
::
|
||||
++ diff-invite-update
|
||||
|= [wir=wire diff=invite-update]
|
||||
^- (quip move _this)
|
||||
?+ -.diff
|
||||
[~ this]
|
||||
::
|
||||
%accepted
|
||||
:_ this
|
||||
[(chat-view-poke [%join ship.invite.diff path.invite.diff])]~
|
||||
==
|
||||
::
|
||||
++ diff-permission-update
|
||||
|= [wir=wire diff=permission-update]
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
?- -.diff
|
||||
%create ~
|
||||
%delete ~
|
||||
%add (handle-permissions [%add path.diff who.diff])
|
||||
%remove (handle-permissions [%remove path.diff who.diff])
|
||||
==
|
||||
::
|
||||
++ handle-permissions
|
||||
|= [kind=?(%add %remove) pax=path who=(set ship)]
|
||||
^- (list move)
|
||||
?> ?=([* *] pax)
|
||||
?. =(%chat i.pax) ~
|
||||
:: check path to see if this is a %read permission
|
||||
?. =(%read (snag (dec (lent pax)) `(list @t)`pax))
|
||||
~
|
||||
=/ sup
|
||||
%- ~(gas by *(map [ship path] bone))
|
||||
%+ turn ~(tap by sup.bol)
|
||||
|=([=bone anchor=[ship path]] [anchor bone])
|
||||
%- zing
|
||||
%+ turn ~(tap in who)
|
||||
|= check-ship=ship
|
||||
?: (permitted-scry [(scot %p check-ship) pax])
|
||||
~
|
||||
:: if ship is not permitted, quit their subscription
|
||||
=/ mail-path
|
||||
(oust [(dec (lent t.pax)) (lent t.pax)] `(list @t)`t.pax)
|
||||
=/ bne (~(get by sup) [check-ship [%mailbox mail-path]])
|
||||
?~(bne ~ [u.bne %quit ~]~)
|
||||
::
|
||||
++ diff-chat-update
|
||||
|= [wir=wire diff=chat-update]
|
||||
^- (quip move _this)
|
||||
?: (team:title our.bol src.bol)
|
||||
(handle-local diff)
|
||||
(handle-foreign diff)
|
||||
::
|
||||
++ handle-local
|
||||
|= diff=chat-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%keys [~ this]
|
||||
%config [~ this]
|
||||
%create [~ this]
|
||||
%read [~ this]
|
||||
%delete
|
||||
?. (~(has by synced) path.diff)
|
||||
[~ this]
|
||||
:_ this(synced (~(del by synced) path.diff))
|
||||
[ost.bol %pull [%mailbox path.diff] [our.bol %chat-store] ~]~
|
||||
::
|
||||
%message
|
||||
:_ this
|
||||
%+ turn (prey:pubsub:userlib [%mailbox path.diff] bol)
|
||||
|= [=bone *]
|
||||
^- move
|
||||
[bone %diff [%chat-update diff]]
|
||||
==
|
||||
::
|
||||
++ handle-foreign
|
||||
|= diff=chat-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%keys [~ this]
|
||||
%config [~ this]
|
||||
%read [~ this]
|
||||
%create
|
||||
:_ this
|
||||
?> ?=([* ^] path.diff)
|
||||
=/ shp (~(get by synced) path.diff)
|
||||
?~ shp ~
|
||||
?. =(src.bol u.shp) ~
|
||||
[(chat-poke [%create ship.diff t.path.diff])]~
|
||||
::
|
||||
%delete
|
||||
?> ?=([* ^] path.diff)
|
||||
=/ shp (~(get by synced) path.diff)
|
||||
?~ shp
|
||||
[~ this]
|
||||
?. =(u.shp src.bol)
|
||||
[~ this]
|
||||
:_ this(synced (~(del by synced) path.diff))
|
||||
:- (chat-poke diff)
|
||||
[ost.bol %pull [%mailbox path.diff] [src.bol %chat-hook] ~]~
|
||||
::
|
||||
%message
|
||||
:_ this
|
||||
?> ?=([* ^] path.diff)
|
||||
=/ shp (~(get by synced) path.diff)
|
||||
?~ shp ~
|
||||
?. =(src.bol u.shp) ~
|
||||
[(chat-poke diff)]~
|
||||
==
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
~& chat-hook-quit+wir
|
||||
?: =(wir /permissions)
|
||||
:_ this
|
||||
[ost.bol %peer /permissions [our.bol %permission-store] /updates]~
|
||||
?> ?=([* ^] wir)
|
||||
?. (~(has by synced) t.wir)
|
||||
:: no-op
|
||||
[~ this]
|
||||
~& %chat-hook-resubscribe
|
||||
:_ (track-bone wir)
|
||||
[ost.bol %peer wir [(slav %p i.t.wir) %chat-hook] wir]~
|
||||
::
|
||||
++ reap
|
||||
|= [wir=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
?~ saw
|
||||
[~ this]
|
||||
?> ?=(^ wir)
|
||||
:_ this(synced (~(del by synced) t.wir))
|
||||
%. ~
|
||||
%- slog
|
||||
:* leaf+"chat-hook failed subscribe on {(spud t.wir)}"
|
||||
leaf+"stack trace:"
|
||||
u.saw
|
||||
==
|
||||
::
|
||||
++ chat-poke
|
||||
|= act=chat-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
|
||||
::
|
||||
++ chat-view-poke
|
||||
|= act=chat-view-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %chat-view] [%chat-view-action act]]
|
||||
::
|
||||
++ permission-poke
|
||||
|= act=permission-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
|
||||
::
|
||||
++ invite-poke
|
||||
|= act=invite-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %invite-store] [%invite-action act]]
|
||||
::
|
||||
++ create-permission
|
||||
|= [pax=path sec=chat-security]
|
||||
^- (list move)
|
||||
=/ read-perm (weld pax /read)
|
||||
=/ write-perm (weld pax /write)
|
||||
?- sec
|
||||
%channel
|
||||
:~ (permission-poke (sec-to-perm read-perm %black))
|
||||
(permission-poke (sec-to-perm write-perm %black))
|
||||
==
|
||||
::
|
||||
%village
|
||||
:~ (permission-poke (sec-to-perm read-perm %white))
|
||||
(permission-poke (sec-to-perm write-perm %white))
|
||||
==
|
||||
::
|
||||
%journal
|
||||
:~ (permission-poke (sec-to-perm read-perm %black))
|
||||
(permission-poke (sec-to-perm write-perm %white))
|
||||
==
|
||||
::
|
||||
%mailbox
|
||||
:~ (permission-poke (sec-to-perm read-perm %white))
|
||||
(permission-poke (sec-to-perm write-perm %black))
|
||||
==
|
||||
==
|
||||
::
|
||||
++ delete-permission
|
||||
|= pax=path
|
||||
^- (list move)
|
||||
=/ read-perm (weld pax /read)
|
||||
=/ write-perm (weld pax /write)
|
||||
:~ (permission-poke [%delete read-perm])
|
||||
(permission-poke [%delete write-perm])
|
||||
==
|
||||
::
|
||||
++ sec-to-perm
|
||||
|= [pax=path =kind]
|
||||
^- permission-action
|
||||
[%create pax kind *(set ship)]
|
||||
::
|
||||
++ chat-scry
|
||||
|= pax=path
|
||||
^- (unit mailbox)
|
||||
=. pax ;:(weld /=chat-store/(scot %da now.bol)/mailbox pax /noun)
|
||||
.^((unit mailbox) %gx pax)
|
||||
::
|
||||
++ invite-scry
|
||||
|= uid=serial
|
||||
^- (unit invite)
|
||||
=/ pax /=invite-store/(scot %da now.bol)/invite/chat/(scot %uv uid)/noun
|
||||
.^((unit invite) %gx pax)
|
||||
::
|
||||
++ permitted-scry
|
||||
|= pax=path
|
||||
^- ?
|
||||
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
|
||||
::
|
||||
++ track-bone
|
||||
|= wir=wire
|
||||
^+ this
|
||||
=/ bnd (~(get by boned) wir)
|
||||
?^ bnd
|
||||
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
|
||||
this(boned (~(put by boned) wir [ost.bol]~))
|
||||
::
|
||||
++ pull-wire
|
||||
|= pax=path
|
||||
^- (list move)
|
||||
?> ?=(^ pax)
|
||||
=/ bnd (~(get by boned) pax)
|
||||
?~ bnd ~
|
||||
=/ shp (~(get by synced) t.pax)
|
||||
?~ shp ~
|
||||
%+ turn u.bnd
|
||||
|= =bone
|
||||
^- move
|
||||
?: =(u.shp our.bol)
|
||||
[bone %pull pax [our.bol %chat-store] ~]
|
||||
[bone %pull pax [u.shp %chat-hook] ~]
|
||||
::
|
||||
--
|
||||
@ -1,344 +0,0 @@
|
||||
:: chat-view: sets up chat JS client, paginates data, and combines commands
|
||||
:: into semantic actions for the UI
|
||||
::
|
||||
/- *permission-store,
|
||||
*permission-hook,
|
||||
*group-store,
|
||||
*permission-group-hook,
|
||||
*chat-hook
|
||||
/+ *server, *chat-json
|
||||
/= index
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/index
|
||||
/| /html/
|
||||
/~ ~
|
||||
==
|
||||
/= tile-js
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/js/tile
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= script
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/js/index
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= style
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/chat/css/index
|
||||
/| /css/
|
||||
/~ ~
|
||||
==
|
||||
/= chat-png
|
||||
/^ (map knot @)
|
||||
/: /===/app/chat/img /_ /png/
|
||||
::
|
||||
|%
|
||||
::
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%http-response =http-event:http]
|
||||
[%connect wire binding:eyre term]
|
||||
[%peer wire dock path]
|
||||
[%poke wire dock poke]
|
||||
[%diff %json json]
|
||||
[%quit ~]
|
||||
==
|
||||
::
|
||||
+$ poke
|
||||
$% [%launch-action [@tas path @t]]
|
||||
[%chat-action chat-action]
|
||||
[%group-action group-action]
|
||||
[%chat-hook-action chat-hook-action]
|
||||
[%permission-hook-action permission-hook-action]
|
||||
[%permission-group-hook-action permission-group-hook-action]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall ?]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit ?)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
:_ this
|
||||
:~ [ost.bol %peer / [our.bol %chat-store] /updates]
|
||||
[ost.bol %connect / [~ /'~chat'] %chat-view]
|
||||
(launch-poke [/configs '/~chat/js/tile.js'])
|
||||
==
|
||||
[~ this(+<+ u.old)]
|
||||
::
|
||||
++ bound
|
||||
|= [wir=wire success=? binding=binding:eyre]
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
%- (require-authorization:app ost.bol move this)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
::
|
||||
=+ url=(parse-request-line url.request.inbound-request)
|
||||
=/ name=@t
|
||||
=+ back-path=(flop site.url)
|
||||
?~ back-path
|
||||
''
|
||||
i.back-path
|
||||
?: =(name 'tile')
|
||||
[[ost.bol %http-response (js-response:app tile-js)]~ this]
|
||||
?+ site.url
|
||||
:_ this
|
||||
[ost.bol %http-response not-found:app]~
|
||||
::
|
||||
:: styling
|
||||
::
|
||||
[%'~chat' %css %index ~]
|
||||
:_ this
|
||||
[ost.bol %http-response (css-response:app style)]~
|
||||
::
|
||||
:: javascript
|
||||
::
|
||||
[%'~chat' %js %index ~]
|
||||
:_ this
|
||||
[ost.bol %http-response (js-response:app script)]~
|
||||
::
|
||||
:: images
|
||||
::
|
||||
[%'~chat' %img *]
|
||||
=/ img (as-octs:mimes:html (~(got by chat-png) `@ta`name))
|
||||
:_ this
|
||||
[ost.bol %http-response (png-response:app img)]~
|
||||
::
|
||||
[%'~chat' %paginate @t @t *]
|
||||
=/ start (need (rush i.t.t.site.url dem))
|
||||
=/ end (need (rush i.t.t.t.site.url dem))
|
||||
=/ pax t.t.t.t.site.url
|
||||
=/ envelopes (envelope-scry [(scot %ud start) (scot %ud end) pax])
|
||||
:_ this
|
||||
:~
|
||||
:+ ost.bol
|
||||
%http-response
|
||||
%- json-response:app
|
||||
%- json-to-octs
|
||||
%+ envelopes-update
|
||||
envelopes
|
||||
[start end pax]
|
||||
==
|
||||
::
|
||||
:: inbox page
|
||||
::
|
||||
[%'~chat' *]
|
||||
:_ this
|
||||
[ost.bol %http-response (html-response:app index)]~
|
||||
==
|
||||
::
|
||||
++ poke-json
|
||||
|= jon=json
|
||||
^- (quip move _this)
|
||||
?. =(src.bol our.bol)
|
||||
[~ this]
|
||||
(poke-chat-view-action (json-to-view-action jon))
|
||||
::
|
||||
++ poke-chat-view-action
|
||||
|= act=chat-view-action
|
||||
^- (quip move _this)
|
||||
?. =(src.bol our.bol)
|
||||
[~ this]
|
||||
?- -.act
|
||||
%create
|
||||
:: TODO: add invites
|
||||
=/ pax [(scot %p our.bol) path.act]
|
||||
=/ group-read=path [%chat (weld pax /read)]
|
||||
=/ group-write=path [%chat (weld pax /write)]
|
||||
:_ this
|
||||
%- zing
|
||||
:~ :~ (group-poke [%bundle group-read])
|
||||
(group-poke [%bundle group-write])
|
||||
(group-poke [%add read.act group-read])
|
||||
(group-poke [%add write.act group-write])
|
||||
(chat-poke [%create our.bol path.act])
|
||||
(chat-hook-poke [%add-owned pax security.act])
|
||||
==
|
||||
(create-security [%chat pax] security.act)
|
||||
:~ (permission-hook-poke [%add-owned group-read group-read])
|
||||
(permission-hook-poke [%add-owned group-write group-read])
|
||||
==
|
||||
==
|
||||
::
|
||||
%delete
|
||||
=/ group-read [%chat (weld path.act /read)]
|
||||
=/ group-write [%chat (weld path.act /write)]
|
||||
:_ this
|
||||
:~ (chat-hook-poke [%remove path.act])
|
||||
(permission-hook-poke [%remove group-read])
|
||||
(permission-hook-poke [%remove group-write])
|
||||
(group-poke [%unbundle group-read])
|
||||
(group-poke [%unbundle group-write])
|
||||
(chat-poke [%delete path.act])
|
||||
==
|
||||
::
|
||||
%join
|
||||
=/ group-read [%chat (scot %p ship.act) (weld path.act /read)]
|
||||
=/ group-write [%chat (scot %p ship.act) (weld path.act /write)]
|
||||
:_ this
|
||||
:~ (chat-hook-poke [%add-synced ship.act path.act])
|
||||
(permission-hook-poke [%add-synced ship.act group-write])
|
||||
(permission-hook-poke [%add-synced ship.act group-read])
|
||||
==
|
||||
::
|
||||
==
|
||||
::
|
||||
++ peer-primary
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: create inbox with 100 messages max per mailbox and send that along
|
||||
:: then quit the subscription
|
||||
:_ this
|
||||
[ost.bol %diff %json (inbox-to-json (truncate-inbox all-scry))]~
|
||||
::
|
||||
++ peer-configs
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:_ this
|
||||
[ost.bol %diff %json *json]~
|
||||
::
|
||||
++ diff-chat-update
|
||||
|= [wir=wire upd=chat-update]
|
||||
^- (quip move _this)
|
||||
=/ updates-json (update-to-json upd)
|
||||
=/ configs-json (configs-to-json configs-scry)
|
||||
:_ this
|
||||
%+ weld
|
||||
%+ turn (prey:pubsub:userlib /primary bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %json updates-json]
|
||||
%+ turn (prey:pubsub:userlib /configs bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %json configs-json]
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
[ost.bol %peer / [our.bol %chat-store] /updates]~
|
||||
::
|
||||
:: +utilities
|
||||
::
|
||||
++ launch-poke
|
||||
|= [=path =cord]
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %launch] [%launch-action %chat-view path cord]]
|
||||
::
|
||||
++ chat-poke
|
||||
|= act=chat-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %chat-store] [%chat-action act]]
|
||||
::
|
||||
++ group-poke
|
||||
|= act=group-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %group-store] [%group-action act]]
|
||||
::
|
||||
++ chat-hook-poke
|
||||
|= act=chat-hook-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %chat-hook] [%chat-hook-action act]]
|
||||
::
|
||||
++ permission-hook-poke
|
||||
|= act=permission-hook-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %permission-hook] [%permission-hook-action act]]
|
||||
::
|
||||
++ perm-group-hook-poke
|
||||
|= act=permission-group-hook-action
|
||||
^- move
|
||||
=/ pok [%permission-group-hook-action act]
|
||||
[ost.bol %poke / [our.bol %permission-group-hook] pok]
|
||||
::
|
||||
++ envelope-scry
|
||||
|= pax=path
|
||||
^- (list envelope)
|
||||
=. pax ;:(weld /=chat-store/(scot %da now.bol)/envelopes pax /noun)
|
||||
.^((list envelope) %gx pax)
|
||||
::
|
||||
++ all-scry
|
||||
^- inbox
|
||||
.^(inbox %gx /=chat-store/(scot %da now.bol)/all/noun)
|
||||
::
|
||||
++ configs-scry
|
||||
^- chat-configs
|
||||
.^(chat-configs %gx /=chat-store/(scot %da now.bol)/configs/noun)
|
||||
::
|
||||
++ create-security
|
||||
|= [pax=path sec=chat-security]
|
||||
^- (list move)
|
||||
=/ read (weld pax /read)
|
||||
=/ write (weld pax /write)
|
||||
?- sec
|
||||
%channel
|
||||
:~ (perm-group-hook-poke [%associate read [[read %black] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
|
||||
==
|
||||
::
|
||||
%village
|
||||
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %white] ~ ~]])
|
||||
==
|
||||
::
|
||||
%journal
|
||||
:~ (perm-group-hook-poke [%associate read [[read %black] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %white] ~ ~]])
|
||||
==
|
||||
::
|
||||
%mailbox
|
||||
:~ (perm-group-hook-poke [%associate read [[read %white] ~ ~]])
|
||||
(perm-group-hook-poke [%associate write [[write %black] ~ ~]])
|
||||
==
|
||||
::
|
||||
==
|
||||
::
|
||||
++ envelopes-update
|
||||
|= [envelopes=(list envelope) start=@ud end=@ud pax=path]
|
||||
^- json
|
||||
=, enjs:format
|
||||
%+ frond %chat-update
|
||||
%- pairs
|
||||
:~
|
||||
:- %messages
|
||||
%- pairs
|
||||
:~ [%path (path pax)]
|
||||
[%start (numb start)]
|
||||
[%end (numb end)]
|
||||
[%envelopes [%a (turn envelopes enve)]]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ truncate-envelopes
|
||||
|= envelopes=(list envelope)
|
||||
^- (list envelope)
|
||||
=/ length (lent envelopes)
|
||||
?: (lth length 100)
|
||||
envelopes
|
||||
(swag [(sub length 100) 100] envelopes)
|
||||
::
|
||||
++ truncate-inbox
|
||||
|= box=inbox
|
||||
^- inbox
|
||||
%- ~(run by box)
|
||||
|= mail=mailbox
|
||||
^- mailbox
|
||||
:- config.mail
|
||||
(truncate-envelopes envelopes.mail)
|
||||
::
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,44 +0,0 @@
|
||||
|%
|
||||
+$ move [bone card]
|
||||
+$ card
|
||||
$% [%conf-mall wire dock dock]
|
||||
[%deal-mall wire sock internal-task:mall]
|
||||
==
|
||||
--
|
||||
|_ [=bowl:gall ~]
|
||||
++ this .
|
||||
++ poke-noun
|
||||
|= arg=*
|
||||
^- (quip move _this)
|
||||
:_ this :_ ~
|
||||
?+ arg ~|(%bad-arg !!)
|
||||
%conf [ost.bowl %conf-mall / [our.bowl %hood] [our.bowl %home]]
|
||||
%poke [ost.bowl %deal-mall / [our.bowl our.bowl] %hood %poke %atom !>(%hey)]
|
||||
%hi [ost.bowl %deal-mall / [our.bowl our.bowl] %hood %poke %helm-send-hi !>([our.bowl `"heyza"])]
|
||||
%start [ost.bowl %deal-mall / [our.bowl our.bowl] %hood %poke %drum-start !>([%home %dojo])]
|
||||
%first [ost.bowl %deal-mall / [our.bowl our.bowl] %first %poke %atom !>(%hey)]
|
||||
==
|
||||
::
|
||||
++ onto
|
||||
|= [wire res=(each suss:mall tang)]
|
||||
?: ?=(%& -.res)
|
||||
~& %ontoad
|
||||
`this
|
||||
%- (slog >'conf-failed'< p.res)
|
||||
`this
|
||||
::
|
||||
++ unto
|
||||
|= [wire res=internal-gift:mall]
|
||||
?- -.res
|
||||
%diff !!
|
||||
%quit !!
|
||||
%reap !!
|
||||
%http-response !!
|
||||
%coup
|
||||
?~ p.res
|
||||
~& %mall-coup-good
|
||||
`this
|
||||
%- (slog >'mall-coup-failed'< u.p.res)
|
||||
`this
|
||||
==
|
||||
--
|
||||
@ -1,923 +0,0 @@
|
||||
/- *dns-bind, dns, hall
|
||||
/+ tapp, stdio
|
||||
::
|
||||
:: tapp types and boilerplate
|
||||
::
|
||||
=> |%
|
||||
++ collector-app `dock`[~zod %dns-collector]
|
||||
+$ app-state
|
||||
$: %0
|
||||
:: nem: authoritative state
|
||||
::
|
||||
nem=(unit nameserver)
|
||||
==
|
||||
+$ peek-data _!!
|
||||
+$ in-poke-data
|
||||
$% [%dns-authority =authority]
|
||||
[%dns-bind =ship =target]
|
||||
[%handle-http-request =inbound-request:eyre]
|
||||
[%handle-http-cancel =inbound-request:eyre]
|
||||
[%noun noun=*]
|
||||
==
|
||||
+$ out-poke-data
|
||||
$% [%dns-bind =ship =target]
|
||||
[%dns-complete =ship =binding:dns]
|
||||
[%drum-unlink =dock]
|
||||
==
|
||||
+$ in-peer-data
|
||||
$% [%dns-request =request:dns]
|
||||
==
|
||||
+$ out-peer-data ~
|
||||
++ tapp
|
||||
%: ^tapp
|
||||
app-state
|
||||
peek-data
|
||||
in-poke-data
|
||||
out-poke-data
|
||||
in-peer-data
|
||||
out-peer-data
|
||||
==
|
||||
++ tapp-async tapp-async:tapp
|
||||
++ stdio (^stdio out-poke-data out-peer-data)
|
||||
--
|
||||
::
|
||||
:: oauth2 implementation
|
||||
::
|
||||
=> |%
|
||||
:: +oauth2-config: as one would expect
|
||||
::
|
||||
+$ oauth2-config
|
||||
$: auth-url=@t
|
||||
exchange-url=@t
|
||||
domain=turf
|
||||
initial-path=path
|
||||
redirect-path=path
|
||||
scopes=(list @t)
|
||||
==
|
||||
:: +oauth2: library core
|
||||
::
|
||||
++ oauth2
|
||||
|_ [our=@p now=@da config=oauth2-config code=@t =hart:eyre secrets=@t]
|
||||
::
|
||||
++ local-uri
|
||||
|= [our=ship =path]
|
||||
^- @t
|
||||
:: XX can't scry in +mule
|
||||
::
|
||||
:: =/ =hart:eyre .^(hart:eyre %e /(scot %p our)/host/real)
|
||||
(crip (en-purl:html [hart [~ path] ~]))
|
||||
::
|
||||
:: XX can't scry in +mule
|
||||
::
|
||||
:: ++ code
|
||||
:: ^- @t
|
||||
:: %- crip
|
||||
:: +:(scow %p .^(@p %j /(scot %p our)/code/(scot %da now)/(scot %p our)))
|
||||
::
|
||||
:: to initialize these values: |init-oauth2 /com/googleapis
|
||||
::
|
||||
++ oauth2-secrets
|
||||
^- [client-id=@t client-secret=@t]
|
||||
=; =wain
|
||||
?> ?=([@t @t ~] wain)
|
||||
[i.wain i.t.wain]
|
||||
::
|
||||
%- to-wain:format
|
||||
%- need
|
||||
%+ de:crub:crypto code
|
||||
%+ slav %uw
|
||||
:: XX can't scry in +mule
|
||||
::
|
||||
:: .^(@ %cx :(weld /(scot %p our)/home/(scot %da now)/sec domain.config /atom))
|
||||
secrets
|
||||
::
|
||||
++ initial-uri (local-uri our initial-path.config)
|
||||
++ redirect-uri (local-uri our redirect-path.config)
|
||||
::
|
||||
++ redirect-to-provider
|
||||
^- @t
|
||||
=/ url (need (de-purl:html auth-url.config))
|
||||
=. r.url
|
||||
:* ['access_type' 'offline']
|
||||
['response_type' 'code']
|
||||
['prompt' 'consent']
|
||||
['client_id' client-id:oauth2-secrets]
|
||||
['redirect_uri' redirect-uri]
|
||||
['scope' (rap 3 (join ' ' scopes.config))]
|
||||
r.url
|
||||
==
|
||||
(crip (en-purl:html url))
|
||||
::
|
||||
++ retrieve-access-token
|
||||
|= code=@t
|
||||
^- request:http
|
||||
=/ hed
|
||||
:~ ['Accept' 'application/json']
|
||||
['Content-Type' 'application/x-www-form-urlencoded']
|
||||
==
|
||||
=/ bod
|
||||
%- some %- as-octt:mimes:html
|
||||
%- tail %- tail:en-purl:html
|
||||
:~ ['client_id' client-id:oauth2-secrets]
|
||||
:: note: required, unused parameter
|
||||
::
|
||||
['redirect_uri' redirect-uri]
|
||||
['client_secret' client-secret:oauth2-secrets]
|
||||
['grant_type' 'authorization_code']
|
||||
['code' code]
|
||||
==
|
||||
[%'POST' exchange-url.config hed bod]
|
||||
::
|
||||
++ parse-token-response
|
||||
|= =octs
|
||||
^- (unit [access=@t expires=@u refresh=@t])
|
||||
%. q.octs
|
||||
;~ biff
|
||||
de-json:html
|
||||
=, dejs-soft:format
|
||||
(ot 'access_token'^so 'expires_in'^ni 'refresh_token'^so ~)
|
||||
==
|
||||
:: XX implement
|
||||
::
|
||||
++ refresh-token !!
|
||||
--
|
||||
--
|
||||
::
|
||||
:: helpers
|
||||
::
|
||||
=> |%
|
||||
:: +name: fully-qualified domain name for :ship
|
||||
::
|
||||
++ name
|
||||
|= [=ship =turf]
|
||||
(cat 3 (en-turf:html (weld turf /(crip +:(scow %p ship)))) '.')
|
||||
:: +lame: domain name for :ship (without trailing '.')
|
||||
::
|
||||
++ lame
|
||||
|= [=ship =turf]
|
||||
(en-turf:html (weld turf /(crip +:(scow %p ship))))
|
||||
:: +endpoint: append :path to :purl
|
||||
::
|
||||
++ endpoint
|
||||
|= [=purl:eyre =path]
|
||||
^+ purl
|
||||
purl(q.q (weld q.q.purl path))
|
||||
:: +params: append :params to :purl
|
||||
::
|
||||
++ params
|
||||
|= [=purl:eyre =quay:eyre]
|
||||
^+ purl
|
||||
purl(r (weld r.purl quay))
|
||||
:: +json-octs: deserialize json and apply reparser
|
||||
::
|
||||
++ json-octs
|
||||
|* [bod=octs wit=fist:dejs:format]
|
||||
=/ jon (de-json:html q.bod)
|
||||
?~ jon ~
|
||||
(wit u.jon)
|
||||
:: +ship-turf: parse ship from first subdomain
|
||||
::
|
||||
++ ship-turf
|
||||
|= [nam=@t aut-dom=turf]
|
||||
^- (unit ship)
|
||||
=/ dom=(unit host:eyre)
|
||||
(rush nam ;~(sfix thos:de-purl:html dot))
|
||||
?: ?| ?=(~ dom)
|
||||
?=(%| -.u.dom)
|
||||
?=(~ p.u.dom)
|
||||
==
|
||||
~
|
||||
=/ who
|
||||
(rush (head (flop p.u.dom)) fed:ag)
|
||||
?~ who ~
|
||||
?. =(aut-dom (flop (tail (flop p.u.dom))))
|
||||
~
|
||||
:: galaxies always excluded
|
||||
::
|
||||
?: ?=(%czar (clan:title u.who))
|
||||
~
|
||||
who
|
||||
--
|
||||
::
|
||||
:: service providers
|
||||
::
|
||||
=> |%
|
||||
:: +provider: initialize provider-specific core
|
||||
::
|
||||
++ provider
|
||||
|= aut=authority
|
||||
?- -.pro.aut
|
||||
%fcloud ~(. fcloud aut)
|
||||
%gcloud ~(. gcloud aut)
|
||||
==
|
||||
:: |fcloud: Cloudflare provider
|
||||
::
|
||||
++ fcloud
|
||||
=> |%
|
||||
++ parse-raw-record
|
||||
|= aut-dom=turf
|
||||
^- $- json
|
||||
(unit [=ship id=@ta tar=target])
|
||||
=, dejs:format
|
||||
%+ cu
|
||||
|= [id=@t typ=@t nam=@t dat=@t]
|
||||
^- (unit [=ship id=@ta tar=target])
|
||||
:: XX fix this
|
||||
::
|
||||
=/ him (ship-turf (cat 3 nam '.') aut-dom)
|
||||
?: ?=(~ him)
|
||||
~
|
||||
?+ typ
|
||||
~
|
||||
::
|
||||
%'A'
|
||||
=/ adr (rush dat lip:ag)
|
||||
?~ adr ~
|
||||
`[u.him `@ta`id %direct %if u.adr]
|
||||
::
|
||||
%'CNAME'
|
||||
:: XX fix this
|
||||
::
|
||||
=/ for (ship-turf (cat 3 dat '.') aut-dom)
|
||||
?~ for ~
|
||||
`[u.him `@ta`id %indirect u.for]
|
||||
==
|
||||
:: XX parse dates, proxied, ttl?
|
||||
::
|
||||
%- ot :~
|
||||
'id'^so
|
||||
'type'^so
|
||||
'name'^so
|
||||
'content'^so
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ aut=authority
|
||||
:: +base: provider service endpoint
|
||||
::
|
||||
++ base
|
||||
^- purl:eyre
|
||||
(need (de-purl:html 'https://api.cloudflare.com/client/v4'))
|
||||
:: +headers: standard HTTP headers for all |fcloud requests
|
||||
::
|
||||
++ headers
|
||||
|= aut=authority
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
%- ~(gas by *math:eyre)
|
||||
:~ ['Content-Type' ['application/json' ~]]
|
||||
['X-Auth-Email' [email.auth.pro.aut ~]]
|
||||
['X-Auth-Key' [key.auth.pro.aut ~]]
|
||||
==
|
||||
:: +zone: provider-specific zone info request
|
||||
::
|
||||
++ zone
|
||||
^- hiss:eyre
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
[(endpoint base /zones/[zone.pro.aut]) %get (headers aut) ~]
|
||||
:: +record: JSON-formatted provider-specific dns record
|
||||
::
|
||||
++ record
|
||||
|= [him=ship tar=target]
|
||||
^- json
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
=/ type
|
||||
?:(?=(%direct -.tar) 'A' 'CNAME')
|
||||
=/ data
|
||||
?: ?=(%direct -.tar)
|
||||
(crip +:(scow %if p.tar))
|
||||
(lame p.tar dom.aut)
|
||||
:- %o
|
||||
%- ~(gas by *(map @t json))
|
||||
:~ ['name' %s (lame him dom.aut)]
|
||||
['type' %s type]
|
||||
['content' %s data]
|
||||
:: XX make configureable?
|
||||
::
|
||||
['ttl' %n ~.1]
|
||||
['proxied' %b %.n]
|
||||
==
|
||||
:: +create: provider-specific record-creation request
|
||||
::
|
||||
++ create
|
||||
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
|
||||
^- hiss:eyre
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
=/ bod=octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
(record him tar)
|
||||
?~ pre
|
||||
:- (endpoint base /zones/[zone.pro.aut]/['dns_records'])
|
||||
[%post (headers aut) `bod]
|
||||
:- (endpoint base /zones/[zone.pro.aut]/['dns_records']/[id.u.pre])
|
||||
[%put (headers aut) `bod]
|
||||
:: +existing: list existing records stored by provider
|
||||
::
|
||||
++ existing
|
||||
|= page=(unit @t)
|
||||
^- hiss:eyre
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
:: XX more url params:
|
||||
:: ?type ?per-page ?order ?direction
|
||||
::
|
||||
:- %+ params
|
||||
(endpoint base /zones/[zone.pro.aut]/['dns_records'])
|
||||
?~(page ~ ['page' u.page]~)
|
||||
[%get (headers aut) ~]
|
||||
:: +parse-list: existing records stored by provider
|
||||
::
|
||||
++ parse-list
|
||||
^- $- json
|
||||
(pair (list [=ship id=@ta tar=target]) (unit @t))
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
=, dejs:format
|
||||
%+ cu
|
||||
|= $: success=?
|
||||
response=(list (unit [=ship id=@ta tar=target]))
|
||||
paginate=[page=@ud per-page=@ud count=@ud total-count=@ud]
|
||||
==
|
||||
^- (pair (list [=ship id=@ta tar=target]) (unit @t))
|
||||
?. success [~ ~]
|
||||
:- (murn response same)
|
||||
:: XX calculate next page number if applicable
|
||||
::
|
||||
~
|
||||
:: XX parse errors and messages?
|
||||
::
|
||||
%- ot :~
|
||||
'success'^bo
|
||||
'result'^(ar (parse-raw-record dom.aut))
|
||||
:- 'result_info'
|
||||
%- ot :~
|
||||
'page'^ni
|
||||
'per_page'^ni
|
||||
'count'^ni
|
||||
'total_count'^ni
|
||||
==
|
||||
==
|
||||
:: +parse-record: single record stored by provider
|
||||
::
|
||||
++ parse-record
|
||||
^- $- json
|
||||
(unit [=ship id=@ta tar=target])
|
||||
?> ?=(%fcloud -.pro.aut)
|
||||
=, dejs:format
|
||||
%+ cu
|
||||
|= [success=? response=(unit [=ship id=@ta tar=target])]
|
||||
^- (unit [=ship id=@ta tar=target])
|
||||
?. success ~
|
||||
response
|
||||
:: XX parse errors and messages?
|
||||
::
|
||||
%- ot :~
|
||||
'success'^bo
|
||||
'result'^(parse-raw-record dom.aut)
|
||||
==
|
||||
--
|
||||
:: |gcloud: GCP provider
|
||||
::
|
||||
++ gcloud
|
||||
|_ aut=authority
|
||||
:: +base: provider service endpoint
|
||||
::
|
||||
++ base
|
||||
^- purl:eyre
|
||||
(need (de-purl:html 'https://www.googleapis.com/dns/v1/projects'))
|
||||
:: +headers: standard HTTP headers for all |gcloud requests
|
||||
::
|
||||
++ headers
|
||||
|= aut=authority
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
?. ?=(^ auth.pro.aut)
|
||||
~| %gcloud-missing-auth !!
|
||||
%- ~(gas by *math:eyre)
|
||||
:~ ['Content-Type' ['application/json' ~]]
|
||||
['Authorization' [`@t`(cat 3 'Bearer ' access.u.auth.pro.aut) ~]]
|
||||
==
|
||||
:: +zone: provider-specific zone info request
|
||||
::
|
||||
++ zone
|
||||
^- hiss:eyre
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
:- (endpoint base /[project.pro.aut]/['managedZones']/[zone.pro.aut])
|
||||
[%get (headers aut) ~]
|
||||
:: +record: JSON-formatted provider-specific dns record
|
||||
::
|
||||
++ record
|
||||
|= [him=ship tar=target]
|
||||
^- json
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
=/ type
|
||||
?:(?=(%direct -.tar) 'A' 'CNAME')
|
||||
=/ data
|
||||
?: ?=(%direct -.tar)
|
||||
[%s (crip +:(scow %if p.tar))]
|
||||
[%s (name p.tar dom.aut)]
|
||||
:- %o
|
||||
%- ~(gas by *(map @t json))
|
||||
:~ ['name' %s (name him dom.aut)]
|
||||
['type' %s type]
|
||||
:: XX make configureable?
|
||||
::
|
||||
['ttl' %n ~.300]
|
||||
['rrdatas' %a data ~]
|
||||
==
|
||||
:: +create: provider-specific record-creation request
|
||||
::
|
||||
++ create
|
||||
=, eyre
|
||||
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
|
||||
^- hiss
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
=/ url=purl
|
||||
%+ endpoint base
|
||||
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/changes
|
||||
=/ bod=octs
|
||||
%- as-octt:mimes:html
|
||||
%- en-json:html
|
||||
:- %o
|
||||
%- ~(gas by *(map @t json))
|
||||
:- ['additions' %a (record him tar) ~]
|
||||
?~ pre ~
|
||||
[['deletions' %a (record him tar.u.pre) ~] ~]
|
||||
[url %post (headers aut) `bod]
|
||||
:: +existing: list existing records stored by provider
|
||||
::
|
||||
++ existing
|
||||
=, eyre
|
||||
|= page=(unit @t)
|
||||
^- hiss
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
=/ url=purl
|
||||
%+ endpoint base
|
||||
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/rrsets
|
||||
=/ hed=math (headers aut)
|
||||
=? hed ?=(^ page)
|
||||
(~(put by hed) 'pageToken' [u.page]~)
|
||||
[url %get hed ~]
|
||||
:: +parse-list: existing records stored by provider
|
||||
::
|
||||
++ parse-list
|
||||
^- $- json
|
||||
(pair (list [=ship id=@ta tar=target]) (unit @t))
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
=, dejs:format
|
||||
=> |%
|
||||
++ page (uf ~ (mu so))
|
||||
++ records
|
||||
%+ uf ~
|
||||
%+ cu
|
||||
|*(a=(list (unit)) (murn a same))
|
||||
(ar parse-record)
|
||||
--
|
||||
:: XX parse but don't produce
|
||||
:: 'kind'^(su (jest "dns#resourceRecordSetsListResponse'))
|
||||
::
|
||||
(ou 'rrsets'^records 'nextPageToken'^page ~)
|
||||
:: +parse-record: single record stored by provider
|
||||
::
|
||||
++ parse-record
|
||||
^- $- json
|
||||
(unit [=ship id=@ta tar=target])
|
||||
?> ?=(%gcloud -.pro.aut)
|
||||
=, dejs:format
|
||||
%+ cu
|
||||
|= [typ=@t nam=@t dat=(list @t)]
|
||||
^- (unit [=ship id=@ta tar=target])
|
||||
:: gcloud doesn't expose UUIDs for bindings
|
||||
::
|
||||
=/ id %$
|
||||
=/ him (ship-turf nam dom.aut)
|
||||
?: |(?=(~ him) ?=(~ dat) ?=(^ t.dat))
|
||||
~
|
||||
?+ typ
|
||||
~
|
||||
::
|
||||
%'A'
|
||||
=/ adr (rush i.dat lip:ag)
|
||||
?~ adr ~
|
||||
`[u.him id %direct %if u.adr]
|
||||
::
|
||||
%'CNAME'
|
||||
=/ for (ship-turf i.dat dom.aut)
|
||||
?~ for ~
|
||||
`[u.him id %indirect u.for]
|
||||
==
|
||||
::
|
||||
%- ot :~
|
||||
:: 'kind'^(su (jest "dns#resourceRecordSet'))
|
||||
::
|
||||
'type'^so
|
||||
'name'^so
|
||||
'rrdatas'^(ar so)
|
||||
==
|
||||
--
|
||||
--
|
||||
::
|
||||
:: monadic helpers (XX move to stdio?)
|
||||
::
|
||||
=> |%
|
||||
:: +backoff: exponential backoff timer
|
||||
::
|
||||
++ backoff
|
||||
|= [try=@ud limit=@dr]
|
||||
=/ m (async:stdio ,~)
|
||||
^- form:m
|
||||
;< eny=@uvJ bind:m get-entropy:stdio
|
||||
;< now=@da bind:m get-time:stdio
|
||||
%- wait:stdio
|
||||
%+ add now
|
||||
%+ min limit
|
||||
?: =(0 try) ~s0
|
||||
%+ add
|
||||
(mul ~s1 (bex (dec try)))
|
||||
(mul ~s0..0001 (~(rad og eny) 1.000))
|
||||
::
|
||||
++ request
|
||||
|= =hiss:eyre
|
||||
=/ m (async:stdio (unit httr:eyre))
|
||||
^- form:m
|
||||
;< ~ bind:m (send-hiss:stdio hiss)
|
||||
take-maybe-sigh:stdio
|
||||
::
|
||||
++ request-retry
|
||||
|= [=hiss:eyre max=@ud limit=@dr]
|
||||
=/ m (async:stdio (unit httr:eyre))
|
||||
=/ try=@ud 0
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?: =(try max)
|
||||
(pure:m ~)
|
||||
;< ~ bind:m (backoff try limit)
|
||||
;< rep=(unit httr:eyre) bind:m (request hiss)
|
||||
:: XX needs a better predicate. LTE will make this easier
|
||||
::
|
||||
?: &(?=(^ rep) =(200 p.u.rep))
|
||||
(pure:m (some u.rep))
|
||||
loop(try +(try))
|
||||
--
|
||||
::
|
||||
:: application actions
|
||||
::
|
||||
=> |%
|
||||
++ confirm-authority
|
||||
|= =authority
|
||||
=/ m (async:stdio ?)
|
||||
^- form:m
|
||||
;< rep=(unit httr:eyre) bind:m
|
||||
(request-retry zone:(provider authority) 5 ~m10)
|
||||
(pure:m &(?=(^ rep) =(200 p.u.rep)))
|
||||
::
|
||||
++ retrieve-existing
|
||||
|= =authority
|
||||
=/ m (async:stdio (map ship bound))
|
||||
^- form:m
|
||||
=| existing=(map ship bound)
|
||||
=| next-page=(unit @t)
|
||||
;< now=@da bind:m get-time:stdio
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
;< rep=(unit httr:eyre) bind:m
|
||||
(request-retry (existing:(provider authority) next-page) 5 ~m10)
|
||||
?: ?| ?=(~ rep)
|
||||
?=(~ r.u.rep)
|
||||
==
|
||||
(pure:m existing)
|
||||
::
|
||||
=* octs u.r.u.rep
|
||||
=+ ^- [dat=(list [=ship id=@ta =target]) page=(unit @t)]
|
||||
:: XX gross
|
||||
::
|
||||
=- ?~(- [~ ~] -)
|
||||
(json-octs octs parse-list:(provider authority))
|
||||
=. existing
|
||||
|- ^+ existing
|
||||
?~ dat
|
||||
existing
|
||||
=/ =bound [now id.i.dat target.i.dat ~]
|
||||
$(dat t.dat, existing (~(put by existing) ship.i.dat bound))
|
||||
?~ page
|
||||
(pure:m existing)
|
||||
loop(next-page page)
|
||||
::
|
||||
++ create-binding
|
||||
|= [=authority =ship =target existing=(unit bound)]
|
||||
=/ m (async:stdio (unit bound))
|
||||
^- form:m
|
||||
?: &(?=(^ existing) =(target cur.u.existing))
|
||||
(pure:m existing)
|
||||
::
|
||||
=/ pre=(unit [@ta ^target])
|
||||
?~(existing ~ (some [id cur]:u.existing))
|
||||
;< rep=(unit httr:eyre) bind:m
|
||||
(request (create:(provider authority) ship target pre))
|
||||
:: XX retryable?
|
||||
::
|
||||
?. &(?=(^ rep) =(200 p.u.rep))
|
||||
?: &(?=(^ rep) =(401 p.u.rep))
|
||||
:: XX automate
|
||||
::
|
||||
~& %authentication-failure
|
||||
~& (skim q.u.rep |=((pair @t @t) ?=(%www-authenticate p)))
|
||||
(pure:m ~)
|
||||
::
|
||||
~& [%create-bind-failed rep]
|
||||
(pure:m ~)
|
||||
::
|
||||
=* httr u.rep
|
||||
=/ id=@ta
|
||||
?. ?=(%fcloud -.pro.authority) ~.
|
||||
?. ?=(^ r.httr)
|
||||
~| [%authority-create-confirm-id rep] !!
|
||||
=/ dat=(unit [^ship id=@ta ^target])
|
||||
(json-octs u.r.httr parse-record:(provider authority))
|
||||
?~(dat ~. id.u.dat)
|
||||
::
|
||||
;< now=@da bind:m get-time:stdio
|
||||
=/ =bound
|
||||
[now id target ?~(existing ~ [[wen cur] hit]:u.existing)]
|
||||
(pure:m (some bound))
|
||||
::
|
||||
++ initialize-authority
|
||||
|= [aut=authority state=app-state]
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?> ?=(^ nem.state)
|
||||
=* nam u.nem.state
|
||||
;< good=? bind:m (confirm-authority aut)
|
||||
?. good
|
||||
~& %dns-authority-failed
|
||||
(pure:m state(nem ~))
|
||||
::
|
||||
:: XX wait-effect
|
||||
::
|
||||
;< existing=(map ship bound) bind:m (retrieve-existing aut)
|
||||
=. bon.nam (~(uni by bon.nam) existing)
|
||||
=. nem.state (some nam)
|
||||
::
|
||||
:: XX wait-effect
|
||||
::
|
||||
;< ~ bind:m (peer-app:stdio collector-app /requests)
|
||||
(pure:m state)
|
||||
--
|
||||
::
|
||||
:: |oauth2-core: configured oauth functionality (for |gcloud only)
|
||||
::
|
||||
=> |%
|
||||
++ oauth2-core
|
||||
|= [=bowl:gall code=@t =hart:eyre secrets=@t]
|
||||
=/ =oauth2-config
|
||||
:* auth-url='https://accounts.google.com/o/oauth2/v2/auth'
|
||||
exchange-url='https://www.googleapis.com/oauth2/v4/token'
|
||||
domain=/com/googleapis
|
||||
redirect-path=/dns/oauth
|
||||
initial-path=/dns/oauth/result
|
||||
:~ 'https://www.googleapis.com/auth/ndev.clouddns.readwrite'
|
||||
'https://www.googleapis.com/auth/cloud-platform.read-only'
|
||||
== ==
|
||||
~(. oauth2 our.bowl now.bowl oauth2-config code hart secrets)
|
||||
--
|
||||
::
|
||||
:: the app itself
|
||||
::
|
||||
=* default-tapp default-tapp:tapp
|
||||
%- create-tapp-all:tapp
|
||||
^- tapp-core-all:tapp
|
||||
|_ [=bowl:gall state=app-state]
|
||||
::
|
||||
++ handle-peek handle-peek:default-tapp
|
||||
++ handle-peer handle-peer:default-tapp
|
||||
::
|
||||
++ handle-init
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
;< success=? bind:m (bind-route:stdio [~ /dns/oauth] dap.bowl)
|
||||
~| %dns-unable-to-bind-route
|
||||
?> success
|
||||
;< ~ bind:m (poke-app:stdio [[our %hood] [%drum-unlink our dap]]:bowl)
|
||||
(pure:m state)
|
||||
::
|
||||
++ handle-poke
|
||||
|= =in-poke-data
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?. (team:title [our src]:bowl)
|
||||
~| %bind-yoself !!
|
||||
?- -.in-poke-data
|
||||
%noun
|
||||
?: ?=(%debug noun.in-poke-data)
|
||||
~& bowl
|
||||
:: XX redact secrets
|
||||
::
|
||||
~& state
|
||||
(pure:m state)
|
||||
::
|
||||
:: XX heavy-handed, will duplicate subscriptions
|
||||
:: should track bones
|
||||
::
|
||||
?: ?=(%resubscribe noun.in-poke-data)
|
||||
;< ~ bind:m (peer-app:stdio collector-app /requests)
|
||||
(pure:m state)
|
||||
::
|
||||
~& %poke-unknown
|
||||
(pure:m state)
|
||||
::
|
||||
%dns-authority
|
||||
?. =(~ nem.state)
|
||||
~| %authority-reset-wat-do !!
|
||||
=* aut authority.in-poke-data
|
||||
=/ nam=nameserver [aut ~ ~]
|
||||
=. nem.state (some nam)
|
||||
:: XX move this into the provider interface
|
||||
::
|
||||
?: ?& ?=(%gcloud -.pro.aut)
|
||||
?=(~ auth.pro.aut)
|
||||
==
|
||||
~& %do-the-oauth-thing
|
||||
~& initial-uri:(oauth2-core bowl scry.pro.aut)
|
||||
(pure:m state)
|
||||
::
|
||||
(initialize-authority aut state)
|
||||
::
|
||||
%dns-bind
|
||||
?~ nem.state
|
||||
~| %bind-not-authority !!
|
||||
=* nam u.nem.state
|
||||
=* who ship.in-poke-data
|
||||
=* tar target.in-poke-data
|
||||
?: ?=(%indirect -.tar)
|
||||
~| %indirect-unsupported !!
|
||||
:: defer %indirect where target isn't yet bound
|
||||
::
|
||||
:: ?: ?& ?=(%indirect -.tar)
|
||||
:: !(~(has by bon.nam) p.tar)
|
||||
:: ==
|
||||
:: =. dep.nam (~(put ju dep.nam) p.tar [who tar])
|
||||
:: =. nem.state (some nam)
|
||||
:: (pure:m state)
|
||||
=/ existing (~(get by bon.nam) who)
|
||||
;< new=(unit bound) bind:m (create-binding aut.nam who tar existing)
|
||||
?~ new
|
||||
~& [%bind-failed in-poke-data]
|
||||
(pure:m state)
|
||||
=/ =turf
|
||||
(weld dom.aut.nam /(crip +:(scow %p who)))
|
||||
;< ~ bind:m
|
||||
(poke-app:stdio collector-app [%dns-complete who +.tar turf])
|
||||
=. bon.nam (~(put by bon.nam) who u.new)
|
||||
=. nem.state (some nam)
|
||||
::
|
||||
:: XX wait-effect
|
||||
::
|
||||
=/ dep=(list [=ship =target])
|
||||
~(tap in (~(get ju dep.nam) who))
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?~ dep
|
||||
=. dep.nam (~(del by dep.nam) who)
|
||||
=. nem.state (some nam)
|
||||
(pure:m state)
|
||||
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship target]:i.dep)
|
||||
loop(dep t.dep)
|
||||
::
|
||||
%handle-http-cancel
|
||||
~& %tapp-http-cant-cancel
|
||||
(pure:m state)
|
||||
::
|
||||
%handle-http-request
|
||||
:: always stash request bone for giving response
|
||||
::
|
||||
=/ =bone ost.bowl
|
||||
:: XX maybe always (set-raw-contract %request) so transaction failure is captured?
|
||||
::
|
||||
=* inbound-request inbound-request.in-poke-data
|
||||
?~ nem.state
|
||||
~& :* %not-an-authority
|
||||
%http-request
|
||||
=> inbound-request
|
||||
[authenticated secure address [method url]:request]
|
||||
==
|
||||
;< ~ bind:m
|
||||
(send-effect-on-bone:stdio bone [%http-response %start [%403 ~] ~ %.y])
|
||||
(pure:m state)
|
||||
::
|
||||
=* nam u.nem.state
|
||||
?> ?=(%gcloud -.pro.aut.nam)
|
||||
::
|
||||
=/ parsed=(unit (pair pork:eyre quay:eyre))
|
||||
%+ rush
|
||||
url.request.inbound-request
|
||||
;~(plug ;~(pose apat:de-purl:html (easy *pork:eyre)) yque:de-purl:html)
|
||||
::
|
||||
?. ?=(^ parsed)
|
||||
~| [%invalid-url url.request.inbound-request] !!
|
||||
=* url q.p.u.parsed
|
||||
=* ext p.p.u.parsed
|
||||
=* params q.u.parsed
|
||||
::
|
||||
?+ url
|
||||
;< ~ bind:m
|
||||
(send-effect-on-bone:stdio bone [%http-response %start [%404 ~] ~ %.y])
|
||||
(pure:m state)
|
||||
::
|
||||
[%dns %oauth ~]
|
||||
=/ link (trip redirect-to-provider:(oauth2-core bowl scry.pro.aut.nam))
|
||||
=/ bod=(unit octs)
|
||||
%- some
|
||||
%- as-octt:mimes:html
|
||||
%- en-xml:html
|
||||
;html
|
||||
;head
|
||||
;title: :dns oauth
|
||||
==
|
||||
;body
|
||||
;p make sure that the oauth credential is configured
|
||||
with a redirect uri of {(trip redirect-uri:(oauth2-core bowl scry.pro.aut.nam))}
|
||||
==
|
||||
;a(href link): {link}
|
||||
==
|
||||
==
|
||||
;< ~ bind:m
|
||||
(send-effect-on-bone:stdio bone [%http-response %start [%200 ~] bod %.y])
|
||||
(pure:m state)
|
||||
::
|
||||
[%dns %oauth %result ~]
|
||||
=/ code (~(got by (my params)) %code)
|
||||
:: XX make path configurable
|
||||
::
|
||||
=/ hed [['Location' '/dns/oauth/success'] ~]
|
||||
::
|
||||
;< ~ bind:m
|
||||
(send-request:stdio (retrieve-access-token:(oauth2-core bowl scry.pro.aut.nam) code))
|
||||
;< rep=(unit client-response:iris) bind:m
|
||||
take-maybe-response:stdio
|
||||
:: XX retry
|
||||
::
|
||||
?> ?& ?=(^ rep)
|
||||
?=(%finished -.u.rep)
|
||||
?=(^ full-file.u.rep)
|
||||
==
|
||||
=/ data (parse-token-response:oauth2 data.u.full-file.u.rep)
|
||||
=. auth.pro.aut.nam (some [access refresh]:(need data))
|
||||
=. nem.state (some nam)
|
||||
:: XX use expiry to set refresh timer
|
||||
::
|
||||
:: XX may need to send this as a card so we don't wait
|
||||
::
|
||||
;< ~ bind:m
|
||||
(send-effect-on-bone:stdio bone [%http-response %start [%301 hed] ~ %.y])
|
||||
(initialize-authority aut.nam state)
|
||||
::
|
||||
[%dns %oauth %success ~]
|
||||
=/ bod=(unit octs)
|
||||
%- some
|
||||
%- as-octt:mimes:html
|
||||
%- en-xml:html
|
||||
;html
|
||||
;head
|
||||
;title: :dns oauth
|
||||
==
|
||||
;body
|
||||
;p: you may close the browser window
|
||||
;p
|
||||
;span: XX remove me
|
||||
:: XX make path configurable
|
||||
::
|
||||
;a(href "/dns/oauth"): again
|
||||
==
|
||||
==
|
||||
==
|
||||
;< ~ bind:m (send-effect:stdio %http-response %start [%201 ~] bod %.y)
|
||||
(pure:m state)
|
||||
==
|
||||
==
|
||||
::
|
||||
++ handle-diff
|
||||
|= [=dock =path =in-peer-data]
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?. =(dock collector-app)
|
||||
(pure:m state)
|
||||
=* req request.in-peer-data
|
||||
=/ =target [%direct address.req]
|
||||
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship.req target])
|
||||
(pure:m state)
|
||||
::
|
||||
++ handle-take
|
||||
|= =sign:tapp
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?. ?=(%quit -.sign)
|
||||
:: XX handle stuff
|
||||
::
|
||||
(pure:m state)
|
||||
::
|
||||
?. ?& =(dock.sign collector-app)
|
||||
=(path.sign /requests)
|
||||
==
|
||||
~& [%unexpected-quit-wat-do [dock path]:sign]
|
||||
(pure:m state)
|
||||
::
|
||||
;< ~ bind:m (peer-app:stdio collector-app /requests)
|
||||
(pure:m state)
|
||||
--
|
||||
@ -1,15 +1,16 @@
|
||||
:: eth-watcher: ethereum event log collector
|
||||
::
|
||||
/- *eth-watcher
|
||||
/+ tapp, stdio, ethio
|
||||
/- *eth-watcher, spider
|
||||
/+ default-agent, verb
|
||||
=, ethereum-types
|
||||
=, able:jael
|
||||
::
|
||||
=> |%
|
||||
++ refresh-rate ~m5
|
||||
++ refresh-rate ~m5 :: ~m5
|
||||
--
|
||||
::
|
||||
=> |%
|
||||
+$ card card:agent:mall
|
||||
+$ app-state
|
||||
$: %0
|
||||
dogs=(map path watchdog)
|
||||
@ -18,6 +19,7 @@
|
||||
+$ context [=path dog=watchdog]
|
||||
+$ watchdog
|
||||
$: config
|
||||
running=(unit =tid:spider)
|
||||
=number:block
|
||||
=pending-logs
|
||||
=history
|
||||
@ -26,298 +28,298 @@
|
||||
::
|
||||
:: history: newest block first, oldest event first
|
||||
+$ history (list loglist)
|
||||
+$ pending-logs (map number:block loglist)
|
||||
::
|
||||
+$ peek-data
|
||||
[%atom =next-block=number:block]
|
||||
+$ in-poke-data
|
||||
$: %eth-watcher-poke
|
||||
poke
|
||||
==
|
||||
+$ out-poke-data ~
|
||||
+$ in-peer-data ~
|
||||
+$ out-peer-data
|
||||
$: %eth-watcher-diff
|
||||
diff
|
||||
==
|
||||
++ tapp
|
||||
%: ^tapp
|
||||
app-state
|
||||
peek-data
|
||||
in-poke-data
|
||||
out-poke-data
|
||||
in-peer-data
|
||||
out-peer-data
|
||||
==
|
||||
++ tapp-async tapp-async:tapp
|
||||
++ stdio (^stdio out-poke-data out-peer-data)
|
||||
++ ethio (^ethio out-poke-data out-peer-data)
|
||||
--
|
||||
::
|
||||
:: Async helpers
|
||||
:: Helpers
|
||||
::
|
||||
=> |%
|
||||
++ send-logs
|
||||
|= [=path =loglist]
|
||||
=/ m (async:stdio ,~)
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?~ loglist
|
||||
(pure:m ~)
|
||||
;< ~ bind:m (send-update path %log i.loglist)
|
||||
loop(loglist t.loglist)
|
||||
++ wait
|
||||
|= now=@da
|
||||
^- card
|
||||
[%pass /timer %arvo %b %wait (add now refresh-rate)]
|
||||
::
|
||||
++ send-update
|
||||
|= [=path =diff]
|
||||
=/ m (async:stdio ,~)
|
||||
^- form:m
|
||||
=. path [%logs path]
|
||||
(give-result:stdio path %eth-watcher-diff diff)
|
||||
--
|
||||
::
|
||||
:: Main loop
|
||||
::
|
||||
=> |%
|
||||
++ wait-shortcut
|
||||
|= now=@da
|
||||
^- card
|
||||
[%pass /shortcut %arvo %b %wait now]
|
||||
::
|
||||
:: Update watchdog configuration, then look for updates
|
||||
++ poke-spider
|
||||
|= [=path our=@p =cage]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %poke cage]
|
||||
::
|
||||
++ configure
|
||||
|= [context =config]
|
||||
=/ m (async:stdio ,watchdog)
|
||||
^- form:m
|
||||
%+ get-updates path
|
||||
%_ dog
|
||||
- config
|
||||
number from.config
|
||||
==
|
||||
++ watch-spider
|
||||
|= [=path our=@p =sub=path]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %watch sub-path]
|
||||
::
|
||||
:: Get updates since last checked
|
||||
::
|
||||
++ get-updates
|
||||
|= context
|
||||
=/ m (async:stdio ,watchdog)
|
||||
^- form:m
|
||||
;< =latest=block bind:m (get-latest-block:ethio url.dog)
|
||||
;< dog=watchdog bind:m (zoom [path dog] number.id.latest-block)
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?: (gth number.dog number.id.latest-block)
|
||||
(pure:m dog)
|
||||
;< =block bind:m (get-block-by-number:ethio url.dog number.dog)
|
||||
;< dog=watchdog bind:m
|
||||
(take-block [path dog] block)
|
||||
loop(dog dog)
|
||||
::
|
||||
:: Process a block, detecting and handling reorgs
|
||||
::
|
||||
++ take-block
|
||||
|= [context =block]
|
||||
=/ m (async:stdio ,watchdog)
|
||||
^- form:m
|
||||
:: if this next block isn't direct descendant of our logs, reorg happened
|
||||
?: &(?=(^ blocks.dog) !=(parent-hash.block hash.id.i.blocks.dog))
|
||||
(rewind [path dog] block)
|
||||
;< [=new=pending-logs =released=loglist] bind:m
|
||||
(release-old-events path pending-logs.dog number.id.block)
|
||||
;< =new=loglist bind:m :: oldest first
|
||||
(get-logs-by-hash:ethio url.dog hash.id.block contracts.dog topics.dog)
|
||||
=. new-pending-logs
|
||||
(~(put by new-pending-logs) number.id.block new-loglist)
|
||||
%- pure:m
|
||||
%_ dog
|
||||
number +(number.id.block)
|
||||
pending-logs new-pending-logs
|
||||
history [released-loglist history.dog]
|
||||
blocks [block blocks.dog]
|
||||
==
|
||||
::
|
||||
:: Release events if they're more than 30 blocks ago
|
||||
::
|
||||
++ release-old-events
|
||||
|= [=path =pending-logs =number:block]
|
||||
=/ m (async:stdio ,[^pending-logs loglist])
|
||||
^- form:m
|
||||
?: (lth number 30) (pure:m pending-logs ~)
|
||||
=/ rel-number (sub number 30)
|
||||
=/ =loglist (~(get ja pending-logs) rel-number)
|
||||
;< ~ bind:m (send-logs path loglist)
|
||||
(pure:m (~(del by pending-logs) rel-number) loglist)
|
||||
::
|
||||
:: Reorg detected, so rewind until we're back in sync
|
||||
::
|
||||
++ rewind
|
||||
:: block: wants to be head of blocks.dog, but might not match
|
||||
|= [context =block]
|
||||
=/ m (async:stdio ,watchdog)
|
||||
=* blocks blocks.dog
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
:: if we have no further history to rewind, we're done
|
||||
?~ blocks
|
||||
(pure:m dog(blocks [block blocks]))
|
||||
:: if target block is directly after "latest", we're done
|
||||
?: =(parent-hash.block hash.id.i.blocks)
|
||||
(pure:m dog(blocks [block blocks]))
|
||||
:: next-block: the new target block
|
||||
;< =next=^block bind:m
|
||||
(get-block-by-number:ethio url.dog number.id.i.blocks)
|
||||
:: remove from either pending-logs or history
|
||||
?: =(~ pending-logs.dog)
|
||||
:: if no more pending logs, start deleting from history instead
|
||||
::NOTE this assumes there's one history entry per item in blocks.
|
||||
:: while +zoom breaks that assumption by clearing blocks, we won't
|
||||
:: run out of history before running out of blocks, allowing us to
|
||||
:: skip the =(number.id.block number.id.i.i.history) check.
|
||||
?~ history.dog
|
||||
loop(block next-block, blocks t.blocks)
|
||||
;< ~ bind:m
|
||||
:: don't bother sending a disavow if there were no logs there
|
||||
?~ i.history.dog (pure:(async:stdio ,~) ~)
|
||||
(disavow path block)
|
||||
loop(block next-block, blocks t.blocks, history.dog t.history.dog)
|
||||
=. pending-logs.dog
|
||||
(~(del by pending-logs.dog) number.id.block)
|
||||
loop(block next-block, blocks t.blocks)
|
||||
::
|
||||
:: Tell subscribers there was a deep reorg
|
||||
::
|
||||
++ disavow
|
||||
|= [=path =block]
|
||||
=/ m (async:stdio ,~)
|
||||
^- form:m
|
||||
(send-update path %disavow id.block)
|
||||
::
|
||||
:: Zoom forward to near a given block number.
|
||||
::
|
||||
:: Zooming doesn't go forward one block at a time. As a
|
||||
:: consequence, it cannot detect and handle reorgs. Only use it
|
||||
:: at a safe distance -- 500 blocks ago is probably sufficient.
|
||||
::
|
||||
++ zoom
|
||||
|= [context =latest=number:block]
|
||||
=/ m (async:stdio ,watchdog)
|
||||
^- form:m
|
||||
=/ zoom-margin=number:block 100
|
||||
?: (lth latest-number (add number.dog zoom-margin))
|
||||
(pure:m dog)
|
||||
=/ to-number=number:block (sub latest-number zoom-margin)
|
||||
;< =loglist bind:m :: oldest first
|
||||
%: get-logs-by-range:ethio
|
||||
url.dog
|
||||
contracts.dog
|
||||
topics.dog
|
||||
number.dog
|
||||
to-number
|
||||
==
|
||||
;< ~ bind:m (send-logs path loglist)
|
||||
=. number.dog +(to-number)
|
||||
=. blocks.dog ~
|
||||
=. history.dog [loglist history.dog]
|
||||
(pure:m dog)
|
||||
++ leave-spider
|
||||
|= [=path our=@p]
|
||||
^- card
|
||||
[%pass [%running path] %agent [our %spider] %leave ~]
|
||||
--
|
||||
::
|
||||
:: Main
|
||||
::
|
||||
=* default-tapp default-tapp:tapp
|
||||
%- create-tapp-all:tapp
|
||||
^- tapp-core-all:tapp
|
||||
|_ [=bowl:gall state=app-state]
|
||||
++ handle-init
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
^- agent:mall
|
||||
=| state=app-state
|
||||
%+ verb &
|
||||
|_ =bowl:mall
|
||||
+* this .
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ on-init
|
||||
^- (quip card _this)
|
||||
:: start update timer loop
|
||||
;< now=@da bind:m get-time:stdio
|
||||
;< ~ bind:m (wait-effect:stdio (add now refresh-rate))
|
||||
(pure:m state)
|
||||
[[(wait now.bowl) ~] this]
|
||||
::
|
||||
++ handle-diff handle-diff:default-tapp
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
=+ !<(old-state=app-state old)
|
||||
`this(state old-state)
|
||||
::
|
||||
++ handle-poke
|
||||
|= in=in-poke-data
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?- +<.in
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
?: ?=(%noun mark)
|
||||
~& state
|
||||
`this
|
||||
?. ?=(%eth-watcher-poke mark)
|
||||
(on-poke:def mark vase)
|
||||
::
|
||||
=+ !<(=poke vase)
|
||||
?- -.poke
|
||||
%watch
|
||||
:: fully restart the watchdog if it doesn't exist yet,
|
||||
:: or if the new config changes more than just the url.
|
||||
=/ restart=?
|
||||
?| !(~(has by dogs.state) path.in)
|
||||
?! .= ->:(~(got by dogs.state) path.in)
|
||||
+.config.in
|
||||
?| !(~(has by dogs.state) path.poke)
|
||||
?! .= ->:(~(got by dogs.state) path.poke)
|
||||
+.config.poke
|
||||
==
|
||||
~? &((~(has by dogs.state) path.in) restart)
|
||||
[dap.bowl 'overwriting existing watchdog on' path.in]
|
||||
;< dog=watchdog bind:m
|
||||
~? &((~(has by dogs.state) path.poke) restart)
|
||||
[dap.bowl 'overwriting existing watchdog on' path.poke]
|
||||
=/ restart-cards
|
||||
=/ dog (~(get by dogs.state) path.poke)
|
||||
?. ?& restart
|
||||
?=(^ dog)
|
||||
?=(^ running.u.dog)
|
||||
==
|
||||
~
|
||||
=/ =cage [%spider-stop !>([u.running.u.dog &])]
|
||||
[%pass [%starting path] %agent [our.bowl %spider] %poke cage]
|
||||
=/ new-dog
|
||||
=/ dog=watchdog
|
||||
?: restart *watchdog
|
||||
(~(got by dogs.state) path.in)
|
||||
(configure [path.in dog] config.in)
|
||||
=. dogs.state (~(put by dogs.state) path.in dog)
|
||||
(pure:m state)
|
||||
(~(got by dogs.state) path.poke)
|
||||
%_ dog
|
||||
- config.poke
|
||||
number from.config.poke
|
||||
==
|
||||
=. dogs.state (~(put by dogs.state) path.poke new-dog)
|
||||
[[(wait-shortcut now.bowl) ~] this]
|
||||
::
|
||||
%clear
|
||||
=. dogs.state (~(del by dogs.state) path.in)
|
||||
(pure:m state)
|
||||
=. dogs.state (~(del by dogs.state) path.poke)
|
||||
[~ this]
|
||||
==
|
||||
::
|
||||
++ handle-take
|
||||
|= =sign:tapp
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?+ -.sign ~|([%strange-sign -.sign] !!)
|
||||
%wake
|
||||
;< ~ bind:m
|
||||
;< now=@da bind:(async:tapp ,~) get-time:stdio
|
||||
=/ next=@da (add now refresh-rate)
|
||||
::NOTE we use +send-raw-card here to ensure we always set a new timer,
|
||||
:: regardless of what happens further on in the flow.
|
||||
(send-raw-card:stdio %wait /effect/(scot %da next) next)
|
||||
::TODO ideally we'd process these in parallel. this seems possible,
|
||||
:: but requires non-trivial work, as it deviates from tapp's flow.
|
||||
:: (when making that change, take note of rpc request id's.)
|
||||
=/ dogs=(list [=path dog=watchdog]) ~(tap by dogs.state)
|
||||
|- ^- form:m
|
||||
=* loop $
|
||||
?~ dogs
|
||||
(pure:m state)
|
||||
=, i.dogs
|
||||
;< dog=watchdog bind:m (get-updates path dog)
|
||||
=. dogs.state (~(put by dogs.state) path dog)
|
||||
loop(dogs t.dogs)
|
||||
==
|
||||
::
|
||||
:: +handle-peer: subscribe & get initial subscription data
|
||||
:: +on-watch: subscribe & get initial subscription data
|
||||
::
|
||||
:: /logs/some-path:
|
||||
::
|
||||
++ handle-peer
|
||||
++ on-watch
|
||||
|= =path
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
^- (quip card agent:mall)
|
||||
?. ?=([%logs ^] path)
|
||||
~| [%invalid-subscription-path path]
|
||||
!!
|
||||
;< ~ bind:m
|
||||
%+ send-effect-on-bone:stdio ost.bowl
|
||||
:+ %diff %eth-watcher-diff
|
||||
:_ this :_ ~
|
||||
:* %give %fact ~ %eth-watcher-diff !>
|
||||
:- %history
|
||||
^- loglist
|
||||
%- zing
|
||||
%- flop
|
||||
=< history
|
||||
(~(gut by dogs.state) t.path *watchdog)
|
||||
(pure:m state)
|
||||
==
|
||||
::
|
||||
:: +handle-peek: get diagnostics data
|
||||
++ on-leave on-leave:def
|
||||
::
|
||||
:: +on-peek: get diagnostics data
|
||||
::
|
||||
:: /block/some-path: get next block number to check for /some-path
|
||||
::
|
||||
++ handle-peek
|
||||
++ on-peek
|
||||
|= =path
|
||||
^- (unit (unit peek-data))
|
||||
^- (unit (unit cage))
|
||||
?. ?=([%x %block ^] path) ~
|
||||
?. (~(has by dogs.state) t.t.path) ~
|
||||
:+ ~ ~
|
||||
:- %atom
|
||||
number:(~(got by dogs.state) t.t.path)
|
||||
!>(number:(~(got by dogs.state) t.t.path))
|
||||
::
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:mall]
|
||||
|^
|
||||
^- (quip card agent:mall)
|
||||
?. ?=([%running *] wire)
|
||||
(on-agent:def wire sign)
|
||||
?- -.sign
|
||||
%poke-ack
|
||||
?~ p.sign
|
||||
[~ this]
|
||||
%- (slog leaf+"eth-watcher couldn't start thread" u.p.sign)
|
||||
:_ (clear-running t.wire) :_ ~
|
||||
(leave-spider t.wire our.bowl)
|
||||
::
|
||||
%watch-ack
|
||||
?~ p.sign
|
||||
[~ this]
|
||||
%- (slog leaf+"eth-watcher couldn't start listen to thread" u.p.sign)
|
||||
[~ (clear-running t.wire)]
|
||||
::
|
||||
%kick [~ (clear-running t.wire)]
|
||||
%fact
|
||||
=* path t.wire
|
||||
=/ dog (~(get by dogs.state) path)
|
||||
?~ dog
|
||||
[~ this]
|
||||
?+ p.cage.sign (on-agent:def wire sign)
|
||||
%thread-fail
|
||||
=+ !<([=term =tang] q.cage.sign)
|
||||
%- (slog leaf+"eth-watcher failed; will retry" leaf+<term> tang)
|
||||
[~ this(dogs.state (~(put by dogs.state) path u.dog(running ~)))]
|
||||
::
|
||||
%thread-done
|
||||
=+ !<([vows=disavows pup=watchpup] q.cage.sign)
|
||||
=. u.dog
|
||||
%_ u.dog
|
||||
- -.pup
|
||||
number number.pup
|
||||
blocks blocks.pup
|
||||
pending-logs pending-logs.pup
|
||||
==
|
||||
=^ cards-1 u.dog (disavow path u.dog vows)
|
||||
=^ cards-2 u.dog (release-logs path u.dog)
|
||||
=. dogs.state (~(put by dogs.state) path u.dog(running ~))
|
||||
[(weld cards-1 cards-2) this]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ clear-running
|
||||
|= =path
|
||||
=/ dog (~(get by dogs.state) path)
|
||||
?~ dog
|
||||
this
|
||||
this(dogs.state (~(put by dogs.state) path u.dog(running ~)))
|
||||
::
|
||||
++ disavow
|
||||
|= [=path dog=watchdog vows=disavows]
|
||||
^- (quip card watchdog)
|
||||
=/ history-ids=(list [id:block loglist])
|
||||
%+ murn history.dog
|
||||
|= logs=loglist
|
||||
^- (unit [id:block loglist])
|
||||
?~ logs
|
||||
~
|
||||
`[[block-hash block-number]:(need mined.i.logs) logs]
|
||||
=/ actual-vows=disavows
|
||||
%+ skim vows
|
||||
|= =id:block
|
||||
(lien history-ids |=([=history=id:block *] =(id history-id)))
|
||||
=/ actual-history=history
|
||||
%+ murn history-ids
|
||||
|= [=id:block logs=loglist]
|
||||
^- (unit loglist)
|
||||
?: (lien actual-vows |=(=vow=id:block =(id vow-id)))
|
||||
~
|
||||
`logs
|
||||
:_ dog(history actual-history)
|
||||
%+ turn actual-vows
|
||||
|= =id:block
|
||||
[%give %fact `[%logs path] %eth-watcher-diff !>([%disavow id])]
|
||||
::
|
||||
++ release-logs
|
||||
|= [=path dog=watchdog]
|
||||
^- (quip card watchdog)
|
||||
?: (lth number.dog 30)
|
||||
`dog
|
||||
=/ rel-number (sub number.dog 30)
|
||||
=/ numbers=(list number:block) ~(tap in ~(key by pending-logs.dog))
|
||||
=. numbers (sort numbers lth)
|
||||
|- ^- (quip card watchdog)
|
||||
?~ numbers
|
||||
`dog
|
||||
?: (gth i.numbers rel-number)
|
||||
$(numbers t.numbers)
|
||||
=^ cards-1 dog
|
||||
=/ =loglist (~(get ja pending-logs.dog) i.numbers)
|
||||
=. pending-logs.dog (~(del by pending-logs.dog) i.numbers)
|
||||
?~ loglist
|
||||
`dog
|
||||
=. history.dog [loglist history.dog]
|
||||
:_ dog
|
||||
%+ turn loglist
|
||||
|= =event-log:rpc:ethereum
|
||||
^- card
|
||||
[%give %fact `[%logs path] %eth-watcher-diff !>([%log event-log])]
|
||||
=^ cards-2 dog $(numbers t.numbers)
|
||||
[(weld cards-1 cards-2) dog]
|
||||
--
|
||||
::
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- (quip card agent:mall)
|
||||
?+ +<.sign-arvo ~|([%strange-sign-arvo -.sign-arvo] !!)
|
||||
%wake
|
||||
=; rest
|
||||
?. =(/timer wire)
|
||||
rest
|
||||
[[(wait now.bowl) -.rest] +.rest]
|
||||
?^ error.sign-arvo
|
||||
:: failed, try again. maybe should tell user if fails more than
|
||||
:: 5 times.
|
||||
::
|
||||
[[(wait now.bowl) ~] this]
|
||||
:: start all updates in parallel
|
||||
::
|
||||
=/ dogs=(list [=path dog=watchdog]) ~(tap by dogs.state)
|
||||
=| cards=(list card)
|
||||
=/ tid-gen ~(. og eny.bowl)
|
||||
^- (quip card agent:mall)
|
||||
=- [(flop -<) ->]
|
||||
|- ^- (quip card agent:mall)
|
||||
=* loop $
|
||||
?~ dogs
|
||||
[cards this]
|
||||
=, i.dogs
|
||||
?^ running.dog.i.dogs
|
||||
:: if still running, kill it and restart
|
||||
::
|
||||
%- (slog leaf+"eth-watcher still running; will restart" ~)
|
||||
=/ =cage [%spider-stop !>([u.running.dog |])]
|
||||
=. cards
|
||||
:* [%pass [%starting path] %agent [our.bowl %spider] %poke cage]
|
||||
(leave-spider path our.bowl)
|
||||
cards
|
||||
==
|
||||
loop(i.dogs i.dogs(running.dog ~))
|
||||
::
|
||||
=^ rand tid-gen (raws:tid-gen 128)
|
||||
=/ new-tid (cat 3 'eth-watcher--' (scot %uv rand))
|
||||
=> .(running.dog.i.dogs `new-tid)
|
||||
=/ args
|
||||
:^ ~ `new-tid %eth-watcher
|
||||
!>(`watchpup`[- number pending-logs blocks]:dog)
|
||||
=. cards
|
||||
:* (watch-spider path our.bowl /thread-result/[new-tid])
|
||||
(poke-spider path our.bowl %spider-start !>(args))
|
||||
cards
|
||||
==
|
||||
=. dogs.state (~(put by dogs.state) path dog)
|
||||
loop(dogs t.dogs)
|
||||
==
|
||||
::
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
|
||||
@ -1,7 +0,0 @@
|
||||
|_ [=bowl:gall ~]
|
||||
++ poke-noun
|
||||
|= a=*
|
||||
:_ ..poke-noun
|
||||
=/ force ?=(%force a)
|
||||
[[ost.bowl %goad /goad force ~] ~]
|
||||
--
|
||||
@ -1,228 +0,0 @@
|
||||
:: group-hook: allow syncing group data from foreign paths to local paths
|
||||
::
|
||||
/- *group-store, *group-hook
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff [%group-update group-update]]
|
||||
[%quit ~]
|
||||
[%poke wire dock [%group-action group-action]]
|
||||
[%pull wire dock ~]
|
||||
[%peer wire dock path]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: synced=(map path ship)
|
||||
boned=(map wire (list bone))
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
[~ this]
|
||||
[~ this(+<+ u.old)]
|
||||
::
|
||||
++ poke-group-hook-action
|
||||
|= act=group-hook-action
|
||||
^- (quip move _this)
|
||||
?- -.act
|
||||
%add
|
||||
?. (team:title our.bol src.bol)
|
||||
[~ this]
|
||||
=/ group-path [%group path.act]
|
||||
=/ group-wire [(scot %p ship.act) group-path]
|
||||
?: (~(has by synced) path.act)
|
||||
[~ this]
|
||||
=. synced (~(put by synced) path.act ship.act)
|
||||
:_ (track-bone group-wire)
|
||||
?: =(ship.act our.bol)
|
||||
[ost.bol %peer group-wire [ship.act %group-store] group-path]~
|
||||
[ost.bol %peer group-wire [ship.act %group-hook] group-path]~
|
||||
::
|
||||
%remove
|
||||
=/ ship (~(get by synced) path.act)
|
||||
?~ ship
|
||||
[~ this]
|
||||
?: &(=(u.ship our.bol) (team:title our.bol src.bol))
|
||||
:: delete one of our own paths
|
||||
=/ group-wire [(scot %p our.bol) %group path.act]
|
||||
:_ this(synced (~(del by synced) path.act))
|
||||
%+ weld
|
||||
(pull-wire group-wire path.act)
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib [%group path.act] bol)
|
||||
|= [=bone *]
|
||||
^- move
|
||||
[bone %quit ~]
|
||||
?: |(=(u.ship src.bol) (team:title our.bol src.bol))
|
||||
:: delete a foreign ship's path
|
||||
=/ group-wire [(scot %p u.ship) %group path.act]
|
||||
:_ this(synced (~(del by synced) path.act))
|
||||
(pull-wire group-wire path.act)
|
||||
:: don't allow
|
||||
[~ this]
|
||||
==
|
||||
::
|
||||
++ peer-group
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?~ pax !!
|
||||
?> (~(has by synced) pax)
|
||||
=/ grp (group-scry pax)
|
||||
?~ grp !!
|
||||
:_ this
|
||||
[ost.bol %diff [%group-update [%path u.grp pax]]]~
|
||||
::
|
||||
++ diff-group-update
|
||||
|= [wir=wire diff=group-update]
|
||||
^- (quip move _this)
|
||||
?: (team:title our.bol src.bol)
|
||||
(handle-local diff)
|
||||
(handle-foreign diff)
|
||||
::
|
||||
++ handle-local
|
||||
|= diff=group-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%keys [~ this]
|
||||
%path [~ this]
|
||||
%bundle [~ this]
|
||||
%add [(update-subscribers [%group pax.diff] diff) this]
|
||||
%remove [(update-subscribers [%group pax.diff] diff) this]
|
||||
::
|
||||
%unbundle
|
||||
:_ this(synced (~(del by synced) pax.diff))
|
||||
%+ weld
|
||||
(update-subscribers [%group pax.diff] diff)
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib [%group pax.diff] bol)
|
||||
|= [=bone *]
|
||||
[bone %quit ~]
|
||||
==
|
||||
::
|
||||
++ handle-foreign
|
||||
|= diff=group-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%keys [~ this]
|
||||
%bundle [~ this]
|
||||
::
|
||||
%path
|
||||
:_ this
|
||||
?~ pax.diff ~
|
||||
=/ ship (~(get by synced) pax.diff)
|
||||
?~ ship ~
|
||||
?. =(src.bol u.ship) ~
|
||||
:~ (group-poke pax.diff [%unbundle pax.diff])
|
||||
(group-poke pax.diff [%bundle pax.diff])
|
||||
(group-poke pax.diff [%add members.diff pax.diff])
|
||||
==
|
||||
::
|
||||
%add
|
||||
:_ this
|
||||
?~ pax.diff ~
|
||||
=/ ship (~(get by synced) pax.diff)
|
||||
?~ ship ~
|
||||
?. =(src.bol u.ship) ~
|
||||
[(group-poke pax.diff diff)]~
|
||||
::
|
||||
%remove
|
||||
:_ this
|
||||
?~ pax.diff ~
|
||||
=/ ship (~(get by synced) pax.diff)
|
||||
?~ ship ~
|
||||
?. =(src.bol u.ship) ~
|
||||
[(group-poke pax.diff diff)]~
|
||||
::
|
||||
%unbundle
|
||||
?~ pax.diff
|
||||
[~ this]
|
||||
=/ ship (~(get by synced) pax.diff)
|
||||
?~ ship
|
||||
[~ this]
|
||||
?. =(src.bol u.ship)
|
||||
[~ this]
|
||||
:_ this(synced (~(del by synced) pax.diff))
|
||||
[(group-poke pax.diff diff)]~
|
||||
==
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
=^ =ship wir
|
||||
?> ?=([* ^] wir)
|
||||
[(slav %p i.wir) t.t.wir]
|
||||
?. (~(has by synced) wir)
|
||||
[~ this]
|
||||
=/ group-path [%group wir]
|
||||
=/ group-wire [(scot %p ship) group-path]
|
||||
:_ (track-bone group-wire)
|
||||
[ost.bol %peer group-wire [ship %group-hook] group-path]~
|
||||
::
|
||||
++ reap
|
||||
|= [wir=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
?~ saw
|
||||
[~ this]
|
||||
=^ =ship wir
|
||||
?> ?=([* ^] wir)
|
||||
[(slav %p i.wir) t.t.wir]
|
||||
~& %insufficient-permissions-for-group
|
||||
[((slog u.saw) ~) this(synced (~(del by synced) wir))]
|
||||
::
|
||||
++ group-poke
|
||||
|= [pax=path action=group-action]
|
||||
^- move
|
||||
[ost.bol %poke pax [our.bol %group-store] [%group-action action]]
|
||||
::
|
||||
++ group-scry
|
||||
|= pax=path
|
||||
^- (unit group)
|
||||
.^((unit group) %gx ;:(weld /=group-store/(scot %da now.bol) pax /noun))
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path diff=group-update]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
^- move
|
||||
[bone %diff [%group-update diff]]
|
||||
::
|
||||
++ track-bone
|
||||
|= wir=wire
|
||||
^+ this
|
||||
=/ bnd (~(get by boned) wir)
|
||||
?^ bnd
|
||||
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
|
||||
this(boned (~(put by boned) wir [ost.bol]~))
|
||||
::
|
||||
++ pull-wire
|
||||
|= [wir=wire pax=path]
|
||||
^- (list move)
|
||||
=/ bnd (~(get by boned) wir)
|
||||
?~ bnd
|
||||
~
|
||||
=/ shp (~(get by synced) pax)
|
||||
?~ shp
|
||||
~
|
||||
%+ turn u.bnd
|
||||
|= ost=bone
|
||||
^- move
|
||||
?: =(u.shp our.bol)
|
||||
[ost %pull wir [our.bol %group-store] ~]
|
||||
[ost %pull wir [u.shp %group-hook] ~]
|
||||
::
|
||||
--
|
||||
|
||||
@ -1,144 +0,0 @@
|
||||
:: group-store: data store for groups of ships
|
||||
::
|
||||
/- *group-store
|
||||
|%
|
||||
+$ move [bone [%diff diff]]
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: =groups
|
||||
==
|
||||
::
|
||||
+$ diff
|
||||
$% [%group-update group-update]
|
||||
[%group-initial groups]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
[~ ?~(old this this(+<+ u.old))]
|
||||
::
|
||||
++ peek-x
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (unit group)]))
|
||||
?~ pax
|
||||
[~ ~ %noun ~]
|
||||
=/ grp=(unit group) (~(get by groups) pax)
|
||||
[~ ~ %noun grp]
|
||||
::
|
||||
++ peer-all
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: we now proxy all events to this path
|
||||
:_ this
|
||||
[ost.bol %diff %group-initial groups]~
|
||||
::
|
||||
++ peer-keys
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: we send the list of keys then send events when they change
|
||||
:_ this
|
||||
[ost.bol %diff %group-update [%keys ~(key by groups)]]~
|
||||
::
|
||||
++ peer-group
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ grp (~(got by groups) pax)
|
||||
:_ this
|
||||
[ost.bol %diff %group-update [%path grp pax]]~
|
||||
::
|
||||
++ poke-group-action
|
||||
|= action=group-action
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?- -.action
|
||||
%add (handle-add action)
|
||||
%remove (handle-remove action)
|
||||
%bundle (handle-bundle action)
|
||||
%unbundle (handle-unbundle action)
|
||||
==
|
||||
::
|
||||
++ handle-add
|
||||
|= act=group-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%add -.act)
|
||||
?~ pax.act
|
||||
[~ this]
|
||||
?. (~(has by groups) pax.act)
|
||||
[~ this]
|
||||
=/ members (~(got by groups) pax.act)
|
||||
=. members (~(uni in members) members.act)
|
||||
?: =(members (~(got by groups) pax.act))
|
||||
[~ this]
|
||||
:- (send-diff pax.act act)
|
||||
this(groups (~(put by groups) pax.act members))
|
||||
::
|
||||
++ handle-remove
|
||||
|= act=group-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%remove -.act)
|
||||
?~ pax.act
|
||||
[~ this]
|
||||
?. (~(has by groups) pax.act)
|
||||
[~ this]
|
||||
=/ members (~(got by groups) pax.act)
|
||||
=. members (~(dif in members) members.act)
|
||||
?: =(members (~(got by groups) pax.act))
|
||||
[~ this]
|
||||
:- (send-diff pax.act act)
|
||||
this(groups (~(put by groups) pax.act members))
|
||||
::
|
||||
++ handle-bundle
|
||||
|= act=group-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%bundle -.act)
|
||||
?~ pax.act
|
||||
[~ this]
|
||||
?: (~(has by groups) pax.act)
|
||||
[~ this]
|
||||
:- (send-diff pax.act act)
|
||||
this(groups (~(put by groups) pax.act *group))
|
||||
::
|
||||
++ handle-unbundle
|
||||
|= act=group-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%unbundle -.act)
|
||||
?~ pax.act
|
||||
[~ this]
|
||||
?. (~(has by groups) pax.act)
|
||||
[~ this]
|
||||
:- (send-diff pax.act act)
|
||||
this(groups (~(del by groups) pax.act))
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path act=group-action]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %group-update act]
|
||||
::
|
||||
++ send-diff
|
||||
|= [pax=path act=group-action]
|
||||
^- (list move)
|
||||
%- zing
|
||||
:~ (update-subscribers /all act)
|
||||
(update-subscribers [%group pax] act)
|
||||
?. |(=(%bundle -.act) =(%unbundle -.act))
|
||||
~
|
||||
(update-subscribers /keys act)
|
||||
==
|
||||
::
|
||||
--
|
||||
|
||||
@ -1,61 +0,0 @@
|
||||
:: invite-hook: receive invites from any source
|
||||
::
|
||||
/+ *invite-json
|
||||
|%
|
||||
+$ move [bone [%poke wire dock [%invite-action invite-action]]]
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall ~]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ poke-json
|
||||
|= =json
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ act (json-to-action json)
|
||||
?> ?=(%invite -.act)
|
||||
:_ this
|
||||
[(invite-hook-poke recipient.invite.act act)]~
|
||||
::
|
||||
++ poke-invite-action
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
?+ -.act
|
||||
~
|
||||
::
|
||||
%invite
|
||||
?: (team:title our.bol src.bol)
|
||||
?> !(team:title our.bol ship.invite.act)
|
||||
[(invite-hook-poke recipient.invite.act act)]~
|
||||
?> ?=(^ (invitatory-scry path.act))
|
||||
?> ?=(~ (invite-scry path.act uid.act))
|
||||
[(invite-poke path.act act)]~
|
||||
==
|
||||
::
|
||||
++ invite-hook-poke
|
||||
|= [=ship action=invite-action]
|
||||
^- move
|
||||
[ost.bol %poke /invite-hook [ship %invite-hook] [%invite-action action]]
|
||||
::
|
||||
++ invite-poke
|
||||
|= [pax=path action=invite-action]
|
||||
^- move
|
||||
[ost.bol %poke pax [our.bol %invite-store] [%invite-action action]]
|
||||
::
|
||||
++ invitatory-scry
|
||||
|= pax=path
|
||||
^- (unit invitatory)
|
||||
=. pax
|
||||
;:(weld /=invite-store/(scot %da now.bol)/invitatory pax /noun)
|
||||
.^((unit invitatory) %gx pax)
|
||||
::
|
||||
++ invite-scry
|
||||
|= [pax=path uid=serial]
|
||||
^- (unit invite)
|
||||
=. pax
|
||||
;:(weld /=invite-store/(scot %da now.bol)/invite pax /(scot %uv uid)/noun)
|
||||
.^((unit invite) %gx pax)
|
||||
--
|
||||
|
||||
@ -1,174 +0,0 @@
|
||||
/+ *invite-json
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff invite-diff]
|
||||
[%quit ~]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ state-zero
|
||||
$: =invites
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
[~ this]
|
||||
[~ this(+<+ u.old)]
|
||||
::
|
||||
++ peek-x-all
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (map path invitatory)]))
|
||||
[~ ~ %noun invites]
|
||||
::
|
||||
++ peek-x-invitatory
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (unit invitatory)]))
|
||||
?~ pax
|
||||
~
|
||||
=/ invitatory=(unit invitatory) (~(get by invites) pax)
|
||||
[~ ~ %noun invitatory]
|
||||
::
|
||||
++ peek-x-invite
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (unit invite)]))
|
||||
:: /:path/:uid
|
||||
=/ pas (flop pax)
|
||||
?~ pas
|
||||
~
|
||||
=/ uid=serial (slav %uv i.pas)
|
||||
=. pax (scag (dec (lent pax)) `(list @ta)`pax)
|
||||
=/ invitatory=(unit invitatory) (~(get by invites) pax)
|
||||
?~ invitatory
|
||||
~
|
||||
=/ invite=(unit invite) (~(get by u.invitatory) uid)
|
||||
[~ ~ %noun invite]
|
||||
::
|
||||
++ peer-all
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: send all updates from now on
|
||||
:_ this
|
||||
[ost.bol %diff %invite-initial invites]~
|
||||
::
|
||||
++ peer-updates
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: send all updates from now on
|
||||
[~ this]
|
||||
::
|
||||
++ peer-invitatory
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
=/ inv=(unit invitatory) (~(get by invites) pax)
|
||||
?~ inv !!
|
||||
:_ this
|
||||
[ost.bol %diff %invite-update [%invitatory u.inv]]~
|
||||
::
|
||||
++ poke-json
|
||||
|= =json
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
(poke-invite-action (json-to-action json))
|
||||
::
|
||||
++ poke-invite-action
|
||||
|= action=invite-action
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?- -.action
|
||||
%create (handle-create action)
|
||||
%delete (handle-delete action)
|
||||
%invite (handle-invite action)
|
||||
%accept (handle-accept action)
|
||||
%decline (handle-decline action)
|
||||
==
|
||||
::
|
||||
++ handle-create
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%create -.act)
|
||||
?: (~(has by invites) path.act)
|
||||
[~ this]
|
||||
:- (send-diff path.act act)
|
||||
this(invites (~(put by invites) path.act *invitatory))
|
||||
::
|
||||
++ handle-delete
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%delete -.act)
|
||||
?. (~(has by invites) path.act)
|
||||
[~ this]
|
||||
:- (send-diff path.act act)
|
||||
this(invites (~(del by invites) path.act))
|
||||
::
|
||||
++ handle-invite
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%invite -.act)
|
||||
?. (~(has by invites) path.act)
|
||||
[~ this]
|
||||
=/ container (~(got by invites) path.act)
|
||||
=. uid.act (sham eny.bol)
|
||||
=. container (~(put by container) uid.act invite.act)
|
||||
:- (send-diff path.act act)
|
||||
this(invites (~(put by invites) path.act container))
|
||||
::
|
||||
++ handle-accept
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%accept -.act)
|
||||
?. (~(has by invites) path.act)
|
||||
[~ this]
|
||||
=/ container (~(got by invites) path.act)
|
||||
=/ invite (~(get by container) uid.act)
|
||||
?~ invite
|
||||
[~ this]
|
||||
=. container (~(del by container) uid.act)
|
||||
:- (send-diff path.act [%accepted path.act uid.act u.invite])
|
||||
this(invites (~(put by invites) path.act container))
|
||||
::
|
||||
++ handle-decline
|
||||
|= act=invite-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%decline -.act)
|
||||
?. (~(has by invites) path.act)
|
||||
[~ this]
|
||||
=/ container (~(got by invites) path.act)
|
||||
=/ invite (~(get by container) uid.act)
|
||||
?~ invite
|
||||
[~ this]
|
||||
=. container (~(del by container) uid.act)
|
||||
:- (send-diff path.act act)
|
||||
this(invites (~(put by invites) path.act container))
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path upd=invite-update]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %invite-update upd]
|
||||
::
|
||||
++ send-diff
|
||||
|= [pax=path upd=invite-update]
|
||||
^- (list move)
|
||||
%- zing
|
||||
:~ (update-subscribers /all upd)
|
||||
(update-subscribers /updates upd)
|
||||
(update-subscribers [%invitatory pax] upd)
|
||||
==
|
||||
::
|
||||
--
|
||||
@ -1,49 +0,0 @@
|
||||
:: invite-view: provide a json interface to invite-store
|
||||
::
|
||||
/+ *invite-json
|
||||
::
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%peer wire dock path]
|
||||
[%diff %json json]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall ~]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=*
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
[ost.bol %peer / [our.bol %invite-store] /updates]~
|
||||
::
|
||||
++ peer-primary
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:_ this
|
||||
[ost.bol %diff %json (invites-to-json invites-scry)]~
|
||||
::
|
||||
++ diff-invite-update
|
||||
|= [wir=wire upd=invite-update]
|
||||
^- (quip move _this)
|
||||
=/ updates-json (update-to-json upd)
|
||||
:_ this
|
||||
%+ turn (prey:pubsub:userlib /primary bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %json updates-json]
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
[ost.bol %peer / [our.bol %invite-store] /updates]~
|
||||
::
|
||||
++ invites-scry
|
||||
^- invites
|
||||
.^(invites %gx /=invite-store/(scot %da now.bol)/all/noun)
|
||||
--
|
||||
@ -1,150 +0,0 @@
|
||||
/- launch
|
||||
/+ *server
|
||||
::
|
||||
/= index
|
||||
/^ $-(marl manx)
|
||||
/: /===/app/launch/index /!noun/
|
||||
/= script
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/launch/js/index
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= style
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/launch/css/index
|
||||
/| /css/
|
||||
/~ ~
|
||||
==
|
||||
/= launch-png
|
||||
/^ (map knot @)
|
||||
/: /===/app/launch/img /_ /png/
|
||||
::
|
||||
=, launch
|
||||
::
|
||||
|%
|
||||
+$ state
|
||||
$% [%0 tiles=(set tile) data=tile-data path-to-tile=(map path @tas)]
|
||||
==
|
||||
::
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%http-response =http-event:http]
|
||||
[%connect wire binding:eyre term]
|
||||
[%peer wire dock path]
|
||||
[%diff %json json]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall sta=state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
:_ this
|
||||
[ost.bol %connect / [~ /] %launch]~
|
||||
[~ this(sta u.old)]
|
||||
::
|
||||
++ poke-launch-action
|
||||
|= act=action
|
||||
^- (quip move _this)
|
||||
=/ beforedata (~(get by data.sta) name.act)
|
||||
=/ newdata
|
||||
?~ beforedata
|
||||
(~(put by data.sta) name.act [*json url.act])
|
||||
(~(put by data.sta) name.act [jon.u.beforedata url.act])
|
||||
:- [ost.bol %peer subscribe.act [our.bol name.act] subscribe.act]~
|
||||
%= this
|
||||
tiles.sta (~(put in tiles.sta) [name.act subscribe.act])
|
||||
data.sta newdata
|
||||
path-to-tile.sta (~(put by path-to-tile.sta) subscribe.act name.act)
|
||||
==
|
||||
::
|
||||
++ peer-main
|
||||
|= [pax=path]
|
||||
^- (quip move _this)
|
||||
=/ data/json
|
||||
%- pairs:enjs:format
|
||||
%+ turn ~(tap by data.sta)
|
||||
|= [key=@tas [jon=json url=@t]]
|
||||
[key jon]
|
||||
:_ this
|
||||
[ost.bol %diff %json data]~
|
||||
::
|
||||
++ diff-json
|
||||
|= [pax=path jon=json]
|
||||
^- (quip move _this)
|
||||
=/ name/@tas (~(got by path-to-tile.sta) pax)
|
||||
=/ data/(unit [json url=@t]) (~(get by data.sta) name)
|
||||
?~ data
|
||||
[~ this]
|
||||
::
|
||||
:-
|
||||
%+ turn (prey:pubsub:userlib /main bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %json (frond:enjs:format name jon)]
|
||||
::
|
||||
%= this
|
||||
data.sta (~(put by data.sta) name [jon url.u.data])
|
||||
==
|
||||
::
|
||||
++ generate-script-marl
|
||||
|= data=tile-data
|
||||
^- marl
|
||||
%+ turn ~(tap by data)
|
||||
|= [key=@tas [jon=json url=@t]]
|
||||
^- manx
|
||||
;script@"{(trip url)}";
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
%- (require-authorization:app ost.bol move this)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
::
|
||||
=/ request-line (parse-request-line url.request.inbound-request)
|
||||
=/ name=@t
|
||||
=/ back-path (flop site.request-line)
|
||||
?~ back-path
|
||||
''
|
||||
i.back-path
|
||||
=/ site (flop site.request-line)
|
||||
?~ site
|
||||
=/ hym=manx (index (generate-script-marl data.sta))
|
||||
:_ this
|
||||
[ost.bol %http-response (manx-response:app hym)]~
|
||||
?+ site.request-line
|
||||
:_ this
|
||||
[ost.bol %http-response not-found:app]~
|
||||
::
|
||||
:: styling
|
||||
::
|
||||
[%'~launch' %css %index ~]
|
||||
:_ this
|
||||
[ost.bol %http-response (css-response:app style)]~
|
||||
::
|
||||
:: javascript
|
||||
::
|
||||
[%'~launch' %js %index ~]
|
||||
:_ this
|
||||
[ost.bol %http-response (js-response:app script)]~
|
||||
::
|
||||
:: images
|
||||
::
|
||||
[%'~launch' %img *]
|
||||
=/ img (as-octs:mimes:html (~(got by launch-png) `@ta`name))
|
||||
:_ this
|
||||
[ost.bol %http-response (png-response:app img)]~
|
||||
==
|
||||
::
|
||||
++ bound
|
||||
|= [wir=wire success=? binding=binding:eyre]
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
--
|
||||
@ -1,5 +1,5 @@
|
||||
/- lens, *sole
|
||||
/+ base64, *server
|
||||
/+ base64, *server, default-agent
|
||||
/= lens-mark /: /===/mar/lens/command
|
||||
/!noun/
|
||||
=, format
|
||||
@ -10,57 +10,32 @@
|
||||
$% [%json =json]
|
||||
[%mime =mime]
|
||||
==
|
||||
:: +move: output effect
|
||||
::
|
||||
+$ move [bone card]
|
||||
:: +card: output effect payload
|
||||
::
|
||||
+$ card
|
||||
$% [%connect wire binding:eyre term]
|
||||
[%http-response =http-event:http]
|
||||
[%peer wire dock path]
|
||||
[%peer wire dock path]
|
||||
[%poke wire dock poke]
|
||||
[%pull wire dock ~]
|
||||
==
|
||||
::
|
||||
+$ poke
|
||||
$% [%lens-command command:lens]
|
||||
[%import *]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% $: %0
|
||||
job=(unit [=bone com=command:lens])
|
||||
job=(unit [eyre-id=@ta com=command:lens])
|
||||
==
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bow=bowl:gall state=state]
|
||||
=| =state
|
||||
|_ =bowl:mall
|
||||
+* this .
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
::
|
||||
++ this .
|
||||
++ on-init on-init:def
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
`this(state !<(^state old))
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit *)
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
:: alerts us that we were bound. we need this because the vane calls back.
|
||||
::
|
||||
++ bound
|
||||
|= [wir=wire success=? binding=binding:eyre]
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
%- (require-authorization:app ost.bow move this)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
::
|
||||
?^ job.state
|
||||
:_ this
|
||||
[ost.bow %http-response %start [%500 ~] ~ %.y]~
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
^- (quip card:agent:mall _this)
|
||||
?. ?=(%handle-http-request mark)
|
||||
(on-poke:def mark vase)
|
||||
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
|
||||
?> ?=(~ job.state)
|
||||
::
|
||||
=/ request-line (parse-request-line url.request.inbound-request)
|
||||
=/ site (flop site.request-line)
|
||||
@ -72,25 +47,101 @@
|
||||
::
|
||||
?: ?=(%export -.source.com)
|
||||
~& [%export app.source.com]
|
||||
:_ this(job.state (some [ost.bow com]))
|
||||
[ost.bow %peer /export [our.bow app.source.com] /export]~
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /export %agent [our.bowl app.source.com] %watch /export]~
|
||||
::
|
||||
?: ?=(%import -.source.com)
|
||||
?~ enc=(de:base64 base64-jam.source.com)
|
||||
:_ this
|
||||
[ost.bow %http-response %start [%500 ~] ~ %.y]~
|
||||
!!
|
||||
::
|
||||
=/ c=* (cue q.u.enc)
|
||||
::
|
||||
:_ this(job.state (some [ost.bow com]))
|
||||
[ost.bow %poke /import [our.bow app.source.com] %import c]~
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /import %agent [our.bowl app.source.com] %poke %import !>(c)]~
|
||||
::
|
||||
:_ this(job.state (some [ost.bow com]))
|
||||
[ost.bow %peer /sole [our.bow %dojo] /sole]~
|
||||
:_ this(job.state (some [eyre-id com]))
|
||||
[%pass /sole %agent [our.bowl %dojo] %watch /sole/[eyre-id]]~
|
||||
::
|
||||
++ diff-sole-effect
|
||||
|= [=wire fec=sole-effect]
|
||||
^- (quip move _this)
|
||||
++ on-watch
|
||||
|= =path
|
||||
^- (quip card:agent:mall _this)
|
||||
?: ?=([%http-response *] path)
|
||||
`this
|
||||
(on-watch:def path)
|
||||
::
|
||||
++ on-leave on-leave:def
|
||||
++ on-peek on-peek:def
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:mall]
|
||||
^- (quip card:agent:mall _this)
|
||||
|^
|
||||
?+ wire (on-agent:def wire sign)
|
||||
[%import ~]
|
||||
?> ?=(%poke-ack -.sign)
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
[[200 ~] `(as-octt:mimes:html "\"Imported data\"")]
|
||||
::
|
||||
[%export ~]
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%watch-ack
|
||||
?~ p.sign
|
||||
`this
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
|
||||
::
|
||||
%fact
|
||||
=^ cards this (take-export !<(* q.cage.sign))
|
||||
:_ this :_ cards
|
||||
?> ?=(^ job.state)
|
||||
?> ?=(%export -.source.com.u.job.state)
|
||||
[%pass /export %agent [our.bowl app.source.com.u.job.state] %leave ~]
|
||||
==
|
||||
::
|
||||
[%sole ~]
|
||||
?+ -.sign (on-agent:def wire sign)
|
||||
%watch-ack
|
||||
?> ?=(^ job.state)
|
||||
?^ p.sign
|
||||
:_ this(job.state ~)
|
||||
(give-simple-payload:app eyre-id.u.job.state not-found:gen)
|
||||
:_ this :_ ~
|
||||
:* %pass /sole
|
||||
%agent [our.bowl %dojo]
|
||||
%poke %lens-command !>
|
||||
[eyre-id.u.job.state com.u.job.state]
|
||||
==
|
||||
::
|
||||
%fact
|
||||
?> ?=(%sole-effect p.cage.sign)
|
||||
=^ cards this (take-sole-effect !<(sole-effect q.cage.sign))
|
||||
[[[%pass /sole %agent [our.bowl %dojo] %leave ~] cards] this]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ take-export
|
||||
|= data=*
|
||||
^- (quip card:agent:mall _this)
|
||||
?> ?=(^ job.state)
|
||||
?> ?=(%export -.source.com.u.job.state)
|
||||
=/ app-name=tape (trip app.source.com.u.job.state)
|
||||
=/ output=@t (crip "/{app-name}/jam")
|
||||
::
|
||||
=/ jon=json
|
||||
=/ =atom (jam data)
|
||||
=/ =octs [(met 3 atom) atom]
|
||||
=/ enc (en:base64 octs)
|
||||
(pairs:enjs:format file+s+output data+s+enc ~)
|
||||
::
|
||||
:_ this(job.state ~)
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
(json-response:gen (json-to-octs jon))
|
||||
::
|
||||
++ take-sole-effect
|
||||
|= fec=sole-effect
|
||||
^- (quip card:agent:mall _this)
|
||||
=/ out
|
||||
|- ^- (unit lens-out)
|
||||
=* loop $
|
||||
@ -130,19 +181,17 @@
|
||||
::
|
||||
?~ out
|
||||
[~ this]
|
||||
::
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
:_ ~
|
||||
:+ bone.u.job.state
|
||||
%http-response
|
||||
%+ give-simple-payload:app eyre-id.u.job.state
|
||||
?- -.u.out
|
||||
%json
|
||||
(json-response:app (json-to-octs json.u.out))
|
||||
(json-response:gen (json-to-octs json.u.out))
|
||||
::
|
||||
%mime
|
||||
:* %start
|
||||
:~ 200
|
||||
['content-type' 'application/octet-stream']
|
||||
=/ headers
|
||||
:~ ['content-type' 'application/octet-stream']
|
||||
?> ?=([@ @ ~] p.mime.u.out)
|
||||
:- 'content-disposition'
|
||||
^- @t
|
||||
@ -150,90 +199,16 @@
|
||||
'attachment; filename='
|
||||
(rap 3 '"' i.p.mime.u.out '.' i.t.p.mime.u.out '"' ~)
|
||||
==
|
||||
(some q.mime.u.out)
|
||||
%.y
|
||||
==
|
||||
[[200 headers] (some q.mime.u.out)]
|
||||
==
|
||||
--
|
||||
::
|
||||
++ diff-export
|
||||
|= [=wire data=*]
|
||||
^- (quip move _this)
|
||||
::
|
||||
?> ?=(^ job.state)
|
||||
:: herb will do whatever we tell it to, so by convention have it write to an
|
||||
:: app name based on the file name.
|
||||
::
|
||||
?> ?=(%export -.source.com.u.job.state)
|
||||
=/ app-name=tape (trip app.source.com.u.job.state)
|
||||
=/ output=@t (crip "/{app-name}/jam")
|
||||
::
|
||||
=/ jon=json
|
||||
=/ =atom (jam data)
|
||||
=/ =octs [(met 3 atom) atom]
|
||||
=/ enc (en:base64 octs)
|
||||
(pairs:enjs:format file+s+output data+s+enc ~)
|
||||
::
|
||||
:_ this(job.state ~)
|
||||
:~ [bone.u.job.state %http-response (json-response:app (json-to-octs jon))]
|
||||
[ost.bow %pull /export [our.bow app.source.com.u.job.state] ~]
|
||||
==
|
||||
::
|
||||
++ quit
|
||||
|= =wire
|
||||
^- (quip move _this)
|
||||
~& [%quit wire]
|
||||
[~ this]
|
||||
::
|
||||
++ reap
|
||||
|= [=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
::
|
||||
?: =([%export ~] wire)
|
||||
[~ this]
|
||||
::
|
||||
?^ saw
|
||||
[((slog u.saw) ~) this]
|
||||
?> ?=(^ job.state)
|
||||
:_ this
|
||||
:~ [ost.bow %poke /sole [our.bow %dojo] %lens-command com.u.job.state]
|
||||
:: XX move to +diff-sole-effect?
|
||||
::
|
||||
[ost.bow %pull /sole [our.bow %dojo] ~]
|
||||
==
|
||||
::
|
||||
++ coup
|
||||
|= [=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
::
|
||||
?: =([%import ~] wire)
|
||||
?> ?=(^ job.state)
|
||||
:_ this(job.state ~)
|
||||
:_ ~
|
||||
:* bone.u.job.state
|
||||
%http-response
|
||||
%start
|
||||
[%200 ~]
|
||||
[~ (as-octt:mimes:html "\"Imported data\"")]
|
||||
%.y
|
||||
==
|
||||
::
|
||||
?^ saw
|
||||
[((slog u.saw) ~) this]
|
||||
[~ this]
|
||||
::
|
||||
:: +poke-handle-http-cancel: received when a connection was killed
|
||||
::
|
||||
++ poke-handle-http-cancel
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
:: the only long lived connections we keep state about are the stream ones.
|
||||
::
|
||||
[~ this]
|
||||
::
|
||||
++ poke-noun
|
||||
|= a=*
|
||||
^- (quip move _this)
|
||||
~& poke+a
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- (quip card:agent:mall _this)
|
||||
?. ?=(%bound +<.sign-arvo)
|
||||
(on-arvo:def wire sign-arvo)
|
||||
[~ this]
|
||||
::
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
|
||||
@ -1,51 +0,0 @@
|
||||
/+ *server
|
||||
|%
|
||||
:: +move: output effect
|
||||
::
|
||||
+$ move [bone card]
|
||||
:: +card: output effect payload
|
||||
::
|
||||
+$ card
|
||||
$% [%connect wire binding:eyre term]
|
||||
[%disconnect wire binding:eyre]
|
||||
[%http-response =http-event:http]
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bow=bowl:gall ~]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit *)
|
||||
^- (quip move _this)
|
||||
?~ old
|
||||
:_ this
|
||||
[ost.bow %connect / [~ /'~modulo'] %modulo]~
|
||||
[~ this]
|
||||
::
|
||||
:: alerts us that we were bound. we need this because the vane calls back.
|
||||
::
|
||||
++ bound
|
||||
|= [wir=wire success=? binding=binding:eyre]
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
++ session-js
|
||||
^- octs
|
||||
%- as-octt:mimes:html
|
||||
;: weld
|
||||
"window.ship = '{+:(scow %p our.bow)}';"
|
||||
"window.urb = new Channel();"
|
||||
==
|
||||
::
|
||||
:: +poke-handle-http-request: received on a new connection established
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
%- (require-authorization:app ost.bow move this)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
[[ost.bow %http-response (js-response:app session-js)]~ this]
|
||||
::
|
||||
--
|
||||
@ -1,171 +0,0 @@
|
||||
:: permission-group-hook:
|
||||
:: mirror the ships in some group to some set of permission paths
|
||||
::
|
||||
/- *group-store, *permission-group-hook
|
||||
/+ *permission-json
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff [%group-update group-update]]
|
||||
[%poke wire dock poke]
|
||||
[%pull wire dock ~]
|
||||
[%peer wire dock path]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ group-path path
|
||||
::
|
||||
+$ permission-path path
|
||||
::
|
||||
+$ state-zero
|
||||
$: relation=(map group-path (set permission-path))
|
||||
==
|
||||
::
|
||||
+$ poke
|
||||
$% [%permission-action permission-action]
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
[~ ?~(old this this(+<+ u.old))]
|
||||
::
|
||||
++ poke-json
|
||||
|= =json
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
(poke-permission-group-hook-action (json-to-perm-group-hook-action json))
|
||||
::
|
||||
++ poke-permission-group-hook-action
|
||||
|= act=permission-group-hook-action
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?- -.act
|
||||
%associate (handle-associate group.act permissions.act)
|
||||
%dissociate (handle-dissociate group.act permissions.act)
|
||||
==
|
||||
::
|
||||
++ handle-associate
|
||||
|= [group=path permission-paths=(set [path kind])]
|
||||
^- (quip move _this)
|
||||
=/ perms (~(get by relation) group)
|
||||
:: if relation does not exist, create it and subscribe.
|
||||
=/ permissions=(set path)
|
||||
%- ~(run in permission-paths)
|
||||
|=([=path =kind] path)
|
||||
?~ perms
|
||||
=/ group-path [%group group]
|
||||
:_ this(relation (~(put by relation) group permissions))
|
||||
[ost.bol %peer group-path [our.bol %group-store] group-path]~
|
||||
::
|
||||
=. u.perms (~(uni in u.perms) permissions)
|
||||
:_ this(relation (~(put by relation) group u.perms))
|
||||
%+ weld
|
||||
%+ turn ~(tap in permissions)
|
||||
|=(=path (permission-poke path [%delete path]))
|
||||
%+ turn ~(tap in permission-paths)
|
||||
|= [=path =kind]
|
||||
=/ pem *permission
|
||||
=. kind.pem kind
|
||||
(permission-poke path [%create path pem])
|
||||
::
|
||||
++ handle-dissociate
|
||||
|= [group=path permissions=(set path)]
|
||||
^- (quip move _this)
|
||||
=/ perms (~(get by relation) group)
|
||||
?~ perms
|
||||
[~ this]
|
||||
::
|
||||
=. permissions (~(del in u.perms) permissions)
|
||||
?~ permissions
|
||||
:_ this(relation (~(del by relation) group))
|
||||
[(group-pull [%group group])]~
|
||||
[~ this(relation (~(put by relation) group permissions))]
|
||||
::
|
||||
++ diff-group-update
|
||||
|= [wir=wire diff=group-update]
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%keys
|
||||
[~ this]
|
||||
%bundle
|
||||
[~ this]
|
||||
%path
|
||||
:: set all permissions paths
|
||||
=/ perms (~(get by relation) pax.diff)
|
||||
?~ perms
|
||||
[~ this]
|
||||
:_ this
|
||||
%+ turn ~(tap in u.perms)
|
||||
|= =path
|
||||
(permission-poke path [%add path members.diff])
|
||||
::
|
||||
%add
|
||||
:: set all permissions paths
|
||||
=/ perms (~(get by relation) pax.diff)
|
||||
?~ perms
|
||||
[~ this]
|
||||
:_ this
|
||||
%+ turn ~(tap in u.perms)
|
||||
|= =path
|
||||
(permission-poke path [%add path members.diff])
|
||||
::
|
||||
%remove
|
||||
:: set all permissions paths
|
||||
=/ perms (~(get by relation) pax.diff)
|
||||
?~ perms
|
||||
[~ this]
|
||||
:_ this
|
||||
%+ turn ~(tap in u.perms)
|
||||
|= =path
|
||||
(permission-poke path [%remove path members.diff])
|
||||
::
|
||||
%unbundle
|
||||
:: pull subscriptions
|
||||
=/ perms (~(get by relation) pax.diff)
|
||||
?~ perms
|
||||
:_ this(relation (~(del by relation) pax.diff))
|
||||
[(group-pull [%group pax.diff])]~
|
||||
:_ this(relation (~(del by relation) pax.diff))
|
||||
:- (group-pull [%group pax.diff])
|
||||
%+ turn ~(tap in u.perms)
|
||||
|= =path
|
||||
(permission-poke path [%delete path])
|
||||
==
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
:: no-op
|
||||
[~ this]
|
||||
::
|
||||
++ reap
|
||||
|= [wir=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
?~ saw
|
||||
[~ this]
|
||||
=. wir ?^(wir t.wir ~)
|
||||
~& %reap-permission-group-hook
|
||||
[((slog u.saw) ~) this(relation (~(del by relation) wir))]
|
||||
::
|
||||
++ permission-poke
|
||||
|= [pax=path action=permission-action]
|
||||
^- move
|
||||
[ost.bol %poke pax [our.bol %permission-store] [%permission-action action]]
|
||||
::
|
||||
++ group-pull
|
||||
|= =path
|
||||
^- move
|
||||
[ost.bol %pull [%group path] [our.bol %group-store] ~]
|
||||
::
|
||||
--
|
||||
@ -1,281 +0,0 @@
|
||||
:: permission-hook: allows mirroring permissions between local and foreign
|
||||
:: ships. access control to an owned permission path is specified by the
|
||||
:: access-control path.
|
||||
::
|
||||
/- *permission-hook
|
||||
/+ *permission-json
|
||||
|%
|
||||
+$ move [bone card]
|
||||
::
|
||||
+$ card
|
||||
$% [%diff [%permission-update permission-update]]
|
||||
[%quit ~]
|
||||
[%poke wire dock [%permission-action permission-action]]
|
||||
[%pull wire dock ~]
|
||||
[%peer wire dock path]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$% [%0 state-zero]
|
||||
==
|
||||
::
|
||||
+$ owner-access [ship=ship access-control=path]
|
||||
::
|
||||
+$ state-zero
|
||||
$: synced=(map path owner-access)
|
||||
access-control=(map path (set path))
|
||||
boned=(map wire (list bone))
|
||||
==
|
||||
::
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
[~ ?~(old this this(+<+ u.old))]
|
||||
::
|
||||
++ poke-permission-hook-action
|
||||
|= act=permission-hook-action
|
||||
^- (quip move _this)
|
||||
?- -.act
|
||||
%add-owned
|
||||
?> (team:title our.bol src.bol)
|
||||
?: (~(has by synced) owned.act)
|
||||
[~ this]
|
||||
=. synced (~(put by synced) owned.act [our.bol access.act])
|
||||
=/ access-paths
|
||||
?. (~(has by access-control) access.act)
|
||||
[owned.act ~ ~]
|
||||
(~(put in (~(got by access-control) access.act)) owned.act)
|
||||
=. access-control
|
||||
(~(put by access-control) access.act access-paths)
|
||||
=/ perm-path [%permission owned.act]
|
||||
:_ (track-bone perm-path)
|
||||
[ost.bol %peer perm-path [our.bol %permission-store] perm-path]~
|
||||
::
|
||||
%add-synced
|
||||
?> (team:title our.bol src.bol)
|
||||
?: (~(has by synced) path.act)
|
||||
[~ this]
|
||||
=. synced (~(put by synced) path.act [ship.act ~])
|
||||
=/ perm-path [%permission path.act]
|
||||
:_ (track-bone perm-path)
|
||||
[ost.bol %peer perm-path [ship.act %permission-hook] perm-path]~
|
||||
::
|
||||
%remove
|
||||
=/ owner-access=(unit owner-access) (~(get by synced) path.act)
|
||||
?~ owner-access
|
||||
[~ this]
|
||||
?: &(=(ship.u.owner-access our.bol) (team:title our.bol src.bol))
|
||||
:: delete one of our.bol own paths
|
||||
:_ %_ this
|
||||
synced (~(del by synced) path.act)
|
||||
boned (~(del by boned) [%permission path.act])
|
||||
::
|
||||
access-control
|
||||
(~(del by access-control) access-control.u.owner-access)
|
||||
==
|
||||
%- zing
|
||||
:~ (pull-wire [%permission path.act])
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib [%permission path.act] bol)
|
||||
|= [=bone *]
|
||||
[bone %quit ~]
|
||||
==
|
||||
?. |(=(ship.u.owner-access src.bol) (team:title our.bol src.bol))
|
||||
:: if neither ship = source or source = us, do nothing
|
||||
[~ this]
|
||||
:: delete a foreign ship's path
|
||||
:_ %_ this
|
||||
synced (~(del by synced) path.act)
|
||||
boned (~(del by boned) [%permission path.act])
|
||||
==
|
||||
(pull-wire [%permission path.act])
|
||||
==
|
||||
::
|
||||
++ peer-permission
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
?> ?=([* ^] pax)
|
||||
=/ =owner-access (~(got by synced) pax)
|
||||
?> =(our.bol ship.owner-access)
|
||||
:: scry permissions to check if subscriber is allowed
|
||||
?> (permitted-scry (scot %p src.bol) access-control.owner-access)
|
||||
=/ pem (permission-scry pax)
|
||||
:_ this
|
||||
[ost.bol %diff %permission-update [%create pax pem]]~
|
||||
::
|
||||
++ diff-permission-update
|
||||
|= [wir=wire diff=permission-update]
|
||||
^- (quip move _this)
|
||||
?: (team:title our.bol src.bol)
|
||||
(handle-local diff)
|
||||
(handle-foreign diff)
|
||||
::
|
||||
++ handle-local
|
||||
|= diff=permission-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%create [~ this]
|
||||
%add (change-local-permission [%add path.diff who.diff])
|
||||
%remove (change-local-permission [%remove path.diff who.diff])
|
||||
::
|
||||
%delete
|
||||
?. (~(has by synced) path.diff)
|
||||
[~ this]
|
||||
:_ this(synced (~(del by synced) path.diff))
|
||||
[ost.bol %pull [%permission path.diff] [our.bol %permission-store] ~]~
|
||||
==
|
||||
::
|
||||
++ change-local-permission
|
||||
|= [kind=?(%add %remove) pax=path who=(set ship)]
|
||||
^- (quip move _this)
|
||||
:_ this
|
||||
%+ weld
|
||||
?- kind
|
||||
%add (update-subscribers [%permission pax] [%add pax who])
|
||||
%remove (update-subscribers [%permission pax] [%remove pax who])
|
||||
==
|
||||
=/ access-paths=(unit (set path)) (~(get by access-control) pax)
|
||||
:: check if this path changes the access permissions for other paths
|
||||
?~ access-paths
|
||||
~
|
||||
(quit-subscriptions kind pax who u.access-paths)
|
||||
::
|
||||
++ handle-foreign
|
||||
|= diff=permission-update
|
||||
^- (quip move _this)
|
||||
?- -.diff
|
||||
%create (change-foreign-permission path.diff diff)
|
||||
%add (change-foreign-permission path.diff diff)
|
||||
%remove (change-foreign-permission path.diff diff)
|
||||
::
|
||||
%delete
|
||||
?> ?=([* ^] path.diff)
|
||||
=/ owner-access=(unit owner-access) (~(get by synced) path.diff)
|
||||
?~ owner-access
|
||||
[~ this]
|
||||
?. =(ship.u.owner-access src.bol)
|
||||
[~ this]
|
||||
:_ this(synced (~(del by synced) path.diff))
|
||||
:~ (permission-poke diff)
|
||||
[ost.bol %pull [%permission path.diff] [src.bol %permission-hook] ~]
|
||||
==
|
||||
==
|
||||
::
|
||||
++ change-foreign-permission
|
||||
|= [pax=path diff=permission-update]
|
||||
^- (quip move _this)
|
||||
?> ?=([* ^] pax)
|
||||
=/ owner-access=(unit owner-access) (~(get by synced) pax)
|
||||
:_ this
|
||||
?~ owner-access ~
|
||||
?. =(src.bol ship.u.owner-access) ~
|
||||
[(permission-poke diff)]~
|
||||
::
|
||||
++ quit-subscriptions
|
||||
|= [kind=?(%add %remove) pax=path who=(set ship) access-paths=(set path)]
|
||||
^- (list move)
|
||||
=/ perm (permission-scry pax)
|
||||
?. ?|
|
||||
?&(=(kind.perm %black) =(kind %add))
|
||||
?&(=(kind.perm %white) =(kind %remove))
|
||||
==
|
||||
:: if allow, do nothing
|
||||
~
|
||||
=/ sup
|
||||
%- ~(gas by *(map [ship path] bone))
|
||||
%+ turn ~(tap by sup.bol)
|
||||
|=([=bone anchor=[ship path]] [anchor bone])
|
||||
:: if ban, iterate through
|
||||
:: all ships that have been banned
|
||||
:: and all affected paths that have had their permissions changed
|
||||
:: then quit their subscriptions
|
||||
::
|
||||
%- zing
|
||||
%+ turn ~(tap in who)
|
||||
|= check-ship=ship
|
||||
^- (list move)
|
||||
%+ murn ~(tap in access-paths)
|
||||
|= access-path=path
|
||||
^- (unit move)
|
||||
=/ bne (~(get by sup) [check-ship [%permission access-path]])
|
||||
?~(bne ~ `[u.bne %quit ~])
|
||||
::
|
||||
++ quit
|
||||
|= wir=wire
|
||||
^- (quip move _this)
|
||||
~& permission-hook-quit+wir
|
||||
?> ?=([* ^] wir)
|
||||
?. (~(has by synced) t.wir)
|
||||
:: no-op
|
||||
[~ this]
|
||||
=/ =owner-access (~(got by synced) t.wir)
|
||||
~& %permission-hook-resubscribe
|
||||
:_ (track-bone wir)
|
||||
[ost.bol %peer wir [ship.owner-access %permission-hook] wir]~
|
||||
::
|
||||
++ reap
|
||||
|= [wir=wire saw=(unit tang)]
|
||||
^- (quip move _this)
|
||||
?~ saw
|
||||
[~ this]
|
||||
?> ?=(^ wir)
|
||||
:_ this(synced (~(del by synced) t.wir))
|
||||
%. ~
|
||||
%- slog
|
||||
:* leaf+"permission-hook failed subscribe on {(spud t.wir)}"
|
||||
leaf+"stack trace:"
|
||||
u.saw
|
||||
==
|
||||
::
|
||||
++ permission-scry
|
||||
|= pax=path
|
||||
^- permission
|
||||
=. pax ;:(weld /=permission-store/(scot %da now.bol)/permission pax /noun)
|
||||
(need .^((unit permission) %gx pax))
|
||||
::
|
||||
++ permitted-scry
|
||||
|= pax=path
|
||||
^- ?
|
||||
.^(? %gx ;:(weld /=permission-store/(scot %da now.bol)/permitted pax /noun))
|
||||
::
|
||||
++ permission-poke
|
||||
|= act=permission-action
|
||||
^- move
|
||||
[ost.bol %poke / [our.bol %permission-store] [%permission-action act]]
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path upd=permission-update]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %permission-update upd]
|
||||
::
|
||||
++ track-bone
|
||||
|= wir=wire
|
||||
^+ this
|
||||
=/ bnd (~(get by boned) wir)
|
||||
?^ bnd
|
||||
this(boned (~(put by boned) wir (snoc u.bnd ost.bol)))
|
||||
this(boned (~(put by boned) wir [ost.bol]~))
|
||||
::
|
||||
++ pull-wire
|
||||
|= pax=path
|
||||
^- (list move)
|
||||
?> ?=([* ^] pax)
|
||||
=/ bnd (~(get by boned) pax)
|
||||
?~ bnd ~
|
||||
=/ owner-access=(unit owner-access) (~(get by synced) t.pax)
|
||||
?~ owner-access ~
|
||||
%+ turn u.bnd
|
||||
|= =bone
|
||||
?: =(ship.u.owner-access our.bol)
|
||||
[bone %pull pax [our.bol %permission-store] ~]
|
||||
[bone %pull pax [ship.u.owner-access %permission-hook] ~]
|
||||
::
|
||||
--
|
||||
@ -1,184 +0,0 @@
|
||||
:: permission-store: data store for keeping track of permissions
|
||||
:: permissions are white lists or black lists of ships
|
||||
::
|
||||
/- *permission-store
|
||||
::
|
||||
|%
|
||||
+$ move [bone [%diff diff]]
|
||||
::
|
||||
+$ diff
|
||||
$% [%permission-initial =permission-map]
|
||||
[%permission-update =permission-update]
|
||||
==
|
||||
::
|
||||
+$ state
|
||||
$: permissions=permission-map
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall %v0 state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
:: gall interface
|
||||
::
|
||||
++ peer-all
|
||||
|= =path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: we now proxy all events to this path
|
||||
:_ this
|
||||
[ost.bol %diff %permission-initial permissions]~
|
||||
::
|
||||
++ peer-updates
|
||||
|= =path
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
:: we now proxy all events to this path
|
||||
[~ this]
|
||||
::
|
||||
++ peer-permission
|
||||
|= =path
|
||||
^- (quip move _this)
|
||||
?~ path !!
|
||||
?> (team:title our.bol src.bol)
|
||||
?> (~(has by permissions) path)
|
||||
:_ this
|
||||
[ost.bol %diff %permission-update [%create path (~(got by permissions) path)]]~
|
||||
::
|
||||
++ peek-x-keys
|
||||
|= pax=path
|
||||
^- (unit (unit [%noun (set path)]))
|
||||
[~ ~ %noun ~(key by permissions)]
|
||||
::
|
||||
++ peek-x-permission
|
||||
|= =path
|
||||
^- (unit (unit [%noun (unit permission)]))
|
||||
?~ path
|
||||
~
|
||||
[~ ~ %noun (~(get by permissions) path)]
|
||||
::
|
||||
++ peek-x-permitted
|
||||
|= =path
|
||||
^- (unit (unit [%noun ?]))
|
||||
?~ path
|
||||
~
|
||||
=/ pem (~(get by permissions) t.path)
|
||||
?~ pem
|
||||
~
|
||||
=/ who (slav %p i.path)
|
||||
=/ has (~(has in who.u.pem) who)
|
||||
:^ ~ ~ %noun
|
||||
?-(kind.u.pem %black !has, %white has)
|
||||
::
|
||||
++ poke-permission-action
|
||||
|= action=permission-action
|
||||
^- (quip move _this)
|
||||
?> (team:title our.bol src.bol)
|
||||
?- -.action
|
||||
%add (handle-add action)
|
||||
%remove (handle-remove action)
|
||||
%create (handle-create action)
|
||||
%delete (handle-delete action)
|
||||
%allow (handle-allow action)
|
||||
%deny (handle-deny action)
|
||||
==
|
||||
::
|
||||
++ handle-add
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%add -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
:: TODO: calculate diff
|
||||
:: =+ new=(~(dif in who.what.action) who.u.pem)
|
||||
:: ?~(new ~ `what.action(who new))
|
||||
?. (~(has by permissions) path.act)
|
||||
[~ this]
|
||||
:- (send-diff path.act act)
|
||||
=/ perm (~(got by permissions) path.act)
|
||||
=. who.perm (~(uni in who.perm) who.act)
|
||||
this(permissions (~(put by permissions) path.act perm))
|
||||
::
|
||||
++ handle-remove
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%remove -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
?. (~(has by permissions) path.act)
|
||||
[~ this]
|
||||
=/ perm (~(got by permissions) path.act)
|
||||
=. who.perm (~(dif in who.perm) who.act)
|
||||
:: TODO: calculate diff
|
||||
:: =+ new=(~(int in who.what.action) who.u.pem)
|
||||
:: ?~(new ~ `what.action(who new))
|
||||
:- (send-diff path.act act)
|
||||
this(permissions (~(put by permissions) path.act perm))
|
||||
::
|
||||
++ handle-create
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%create -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
?: (~(has by permissions) path.act)
|
||||
[~ this]
|
||||
:: TODO: calculate diff
|
||||
:- (send-diff path.act act)
|
||||
this(permissions (~(put by permissions) path.act permission.act))
|
||||
::
|
||||
++ handle-delete
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%delete -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
?. (~(has by permissions) path.act)
|
||||
[~ this]
|
||||
:- (send-diff path.act act)
|
||||
this(permissions (~(del by permissions) path.act))
|
||||
::
|
||||
++ handle-allow
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%allow -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
=/ perm (~(get by permissions) path.act)
|
||||
?~ perm
|
||||
[~ this]
|
||||
?: =(kind.u.perm %white)
|
||||
(handle-add [%add +.act])
|
||||
(handle-remove [%remove +.act])
|
||||
::
|
||||
++ handle-deny
|
||||
|= act=permission-action
|
||||
^- (quip move _this)
|
||||
?> ?=(%deny -.act)
|
||||
?~ path.act
|
||||
[~ this]
|
||||
=/ perm (~(get by permissions) path.act)
|
||||
?~ perm
|
||||
[~ this]
|
||||
?: =(kind.u.perm %black)
|
||||
(handle-add [%add +.act])
|
||||
(handle-remove [%remove +.act])
|
||||
::
|
||||
++ update-subscribers
|
||||
|= [pax=path upd=permission-update]
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib pax bol)
|
||||
|= [=bone *]
|
||||
[bone %diff %permission-update upd]
|
||||
::
|
||||
++ send-diff
|
||||
|= [pax=path upd=permission-update]
|
||||
^- (list move)
|
||||
%- zing
|
||||
:~ (update-subscribers /all upd)
|
||||
(update-subscribers /updates upd)
|
||||
(update-subscribers [%permission pax] upd)
|
||||
==
|
||||
::
|
||||
--
|
||||
@ -1,162 +0,0 @@
|
||||
:: pool-group-hook: maintain groups based on invite pool
|
||||
::
|
||||
/- group-store
|
||||
/+ tapp, stdio, ethio
|
||||
=, ethereum-types
|
||||
=, able:jael
|
||||
::
|
||||
=> |%
|
||||
++ group-path /invite-peers
|
||||
++ refresh-rate ~m15
|
||||
--
|
||||
::
|
||||
=> |%
|
||||
+$ app-state
|
||||
$: %0
|
||||
url=_'http://eth-mainnet.urbit.org:8545'
|
||||
inviter=ship
|
||||
invited=(set ship)
|
||||
==
|
||||
::
|
||||
+$ peek-data ~
|
||||
+$ in-poke-data ~
|
||||
+$ out-poke-data
|
||||
[%group-action group-action:group-store]
|
||||
+$ in-peer-data ~
|
||||
+$ out-peer-data ~
|
||||
++ tapp
|
||||
%: ^tapp
|
||||
app-state
|
||||
peek-data
|
||||
in-poke-data
|
||||
out-poke-data
|
||||
in-peer-data
|
||||
out-peer-data
|
||||
==
|
||||
++ tapp-async tapp-async:tapp
|
||||
++ stdio (^stdio out-poke-data out-peer-data)
|
||||
++ ethio (^ethio out-poke-data out-peer-data)
|
||||
--
|
||||
::
|
||||
:: Async helpers
|
||||
::
|
||||
=> |%
|
||||
++ get-invited-by
|
||||
|= [url=@t who=ship]
|
||||
=/ m (async:stdio ,ship)
|
||||
^- form:m
|
||||
;< res=@t bind:m
|
||||
%+ read-contract:ethio url
|
||||
:+ `'invitedBy'
|
||||
delegated-sending:contracts:azimuth
|
||||
:- 'invitedBy(uint32)'
|
||||
:~ [%uint `@`who]
|
||||
==
|
||||
%- pure:m
|
||||
^- ship ^- @
|
||||
%+ decode-results:abi:ethereum res
|
||||
[%uint]~
|
||||
::
|
||||
++ get-invited
|
||||
|= [url=@ta who=ship]
|
||||
=/ m (async:stdio ,(list ship))
|
||||
^- form:m
|
||||
;< res=@t bind:m
|
||||
%+ read-contract:ethio url
|
||||
:+ `'getInvited'
|
||||
delegated-sending:contracts:azimuth
|
||||
:- 'getInvited(uint32)'
|
||||
:~ [%uint `@`who]
|
||||
==
|
||||
%- pure:m
|
||||
;; (list ship)
|
||||
%+ decode-results:abi:ethereum res
|
||||
[%array %uint]~
|
||||
::
|
||||
++ send-poke
|
||||
|= [our=ship =group-action:group-store]
|
||||
=/ m (async:stdio ,~)
|
||||
^- form:m
|
||||
%+ poke-app:stdio
|
||||
[our %group-store]
|
||||
[%group-action group-action]
|
||||
--
|
||||
::
|
||||
:: Main loop
|
||||
::
|
||||
=> |%
|
||||
++ start
|
||||
|= [state=app-state our=ship]
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
;< inviter=ship bind:m (get-invited-by url.state our)
|
||||
?: =(0 inviter)
|
||||
:: we're done here, don't do anything ever again
|
||||
(pure:m state)
|
||||
=. inviter.state inviter
|
||||
:: create the group
|
||||
;< ~ bind:m (send-poke our %bundle group-path)
|
||||
:: start update timer loop
|
||||
;< ~ bind:m set-timer
|
||||
:: go ahead and update for the first time
|
||||
(update state our)
|
||||
::
|
||||
:: Get updates since last checked
|
||||
::
|
||||
++ update
|
||||
|= [state=app-state our=ship]
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
;< invited=(list ship) bind:m (get-invited [url inviter]:state)
|
||||
=/ new=(list ship)
|
||||
%+ skip invited
|
||||
~(has in invited.state)
|
||||
;< ~ bind:m
|
||||
?: =(~ new) (pure:(async:stdio ,~) ~)
|
||||
(send-poke our %add (sy new) group-path)
|
||||
%- pure:m
|
||||
state(invited (~(gas in invited.state) new))
|
||||
::
|
||||
:: Set update timer
|
||||
::
|
||||
++ set-timer
|
||||
=/ m (async:tapp ,~)
|
||||
^- form:m
|
||||
;< now=@da bind:m get-time:stdio
|
||||
=/ next=@da (add now refresh-rate)
|
||||
::NOTE we use +send-raw-card here to ensure we always set a new timer,
|
||||
:: regardless of what happens further on in the flow.
|
||||
(send-raw-card:stdio %wait /effect/(scot %da next) next)
|
||||
--
|
||||
::
|
||||
:: Main
|
||||
::
|
||||
=* default-tapp default-tapp:tapp
|
||||
%- create-tapp-all:tapp
|
||||
|_ [=bowl:gall state=app-state]
|
||||
++ handle-init
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
(start state our.bowl)
|
||||
::
|
||||
++ handle-take
|
||||
|= =sign:tapp
|
||||
=/ m tapp-async
|
||||
^- form:m
|
||||
?+ -.sign ~|([%strange-sign -.sign] !!)
|
||||
%coup
|
||||
?~ error.sign (pure:m state)
|
||||
%- (slog [leaf+"pool-group-hook effect failed" u.error.sign])
|
||||
(pure:m state)
|
||||
::
|
||||
%wake
|
||||
;< ~ bind:m
|
||||
set-timer
|
||||
(update state our.bowl)
|
||||
==
|
||||
::
|
||||
++ handle-poke handle-poke:default-tapp
|
||||
++ handle-diff handle-diff:default-tapp
|
||||
++ handle-peer handle-peer:default-tapp
|
||||
++ handle-peek handle-peek:default-tapp
|
||||
--
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,385 +0,0 @@
|
||||
::
|
||||
:: there's a small state machine here that goes like this (happy path):
|
||||
:: =/ wen ~
|
||||
:: apex
|
||||
:: -> [if =(~ wen)]
|
||||
:: -> apex
|
||||
:: [else]
|
||||
:: -> wen=`(add now ~s10)
|
||||
:: -> send-next-batch
|
||||
:: [n times]
|
||||
:: -> eth-send-raw-transaction
|
||||
:: -> sigh-send
|
||||
:: -> wait 30s in behn
|
||||
:: -> wake-see
|
||||
:: [n times]
|
||||
:: -> wen=~
|
||||
:: -> eth-get-transaction-receipt
|
||||
:: -> sigh-see
|
||||
:: -> apex
|
||||
::
|
||||
|%
|
||||
++ state
|
||||
$: txs=(list @ux)
|
||||
see=(set @ux)
|
||||
wen=(unit @da)
|
||||
outstanding-send=_|
|
||||
==
|
||||
::
|
||||
++ move (pair bone card)
|
||||
++ card
|
||||
$% [%hiss wire ~ mark %hiss hiss:eyre]
|
||||
[%info wire ship desk nori:clay]
|
||||
[%rest wire @da]
|
||||
[%wait wire @da]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
++ pretty-see (turn (sort (turn ~(tap in see) mug) lth) @p)
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit *)
|
||||
?: ?=([~ * * ~ @da] old)
|
||||
~& [%cancelling +>+>.old]
|
||||
[[ost.bol %rest /see +>+>.old]~ ..prep]
|
||||
[~ ..prep]
|
||||
::
|
||||
:: usage:
|
||||
::
|
||||
:: generate txs starting from nonce 0 on fake chain at 11 gwei
|
||||
:: from address; store at path
|
||||
:: :send-txs [%gen %/txs/eth-txs %fake 0 11 '0x0000000']
|
||||
::
|
||||
:: sign txs for gasses of 2 and 11 gwei; (~ for default gwei set)
|
||||
:: store at path
|
||||
:: :send-txs [%sign %/txs %/txs/eth-txs %/pk/txt ~[2 0]]
|
||||
::
|
||||
:: read nonce range from signed transactions at path
|
||||
:: :send-txs [%read %txs/txt]
|
||||
::
|
||||
:: send all but first 50 txs from path
|
||||
:: :send-txs [%send %/txs/txt 50]
|
||||
::
|
||||
++ poke-noun
|
||||
|= $% [%sign bout=path in=path key=path gasses=(list @ud)]
|
||||
::
|
||||
[%read pax=path]
|
||||
::
|
||||
$: %send
|
||||
pax=path
|
||||
how=?(%nonce %number) :: tx nonce / index in file
|
||||
range=(unit $@(@ud (pair @ud @ud))) :: inclusive. end optional
|
||||
==
|
||||
==
|
||||
^- [(list move) _this]
|
||||
?- +<-
|
||||
%sign
|
||||
:_ this
|
||||
%+ turn
|
||||
?. =(~ gasses) gasses
|
||||
:: default gwei set
|
||||
~[3 4 6 9 11 21 31]
|
||||
|= gas=@ud
|
||||
%+ write-file-wain
|
||||
:: add gas amount to path
|
||||
=+ end=(dec (lent bout))
|
||||
=- (weld (scag end bout) -)
|
||||
?: =(0 gas) [(snag end bout) /txt]
|
||||
:_ /txt
|
||||
(cat 3 (snag end bout) (crip '-' ((d-co:co 1) gas)))
|
||||
::
|
||||
%- sign
|
||||
:+ in key
|
||||
:: modify tx gas if non-zero gwei specified
|
||||
?: =(0 gas) ~
|
||||
`(mul gas 1.000.000.000)
|
||||
::
|
||||
%read
|
||||
=+ tox=.^((list cord) %cx pax)
|
||||
=+ [first last]=(read-nonces tox)
|
||||
~& %+ weld
|
||||
"Found nonces {(scow %ud first)} through {(scow %ud last)}"
|
||||
" in {(scow %ud (lent tox))} transactions."
|
||||
[~ this]
|
||||
::
|
||||
%send
|
||||
~& 'loading txs...'
|
||||
=. see ~
|
||||
=/ tox=(list cord) .^((list cord) %cx pax)
|
||||
=. tox
|
||||
?~ range tox
|
||||
=* r u.range
|
||||
?: ?=(%number how)
|
||||
?@ r
|
||||
(slag r tox)
|
||||
%+ slag p.r
|
||||
(scag q.r tox)
|
||||
=+ [first last]=(read-nonces tox)
|
||||
?: !=((lent tox) +((sub last first)))
|
||||
~| 'woah, probably non-contiguous set of transactions'
|
||||
!!
|
||||
?@ r
|
||||
(slag (sub r first) tox)
|
||||
(slag (sub p.r first) (scag (sub +(q.r) first) tox))
|
||||
=. txs
|
||||
%+ turn tox
|
||||
(cork trip tape-to-ux)
|
||||
~& [(lent txs) 'loaded txs']
|
||||
~& [%clearing-see ~(wyt in see)]
|
||||
=. see ~
|
||||
=. outstanding-send |
|
||||
apex
|
||||
==
|
||||
::
|
||||
++ get-file
|
||||
|= pax=path
|
||||
~| pax
|
||||
.^ (list cord) %cx
|
||||
(weld /(scot %p our.bol)/home/(scot %da now.bol) pax)
|
||||
==
|
||||
::
|
||||
:: sign pre-generated transactions
|
||||
++ sign
|
||||
=, rpc:ethereum
|
||||
|= [in=path key=path gas=(unit @ud)]
|
||||
^- (list cord)
|
||||
?> ?=([@ @ @ *] key)
|
||||
=/ pkf (get-file t.t.t.key)
|
||||
?> ?=(^ pkf)
|
||||
=/ pk (rash i.pkf ;~(pfix (jest '0x') hex))
|
||||
=/ txs .^((list transaction) %cx in)
|
||||
=/ enumerated
|
||||
=/ n 1
|
||||
|- ^- (list [@ud transaction])
|
||||
?~ txs
|
||||
~
|
||||
[[n i.txs] $(n +(n), txs t.txs)]
|
||||
%+ turn enumerated
|
||||
|= [n=@ud tx=transaction]
|
||||
~? =(0 (mod n 100)) [%signing n]
|
||||
=? gas-price.tx ?=(^ gas) u.gas
|
||||
(crip '0' 'x' ((x-co:co 0) (sign-transaction:key:ethereum tx pk)))
|
||||
::
|
||||
++ read-nonces
|
||||
|= tox=(list cord)
|
||||
^- [@ud @ud]
|
||||
?: =(~ tox) :: not ?~ because fucking tmi
|
||||
[0 0]
|
||||
:- (read-nonce (snag 0 tox))
|
||||
(read-nonce (snag (dec (lent tox)) tox))
|
||||
::
|
||||
++ read-nonce
|
||||
|= tex=cord
|
||||
^- @ud
|
||||
::NOTE this is profoundly stupid but should work well enough
|
||||
=+ (find "82" (trip tex))
|
||||
?> ?=(^ -)
|
||||
(rash (rsh 3 (add u 2) (end 3 (add u 6) tex)) hex)
|
||||
::
|
||||
++ write-file-wain
|
||||
|= [pax=path tox=(list cord)]
|
||||
^- move
|
||||
?> ?=([@ desk @ *] pax)
|
||||
:* ost.bol
|
||||
%info
|
||||
(weld /write pax)
|
||||
our.bol
|
||||
i.t.pax
|
||||
=- &+[t.t.t.pax -]~
|
||||
=/ y .^(arch %cy pax)
|
||||
?~ fil.y
|
||||
ins+txt+!>(tox)
|
||||
mut+txt+!>(tox)
|
||||
==
|
||||
::
|
||||
++ write-file-transactions
|
||||
|= [pax=path tox=(list transaction:rpc:ethereum)]
|
||||
^- move
|
||||
?> ?=([@ desk @ *] pax)
|
||||
:* ost.bol
|
||||
%info
|
||||
(weld /write pax)
|
||||
our.bol
|
||||
i.t.pax
|
||||
=- &+[t.t.t.pax -]~
|
||||
=/ y .^(arch %cy pax)
|
||||
?~ fil.y
|
||||
ins+eth-txs+!>(tox)
|
||||
mut+eth-txs+!>(tox)
|
||||
==
|
||||
::
|
||||
++ fan-requests
|
||||
|= [wir=wire nodes=(list [tag=@tas url=purl:eyre]) jon=json]
|
||||
:: =- ~& [batch=((list ,[bone * wire]) (turn - |=(* [- +< +>-]:+<))) jon=jon] -
|
||||
^- (list move)
|
||||
%+ turn nodes
|
||||
|= [tag=@tas url=purl:eyre]
|
||||
^- move
|
||||
:- ost.bol
|
||||
:^ %hiss (weld wir ~[tag]) ~
|
||||
:+ %json-rpc-response %hiss
|
||||
(json-request:rpc:ethereum url jon)
|
||||
::
|
||||
++ batch-requests
|
||||
|= [wir=wire req=(list [(unit @t) request:rpc:ethereum])]
|
||||
^- (list move)
|
||||
%^ fan-requests
|
||||
wir
|
||||
:~ => (need (de-purl:html 'http://35.226.110.143:8545'))
|
||||
geth+.(p.p |)
|
||||
::
|
||||
=> (need (de-purl:html 'http://104.198.35.227:8545'))
|
||||
parity+.(p.p |)
|
||||
==
|
||||
a+(turn req request-to-json:rpc:ethereum)
|
||||
::
|
||||
++ send-next-batch
|
||||
^- [(list move) _this]
|
||||
?: outstanding-send
|
||||
~& 'waiting for previous send to complete'
|
||||
`this
|
||||
?: =(0 (lent txs))
|
||||
~& 'all sent!'
|
||||
[~ this(txs ~, see ~, wen ~, outstanding-send |)]
|
||||
:: ~& send-next-batch=pretty-see
|
||||
=/ new-count (sub 500 ~(wyt in see))
|
||||
?: =(0 new-count)
|
||||
~& %no-new-txs-yet
|
||||
`this
|
||||
:_ this(txs (slag new-count txs), outstanding-send &)
|
||||
~& ['remaining txs: ' (lent txs)]
|
||||
~& ['sending txs...' new-count]
|
||||
%+ batch-requests /send
|
||||
%+ turn (scag new-count txs)
|
||||
|= tx=@ux
|
||||
:- `(crip 'id-' (scot %ux (end 3 10 tx)) ~)
|
||||
[%eth-send-raw-transaction tx]
|
||||
::
|
||||
++ sigh-json-rpc-response-send
|
||||
|= [wir=wire res=response:rpc:jstd]
|
||||
^- [(list move) _this]
|
||||
?: ?=(%fail -.res)
|
||||
~& %send-failed
|
||||
`this
|
||||
?> ?=(%batch -.res)
|
||||
:: ~& sigh-send-a=pretty-see
|
||||
=. see
|
||||
%- ~(uni in see)
|
||||
%- silt
|
||||
^- (list @ux)
|
||||
%+ murn bas.res
|
||||
|= r=response:rpc:jstd
|
||||
^- (unit @ux)
|
||||
?: ?=(%error -.r)
|
||||
?: ?| =('known transaction' (end 3 17 message.r))
|
||||
=('Known transaction' (end 3 17 message.r))
|
||||
=('Transaction with the same ' (end 3 26 message.r))
|
||||
==
|
||||
~& [%sent-a-known-transaction--skipping wir]
|
||||
~
|
||||
?: =('Nonce too low' message.r)
|
||||
~& %nonce-too-low--skipping
|
||||
~
|
||||
~| :- 'transaction send failed, game over'
|
||||
[code.r message.r]
|
||||
!!
|
||||
?> ?=(%result -.r)
|
||||
:- ~
|
||||
%- tape-to-ux
|
||||
(sa:dejs:format res.r)
|
||||
=. outstanding-send |
|
||||
:: ~& sigh-send-b=pretty-see
|
||||
`this
|
||||
::
|
||||
++ apex
|
||||
^- [(list move) _this]
|
||||
~& :_ ~(wyt in see)
|
||||
'waiting for transaction confirms... '
|
||||
?. =(~ wen) [~ this]
|
||||
=. wen `(add now.bol ~s30)
|
||||
:: ~& apex=[wen pretty-see]
|
||||
=^ moves this send-next-batch
|
||||
:: timer got un-set, meaning we're done here
|
||||
?~ wen [moves this]
|
||||
[[[ost.bol %wait /see (need wen)] moves] this]
|
||||
::
|
||||
++ wake-see
|
||||
|= [wir=wire ~]
|
||||
^- [(list move) _this]
|
||||
=. wen ~
|
||||
:: ~& wake-see=[wen pretty-see]
|
||||
?: =(~ see)
|
||||
apex
|
||||
:_ this
|
||||
%+ batch-requests /see
|
||||
%+ turn ~(tap in see)
|
||||
|= txh=@ux
|
||||
:- `(crip 'see-0x' ((x-co:co 64) txh))
|
||||
[%eth-get-transaction-receipt txh]
|
||||
::
|
||||
++ sigh-json-rpc-response-see
|
||||
|= [wir=wire res=response:rpc:jstd]
|
||||
^- [(list move) _this]
|
||||
?: ?| ?=(%error -.res)
|
||||
?=(%fail -.res)
|
||||
==
|
||||
~& [%bad-rpc-response--kicking res]
|
||||
apex
|
||||
:: `this
|
||||
?> ?=(%batch -.res)
|
||||
?: =(~ see)
|
||||
apex
|
||||
?: =(0 (lent bas.res))
|
||||
::TODO node lost our txs?
|
||||
~& [%txs-lost-tmp wir '!!']
|
||||
apex
|
||||
:: ~& sigh-see-a=pretty-see
|
||||
=. see
|
||||
%- ~(dif in see)
|
||||
%- silt
|
||||
^- (list @ux)
|
||||
%+ murn bas.res
|
||||
|= r=response:rpc:jstd
|
||||
^- (unit @ux)
|
||||
?< ?=(%batch -.r)
|
||||
?< ?=(%fail -.r)
|
||||
~| [id.r res]
|
||||
=+ txh=(tape-to-ux (trip (rsh 3 4 id.r)))
|
||||
:: ~& see-tx=[(@p (mug txh)) `@ux`txh]
|
||||
=* done `txh
|
||||
=* wait ~
|
||||
?: ?=(%error -.r)
|
||||
~& :- 'receipt fetch error'
|
||||
[code.r message.r]
|
||||
wait
|
||||
?~ res.r wait
|
||||
?> ?=(%o -.res.r)
|
||||
=/ status
|
||||
%- tape-to-ux
|
||||
%- sa:dejs:format
|
||||
(~(got by p.res.r) 'status')
|
||||
?: =(1 status)
|
||||
done
|
||||
~& [%see-bad-status status]
|
||||
wait
|
||||
:: ~& sigh-see-b=pretty-see
|
||||
apex
|
||||
::
|
||||
++ sigh-tang
|
||||
|= [wir=wire err=tang]
|
||||
~& [%sigh-tang wir]
|
||||
~& (slog err)
|
||||
?: =(~ wen) [~ this]
|
||||
=. wen `(add now.bol ~s30)
|
||||
[[ost.bol %wait /see (need wen)]~ this]
|
||||
::
|
||||
++ tape-to-ux
|
||||
|= t=tape
|
||||
(scan t zero-ux)
|
||||
::
|
||||
++ zero-ux
|
||||
;~(pfix (jest '0x') hex)
|
||||
--
|
||||
@ -54,7 +54,7 @@
|
||||
%marks ~|(%stub !!) ::TODO restore historical handler
|
||||
%renders ~&(%all-renderers-are-disabled ~)
|
||||
%cores
|
||||
=/ spurs [- +]:(list-hoons p.a skip=(sy /sys /ren /tests /app ~))
|
||||
=/ spurs [- +]:(list-hoons p.a skip=(sy /sys /ren /tests ~))
|
||||
[(build-core [p q]:byk.bowl spurs) ~]
|
||||
==
|
||||
::
|
||||
@ -1,23 +0,0 @@
|
||||
::
|
||||
:::: /hoon/time/app
|
||||
::
|
||||
/? 310
|
||||
|%
|
||||
++ card {$wait wire @da}
|
||||
--
|
||||
|_ {bowl:gall ~}
|
||||
++ poke-noun
|
||||
|= *
|
||||
:_ +>.$ :_ ~
|
||||
[ost %wait /(scot %da now) +(now)]
|
||||
::
|
||||
++ wake
|
||||
|= {wir/wire error=(unit tang)}
|
||||
?> ?=({@ ~} wir)
|
||||
?^ error
|
||||
%- (slog u.error)
|
||||
~& %time-behn-failed
|
||||
[~ +>.$]
|
||||
~& [%took `@dr`(sub now (slav %da i.wir))]
|
||||
[~ +>.$]
|
||||
--
|
||||
@ -1,169 +0,0 @@
|
||||
/+ *server
|
||||
/= tile-js
|
||||
/^ octs
|
||||
/; as-octs:mimes:html
|
||||
/: /===/app/weather/js/tile
|
||||
/| /js/
|
||||
/~ ~
|
||||
==
|
||||
/= weather-png
|
||||
/^ (map knot @)
|
||||
/: /===/app/weather/img /_ /png/
|
||||
=, format
|
||||
::
|
||||
|%
|
||||
:: +move: output effect
|
||||
::
|
||||
+$ move [bone card]
|
||||
:: +card: output effect payload
|
||||
::
|
||||
+$ card
|
||||
$% [%poke wire dock poke]
|
||||
[%http-response =http-event:http]
|
||||
[%diff %json json]
|
||||
[%connect wire binding:eyre term]
|
||||
[%request wire request:http outbound-config:iris]
|
||||
[%wait wire @da]
|
||||
==
|
||||
+$ poke
|
||||
$% [%launch-action [@tas path @t]]
|
||||
==
|
||||
+$ state
|
||||
$% [%0 data=json time=@da location=@t timer=(unit @da)]
|
||||
==
|
||||
--
|
||||
::
|
||||
|_ [bol=bowl:gall state]
|
||||
::
|
||||
++ this .
|
||||
::
|
||||
++ bound
|
||||
|= [wir=wire success=? binding=binding:eyre]
|
||||
^- (quip move _this)
|
||||
[~ this]
|
||||
::
|
||||
++ prep
|
||||
|= old=(unit state)
|
||||
^- (quip move _this)
|
||||
=/ launcha
|
||||
[%launch-action [%weather /weathertile '/~weather/js/tile.js']]
|
||||
:-
|
||||
:~
|
||||
[ost.bol %connect / [~ /'~weather'] %weather]
|
||||
[ost.bol %poke /weather [our.bol %launch] launcha]
|
||||
==
|
||||
?~ old
|
||||
this
|
||||
%= this
|
||||
data data.u.old
|
||||
time time.u.old
|
||||
==
|
||||
::
|
||||
++ peer-weathertile
|
||||
|= pax=path
|
||||
^- (quip move _this)
|
||||
[[ost.bol %diff %json data]~ this]
|
||||
::
|
||||
++ poke-json
|
||||
|= jon=json
|
||||
^- (quip move _this)
|
||||
?. ?=(%s -.jon)
|
||||
[~ this]
|
||||
=/ str/@t +.jon
|
||||
=/ req/request:http (request-darksky str)
|
||||
=/ out *outbound-config:iris
|
||||
=/ lismov [ost.bol %request /[(scot %da now.bol)] req out]~
|
||||
?~ timer
|
||||
:- [[ost.bol %wait /timer (add now.bol ~h3)] lismov]
|
||||
%= this
|
||||
location str
|
||||
timer `(add now.bol ~h3)
|
||||
==
|
||||
:- lismov
|
||||
%= this
|
||||
location str
|
||||
==
|
||||
::
|
||||
++ request-darksky
|
||||
|= location=@t
|
||||
^- request:http
|
||||
=/ base
|
||||
"https://api.darksky.net/forecast/634639c10670c7376dc66b6692fe57ca/"
|
||||
=/ url/@t %- crip
|
||||
:(weld base (trip location) "?units=auto")
|
||||
=/ hed [['Accept' 'application/json']]~
|
||||
[%'GET' url hed *(unit octs)]
|
||||
::
|
||||
++ send-tile-diff
|
||||
|= jon=json
|
||||
^- (list move)
|
||||
%+ turn (prey:pubsub:userlib /weathertile bol)
|
||||
|= [=bone ^]
|
||||
[bone %diff %json jon]
|
||||
::
|
||||
++ http-response
|
||||
|= [=wire response=client-response:iris]
|
||||
^- (quip move _this)
|
||||
:: ignore all but %finished
|
||||
?. ?=(%finished -.response)
|
||||
[~ this]
|
||||
=/ data/(unit mime-data:iris) full-file.response
|
||||
?~ data
|
||||
:: data is null
|
||||
[~ this]
|
||||
=/ ujon/(unit json) (de-json:html q.data.u.data)
|
||||
?~ ujon
|
||||
[~ this]
|
||||
?> ?=(%o -.u.ujon)
|
||||
?: (gth 200 status-code.response-header.response)
|
||||
~& weather+u.ujon
|
||||
~& weather+location
|
||||
[~ this]
|
||||
=/ jon/json %- pairs:enjs:format :~
|
||||
currently+(~(got by p.u.ujon) 'currently')
|
||||
daily+(~(got by p.u.ujon) 'daily')
|
||||
==
|
||||
:- (send-tile-diff jon)
|
||||
%= this
|
||||
data jon
|
||||
time now.bol
|
||||
==
|
||||
::
|
||||
++ poke-handle-http-request
|
||||
%- (require-authorization:app ost.bol move this)
|
||||
|= =inbound-request:eyre
|
||||
^- (quip move _this)
|
||||
=/ request-line (parse-request-line url.request.inbound-request)
|
||||
=/ back-path (flop site.request-line)
|
||||
=/ name=@t
|
||||
=/ back-path (flop site.request-line)
|
||||
?~ back-path
|
||||
''
|
||||
i.back-path
|
||||
::
|
||||
?~ back-path
|
||||
:_ this ~
|
||||
?: =(name 'tile')
|
||||
[[ost.bol %http-response (js-response:app tile-js)]~ this]
|
||||
?: (lte (lent back-path) 1)
|
||||
[[ost.bol %http-response not-found:app]~ this]
|
||||
?: =(&2:site.request-line 'img')
|
||||
=/ img (as-octs:mimes:html (~(got by weather-png) `@ta`name))
|
||||
[[ost.bol %http-response (png-response:app img)]~ this]
|
||||
[~ this]
|
||||
::
|
||||
++ wake
|
||||
|= [wir=wire err=(unit tang)]
|
||||
^- (quip move _this)
|
||||
?~ err
|
||||
=/ req/request:http (request-darksky location)
|
||||
=/ out *outbound-config:iris
|
||||
:_ this(timer `(add now.bol ~h3))
|
||||
:~
|
||||
[ost.bol %request /[(scot %da now.bol)] req out]
|
||||
[ost.bol %wait /timer (add now.bol ~h3)]
|
||||
==
|
||||
~& err
|
||||
[~ this]
|
||||
::
|
||||
--
|
||||
@ -63,7 +63,7 @@
|
||||
::
|
||||
++ file-ovum
|
||||
=/ directories
|
||||
`(list path)`~[/app /age /ted /gen /lib /mar /ren /sec /sur /sys /tests /web]
|
||||
`(list path)`~[/app /ted /gen /lib /mar /ren /sec /sur /sys /tests /web]
|
||||
|= bas=path
|
||||
^- unix-event
|
||||
::
|
||||
|
||||
0
pkg/arvo/sys/vane/eyre.hoon
Executable file → Normal file
0
pkg/arvo/sys/vane/eyre.hoon
Executable file → Normal file
@ -220,7 +220,7 @@
|
||||
/sys/core/[term]/[ship]/[desk]/[case]
|
||||
::
|
||||
=/ =note-arvo
|
||||
=/ =schematic:ford [%core [ship desk] /hoon/[term]/age]
|
||||
=/ =schematic:ford [%core [ship desk] /hoon/[term]/app]
|
||||
[%f %build live=%.y schematic]
|
||||
::
|
||||
=/ pass [path note-arvo]
|
||||
|
||||
@ -45,7 +45,7 @@
|
||||
=/ =move:gall-gate
|
||||
=/ =path /sys/core/[term]/(scot %p ship)/[term]/(scot %da time)
|
||||
=/ =note-arvo
|
||||
=/ =schematic:ford [%core [ship term] /hoon/[term]/age]
|
||||
=/ =schematic:ford [%core [ship term] /hoon/[term]/app]
|
||||
=/ =task:able:ford [%build %.y schematic]
|
||||
[%f task]
|
||||
[duct %pass path note-arvo]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user