mirror of
https://github.com/urbit/shrub.git
synced 2024-12-22 02:11:38 +03:00
f1bb35fcee
If the docket says the glob is a local ames glob, then update the hash to match the newly uploaded glob. One would naively expect this to result in a %commit fact being received, letting us update our state through the usual mechanism. This is, for some reason, not the case...
619 lines
18 KiB
Plaintext
619 lines
18 KiB
Plaintext
/- *docket, hood, treaty
|
|
/+ *server, agentio, default-agent, multipart, dbug, verb
|
|
|%
|
|
+$ card card:agent:gall
|
|
+$ state-0
|
|
$: :: local
|
|
charges=(map desk charge)
|
|
==
|
|
:: $cache: impermanent state
|
|
+$ cache
|
|
by-base=(map term desk)
|
|
::
|
|
+$ inflated-state
|
|
[state-0 cache]
|
|
:: +lac: toggle verbosity
|
|
++ lac &
|
|
::
|
|
++ ver
|
|
|%
|
|
++ poke 1
|
|
++ scry 1
|
|
++ peer 1
|
|
--
|
|
::
|
|
--
|
|
^- agent:gall
|
|
%- agent:dbug
|
|
%+ verb |
|
|
=| inflated-state
|
|
=* state -
|
|
=<
|
|
|_ =bowl:gall
|
|
+* this .
|
|
io ~(. agentio bowl)
|
|
pass pass:io
|
|
def ~(. (default-agent this %|) bowl)
|
|
cc ~(. +> bowl)
|
|
ch ch:cc
|
|
::
|
|
++ on-init
|
|
^- (quip card _this)
|
|
:_ this
|
|
:~ (~(watch-our pass /kiln) %hood /kiln/vats)
|
|
(~(connect pass /eyre) [~ /] %docket)
|
|
(~(wait pass /init) (add 1 now.bowl))
|
|
(~(connect pass /eyre) [~ /apps] %docket)
|
|
==
|
|
::
|
|
++ on-load
|
|
|= =vase
|
|
^- (quip card _this)
|
|
=+ !<(old=state-0 vase)
|
|
=* cha ~(. ch q.byk.bowl)
|
|
|^
|
|
=. -.state old
|
|
=. +.state inflate-cache
|
|
`this
|
|
::
|
|
++ inflate-cache
|
|
^- cache
|
|
%- ~(gas by *(map term desk))
|
|
%+ murn ~(tap by charges)
|
|
|= [=desk =charge]
|
|
?. ?=(%glob -.href.docket.charge) ~
|
|
`:_(desk base.href.docket.charge)
|
|
--
|
|
::
|
|
++ on-save !>(-.state)
|
|
++ on-poke
|
|
|= [=mark =vase]
|
|
^- (quip card _this)
|
|
|^
|
|
=^ cards state
|
|
?+ mark (on-poke:def:cc mark vase)
|
|
%docket-install (install !<([ship desk] vase))
|
|
%docket-uninstall (uninstall !<(desk vase))
|
|
::
|
|
%noun
|
|
=+ ;;([%kick =desk] q.vase)
|
|
:_(state ~(fetch-glob ch desk))
|
|
::
|
|
%handle-http-request
|
|
=+ !<([id=@ta req=inbound-request:eyre] vase)
|
|
(handle-http-request:cc id req)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ install
|
|
|= [=ship =desk]
|
|
^- (quip card _state)
|
|
=+ .^(=treaty:treaty %gx (scry:io %treaty /treaty/(scot %p ship)/[desk]/noun))
|
|
?: (~(has by charges) desk)
|
|
~| bad-install-desk/desk
|
|
!!
|
|
=. charges
|
|
(~(put by charges) desk docket.treaty %install ~)
|
|
=* cha ~(. ch desk)
|
|
:_ state
|
|
~[add-fact:cha (install:cha ship desk)]
|
|
::
|
|
++ uninstall
|
|
|= =desk
|
|
^- (quip card _state)
|
|
=/ =charge ~|(no-charge-installed+desk (~(got by charges) desk))
|
|
=. charges (~(del by charges) desk)
|
|
=? by-base ?=(%glob -.href.docket.charge)
|
|
(~(del by by-base) base.href.docket)
|
|
=* cha ~(. ch desk)
|
|
:_ state
|
|
~[del-fact:cha uninstall:cha]
|
|
--
|
|
::
|
|
++ on-watch
|
|
|= =path
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ path (on-watch:def path)
|
|
[%http-response *]
|
|
?> (team:title [our src]:bowl)
|
|
`state
|
|
::
|
|
[%charges ~]
|
|
?> (team:title [our src]:bowl)
|
|
`state
|
|
::
|
|
[%glob @ @ ~]
|
|
=* base i.t.path
|
|
=* hash (slav %uv i.t.t.path)
|
|
=/ desk ~|(path/path (~(got by by-base) i.t.path))
|
|
=/ =charge ~|(desk/desk (~(got by charges) desk))
|
|
?> ?=(%glob -.chad.charge)
|
|
?> =(hash (hash-glob:cc glob.chad.charge))
|
|
:_ state
|
|
:~ [%give %fact ~[path] %glob !>(`glob`glob.chad.charge)]
|
|
[%give %kick ~[path] ~]
|
|
==
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-peek
|
|
|= =path
|
|
^- (unit (unit cage))
|
|
?+ path [~ ~]
|
|
[%x %ver %poke ~] ``noun+!>(poke:ver)
|
|
[%x %ver %peer ~] ``noun+!>(peer:ver)
|
|
[%x %ver %scry ~] ``noun+!>(scry:ver)
|
|
[%x %our ~] ``json+!>(s+(scot %p our.bowl))
|
|
::
|
|
[%x %dbug %state ~]
|
|
=- ``noun+!>(-)
|
|
%_ state
|
|
charges
|
|
%- ~(run by charges)
|
|
|= =charge
|
|
=? chad.charge ?=(%glob -.chad.charge)
|
|
:- %glob
|
|
%- ~(run by glob.chad.charge)
|
|
|=(=mime mime(q.q 1.337))
|
|
charge
|
|
==
|
|
::
|
|
[%x %charges ~]
|
|
:- ~ :- ~
|
|
:- %charge-update
|
|
!> ^- charge-update
|
|
:- %initial
|
|
%- ~(gas by *(map desk charge))
|
|
%+ turn ~(tap by charges)
|
|
|= [=desk =charge]
|
|
[desk (get-light-charge charge)]
|
|
==
|
|
::
|
|
++ on-agent
|
|
|= [=wire =sign:agent:gall]
|
|
^- (quip card _this)
|
|
|^
|
|
=^ cards state
|
|
?+ wire ~&(bad-docket-take+wire `state)
|
|
~ `state
|
|
[%kiln ~] take-kiln
|
|
[%charge @ *] (take-charge i.t.wire t.t.wire)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ take-kiln
|
|
^- (quip card _state)
|
|
?+ -.sign (on-agent:def:cc wire sign)
|
|
%kick [(~(watch-our pass /kiln) %hood /kiln/vats)^~ state]
|
|
::
|
|
%fact
|
|
?. ?=(%kiln-vats-diff p.cage.sign) `state
|
|
=+ !<(=diff:hood q.cage.sign)
|
|
=* cha ~(. ch desk.diff)
|
|
?+ -.diff `state
|
|
::
|
|
%commit
|
|
=* cha ~(. ch desk.diff)
|
|
?. docket-exists:cha `state
|
|
=/ =docket docket:cha
|
|
:: if the new chad is a site, we're instantly done
|
|
::
|
|
?: ?=(%site -.href.docket)
|
|
:- ~[add-fact:cha]
|
|
state(charges (~(put by charges) desk.diff [docket [%site ~]]))
|
|
:: if the glob is unchanged, keep it
|
|
::
|
|
=/ pre=(unit href)
|
|
?~ cho=(~(get by charges) desk.diff) ~
|
|
`href.docket.u.cho
|
|
?: =(pre `href.docket)
|
|
[~[add-fact:cha] state]
|
|
:: if the glob changed, forget the old and fetch the new
|
|
::
|
|
=. charges (~(put by charges) desk.diff [docket %install ~])
|
|
=. by-base (~(put by by-base) base.href.docket desk.diff)
|
|
:_ state
|
|
[add-fact:cha fetch-glob:cha]
|
|
::
|
|
%suspend
|
|
?. (~(has by charges) desk.diff) `state
|
|
=/ glob=(unit glob)
|
|
=/ =chad
|
|
chad:(~(got by charges) desk.diff)
|
|
?:(?=(%glob -.chad) `glob.chad ~)
|
|
=. charges (new-chad:cha %suspend glob)
|
|
:_(state ~[add-fact:cha])
|
|
::
|
|
%revive
|
|
?. (~(has by charges) desk.diff) `state
|
|
=/ =charge (~(got by charges) desk.diff)
|
|
?. ?=(%glob -.href.docket.charge)
|
|
=. charges (new-chad:cha %site ~)
|
|
:_(state ~[add-fact:cha])
|
|
=. charges
|
|
%- new-chad:cha
|
|
?. ?=([%suspend ~ *] chad.charge)
|
|
[%install ~]
|
|
[%glob u.glob.chad.charge]
|
|
:_(state [add-fact fetch-glob]:cha)
|
|
==
|
|
==
|
|
++ take-charge
|
|
|= [=desk =^wire]
|
|
^- (quip card _state)
|
|
~| %took-for-nonexistent-charge
|
|
?> (~(has by charges) desk)
|
|
=* cha ~(. ch desk)
|
|
?+ wire ~|(%bad-charge-wire !!)
|
|
::
|
|
[%install ~]
|
|
?> ?=(%poke-ack -.sign)
|
|
?~ p.sign
|
|
`state
|
|
=. charges (new-chad:cha hung+'Failed install')
|
|
((slog leaf+"Failed installing %{(trip desk)}" u.p.sign) `state)
|
|
::
|
|
[%uninstall ~]
|
|
?> ?=(%poke-ack -.sign)
|
|
?~ p.sign `state
|
|
((slog leaf+"Failed to uninstall %{(trip desk)}" u.p.sign) `state)
|
|
::
|
|
[%glob-ames ~]
|
|
?- -.sign
|
|
%kick `state
|
|
%poke-ack ~&([dap.bowl %unexpected-poke-ack] `state)
|
|
::
|
|
%watch-ack
|
|
?~ p.sign `state
|
|
%- %- slog
|
|
leaf+"docket: failed to fetch glob over ames for {(trip desk)}"
|
|
::TODO maybe we want to retry, but with delay?
|
|
`state
|
|
::
|
|
%fact
|
|
?. =(%glob p.cage.sign)
|
|
~& [dap.bowl %unexpected-fact from=src.bowl p.cage.sign]
|
|
`state
|
|
=+ !<(=glob q.cage.sign)
|
|
=/ =docket docket:(~(got by charges) desk)
|
|
?. ?=([%glob * %ames *] href.docket)
|
|
`state
|
|
?. =(hash.glob-location.href.docket (hash-glob glob))
|
|
~& [dap.bowl %glob-hash-mismatch on=desk from=src.bowl]
|
|
`state
|
|
=. charges (new-chad:cha glob+glob)
|
|
=. by-base (~(put by by-base) base.href.docket desk)
|
|
[~[add-fact:cha] state]
|
|
==
|
|
::
|
|
[%glob-http ~]
|
|
?- -.sign
|
|
%kick `state
|
|
::
|
|
?(%poke-ack %watch-ack)
|
|
?~ p.sign `state
|
|
=/ act=tape ?:(?=(%poke-ack -.sign) "start" "listen")
|
|
=. charges (new-chad:cha hung+'glob-failed')
|
|
:- ~[add-fact:cha]
|
|
((slog leaf+"docket: couldn't {act} thread; will retry" u.p.sign) state)
|
|
::
|
|
%fact
|
|
?+ p.cage.sign `state
|
|
%thread-fail
|
|
=+ !<([=term =tang] q.cage.sign)
|
|
=. charges (new-chad:cha hung+'glob-failed')
|
|
:- ~[add-fact:cha]
|
|
((slog leaf+"docket: thread failed; will retry" leaf+<term> tang) state)
|
|
::
|
|
%thread-done
|
|
=+ !<(=glob q.cage.sign)
|
|
=/ =charge (~(got by charges) desk)
|
|
?> ?=(%glob -.href.docket.charge)
|
|
=. charges (new-chad:cha glob+glob)
|
|
=. by-base (~(put by by-base) base.href.docket.charge desk)
|
|
:_(state ~[add-fact:cha])
|
|
==
|
|
==
|
|
==
|
|
--
|
|
::
|
|
++ on-arvo
|
|
|= [=wire sign=sign-arvo]
|
|
=^ cards state
|
|
?+ wire (on-arvo:def wire sign)
|
|
[%init ~]
|
|
=* cha ~(. ch q.byk.bowl)
|
|
=. charges (~(put by charges) q.byk.bowl [docket:cha %install ~])
|
|
[fetch-glob:cha state]
|
|
::
|
|
[%eyre ~]
|
|
?> ?=([%eyre %bound *] sign)
|
|
?: accepted.sign `state
|
|
~& [dap.bowl %failed-to-bind path.binding.sign]
|
|
`state
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-fail on-fail:def
|
|
++ on-leave on-leave:def
|
|
--
|
|
|_ =bowl:gall
|
|
++ io ~(. agentio bowl)
|
|
++ pass pass:io
|
|
++ def ~(. (default-agent state %|) bowl)
|
|
::
|
|
++ hash-glob sham
|
|
::
|
|
++ handle-http-request
|
|
|= [eyre-id=@ta inbound-request:eyre]
|
|
^- (quip card _state)
|
|
::
|
|
=; [payload=simple-payload:http caz=(list card) =_state]
|
|
:_ state
|
|
%+ weld caz
|
|
(give-simple-payload:app eyre-id payload)
|
|
::
|
|
::NOTE we don't use +require-authorization-simple here because we want
|
|
:: to short-circuit all the below logic for the unauthenticated case.
|
|
?. authenticated
|
|
:_ [~ state]
|
|
=- [[307 ['location' -]~] ~]
|
|
(cat 3 '/~/login?redirect=' url.request)
|
|
::
|
|
=* headers header-list.request
|
|
=/ req-line (parse-request-line url.request)
|
|
::
|
|
|^ ?+ method.request [[405^~ ~] ~ state]
|
|
%'GET' [handle-get-request ~ state]
|
|
%'POST' handle-upload
|
|
==
|
|
::
|
|
++ handle-get-request
|
|
^- simple-payload:http
|
|
?+ [site ext]:req-line (redirect:gen '/apps/grid/')
|
|
[[%session ~] [~ %js]]
|
|
%- inline-js-response
|
|
(rap 3 'window.ship = "' (rsh 3 (scot %p our.bowl)) '";' ~)
|
|
::
|
|
[[%docket %upload ~] ?(~ [~ %html])]
|
|
[[200 ~] `(upload-page ~)]
|
|
::
|
|
[[%apps @ *] *]
|
|
%+ payload-from-glob
|
|
(snag 1 site.req-line)
|
|
req-line(site (slag 2 site.req-line))
|
|
==
|
|
::
|
|
++ upload-page
|
|
|= msg=(list @t)
|
|
^- octs
|
|
%- as-octt:mimes:html
|
|
%- en-xml:html
|
|
^- manx
|
|
:: desks: with local globs, eligible for upload
|
|
::
|
|
=/ desks=(list desk)
|
|
%+ murn ~(tap by charges)
|
|
|= [d=desk [docket *]]
|
|
^- (unit desk)
|
|
?:(?=(%glob -.href) `d ~)
|
|
::
|
|
;html
|
|
;head
|
|
;title:"%docket globulator"
|
|
;meta(charset "utf-8");
|
|
;style:'''
|
|
* { font-family: monospace; margin-top: 1em; }
|
|
li { margin-top: 0.5em; }
|
|
'''
|
|
==
|
|
;body
|
|
;h2:"%docket globulator"
|
|
;+ ?. =(~ msg)
|
|
:- [%p ~]
|
|
(join `manx`;br; (turn msg |=(m=@t `manx`:/"{(trip m)}")))
|
|
;ol(start "0")
|
|
;li:"""
|
|
make sure the desk you want to upload a glob for has a
|
|
desk.docket with %base and %glob- entries.
|
|
"""
|
|
;li:"select the desk you want to upload the glob for."
|
|
;li:"""
|
|
select a directory containing the glob contents.
|
|
usually contains at least an /index.html.
|
|
"""
|
|
;li:"glob!"
|
|
==
|
|
;+ ?: =(~ desks)
|
|
;p:"no desks eligible for glob upload"
|
|
;form(method "post", enctype "multipart/form-data")
|
|
;label
|
|
;+ :/"desk: "
|
|
;select(name "desk")
|
|
;* %+ turn desks
|
|
|=(d=desk =+((trip d) ;option(value -):"{-}"))
|
|
==
|
|
==
|
|
;br;
|
|
;label
|
|
;+ :/"data: "
|
|
;input
|
|
=type "file"
|
|
=name "glob"
|
|
=directory ""
|
|
=webkitdirectory ""
|
|
=mozdirectory "";
|
|
==
|
|
;br;
|
|
;button(type "submit"):"glob!"
|
|
==
|
|
==
|
|
==
|
|
::
|
|
++ handle-upload
|
|
^- [simple-payload:http (list card) _state]
|
|
?. ?=([[%docket %upload ~] ?(~ [~ %html])] [site ext]:req-line)
|
|
[[404^~ ~] [~ state]]
|
|
::
|
|
=; [desk=@ta =glob err=(list @t)]
|
|
=* cha ~(. ch desk)
|
|
=/ =charge (~(got by charges) desk)
|
|
::
|
|
=? err =(~ glob)
|
|
['no files in glob' err]
|
|
=? err !?=(%glob -.href.docket.charge)
|
|
['desk does not use glob' err]
|
|
::
|
|
?. =(~ err)
|
|
:_ [~ state]
|
|
[[400 ~] `(upload-page err)]
|
|
:- [[200 ~] `(upload-page 'successfully globbed' ~)]
|
|
?> ?=(%glob -.href.docket.charge)
|
|
::
|
|
=. charges (new-chad:cha glob+glob)
|
|
=. by-base
|
|
=- (~(put by by-base) - desk)
|
|
base.href.docket.charge
|
|
::
|
|
:_ state
|
|
::
|
|
=/ ours=?
|
|
=/ loc glob-location.href.docket.charge
|
|
?& ?=(%ames -.loc)
|
|
=(our.bowl ship.loc)
|
|
==
|
|
::
|
|
:* add-fact:cha
|
|
::
|
|
?. ours ~
|
|
^- (list card)
|
|
::TODO for some reason this doesn't give us a %commit fact?
|
|
=- [%pass /write/[desk] %arvo %c %info -]~
|
|
%+ foal:space:userlib
|
|
/(scot %p our.bowl)/[desk]/(scot %da now.bowl)/desk/docket
|
|
=- [%docket !>(`docket`-)]
|
|
docket.charge(glob-location.href [%ames our.bowl (hash-glob glob)])
|
|
==
|
|
::
|
|
?~ parts=(de-request:multipart [header-list body]:request)
|
|
~& headers=header-list.request
|
|
[*@ta *glob 'failed to parse submitted data' ~]
|
|
::
|
|
%+ roll u.parts
|
|
|= [[name=@t part:multipart] desk=@ta =glob err=(list @t)]
|
|
^+ [desk glob err]
|
|
?: =('desk' name)
|
|
:: must be a desk with existing charge
|
|
::
|
|
?. ((sane %ta) body)
|
|
[desk glob (cat 3 'invalid desk: ' body) err]
|
|
?. (~(has by charges) body)
|
|
[desk glob (cat 3 'unknown desk: ' body) err]
|
|
[body glob err]
|
|
:- desk
|
|
:: all submitted files must be complete
|
|
::
|
|
?. =('glob' name) [glob (cat 3 'weird part: ' name) err]
|
|
?~ file [glob 'file without filename' err]
|
|
?~ type [glob (cat 3 'file without type: ' u.file) err]
|
|
?^ code [glob (cat 3 'strange encoding: ' u.code) err]
|
|
=/ filp (rush u.file fip)
|
|
?~ filp [glob (cat 3 'strange filename: ' u.file) err]
|
|
:: ignore metadata files and other "junk"
|
|
::TODO consider expanding coverage
|
|
::
|
|
?: =('.DS_Store' (rear `path`u.filp))
|
|
[glob err]
|
|
:: make sure to exclude the top-level dir from the path
|
|
::
|
|
:_ err
|
|
%+ ~(put by glob) (slag 1 `path`u.filp)
|
|
[u.type (as-octs:mimes:html body)]
|
|
::
|
|
++ fip
|
|
=, de-purl:html
|
|
%+ cook
|
|
|=(pork (weld q (drop p)))
|
|
(cook deft (more fas smeg))
|
|
::
|
|
++ inline-js-response
|
|
|= js=cord
|
|
^- simple-payload:http
|
|
%. (as-octs:mimes:html js)
|
|
%* . js-response:gen
|
|
cache %.n
|
|
==
|
|
::
|
|
++ payload-from-glob
|
|
|= [from=@ta what=request-line]
|
|
^- simple-payload:http
|
|
=/ des=(unit desk)
|
|
(~(get by by-base) from)
|
|
?~ des not-found:gen
|
|
=/ cha=(unit charge)
|
|
(~(get by charges) u.des)
|
|
?~ cha not-found:gen
|
|
?. ?=(%glob -.chad.u.cha) not-found:gen
|
|
=* glob glob.chad.u.cha
|
|
=/ suffix=^path
|
|
(weld site.what (drop ext.what))
|
|
?: =(suffix /desk/js)
|
|
%- inline-js-response
|
|
(rap 3 'window.desk = "' u.des '";' ~)
|
|
=/ data=mime
|
|
(~(gut by glob) suffix (~(got by glob) /index/html))
|
|
=/ mime-type=@t (rsh 3 (crip <p.data>))
|
|
=; headers
|
|
[[200 headers] `q.data]
|
|
:~ content-type+mime-type
|
|
max-1-wk:gen
|
|
'service-worker-allowed'^'/'
|
|
==
|
|
--
|
|
::
|
|
++ get-light-charge
|
|
|= =charge
|
|
?. ?=(%glob -.chad.charge) charge
|
|
charge(glob.chad *glob)
|
|
:: +ch: Charge engine
|
|
++ ch
|
|
|_ =desk
|
|
++ pass |=(slug=term ~(. ^pass /charge/[desk]/[slug]))
|
|
++ add-fact
|
|
=/ =charge (~(got by charges) desk)
|
|
(fact:io charge-update+!>([%add-charge desk (get-light-charge charge)]) /charges ~)
|
|
++ del-fact (fact:io charge-update+!>([%del-charge desk]) /charges ~)
|
|
++ install
|
|
|= [=ship remote=^desk]
|
|
(poke-our:(pass %install) %hood kiln-install+!>([desk ship remote]))
|
|
++ uninstall
|
|
(poke-our:(pass %uninstall) %hood kiln-uninstall+!>(desk))
|
|
++ new-chad |=(c=chad (~(jab by charges) desk |=(charge +<(chad c))))
|
|
++ fetch-glob
|
|
^- (list card)
|
|
=/ =charge
|
|
~| desk/desk
|
|
(~(got by charges) desk)
|
|
=/ tid=@t (cat 3 'docket-' (scot %uv (sham (mix eny.bowl desk))))
|
|
?> ?=(%glob -.href.docket.charge)
|
|
=/ loc glob-location.href.docket.charge
|
|
?: ?=(%ames -.loc)
|
|
?: =(our.bowl ship.loc)
|
|
~> %slog.0^leaf/"docket: awaiting manual glob for {<desk>} desk"
|
|
~
|
|
:_ ~
|
|
%+ watch:(pass %glob-ames)
|
|
[ship.loc %docket]
|
|
/glob/[base.href.docket.charge]/(scot %uv hash.loc)
|
|
~> %slog.0^leaf/"docket: fetching glob for {<desk>} desk"
|
|
=/ =cage spider-start+!>([~ `tid byk.bowl(r da+now.bowl) %glob !>(`[loc desk])])
|
|
:~ (watch-our:(pass %glob-http) %spider /thread-result/[tid])
|
|
(poke-our:(pass %glob-http) %spider cage)
|
|
==
|
|
++ docket-exists .^(? %cu (scry:io desk /desk/docket))
|
|
++ docket .^(^docket %cx (scry:io desk /desk/docket))
|
|
--
|
|
--
|
|
|