shrub/pkg/garden/app/docket.hoon
Fang b41aaf8f10
docket: stop eating fresh globs and their hashes
When we uploaded a glob we hosted, we'd write a new docket to clay,
triggering a %commit.
The handling of this would:
- fail to update the docket in state,
- and discard our new glob, because the docket had changed.

Here we properly update the docket mirror in state, and make sure to
keep the glob around if its hash lines up.
2021-09-21 18:19:38 +02:00

632 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
:: always update the docket in state to match clay's
::
=/ =docket docket:cha
=/ pre=(unit charge) (~(get by charges) desk.diff)
=. charges (new-docket:cha docket)
:: if the new chad is a site, we're instantly done
::
?: ?=(%site -.href.docket)
:- ~[add-fact:cha]
=. charges (new-chad:cha %site ~)
state
::
=. by-base (~(put by by-base) base.href.docket desk.diff)
:: if the glob specification is unchanged, keep it
::
?: &(?=(^ pre) =(href.docket.u.pre `href.docket))
[~[add-fact:cha] state]
:: if the glob spec changed, but we already host it, keep it
:: (this is the "just locally uploaded" case)
::
?: ?& ?=(^ pre)
?=(%glob -.chad.u.pre)
::
.= [%ames our.bowl (sham glob.chad.u.pre)]
glob-location.href.docket
==
[~[add-fact:cha] state]
:: if the glob changed, forget the old and fetch the new
::
=. charges (new-chad:cha %install ~)
[[add-fact:cha fetch-glob:cha] state]
::
%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)
=- [%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-docket |=(d=^docket (~(jab by charges) desk |=(charge +<(docket d))))
++ 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"
~
~> %slog.0^leaf/"docket: fetching ames 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 http 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))
--
--