mirror of
https://github.com/urbit/shrub.git
synced 2024-12-01 06:35:32 +03:00
898 lines
22 KiB
Plaintext
898 lines
22 KiB
Plaintext
:: dbug: debug dashboard server
|
|
::
|
|
/- spider
|
|
/+ server, default-agent, verb, dbug
|
|
::
|
|
|%
|
|
+$ state-0 [%0 passcode=(unit @t)]
|
|
+$ card card:agent:gall
|
|
--
|
|
::
|
|
=| state-0
|
|
=* state -
|
|
::
|
|
%+ verb |
|
|
%- agent:dbug
|
|
^- agent:gall
|
|
=<
|
|
|_ =bowl:gall
|
|
+* this .
|
|
do ~(. +> bowl)
|
|
def ~(. (default-agent this %|) bowl)
|
|
::
|
|
++ on-init
|
|
^- (quip card _this)
|
|
:_ this
|
|
[%pass /connect %arvo %e %connect [~ /'~debug'] dap.bowl]~
|
|
::
|
|
++ on-save !>(state)
|
|
::
|
|
++ on-load
|
|
|= old=vase
|
|
^- (quip card _this)
|
|
[~ this(state !<(state-0 old))]
|
|
::
|
|
++ on-watch
|
|
|= =path
|
|
^- (quip card _this)
|
|
?. ?=([%http-response *] path)
|
|
(on-watch:def path)
|
|
[~ this]
|
|
::
|
|
++ on-poke
|
|
|= [=mark =vase]
|
|
^- (quip card _this)
|
|
?: ?=(%noun mark)
|
|
?> (team:title [our src]:bowl)
|
|
=/ code !<((unit @t) vase)
|
|
=/ msg=tape
|
|
?~ code
|
|
"Removing passcode access for debug interface."
|
|
"""
|
|
Enabling passcode access for debug interface. Anyone with this code can
|
|
view your applications' state, the people you've talked to, etc. Only
|
|
share with people you trust. To disable, run :dbug ~
|
|
"""
|
|
%- (slog leaf+msg ~)
|
|
[~ this(passcode code)]
|
|
?. ?=(%handle-http-request mark)
|
|
(on-poke:def mark vase)
|
|
=+ !<([eyre-id=@ta =inbound-request:eyre] vase)
|
|
:_ this
|
|
%+ give-simple-payload:app:server eyre-id
|
|
%+ authorize-http-request:do inbound-request
|
|
handle-http-request:do
|
|
::
|
|
++ on-arvo
|
|
|= [=wire =sign-arvo]
|
|
^- (quip card _this)
|
|
?. ?=([%e %bound *] sign-arvo)
|
|
(on-arvo:def wire sign-arvo)
|
|
~? !accepted.sign-arvo
|
|
[dap.bowl "bind rejected!" binding.sign-arvo]
|
|
[~ this]
|
|
::
|
|
++ on-peek on-peek:def
|
|
++ on-leave on-leave:def
|
|
++ on-agent on-agent:def
|
|
++ on-fail on-fail:def
|
|
--
|
|
::
|
|
|_ =bowl:gall
|
|
::
|
|
:: serving
|
|
::
|
|
++ authorize-http-request
|
|
=, server
|
|
:: if no passcode configured, only allow host ship to view
|
|
::
|
|
?~ passcode require-authorization:app
|
|
|= $: =inbound-request:eyre
|
|
handler=$-(inbound-request:eyre simple-payload:http)
|
|
==
|
|
?: authenticated.inbound-request
|
|
(handler inbound-request)
|
|
:: else, allow randos access,
|
|
:: on the condition they provide a correct ?passcode= url parameter
|
|
::
|
|
=; pass=(unit @t)
|
|
?: =(passcode pass)
|
|
(handler inbound-request)
|
|
(require-authorization:app inbound-request handler)
|
|
=/ from-url=(unit @t)
|
|
=- (~(get by -) 'passcode')
|
|
%- ~(gas by *(map @t @t))
|
|
args:(parse-request-line url.request.inbound-request)
|
|
?^ from-url from-url
|
|
:: try the referer field instead
|
|
::
|
|
=/ ref-url=(unit @t)
|
|
(get-header:http 'referer' header-list.request.inbound-request)
|
|
?~ ref-url ~
|
|
?~ (find "passcode={(trip u.passcode)}" (trip u.ref-url)) ~
|
|
passcode
|
|
::
|
|
++ handle-http-request
|
|
=, server
|
|
|= =inbound-request:eyre
|
|
^- simple-payload:http
|
|
=/ =request-line
|
|
%- parse-request-line
|
|
url.request.inbound-request
|
|
=* req-head header-list.request.inbound-request
|
|
::TODO handle POST
|
|
?. ?=(%'GET' method.request.inbound-request)
|
|
not-found:gen
|
|
(handle-get-request req-head request-line)
|
|
::
|
|
++ handle-get-request
|
|
=, server
|
|
|= [headers=header-list:http request-line]
|
|
^- simple-payload:http
|
|
=? site ?=([%'~debug' *] site) t.site
|
|
?~ ext
|
|
$(ext `%html, site [%index ~]) ::NOTE hack
|
|
:: if not json, serve static file
|
|
::
|
|
?. ?=([~ %json] ext)
|
|
=/ file=(unit octs)
|
|
(get-file-at /app/debug site u.ext)
|
|
?~ file not-found:gen
|
|
?+ u.ext not-found:gen
|
|
%html (html-response:gen u.file)
|
|
%js (js-response:gen u.file)
|
|
%css (css-response:gen u.file)
|
|
%png (png-response:gen u.file)
|
|
==
|
|
:: get data matching the json and convert it
|
|
::
|
|
=; json=(unit json)
|
|
?~ json not-found:gen
|
|
(json-response:gen u.json)
|
|
=, enjs:format
|
|
?+ site ~
|
|
:: /apps.json: {appname: running?}
|
|
::
|
|
[%apps ~]
|
|
%- some
|
|
%- pairs
|
|
%+ turn all:apps
|
|
|= app=term
|
|
[app b+(running:apps app)]
|
|
::
|
|
:: /app/[appname]...
|
|
::
|
|
[%app @ *]
|
|
=* app i.t.site
|
|
::TODO ?. (dbugable:apps app) ~
|
|
=/ rest=^path t.t.site
|
|
?+ rest ~
|
|
:: /app/[appname].json: {state: }
|
|
::
|
|
~
|
|
%- some
|
|
%- pairs
|
|
:~ :- 'simpleState'
|
|
%- tank
|
|
=; head=(unit ^tank)
|
|
(fall head leaf+"unversioned")
|
|
:: try to print the state version
|
|
::
|
|
=/ version=(unit vase)
|
|
(slew 2 (state:apps app))
|
|
?~ version ~
|
|
?. ?=(%atom -.p.u.version) ~
|
|
`(sell u.version)
|
|
::
|
|
:- 'subscriptions'
|
|
%- pairs
|
|
=+ (subscriptions:apps app)
|
|
|^ ~['in'^(incoming in) 'out'^(outgoing out)]
|
|
::
|
|
++ incoming
|
|
|= =bitt:gall
|
|
^- json
|
|
:- %a
|
|
%+ turn ~(tap by bitt)
|
|
|= [d=duct [s=^ship p=^path]]
|
|
%- pairs
|
|
:~ 'duct'^a+(turn d path)
|
|
'ship'^(ship s)
|
|
'path'^(path p)
|
|
==
|
|
::
|
|
++ outgoing
|
|
|= =boat:gall
|
|
^- json
|
|
:- %a
|
|
%+ turn ~(tap by boat)
|
|
|= [[w=wire s=^ship t=term] [a=? p=^path]]
|
|
%- pairs
|
|
:~ 'wire'^(path w)
|
|
'ship'^(ship s)
|
|
'app'^s+t
|
|
'acked'^b+a
|
|
'path'^(path p)
|
|
==
|
|
--
|
|
==
|
|
::
|
|
:: /app/[appname]/state.json
|
|
:: /app/[appname]/state/[query].json
|
|
::
|
|
[%state ?(~ [@ ~])]
|
|
%- some
|
|
=- (pairs 'state'^(tank -) ~)
|
|
%+ state-at:apps app
|
|
?~ t.rest ~
|
|
(slaw %t i.t.rest)
|
|
==
|
|
::
|
|
:: /spider.json
|
|
::
|
|
[%spider %threads ~]
|
|
%- some
|
|
:: turn flat stack descriptors into object (tree) representing stacks
|
|
::
|
|
|^ (tree-to-json build-thread-tree)
|
|
::
|
|
+$ tree
|
|
$~ ~
|
|
(map tid:spider tree)
|
|
::
|
|
++ build-thread-tree
|
|
%+ roll tree:threads
|
|
|= [stack=(list tid:spider) =tree]
|
|
?~ stack tree
|
|
%+ ~(put by tree) i.stack
|
|
%_ $
|
|
stack t.stack
|
|
tree (~(gut by tree) i.stack ~)
|
|
==
|
|
::
|
|
++ tree-to-json
|
|
|= =tree
|
|
o+(~(run by tree) tree-to-json)
|
|
--
|
|
::
|
|
:: /azimuth/status
|
|
::
|
|
:: /ames/peer.json
|
|
::
|
|
[%ames %peer ~]
|
|
=/ [known=(list [^ship *]) alien=(list [^ship *])]
|
|
%+ skid ~(tap by peers:v-ames)
|
|
|= [^ship kind=?(%alien %known)]
|
|
?=(%known kind)
|
|
%- some
|
|
%- pairs
|
|
::NOTE would do (cork head ship) but can't get that to compile...
|
|
:~ 'known'^a+(turn (turn known head) ship)
|
|
'alien'^a+(turn (turn alien head) ship)
|
|
==
|
|
::
|
|
:: /ames/peer/[shipname].json
|
|
::
|
|
[%ames %peer @ ~]
|
|
=/ who=^ship
|
|
(rash i.t.t.site fed:ag)
|
|
%- some
|
|
=, v-ames
|
|
(peer-to-json (peer who))
|
|
::
|
|
:: /behn/timers.json
|
|
::
|
|
[%behn %timers ~]
|
|
%- some
|
|
:- %a
|
|
%+ turn timers:v-behn
|
|
|= [date=@da =duct]
|
|
%- pairs
|
|
:~ 'date'^(time date)
|
|
'duct'^a+(turn duct path)
|
|
==
|
|
::
|
|
:: /clay/commits.json
|
|
::
|
|
[%clay %commits ~]
|
|
(some commits-json:v-clay)
|
|
::
|
|
:: /eyre/bindings.json
|
|
::
|
|
[%eyre %bindings ~]
|
|
%- some
|
|
:- %a
|
|
%+ turn bindings:v-eyre
|
|
=, eyre
|
|
|= [binding =duct =action]
|
|
%- pairs
|
|
:~ 'location'^s+(cat 3 (fall site '*') (spat path))
|
|
'action'^(render-action:v-eyre action)
|
|
==
|
|
::
|
|
:: /eyre/connections.json
|
|
::
|
|
[%eyre %connections ~]
|
|
%- some
|
|
:- %a
|
|
%+ turn ~(tap by connections:v-eyre)
|
|
|= [=duct outstanding-connection:eyre]
|
|
%- pairs
|
|
:~ 'duct'^a+(turn duct path)
|
|
'action'^(render-action:v-eyre action)
|
|
::
|
|
:- 'request'
|
|
%- pairs
|
|
=, inbound-request
|
|
:~ 'authenticated'^b+authenticated
|
|
'secure'^b+secure
|
|
'source'^s+(scot %if +.address)
|
|
:: ?- -.address
|
|
:: %ipv4 %if
|
|
:: %ipv6 %is
|
|
:: ==
|
|
==
|
|
::
|
|
:- 'response'
|
|
%- pairs
|
|
:~ 'sent'^(numb bytes-sent)
|
|
::
|
|
:- 'header'
|
|
?~ response-header ~
|
|
=, u.response-header
|
|
%- pairs
|
|
:~ 'status-code'^(numb status-code)
|
|
::
|
|
:- 'headers'
|
|
:- %a
|
|
%+ turn headers
|
|
|=([k=@t v=@t] s+:((cury cat 3) k ': ' v))
|
|
==
|
|
==
|
|
==
|
|
::
|
|
:: /eyre/authentication.json
|
|
::
|
|
[%eyre %authentication ~]
|
|
%- some
|
|
:- %a
|
|
%+ turn
|
|
%+ sort ~(tap by sessions:auth-state:v-eyre)
|
|
|= [[@uv a=session:eyre] [@uv b=session:eyre]]
|
|
(gth expiry-time.a expiry-time.b)
|
|
|= [cookie=@uv session:eyre]
|
|
%- pairs
|
|
:~ 'cookie'^s+(end 3 4 (rsh 3 2 (scot %x (shax cookie))))
|
|
'expiry'^(time expiry-time)
|
|
'channels'^(numb ~(wyt in channels))
|
|
==
|
|
::
|
|
:: /eyre/channels.json
|
|
::
|
|
[%eyre %channels ~]
|
|
%- some
|
|
:- %a
|
|
=+ channel-state:v-eyre
|
|
%+ turn ~(tap by session)
|
|
|= [key=@t channel:eyre]
|
|
%- pairs
|
|
:~ 'session'^s+key
|
|
'connected'^b+!-.state
|
|
'expiry'^?-(-.state %& (time date.p.state), %| ~)
|
|
'next-id'^(numb next-id)
|
|
'unacked'^a+(turn (sort (turn ~(tap in events) head) dor) numb)
|
|
::
|
|
:- 'subscriptions'
|
|
:- %a
|
|
%+ turn ~(tap by subscriptions)
|
|
|= [=wire [=^ship app=term =^path *]]
|
|
%- pairs
|
|
:~ 'wire'^(^path wire)
|
|
'ship'^(^ship ship)
|
|
'app'^s+app
|
|
'path'^(^path path)
|
|
==
|
|
==
|
|
==
|
|
::
|
|
++ get-file-at
|
|
|= [base=path file=path ext=@ta]
|
|
^- (unit octs)
|
|
?. ?=(?(%html %css %js %png) ext)
|
|
~
|
|
=/ =path
|
|
:* (scot %p our.bowl)
|
|
q.byk.bowl
|
|
(scot %da now.bowl)
|
|
(snoc (weld base file) ext)
|
|
==
|
|
?. .^(? %cu path) ~
|
|
%- some
|
|
%- as-octs:mimes:html
|
|
.^(@ %cx path)
|
|
::
|
|
:: applications
|
|
::
|
|
++ apps
|
|
|%
|
|
++ all
|
|
^- (list term)
|
|
%+ murn
|
|
(scry (list path) %ct %home /app)
|
|
|= =path
|
|
^- (unit term)
|
|
?. ?=([%app @ %hoon ~] path) ~
|
|
`i.t.path
|
|
::
|
|
++ running
|
|
|= app=term
|
|
(scry ? %gu app ~)
|
|
::
|
|
++ dbugable
|
|
|= app=term
|
|
^- ?
|
|
!! ::TODO how to check if it supports the /dbug scries?
|
|
::
|
|
++ state
|
|
|= app=term
|
|
^- vase
|
|
(scry-dbug vase app /state)
|
|
::
|
|
++ state-at
|
|
|= [app=term what=(unit @t)]
|
|
^- tank
|
|
=/ state=vase (state app)
|
|
?~ what (sell state)
|
|
=/ result=(each vase tang)
|
|
%- mule |.
|
|
%+ slap
|
|
(slop state !>([bowl=bowl ..zuse]))
|
|
(ream u.what)
|
|
?- -.result
|
|
%& (sell p.result)
|
|
%| (head p.result)
|
|
==
|
|
::
|
|
++ subscriptions
|
|
=, gall
|
|
|= app=term
|
|
^- [out=boat in=bitt]
|
|
(scry-dbug ,[boat bitt] app /subscriptions)
|
|
::
|
|
++ scry-dbug
|
|
|* [=mold app=term =path]
|
|
(scry mold %gx app (snoc `^path`[%dbug path] %noun))
|
|
::
|
|
::TODO but why? we can't tell if it's on or not
|
|
++ poke-verb-toggle
|
|
|= app=term
|
|
^- card
|
|
(poke /verb/[app] app %verb !>(%loud))
|
|
--
|
|
::
|
|
:: threads
|
|
::
|
|
++ threads
|
|
|%
|
|
::NOTE every (list tid:spider) represents a stack,
|
|
:: with a unique tid at the end
|
|
++ tree
|
|
(scry (list (list tid:spider)) %gx %spider /tree/noun)
|
|
::
|
|
++ poke-kill
|
|
|= =tid:spider
|
|
^- card
|
|
(poke /spider/kill/[tid] %spider %spider-stop !>([tid |]))
|
|
--
|
|
::
|
|
:: ames
|
|
::
|
|
++ v-ames
|
|
|%
|
|
++ peers
|
|
(scry (map ship ?(%alien %known)) %ax %$ /peers)
|
|
::
|
|
++ peer
|
|
|= who=ship
|
|
(scry ship-state:ames %ax %$ /peers/(scot %p who))
|
|
::
|
|
++ peer-to-json
|
|
=, ames
|
|
=, enjs:format
|
|
|= =ship-state
|
|
|^ ^- json
|
|
%+ frond -.ship-state
|
|
?- -.ship-state
|
|
%alien (alien +.ship-state)
|
|
%known (known +.ship-state)
|
|
==
|
|
::
|
|
++ alien
|
|
|= alien-agenda
|
|
%- pairs
|
|
:~ 'messages'^(numb (lent messages))
|
|
'packets'^(numb ~(wyt in packets))
|
|
'heeds'^(set-array heeds from-duct)
|
|
==
|
|
::
|
|
:: json for known peer is structured to closely match the peer-state type.
|
|
:: where an index is specified, the array is generally sorted by those.
|
|
::
|
|
:: { life: 123,
|
|
:: route: { direct: true, lane: 'something' },
|
|
:: qos: { kind: 'status', last-contact: 123456 }, // ms timestamp
|
|
:: flows: { forward: [snd, rcv, ...], backward: [snd, rcv, ...] }
|
|
:: -> snd:
|
|
:: { bone: 123, // index
|
|
:: duct: ['/paths', ...]
|
|
:: current: 123,
|
|
:: next: 123,
|
|
:: unsent-messages: [123, ...], // size in bytes
|
|
:: queued-message-acks: [{
|
|
:: message-num: 123, // index
|
|
:: ack: 'ok'
|
|
:: }, ...],
|
|
:: packet-pump-state: {
|
|
:: next-wake: 123456, // ms timestamp
|
|
:: live: [{
|
|
:: message-num: 123, // index
|
|
:: fragment-num: 123, // index
|
|
:: num-fragments: 123,
|
|
:: last-sent: 123456, // ms timestamp
|
|
:: retries: 123,
|
|
:: skips: 123
|
|
:: }, ...],
|
|
:: metrics: {
|
|
:: rto: 123, // seconds
|
|
:: rtt: 123, // seconds
|
|
:: rttvar: 123,
|
|
:: ssthresh: 123,
|
|
:: num-live: 123,
|
|
:: cwnd: 123,
|
|
:: counter: 123
|
|
:: }
|
|
:: }
|
|
:: }
|
|
:: -> rcv:
|
|
:: { bone: 123, // index
|
|
:: duct: ['/paths', ...] // index
|
|
:: last-acked: 123,
|
|
:: last-heard: 123,
|
|
:: pending-vane-ack: [123, ...],
|
|
:: live-messages: [{
|
|
:: message-num: 123, // index
|
|
:: num-received: 122,
|
|
:: num-fragments: 123,
|
|
:: fragments: [123, ...]
|
|
:: }, ...],
|
|
:: nax: [123, ...]
|
|
:: }
|
|
:: nax: [{
|
|
:: bone: 123, // index
|
|
:: duct: ['/paths', ...],
|
|
:: message-num: 123
|
|
:: }, ...],
|
|
:: heeds: [['/paths', ...] ...]
|
|
:: }
|
|
::
|
|
++ known
|
|
|= peer-state
|
|
%- pairs
|
|
:~ 'life'^(numb life)
|
|
::
|
|
:- 'route'
|
|
%+ maybe route
|
|
|= [direct=? =lane]
|
|
%- pairs
|
|
:~ 'direct'^b+direct
|
|
::
|
|
:- 'lane'
|
|
?- -.lane
|
|
%& (ship p.lane)
|
|
::
|
|
%|
|
|
?~ l=((soft ,[=@tas =@if =@ud]) (cue p.lane))
|
|
s+(scot %x p.lane)
|
|
=, u.l
|
|
(tape "%{(trip tas)}, {(scow %if if)}, {(scow %ud ud)}")
|
|
==
|
|
==
|
|
::
|
|
:- 'qos'
|
|
%- pairs
|
|
:~ 'kind'^s+-.qos
|
|
'last-contact'^(time last-contact.qos)
|
|
==
|
|
::
|
|
:- 'flows'
|
|
|^ =/ mix=(list flow)
|
|
=- (sort - dor)
|
|
%+ welp
|
|
(turn ~(tap by snd) (tack %snd))
|
|
(turn ~(tap by rcv) (tack %rcv))
|
|
=/ [forward=(list flow) backward=(list flow)]
|
|
%+ skid mix
|
|
|= [=bone *]
|
|
=(0 (mod bone 2))
|
|
%- pairs
|
|
:~ ['forward' a+(turn forward build)]
|
|
['backward' a+(turn backward build)]
|
|
==
|
|
::
|
|
+$ flow
|
|
$: =bone
|
|
::
|
|
$= state
|
|
$% [%snd message-pump-state]
|
|
[%rcv message-sink-state]
|
|
==
|
|
==
|
|
::
|
|
++ tack
|
|
|* =term
|
|
|* [=bone =noun]
|
|
[bone [term noun]]
|
|
::
|
|
++ build
|
|
|= flow
|
|
^- json
|
|
%+ frond -.state
|
|
?- -.state
|
|
%snd (snd-with-bone ossuary bone +.state)
|
|
%rcv (rcv-with-bone ossuary bone +.state)
|
|
==
|
|
--
|
|
::
|
|
:- 'nax'
|
|
:- %a
|
|
%+ turn (sort ~(tap in nax) dor) :: sort by bone
|
|
|= [=bone =message-num]
|
|
%- pairs
|
|
:* 'message-num'^(numb message-num)
|
|
(bone-to-pairs bone ossuary)
|
|
==
|
|
::
|
|
'heeds'^(set-array heeds from-duct)
|
|
==
|
|
::
|
|
++ snd-with-bone
|
|
|= [=ossuary =bone message-pump-state]
|
|
^- json
|
|
%- pairs
|
|
:* 'current'^(numb current)
|
|
'next'^(numb next)
|
|
::
|
|
:- 'unsent-messages' :: as byte sizes
|
|
(set-array unsent-messages (cork (cury met 3) numb))
|
|
::
|
|
'unsent-fragments'^(numb (lent unsent-fragments)) :: as lent
|
|
::
|
|
:- 'queued-message-acks'
|
|
:- %a
|
|
%+ turn (sort ~(tap by queued-message-acks) dor) :: sort by msg nr
|
|
|= [=message-num =ack]
|
|
%- pairs
|
|
:~ 'message-num'^(numb message-num)
|
|
'ack'^s+-.ack
|
|
==
|
|
::
|
|
:- 'packet-pump-state'
|
|
%- pairs
|
|
=, packet-pump-state
|
|
:~ 'next-wake'^(maybe next-wake time)
|
|
::
|
|
:- 'live'
|
|
:- %a
|
|
%+ turn (sort ~(tap in live) dor) :: sort by msg nr & frg nr
|
|
|= [live-packet-key live-packet-val]
|
|
%- pairs
|
|
:~ 'message-num'^(numb message-num)
|
|
'fragment-num'^(numb fragment-num)
|
|
'num-fragments'^(numb num-fragments)
|
|
'last-sent'^(time last-sent)
|
|
'retries'^(numb retries)
|
|
'skips'^(numb skips)
|
|
==
|
|
::
|
|
:- 'metrics'
|
|
%- pairs
|
|
=, metrics
|
|
:~ 'rto'^(numb (div rto ~s1)) ::TODO milliseconds?
|
|
'rtt'^(numb (div rtt ~s1))
|
|
'rttvar'^(numb (div rttvar ~s1))
|
|
'ssthresh'^(numb ssthresh)
|
|
'num-live'^(numb num-live)
|
|
'cwnd'^(numb cwnd)
|
|
'counter'^(numb counter)
|
|
==
|
|
==
|
|
::
|
|
(bone-to-pairs bone ossuary)
|
|
==
|
|
::
|
|
++ rcv-with-bone
|
|
|= [=ossuary =bone message-sink-state]
|
|
^- json
|
|
%- pairs
|
|
:* 'last-acked'^(numb last-acked)
|
|
'last-heard'^(numb last-heard)
|
|
::
|
|
:- 'pending-vane-ack'
|
|
=- a+(turn - numb)
|
|
(sort (turn ~(tap in pending-vane-ack) head) dor) :: sort by msg #
|
|
::
|
|
:- 'live-messages'
|
|
:- %a
|
|
%+ turn (sort ~(tap by live-messages) dor) :: sort by msg #
|
|
|= [=message-num partial-rcv-message]
|
|
%- pairs
|
|
:~ 'message-num'^(numb message-num)
|
|
'num-received'^(numb num-received)
|
|
'num-fragments'^(numb num-fragments)
|
|
'fragments'^(set-array ~(key by fragments) numb)
|
|
==
|
|
::
|
|
'nax'^a+(turn (sort ~(tap in nax) dor) numb)
|
|
::
|
|
(bone-to-pairs bone ossuary)
|
|
==
|
|
::
|
|
++ bone-to-pairs
|
|
|= [=bone ossuary]
|
|
^- (list [@t json])
|
|
:~ 'bone'^(numb bone)
|
|
'duct'^(from-duct (~(gut by by-bone) bone ~))
|
|
==
|
|
::
|
|
++ maybe
|
|
|* [unit=(unit) enjs=$-(* json)]
|
|
^- json
|
|
?~ unit ~
|
|
(enjs u.unit)
|
|
::
|
|
++ set-array
|
|
|* [set=(set) enjs=$-(* json)]
|
|
^- json
|
|
a+(turn ~(tap in set) enjs)
|
|
::
|
|
++ from-duct
|
|
|= =duct
|
|
a+(turn duct path)
|
|
--
|
|
--
|
|
::
|
|
:: behn
|
|
::
|
|
++ v-behn
|
|
|%
|
|
++ timers
|
|
(scry ,(list [date=@da =duct]) %bx %$ /debug/timers)
|
|
--
|
|
::
|
|
:: clay
|
|
::
|
|
::TODO depends on new clay changes (%s care)
|
|
++ v-clay
|
|
=, clay
|
|
|%
|
|
++ start-path /(scot %p our.bowl)/home/(scot %da now.bowl)
|
|
::
|
|
+$ commit
|
|
[=tako parents=(list tako) children=(list tako) wen=@da content-hash=@uvI]
|
|
::
|
|
++ commits-json
|
|
^- json
|
|
=+ .^(desks=(set desk) %cd start-path)
|
|
=/ heads=(list [tako desk])
|
|
%+ turn ~(tap in desks)
|
|
|= =desk
|
|
=+ .^(=dome %cv /(scot %p our.bowl)/[desk]/(scot %da now.bowl))
|
|
=/ =tako (~(got by hit.dome) let.dome)
|
|
[tako desk]
|
|
=/ yakis=(set yaki)
|
|
%- silt
|
|
^- (list yaki)
|
|
%- zing
|
|
%+ turn heads
|
|
|= [=tako =desk]
|
|
(trace-tako tako)
|
|
=/ commits=(list commit) (yakis-to-commits ~(tap in yakis))
|
|
=, enjs:format
|
|
%: pairs
|
|
head+(pairs (turn heads |=([=tako =desk] (scot %uv tako)^s+desk)))
|
|
commits+(commits-to-json commits)
|
|
~
|
|
==
|
|
::
|
|
++ yakis-to-commits
|
|
|= yakis=(list yaki)
|
|
^- (list commit)
|
|
%+ turn yakis
|
|
|= =yaki
|
|
:* r.yaki p.yaki
|
|
=/ candidates
|
|
%+ turn
|
|
(skim yakis |=(can=^yaki (lien p.can |=(=tako =(r.yaki tako)))))
|
|
|= can=^yaki
|
|
r.can
|
|
~(tap in (silt candidates))
|
|
t.yaki
|
|
.^(@uvI %cs (weld start-path /hash/(scot %uv r.yaki)))
|
|
==
|
|
::
|
|
++ trace-tako
|
|
|= =tako
|
|
~+
|
|
^- (list yaki)
|
|
=+ .^(=yaki %cs (weld start-path /yaki/(scot %uv tako)))
|
|
:- yaki
|
|
(zing (turn p.yaki trace-tako))
|
|
::
|
|
++ commits-to-json
|
|
|= commits=(list commit)
|
|
^- json
|
|
:- %a
|
|
%+ turn
|
|
%+ sort commits
|
|
|= [a=commit b=commit]
|
|
(gte wen.a wen.b)
|
|
|= =commit
|
|
(commit-to-json commit)
|
|
::
|
|
++ commit-to-json
|
|
|= =commit
|
|
^- json
|
|
=, enjs:format
|
|
%: pairs
|
|
'commitHash'^(tako-to-json tako.commit)
|
|
parents+a+(turn parents.commit tako-to-json)
|
|
children+a+(turn children.commit tako-to-json)
|
|
'contentHash'^(tako-to-json content-hash.commit)
|
|
~
|
|
==
|
|
::
|
|
++ tako-to-json
|
|
|= =tako
|
|
^- json
|
|
s+(scot %uv tako)
|
|
--
|
|
::
|
|
:: eyre
|
|
::
|
|
++ v-eyre
|
|
=, eyre
|
|
|%
|
|
++ bindings
|
|
(scry ,(list [=binding =duct =action]) %e %bindings ~)
|
|
::
|
|
++ connections
|
|
(scry ,(map duct outstanding-connection) %e %connections ~)
|
|
::
|
|
++ auth-state
|
|
(scry authentication-state %e %authentication-state ~)
|
|
::
|
|
++ channel-state
|
|
(scry ^channel-state %e %channel-state ~)
|
|
::
|
|
++ render-action
|
|
|= =action
|
|
^- json
|
|
:- %s
|
|
?+ -.action -.action
|
|
%gen :((cury cat 3) '+' (spat [desk path]:generator.action))
|
|
%app (cat 3 ':' app.action)
|
|
==
|
|
--
|
|
::
|
|
:: helpers
|
|
::
|
|
++ poke
|
|
|= [=wire app=term =mark =vase]
|
|
^- card
|
|
[%pass wire %agent [our.bowl app] %poke mark vase]
|
|
::
|
|
++ scry
|
|
|* [=mold care=term =desk =path]
|
|
.^(mold care (scot %p our.bowl) desk (scot %da now.bowl) path)
|
|
--
|