urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-19 08:32:39 +03:00
Code Issues Packages Projects Releases Wiki Activity
959884c9cd
shrub/pkg/arvo/app/dbug.hoon
Fang 959884c9cd
dbug: implement debug dashboard
2020-05-08 14:58:40 +02:00

717 lines
17 KiB
Plaintext
Raw Blame History

:: 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)
[~ this(passcode !<((unit @t) vase))]
?. ?=(%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
=, html
(as-octt:mimes (en-json u.json))
=, enjs:format
?+ site ~
:: /app.json: {appname: running, ...}
::
[%app ~]
%- some
%- pairs
%+ turn all:apps
|= app=term
[app b+(running:apps app)]
::
:: /app/[appname].json: {state: }
::
[%app @ ~]
=* app i.t.site
::TODO ?. (dbugable:apps app) ~
%- some
%- pairs
:~ :- 'state'
(tank (sell (state:apps app)))
::
:- '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
~! (ship s)
:~ '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)
==
--
==
::
:: /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'
:- %s
?+ -.action -.action
%gen :((cury cat 3) '+' (spat [desk path]:generator.action))
%app (cat 3 ':' app.action)
==
==
==
::
++ 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
(scry-dbug vase app /dbug/state)
::
++ subscriptions
=, gall
|= app=term
^- [out=boat in=bitt]
(scry-dbug ,[boat bitt] app /dbug/subscriptions)
::
++ scry-dbug
|* [=mold app=term =path]
(scry mold %gx app (snoc `^path`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)) %a %peers ~)
::
++ peer
|= who=ship
(scry ship-state:ames %a %peer /(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 structures 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
:: 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), %| s+(scot %x p.lane))
==
::
:- 'qos'
%- pairs
:~ 'kind'^s+-.qos
'last-contact'^(time last-contact.qos)
==
::
:- 'snd'
:- %a
%+ turn (sort ~(tap by snd) aor) :: sort by bone
(cury snd-with-bone ossuary)
::
:- 'rcv'
:- %a
%+ turn (sort ~(tap by rcv) aor) :: sort by bone
(cury rcv-with-bone ossuary)
::
:- 'nax'
:- %a
%+ turn (sort ~(tap in nax) aor) :: 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) aor) :: 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) aor) :: 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) aor) :: sort by msg #
::
:- 'live-messages'
:- %a
%+ turn (sort ~(tap by live-messages) aor) :: 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'^(set-array nax 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]) %b %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
|%
++ bindings
=, eyre
(scry ,(list [=binding =duct =action]) %e %bindings ~)
--
::
:: 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)
--
Reference in New Issue View Git Blame Copy Permalink