docket: manual merge of @Fang- web glob upload

This commit is contained in:
Ted Blackman 2021-09-06 22:37:13 +03:00
parent 18019b3eb4
commit 83be5162ed
2 changed files with 234 additions and 55 deletions

View File

@ -1,5 +1,5 @@
/- *docket, hood, treaty
/+ *server, agentio, default-agent, dbug, verb
/+ *server, agentio, default-agent, multipart, dbug, verb
|%
+$ card card:agent:gall
+$ state-0
@ -81,9 +81,7 @@
::
%handle-http-request
=+ !<([id=@ta req=inbound-request:eyre] vase)
:_ state
%+ give-simple-payload:app id
(handle-http-request:cc req)
(handle-http-request:cc id req)
==
[cards this]
::
@ -91,8 +89,9 @@
|= [=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 !!)
?: (~(has by charges) desk)
~| bad-install-desk/desk
!!
=. charges
(~(put by charges) desk docket.treaty %install ~)
=* cha ~(. ch desk)
@ -292,6 +291,147 @@
++ pass pass:io
++ def ~(. (default-agent state %|) bowl)
::
++ 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
;html
;head
;title:"%docket globulator"
;meta(charset "utf-8");
;style:'* { font-family: monospace; margin-top: 1em; }'
==
;body
;h2:"%docket globulator"
;+ ?. =(~ msg)
:- [%p ~]
(join `manx`;br; (turn msg |=(m=@t `manx`:/"{(trip m)}")))
;p:"ur on ur own kid, glhf" ::TODO instructions
;form(method "post", enctype "multipart/form-data")
::TODO could be dropdown
;input(type "text", name "desk", placeholder "desk");
;br;
;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 for glob' err]
=? err ?=(%glob -.href.docket.charge)
['desk does not use glob' err]
::
?. =(~ err)
:_ [~ state]
[[400 ~] `(upload-page err)]
:- [[200 ~] `(upload-page 'successfully globbed' ~)]
::
=. charges (new-chad:cha glob+glob)
=. by-base
=- (~(put by by-base) - desk)
?> ?=(%glob -.href.docket.charge)
base.href.docket.charge
[~[add-fact:cha] state]
::
?~ 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
@ -300,21 +440,11 @@
cache %.n
==
::
++ handle-http-request
|= =inbound-request:eyre
++ payload-from-glob
|= [from=@ta what=request-line]
^- simple-payload:http
%+ require-authorization-simple:app inbound-request
=* req request.inbound-request
=* headers header-list.req
=/ req-line (parse-request-line url.req)
?. =(method.req %'GET') not-found:gen
?: &(=(ext.req-line `%js) ?=([%session ~] site.req-line))
%- inline-js-response
(rap 3 'window.ship = "' (rsh 3 (scot %p our.bowl)) '";' ~)
?. ?=([%apps @ *] site.req-line)
(redirect:gen '/apps/grid/')
=/ des=(unit desk)
(~(get by by-base) i.t.site.req-line)
(~(get by by-base) from)
?~ des not-found:gen
=/ cha=(unit charge)
(~(get by charges) u.des)
@ -322,20 +452,20 @@
?. ?=(%glob -.chad.u.cha) not-found:gen
=* glob glob.chad.u.cha
=/ suffix=^path
(weld (slag 2 `^path`site.req-line) (drop ext.req-line))
(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
=; headers
[[200 headers] `q.data]
:~ content-type+mime-type
max-1-wk:gen
'service-worker-allowed'^'/'
==
[[200 headers] `q.data]
--
::
++ get-light-charge
|= =charge

View File

@ -0,0 +1,49 @@
:: multipart: multipart/form-data request decoding
::
|%
+$ part
$: file=(unit @t) :: filename
type=(unit mite) :: content-type
code=(unit @t) :: content-transfer-encoding
body=@t :: content
==
::
++ de-request
|= [=header-list:http body=(unit octs)]
^- (unit (list [@t part]))
?~ body ~
?~ cot=(get-header:http 'content-type' header-list) ~
?. =('multipart/form-data; boundary=' (end 3^30 u.cot)) ~
%+ rush q.u.body
(dep (rsh 3^30 u.cot))
::
++ dep
|= del=@t
|^
%+ knee *(list [@t part]) |. ~+
;~ pose (cold ~ (full tip)) :: end, or
;~ pfix dim nip :: section start
;~ plug ;~ plug :: containing:
(ifix [cof doq] nom) :: name
(punt (ifix [cup doq] nod)) :: filename
(punt ;~(pfix nip cut nab)) :: content-type
(punt ;~(pfix nip cue nom)) :: con-tra-encoding
(ifix [sip nip] nag) :: content
== ^$ == == ==
::
++ cof (jest 'Content-Disposition: form-data; name="')
++ cue (jest 'Content-Transfer-Encoding: ')
++ cup (jest '; filename="')
++ cut (jest 'Content-Type: ')
++ dim (jest (cat 3 '--' del))
++ nip (jest '\0d\0a')
++ nab (more fas urs:ab)
++ nag (dine ;~(less ;~(plug nip dim) next))
++ nod (dine ;~(less doq next))
++ nom (dine alp)
++ sip ;~(plug nip nip)
++ tip ;~(plug dim hep hep nip)
::
++ dine |*(r=rule (cook (cury rep 3) (star r)))
--
--