diff options
Diffstat (limited to 'arvo/eyre.hoon')
| -rw-r--r-- | arvo/eyre.hoon | 4712 |
1 files changed, 4712 insertions, 0 deletions
diff --git a/arvo/eyre.hoon b/arvo/eyre.hoon new file mode 100644 index 0000000..0abd1c3 --- /dev/null +++ b/arvo/eyre.hoon @@ -0,0 +1,4712 @@ +!: +:: lighter than eyre +:: +|= our=ship +=, eyre +:: internal data structures +:: +=> =~ +:: +:: internal data structures that won't go in zuse +:: +|% ++$ move + :: + $: :: duct: request identifier + :: + =duct + :: + :: + card=(wind note gift) + == +:: +note: private request from eyre to another vane +:: ++$ note + $% [%a $>(?(%plea %keen %yawn) task:ames)] + [%b $>(?(%rest %wait) task:behn)] + [%c $>(%warp task:clay)] + [%d $>(%flog task:dill)] + [%g $>(%deal task:gall)] + == +:: +sign: private response from another vane to eyre +:: ++$ sign + $% [%ames $>(?(%done %boon %lost %sage) gift:ames)] + [%behn $>(%wake gift:behn)] + [%gall gift:gall] + [%clay gift:clay] + == +-- +:: more structures +:: +|% +++ axle + $: :: date: date at which http-server's state was updated to this data structure + :: + date=%~2025.1.31 + :: server-state: state of inbound requests + :: + =server-state + == +:: +server-state: state relating to open inbound HTTP connections +:: ++$ server-state + $: :: bindings: actions to dispatch to when a binding matches + :: + :: Eyre is responsible for keeping its bindings sorted so that it + :: will trigger on the most specific binding first. Eyre should send + :: back an error response if an already bound binding exists. + :: + :: TODO: It would be nice if we had a path trie. We could decompose + :: the :binding into a (map (unit @t) (trie knot =action)). + :: + bindings=(list [=binding =duct =action]) + :: cache: mapping from url to versioned entry + :: + cache=(map url=@t [aeon=@ud val=(unit cache-entry)]) + :: cors-registry: state used and managed by the +cors core + :: + =cors-registry + :: connections: open http connections not fully complete + :: + connections=(map duct outstanding-connection) + :: auth: state managed by the +authentication core + :: + auth=authentication-state + :: channel-state: state managed by the +channel core + :: + =channel-state + :: domains: domain-names that resolve to us + :: + domains=(set turf) + :: http-config: our server configuration + :: + =http-config + :: ports: live servers + :: + ports=[insecure=@ud secure=(unit @ud)] + :: outgoing-duct: to unix + :: + outgoing-duct=duct + :: verb: verbosity + :: + verb=@ + :: check-session-timer: set to true for ships prior to ~2025.01.31, + :: who may have been affected by urbit/urbit#7103 + :: + check-session-timer=_| + == +:: channel-request: an action requested on a channel +:: ++$ channel-request + $% :: %ack: acknowledges that the client has received events up to :id + :: + [%ack event-id=@ud] + :: %poke: pokes an application, validating :noun against :mark + :: + [%poke request-id=@ud ship=@p app=term mark=@tas =noun] + :: %poke-json: pokes an application, translating :json to :mark + :: + [%poke-json request-id=@ud ship=@p app=term mark=@tas =json] + :: %watch: subscribes to an application path + :: + [%subscribe request-id=@ud ship=@p app=term =path] + :: %leave: unsubscribes from an application path + :: + [%unsubscribe request-id=@ud subscription-id=@ud] + :: %delete: kills a channel + :: + [%delete ~] + == +:: clog-timeout: the delay between acks after which clog-threshold kicks in +:: +++ clog-timeout ~s30 +:: clog-threshold: maximum per-subscription event buildup, after clog-timeout +:: +++ clog-threshold 50 +:: channel-timeout: the delay before a channel should be reaped +:: +++ channel-timeout ~h12 +:: session-timeout: the delay before an idle session expires +:: +++ session-timeout + |% + ++ auth ~d30 + ++ guest ~d7 + -- +:: eauth-timeout: max time we wait for remote scry response before serving 504 +:: eauth-cache-rounding: scry case rounding for cache hits & clock skew aid +:: +++ eauth-timeout ~s50 +++ eauth-cache-rounding ~m5 +-- +:: utilities +:: +|% +:: +combine-octs: combine multiple octs into one +:: +++ combine-octs + |= a=(list octs) + ^- octs + :- %+ roll a + |= [=octs sum=@ud] + (add sum p.octs) + (can 3 a) +:: +prune-events: removes all items from the front of the queue up to :id +:: +:: also produces, per request-id, the amount of events that have got acked, +:: for use with +subtract-acked-events. +:: +++ prune-events + =| acked=(map @ud @ud) + |= [q=(qeu [id=@ud @ud channel-event]) id=@ud] + ^+ [acked q] + :: if the queue is now empty, that's fine + :: + ?: =(~ q) + [acked ~] + :: + =/ next=[item=[id=@ud request-id=@ud channel-event] _q] ~(get to q) + :: if the head of the queue is newer than the acknowledged id, we're done + :: + ?: (gth id.item.next id) + [acked q] + :: otherwise, note the ack, and check next item + :: + %_ $ + q +:next + :: + acked + =, item.next + %+ ~(put by acked) request-id + +((~(gut by acked) request-id 0)) + == +:: +subtract-acked-events: update the subscription map's pending ack counts +:: +++ subtract-acked-events + |= [acked=(map @ud @ud) unacked=(map @ud @ud)] + ^+ unacked + %+ roll ~(tap by acked) + |= [[rid=@ud ack=@ud] unacked=_unacked] + ?~ sus=(~(get by unacked) rid) + unacked + %+ ~(put by unacked) rid + ?: (lte u.sus ack) 0 + (sub u.sus ack) +:: +find-channel-mode: deduce requested mode from headers +:: +++ find-channel-mode + |= [met=method:http hes=header-list:http] + ^- ?(%json %jam) + =+ ^- [hed=@t jam=@t] + ?: ?=(%'GET' met) ['x-channel-format' 'application/x-urb-jam'] + ['content-type' 'application/x-urb-jam'] + =+ typ=(bind (get-header:http hed hes) :(cork trip cass crip)) + ?:(=(`jam typ) %jam %json) +:: +parse-channel-request: parses a list of channel-requests +:: +++ parse-channel-request + |= [mode=?(%json %jam) body=octs] + ^- (each (list channel-request) @t) + ?- mode + %json + ?~ maybe-json=(de:json:html q.body) + |+'put body not json' + ?~ maybe-requests=(parse-channel-request-json u.maybe-json) + |+'invalid channel json' + &+u.maybe-requests + :: + %jam + ?~ maybe-noun=(bind (slaw %uw q.body) cue) + |+'invalid request format' + ?~ maybe-reqs=((soft (list channel-request)) u.maybe-noun) + ~& [%miss u.maybe-noun] + |+'invalid request data' + &+u.maybe-reqs + == +:: +parse-channel-request-json: parses a json list of channel-requests +:: +:: Parses a json array into a list of +channel-request. If any of the items +:: in the list fail to parse, the entire thing fails so we can 400 properly +:: to the client. +:: +++ parse-channel-request-json + |= request-list=json + ^- (unit (list channel-request)) + :: parse top + :: + =, dejs-soft:format + =- ((ar -) request-list) + :: + |= item=json + ^- (unit channel-request) + :: + ?~ maybe-key=((ot action+so ~) item) + ~ + ?: =('ack' u.maybe-key) + ((pe %ack (ot event-id+ni ~)) item) + ?: =('poke' u.maybe-key) + %. item + %+ pe %poke-json + (ot id+ni ship+(su fed:ag) app+so mark+(su sym) json+some ~) + ?: =('subscribe' u.maybe-key) + %. item + %+ pe %subscribe + (ot id+ni ship+(su fed:ag) app+so path+(su stap) ~) + ?: =('unsubscribe' u.maybe-key) + %. item + %+ pe %unsubscribe + (ot id+ni subscription+ni ~) + ?: =('delete' u.maybe-key) + `[%delete ~] + :: if we reached this, we have an invalid action key. fail parsing. + :: + ~ +:: +auth-styling: css for login and eauth pages +:: +++ auth-styling + ''' + @import url("https://rsms.me/inter/inter.css"); + @font-face { + font-family: "Source Code Pro"; + src: url("https://storage.googleapis.com/media.urbit.org/fonts/scp-regular.woff"); + font-weight: 400; + font-display: swap; + } + :root { + --red-soft: #FFEFEC; + --red: #FF6240; + --gray-100: #E5E5E5; + --gray-400: #999999; + --gray-800: #333333; + --white: #FFFFFF; + } + html { + font-family: Inter, sans-serif; + height: 100%; + margin: 0; + width: 100%; + background: var(--white); + color: var(--gray-800); + -webkit-font-smoothing: antialiased; + line-height: 1.5; + font-size: 16px; + font-weight: 600; + display: flex; + flex-flow: row nowrap; + justify-content: center; + } + body { + display: flex; + flex-flow: column nowrap; + justify-content: center; + max-width: 300px; + padding: 1rem; + width: 100%; + } + body.local #eauth, + body.eauth #local { + display: none; + min-height: 100%; + } + #eauth input { + /*NOTE dumb hack to get approx equal height with #local */ + margin-bottom: 15px; + } + body nav { + background: var(--gray-100); + border-radius: 2rem; + display: flex; + justify-content: space-around; + overflow: hidden; + margin-bottom: 1rem; + } + body nav div { + width: 50%; + padding: 0.5rem 1rem; + text-align: center; + cursor: pointer; + } + body.local nav div.local, + body.eauth nav div.eauth { + background: var(--gray-800); + color: var(--white); + cursor: default; + } + nav div.local { + border-right: none; + border-top-right-radius: 0; + border-bottom-right-radius: 0; + } + nav div.eauth { + border-left: none; + border-top-left-radius: 0; + border-bottom-left-radius: 0; + } + body > *, + form > input { + width: 100%; + } + form { + display: flex; + flex-flow: column; + align-items: flex-start; + } + input { + background: var(--gray-100); + border: 2px solid transparent; + padding: 0.5rem; + border-radius: 0.5rem; + font-size: inherit; + color: var(--gray-800); + box-shadow: none; + width: 100%; + } + input:disabled { + background: var(--gray-100); + color: var(--gray-400); + } + input:focus { + outline: none; + background: var(--white); + border-color: var(--gray-400); + } + input:invalid:not(:focus) { + background: var(--red-soft); + border-color: var(--red); + outline: none; + color: var(--red); + } + button[type=submit] { + margin-top: 1rem; + } + button[type=submit], a.button { + font-size: 1rem; + padding: 0.5rem 1rem; + border-radius: 0.5rem; + background: var(--gray-800); + color: var(--white); + border: none; + font-weight: 600; + text-decoration: none; + } + input:invalid ~ button[type=submit] { + border-color: currentColor; + background: var(--gray-100); + color: var(--gray-400); + pointer-events: none; + } + span.guest, span.guest a { + color: var(--gray-400); + } + span.failed { + display: flex; + flex-flow: row nowrap; + height: 1rem; + align-items: center; + margin-top: 0.875rem; + color: var(--red); + } + span.failed svg { + height: 1rem; + margin-right: 0.25rem; + } + span.failed path { + fill: transparent; + stroke-width: 2px; + stroke-linecap: round; + stroke: currentColor; + } + .mono { + font-family: 'Source Code Pro', monospace; + } + @media all and (prefers-color-scheme: dark) { + :root { + --white: #000000; + --gray-800: #E5E5E5; + --gray-400: #808080; + --gray-100: #333333; + --red-soft: #7F1D1D; + } + } + @media screen and (min-width: 30em) { + html { + font-size: 14px; + } + } + ''' +:: +login-page: internal page to login to an Urbit +:: +++ login-page + |= [redirect-url=(unit @t) our=@p =identity eauth=(unit ?) failed=?] + ^- octs + =+ redirect-str=?~(redirect-url "" (trip u.redirect-url)) + %- as-octs:mimes:html + %- crip + %- en-xml:html + =/ favicon %+ + weld "<svg width='10' height='10' viewBox='0 0 10 10' xmlns='http://www.w3.org/2000/svg'>" + "<circle r='3.09' cx='5' cy='5' /></svg>" + ;html + ;head + ;meta(charset "utf-8"); + ;meta(name "viewport", content "width=device-width, initial-scale=1, shrink-to-fit=no"); + ;link(rel "icon", type "image/svg+xml", href (weld "data:image/svg+xml;utf8," favicon)); + ;title:"Urbit" + ;style:"{(trip auth-styling)}" + ;style:"{?^(eauth "" "nav \{ display: none; }")}" + ;script:"our = '{(scow %p our)}';" + ;script:''' + let name, pass; + function setup(isEauth) { + name = document.getElementById('name'); + pass = document.getElementById('pass'); + if (isEauth) goEauth(); else goLocal(); + } + function goLocal() { + document.body.className = 'local'; + pass.focus(); + } + function goEauth() { + document.body.className = 'eauth'; + name.focus(); + } + function doEauth() { + if (name.value == our) { + event.preventDefault(); + goLocal(); + } + } + ''' + == + ;body + =class "{?:(=(`& eauth) "eauth" "local")}" + =onload "setup({?:(=(`& eauth) "true" "false")})" + ;div#local + ;p:"Urbit ID" + ;input(value "{(scow %p our)}", disabled "true", class "mono"); + ;+ ?: =(%ours -.identity) + ;div + ;p:"Already authenticated" + ;a.button/"{(trip (fall redirect-url '/'))}":"Continue" + == + ;form(action "/~/login", method "post", enctype "application/x-www-form-urlencoded") + ;p:"Access Key" + ;input + =type "password" + =name "password" + =id "pass" + =placeholder "sampel-ticlyt-migfun-falmel" + =class "mono" + =required "true" + =minlength "27" + =maxlength "27" + =pattern "((?:[a-z]\{6}-)\{3}(?:[a-z]\{6}))"; + ;input(type "hidden", name "redirect", value redirect-str); + ;+ ?. failed ;span; + ;span.failed + ;svg(xmlns "http://www.w3.org/2000/svg", viewBox "0 0 16 16") + ;path(d "m8 8 4-4M8 8 4 4m4 4-4 4m4-4 4 4"); + == + Key is incorrect + == + ;button(type "submit"):"Continue" + == + == + ;div#eauth + ;form(action "/~/login", method "post", onsubmit "return doEauth()") + ;p:"Urbit ID" + ;input.mono + =name "name" + =id "name" + =placeholder "{(scow %p our)}" + =required "true" + =minlength "4" + =maxlength "57" + =pattern "~((([a-z]\{6})\{1,2}-\{0,2})+|[a-z]\{3})"; + ;p + ; You will be redirected to your own web interface to authorize + ; logging in to + ;span.mono:"{(scow %p our)}" + ; . + == + ;input(type "hidden", name "redirect", value redirect-str); + ;button(name "eauth", type "submit"):"Continue" + == + == + ;* ?: ?=(%ours -.identity) ~ + =+ as="proceed as{?:(?=(%fake -.identity) " guest" "")}" + ;+ ;span.guest.mono + ; Or try to + ;a/"{(trip (fall redirect-url '/'))}":"{as}" + ; . + == + == + ;script:''' + var failSpan = document.querySelector('.failed'); + if (failSpan) { + document.querySelector("input[type=password]") + .addEventListener('keyup', function (event) { + failSpan.style.display = 'none'; + }); + } + ''' + == +:: +eauth-error-page: render an eauth error reporting page +:: +:: optionally redirects the user back to either the login page if we're +:: acting as server, or the host if we're the client. +:: +++ eauth-error-page + |= $= return + $? ~ :: no known return target + [%server last=@t] :: we are the host, return to login + [%client goal=@t] :: we are the client, return to host + == + ^- octs + %- as-octs:mimes:html + %- crip + %- en-xml:html + =/ return=(unit @t) + ?- return + ~ ~ + [%server *] %- some + %^ cat 3 '/~/login?eauth&redirect=' + (crip (en-urlt:html (trip last.return))) + [%client *] `goal.return ::TODO plus nonce? or abort? + == + =/ favicon %+ + weld "<svg width='10' height='10' viewBox='0 0 10 10' xmlns='http://www.w3.org/2000/svg'>" + "<circle r='3.09' cx='5' cy='5' /></svg>" + =/ msg=tape + ?~ return "Something went wrong!" + "Something went wrong! You will be redirected back..." + ;html + ;head + ;* ?~ return ~ + :_ ~ + ;meta(http-equiv "Refresh", content "5; url={(trip u.return)}"); + ;meta(charset "utf-8"); + ;meta(name "viewport", content "width=device-width, initial-scale=1, shrink-to-fit=no"); + ;link(rel "icon", type "image/svg+xml", href (weld "data:image/svg+xml;utf8," favicon)); + ;title:"Urbit" + ;style:''' + @import url("https://rsms.me/inter/inter.css"); + :root { + --black60: rgba(0,0,0,0.6); + --white: rgba(255,255,255,1); + } + html { + font-family: Inter, sans-serif; + height: 100%; + margin: 0; + width: 100%; + background: var(--white); + color: var(--black60); + -webkit-font-smoothing: antialiased; + line-height: 1.5; + font-size: 12px; + display: flex; + flex-flow: row nowrap; + justify-content: center; + } + body { + display: flex; + flex-flow: column nowrap; + justify-content: center; + max-width: 300px; + padding: 1rem; + width: 100%; + } + ''' + == + ;body:"{msg}" + == +:: +render-tang-to-marl: renders a tang and adds <br/> tags between each line +:: +++ render-tang-to-marl + |= [wid=@u tan=tang] + ^- marl + =/ raw=(list tape) (zing (turn tan |=(a=tank (wash 0^wid a)))) + :: + |- ^- marl + ?~ raw ~ + [;/(i.raw) ;br; $(raw t.raw)] +:: +render-tang-to-wall: renders tang as text lines +:: +++ render-tang-to-wall + |= [wid=@u tan=tang] + ^- wall + (zing (turn tan |=(a=tank (wash 0^wid a)))) +:: +wall-to-octs: text to binary output +:: +++ wall-to-octs + |= =wall + ^- (unit octs) + :: + ?: =(~ wall) + ~ + :: + :- ~ + %- as-octs:mimes:html + %- crip + %- zing ^- ^wall + %- zing ^- (list ^wall) + %+ turn wall + |= t=tape + ^- ^wall + ~[t "\0a"] +:: +internal-server-error: 500 page, with a tang +:: +++ internal-server-error + |= [authorized=? url=@t t=tang] + ^- octs + %- as-octs:mimes:html + %- crip + %- en-xml:html + ;html + ;head + ;title:"500 Internal Server Error" + == + ;body + ;h1:"Internal Server Error" + ;p:"There was an error while handling the request for {(trip url)}." + ;* ?: authorized + ;= + ;code:"*{(render-tang-to-marl 80 t)}" + == + ~ + == + == +:: +error-page: error page, with an error string if logged in +:: +++ error-page + |= [code=@ud authorized=? url=@t t=tape] + ^- octs + =/ message=tape + ?+ code "{(scow %ud code)} Error" + %400 "Bad Request" + %403 "Forbidden" + %404 "Not Found" + %405 "Method Not Allowed" + %500 "Internal Server Error" + == + :: + %- as-octs:mimes:html + %- crip + %- en-xml:html + ;html + ;head + ;title:"{(a-co:co code)} {message}" + == + ;body + ;h1:"{message}" + ;p:"There was an error while handling the request for {(trip url)}." + ;* ?: authorized + ;= + ;code:"{t}" + == + ~ + == + == +:: +host-matches: %.y if the site :binding should be used to handle :host +:: +++ host-matches + |= [binding=(unit @t) host=(unit @t)] + ^- ? + :: if the binding allows for matching anything, match + :: + ?~ binding + %.y + :: if the host is ~, that means we're trying to bind nothing to a real + :: binding. fail. + :: + ?~ host + %.n + :: otherwise, do a straight comparison + :: + =(u.binding u.host) +:: +find-suffix: returns [~ /tail] if :full is (weld :prefix /tail) +:: +++ find-suffix + |= [prefix=path full=path] + ^- (unit path) + ?~ prefix + `full + ?~ full + ~ + ?. =(i.prefix i.full) + ~ + $(prefix t.prefix, full t.full) +:: +simplified-url-parser: returns [(each @if @t) (unit port=@ud)] +:: +++ simplified-url-parser + ;~ plug + ;~ pose + %+ stag %ip + =+ tod=(ape:ag ted:ab) + %+ bass 256 + ;~(plug tod (stun [3 3] ;~(pfix dot tod))) + :: + (stag %site (cook crip (star ;~(pose dot alp)))) + == + ;~ pose + (stag ~ ;~(pfix col dim:ag)) + (easy ~) + == + == +:: +host-sans-port: strip the :<port> from a host string +:: +++ host-sans-port + ;~ sfix + %+ cook crip + %- star + ;~ less + ;~(plug col (punt dem) ;~(less next (easy ~))) + next + == + (star next) + == +:: +per-server-event: per-event server core +:: +++ per-server-event + ~% %eyre-per-server-event ..part ~ + :: gate that produces the +per-server-event core from event information + :: + |= [[eny=@ =duct now=@da rof=roof] state=server-state] + =/ eyre-id (scot %ta (cat 3 'eyre_' (scot %uv (sham duct)))) + |% + :: +request-local: bypass authentication for local lens connections + :: + ++ request-local + |= [secure=? =address =request:http] + ^- [(list move) server-state] + :: + =/ act [%app app=%lens] + :: + =/ connection=outstanding-connection + [act [& secure address request] [*@uv [%ours ~]] ~ 0] + :: + =. connections.state + %. (~(put by connections.state) duct connection) + (trace 2 |.("{<duct>} creating local")) + :: + (request-to-app [%ours ~] app.act inbound-request.connection) + :: +request: starts handling an inbound http request + :: + ++ request + |= [secure=? =address =request:http] + ^- [(list move) server-state] + =* headers header-list.request + :: for requests from localhost, respect the "forwarded" header + :: + =/ [secure=? host=(unit @t) =^address] + =/ host=(unit @t) (get-header:http 'host' headers) + =* same [secure host address] + ?. =([%ipv4 .127.0.0.1] address) same + ?~ forwards=(forwarded-params headers) same + :+ (fall (forwarded-secure u.forwards) secure) + (clap (forwarded-host u.forwards) host head) + (fall (forwarded-for u.forwards) address) + :: + =/ [=action suburl=@t] + (get-action-for-binding host url.request) + :: + ::TODO we might want to mint new identities only for requests that end + :: up going into userspace, not the ones that get handled by eyre. + :: perhaps that distinction, where userspace requests are async, but + :: eyre-handled requests are always synchronous, provides a fruitful + :: angle for refactoring... + =^ ?(invalid=@uv [suv=@uv =identity som=(list move)]) state + (session-for-request:authentication request) + ?@ - + :: the request provided a session cookie that's not (or no longer) + :: valid. to make sure they're aware, tell them 401 + :: + ::NOTE some code duplication with below, but request handling deserves + :: a refactor anyway + =. connections.state + ::NOTE required by +handle-response. + :: the session identity we provide here doesn't actually exist. + :: that's fine: we call +handle-response for this connection right + :: away, that no-ops for the non-existing session, and then + :: deletes the connection from state. + %+ ~(put by connections.state) duct + ^- outstanding-connection + [action [| secure address request] [invalid %fake *@p] ~ 0] + :: their cookie was invalid, make sure they expire it + :: + =/ bod=octs (as-octs:mimes:html 'bad session auth') + %- handle-response + :* %start + :- 401 + :~ ['set-cookie' (session-cookie-string:authentication invalid ~)] + ['content-length' (crip (a-co:co p.bod))] + == + `bod + complete=%.y + == + =; [moz=(list move) sat=server-state] + [(weld som moz) sat] + :: + =/ authenticated ?=(%ours -.identity) + :: if we have no eauth endpoint yet, and the request is authenticated, + :: deduce it from the hostname + :: + =? endpoint.auth.state + ?& authenticated + ?=(^ host) + ?=(~ auth.endpoint.auth.state) + == + %- (trace 2 |.("eauth: storing endpoint at {(trip u.host)}")) + :+ user.endpoint.auth.state + `(cat 3 ?:(secure 'https://' 'http://') u.host) + now + :: record that we started an asynchronous response + :: + =/ connection=outstanding-connection + [action [authenticated secure address request] [suv identity] ~ 0] + =. connections.state + :: NB: required by +handle-response and +handle-request:authentication. + :: XX optimize, not all requests are asynchronous + :: + (~(put by connections.state) duct connection) + :: redirect to https if insecure, redirects enabled + :: and secure port live + :: + ?: ?& !secure + redirect.http-config.state + ?=(^ secure.ports.state) + == + =/ location=@t + %+ rap 3 + :~ 'https://' + (rash (fall host '') host-sans-port) + ?: =(443 u.secure.ports.state) + '' + (crip ":{(a-co:co u.secure.ports.state)}") + ?: ?=([[~ ~] ~] (parse-request-line url.request)) + '/' + url.request + == + %- handle-response + :* %start + :- status-code=301 + headers=['location' location]~ + data=~ + complete=%.y + == + :: figure out whether this is a cors request, + :: whether the origin is approved or not, + :: and maybe add it to the "pending approval" set + :: + =/ origin=(unit origin) + (get-header:http 'origin' headers) + =^ cors-approved requests.cors-registry.state + =, cors-registry.state + ?~ origin [| requests] + ?: (~(has in approved) u.origin) [& requests] + ?: (~(has in rejected) u.origin) [| requests] + [| (~(put in requests) u.origin)] + :: if this is a cors preflight request from an approved origin + :: handle it synchronously + :: + ?: &(?=(^ origin) cors-approved ?=(%'OPTIONS' method.request)) + %- handle-response + =; =header-list:http + [%start [204 header-list] ~ &] + :: allow the method and headers that were asked for, + :: falling back to wildcard if none specified + :: + ::NOTE +handle-response will add the rest of the headers + :: + :~ :- 'Access-Control-Allow-Methods' + =- (fall - '*') + (get-header:http 'access-control-request-method' headers) + :: + :- 'Access-Control-Allow-Headers' + =- (fall - '*') + (get-header:http 'access-control-request-headers' headers) + == + :: handle HTTP scries + :: + :: TODO: ideally this would look more like: + :: + :: ?^ p=(parse-http-scry url.request) + :: (handle-http-scry authenticated p request) + :: + ?: =('/_~_/' (end [3 5] url.request)) + (handle-http-scry authenticated request) + :: handle requests to the cache, if a non-empty entry exists + :: + =/ cached=(unit [aeon=@ud val=(unit cache-entry)]) + (~(get by cache.state) url.request) + ?: &(?=([~ @ ^] cached) ?=(%'GET' method.request)) + (handle-cache-req authenticated request u.val.u.cached) + :: + ~& >> eyre-request-action=-.action + ?- -.action + %gen + =/ bek=beak [our desk.generator.action da+now] + =/ sup=spur path.generator.action + =/ ski (rof [~ ~] /eyre %ca bek sup) + =/ cag=cage (need (need ski)) + ?> =(%vase p.cag) + =/ gat=vase !<(vase q.cag) + =/ res=toon + %- mock :_ (look rof [~ ~] /eyre) + :_ [%9 2 %0 1] |. + %+ slam + %+ slam gat + !>([[now=now eny=eny bek=bek] ~ ~]) + ::TODO should get passed the requester's identity + !>([authenticated request]) + ?: ?=(%2 -.res) + =+ connection=(~(got by connections.state) duct) + %^ return-static-data-on-duct 500 'text/html' + %: internal-server-error + authenticated.inbound-request.connection + url.request.inbound-request.connection + leaf+"generator crashed" + p.res + == + ?: ?=(%1 -.res) + =+ connection=(~(got by connections.state) duct) + %^ return-static-data-on-duct 500 'text/html' + %: internal-server-error + authenticated.inbound-request.connection + url.request.inbound-request.connection + leaf+"scry blocked on" + (fall (bind (bind ((soft path) p.res) smyt) (late ~)) ~) + == + =/ result ;;(simple-payload:http +.p.res) + :: ensure we have a valid content-length header + :: + :: We pass on the response and the headers the generator produces, but + :: ensure that we have a single content-length header set correctly in + :: the returned if this has a body, and has no content-length if there + :: is no body returned to the client. + :: + =. headers.response-header.result + ?~ data.result + (delete-header:http 'content-length' headers.response-header.result) + :: + %^ set-header:http 'content-length' + (crip (a-co:co p.u.data.result)) + headers.response-header.result + :: + %- handle-response + ^- http-event:http + :* %start + response-header.result + data.result + complete=%.y + == + :: + %app + (request-to-app identity app.action inbound-request.connection) + :: + %authentication + (handle-request:authentication secure host address [suv identity] request) + :: + %eauth + (on-request:eauth:authentication [suv identity] request) + :: + %logout + (handle-logout:authentication [suv identity] request) + :: + %channel + (handle-request:by-channel [suv identity] address request) + :: + %scry + (handle-scry authenticated address request(url suburl)) + :: + %name + (handle-name identity request) + :: + %host + %^ return-static-data-on-duct 200 'text/plain' + (as-octs:mimes:html (scot %p our)) + :: + %ip + (handle-ip address request) + %boot + (handle-boot identity request) + :: + %sponsor + (handle-sponsor identity request) + :: + %four-oh-four + %^ return-static-data-on-duct 404 'text/html' + (error-page 404 authenticated url.request ~) + == + ++ ws-event + |= [wid=@ event=websocket-event] + =/ conn (~(get by connections.state) duct) + ?~ conn `state + ?. ?=(%app -.action.u.conn) `state + =/ app app.action.u.conn + ~& ws-event=[wid app] + =/ identity [%ours ~] + =/ wsid (scot %p wid) + :: TODO damn how + ?+ -.event `state + %message + :_ state + :~ %+ deal-as + /run-ws-app-request/(scot %uw (cut 3 [2 4] eny)) + :^ identity our app + :+ %poke %websocket-server-message + !>([wid message.event]) + == + %disconnect + =. connections.state (~(del by connections.state) duct) + :_ state + :~ %+ deal-as + /ws-watch-response/[wsid] + [identity our app %leave ~] + == + == + ++ ws-handshake + |= [wid=@ secure=? =address:eyre =request:http] + ^- [(list move) server-state] + ~& >>> sending-ws-handshake=[wid eyre-id] + + =/ host=(unit @t) (get-header:http 'host' header-list.request) + =/ [=action suburl=@t] + (get-action-for-binding host url.request) + :: TODO enable other actions + ?> ?=(%app -.action) + + :: TODO!! get clear what all the identity thing has to be + =/ =identity [%ours ~] + =/ app app.action + =^ ?(invalid=@uv [suv=@uv fi=^identity som=(list move)]) state + (session-for-request:authentication request) + =/ connection=outstanding-connection + ?@ - ~& invalid-session=- + [action [.n secure address request] [invalid identity] ~ 0] + [action [.n secure address request] [suv identity] ~ 0] + + + =. connections.state + (~(put by connections.state) duct connection) + :: eyre-id is assigned way up in this arm + =/ wsid (scot %ud wid) + :_ state + :~ %+ deal-as + /ws-watch-response/[wsid] + [identity our app %watch /websocket-server/[wsid]] + :: + %+ deal-as + /run-ws-app-request/[wsid] + :^ identity our app + :+ %poke %websocket-handshake + !>(`[@ inbound-request:eyre]`[wid inbound-request.connection]) + == + + :: +handle-ip: respond with the requester's ip + :: + ++ handle-ip + |= [=address =request:http] + ^- (quip move server-state) + ?. =(%'GET' method.request) + %^ return-static-data-on-duct 405 'text/html' + (error-page 405 & url.request "may only GET ip") + %^ return-static-data-on-duct 200 'text/plain' + =/ ip=@t + ?- address + [%ipv4 *] + (crip (tail ~(rend co [%$ %if +.address]))) + :: + [%ipv6 *] + %- crip + %+ scan ~(rend co [%$ %is +.address]) + ;~(pfix dot (star ;~(pose (cold ':' dot) next))) + == + (as-octs:mimes:html ip) + :: Get current sponsor of ship + :: + ++ galaxy-for + |= =ship + ^- @p + =/ next (^^sein:title rof /eyre our now ship) + ?: ?=(%czar (clan:title next)) + next + $(ship next) + :: + ++ handle-sponsor + |= [=identity =request:http] + ^- (quip move server-state) + =/ crumbs q:(rash url.request apat:de-purl:html) + ?. ?=([@t @t @t ~] crumbs) + %^ return-static-data-on-duct 400 'text/html' + %: error-page + 400 + & + url.request + "Invalid input: Expected /~/boot/<ship=@p>" + == + =/ ship + %+ slaw + %p + i.t.t.crumbs + ?~ ship + %^ return-static-data-on-duct 400 'text/html' + %: error-page + 400 + & + url.request + "Invalid input: Expected /~/boot/<ship=@p>" + == + %^ return-static-data-on-duct 200 'text/plain' + (as-octs:mimes:html (scot %p (galaxy-for u.ship))) + :: Returns peer-state data for verifying sync status between ship and network. + :: Takes two path parameters - ship=@p and optional bone=@u. + :: + :: Responds with a @uw jam of a noun containing: + :: version, sponsor, rift, life, bone as a unit (null if not provided), and + :: the last-acked message-num of the provided ship and bone as a unit (null if + :: bone is not provided). + :: + :: Responds with a 404 error-page if either: + :: - Peer is not %known + :: - Bone was not found under peer (assuming bone was provided) + :: + ++ handle-boot + |= [=identity =request:http] + ^- (quip move server-state) + ?. =(%'GET' method.request) + %^ return-static-data-on-duct 405 'text/html' + (error-page 405 & url.request "may only GET boot data") + =/ crumbs q:(rash url.request apat:de-purl:html) + => .(crumbs `(pole knot)`crumbs) + ?. ?=([%'~' %boot ship=@t req=*] crumbs) + %^ return-static-data-on-duct 400 'text/html' + %: error-page + 400 + & + url.request + "Invalid input: Expected /~/boot/<ship=@p> or /~/boot/<ship=@p>/<bone=@u>" + == + =/ ship=(unit ship) (slaw %p ship.crumbs) + =/ bone=(unit @ud) + ?. ?=([bone=@t ~] req.crumbs) ~ + (rush bone.req.crumbs dem) + ?: ?| ?=(~ ship) + &(?=([bone=@ ~] req.crumbs) ?=(~ bone)) + == + %^ return-static-data-on-duct 400 'text/html' + %: error-page + 400 + & + url.request + "Invalid input: Expected /~/boot/<ship=@p> or /~/boot/<ship=@p>/<bone=@u>" + == + :: + =/ des=(unit (unit cage)) + %: rof + [~ ~] + /eyre + %ax + [our %$ da+now] + :+ %boot (scot %p u.ship) + ?~(bone ~ [(scot %ud u.bone) ~]) :: XX + == + ?. ?=([~ ~ %noun *] des) + %^ return-static-data-on-duct 404 'text/html' + (error-page 404 & url.request "Peer {(scow %p u.ship)} not found.") + =+ !< [rift=@ud life=@ud bone=(unit @ud) last-acked=(unit @ud)] q.u.u.des + %^ return-static-data-on-duct 200 'application/octet-stream' + %- as-octs:mimes:html + %- jam + ^- boot + [%1 (galaxy-for u.ship) rift life bone last-acked] + :: +handle-name: respond with the requester's @p + :: + ++ handle-name + |= [=identity =request:http] + ^- (quip move server-state) + ?. =(%'GET' method.request) + %^ return-static-data-on-duct 405 'text/html' + (error-page 405 & url.request "may only GET name") + %^ return-static-data-on-duct 200 'text/plain' + =/ nom=@p + ?+(-.identity who.identity %ours our) + (as-octs:mimes:html (scot %p nom)) + :: +handle-http-scry: respond with scry result + :: + ++ handle-http-scry + |= [authenticated=? =request:http] + |^ ^- (quip move server-state) + ?. authenticated (error-response 403 ~) + ?. =(%'GET' method.request) + (error-response 405 "may only GET scries") + =/ req (parse-request-line url.request) + =/ fqp (fully-qualified site.req) + =/ mym (scry-mime now rof [~ ~] ext.req site.req) + ?: ?=(%| -.mym) (error-response 500 p.mym) + =* mime p.mym + %- handle-response + :* %start + :- status-code=200 + ^= headers + :~ ['content-type' (rsh 3 (spat p.mime))] + ['content-length' (crip (a-co:co p.q.mime))] + ['cache-control' ?:(fqp 'max-age=31536000' 'no-cache')] + == + data=[~ q.mime] + complete=%.y + == + :: + ++ fully-qualified + |= a=path + ^- ? + ?. ?=([%'_~_' @ @ @ *] a) %.n + =/ vez (vang | (en-beam [our %base da+now] ~)) + ?= [~ [^ ^ ^ *]] (rush (spat t.t.a) ;~(pfix fas gash:vez)) + :: + ++ error-response + |= [status=@ud =tape] + ^- (quip move server-state) + %^ return-static-data-on-duct status 'text/html' + (error-page status authenticated url.request tape) + -- + :: +handle-cache-req: respond with cached value, 404 or 500 + :: + ++ handle-cache-req + |= [authenticated=? =request:http entry=cache-entry] + |^ ^- (quip move server-state) + ?: &(auth.entry !authenticated) + (error-response 403 ~) + =* body body.entry + ?- -.body + %payload + %- handle-response + :* %start + response-header.simple-payload.body + data.simple-payload.body + complete=%.y + == + == + :: + ++ error-response + |= [status=@ud =tape] + ^- (quip move server-state) + %^ return-static-data-on-duct status 'text/html' + (error-page status authenticated url.request tape) + -- + :: +handle-scry: respond with scry result, 404 or 500 + :: + ++ handle-scry + |= [authenticated=? =address =request:http] + |^ ^- (quip move server-state) + ?. authenticated + (error-response 403 ~) + ?. =(%'GET' method.request) + (error-response 405 "may only GET scries") + :: make sure the path contains an app to scry into + :: + =+ req=(parse-request-line url.request) + ?. ?=(^ site.req) + (error-response 400 "scry path must start with app name") + :: attempt the scry that was asked for + :: + =/ res=(unit (unit cage)) + (do-scry %gx i.site.req (snoc t.site.req (fall ext.req %mime))) + ?~ res (error-response 500 "failed scry") + ?~ u.res (error-response 404 "no scry result") + =* mark p.u.u.res + =* vase q.u.u.res + ?: =(%mime mark) + =/ =mime !<(mime vase) + %^ return-static-data-on-duct 200 + (rsh 3 (spat p.mime)) q.mime + :: attempt to find conversion gate to mime + :: + =/ tub=(unit [tub=tube:clay mov=move]) + (find-tube i.site.req mark %mime) + ?~ tub (error-response 500 "no tube from {(trip mark)} to mime") + :: attempt conversion, then send results + :: + =/ mym=(each mime tang) + (mule |.(!<(mime (tub.u.tub vase)))) + =^ cards state + ?- -.mym + %| (error-response 500 "failed tube from {(trip mark)} to mime") + %& %+ return-static-data-on-duct 200 + [(rsh 3 (spat p.p.mym)) q.p.mym] + == + [[mov.u.tub cards] state] + :: + ++ find-tube + |= [dap=term from=mark to=mark] + ^- (unit [tube:clay move]) + =/ des=(unit (unit cage)) + (do-scry %gd dap /$) + ?. ?=([~ ~ *] des) ~ + =+ !<(=desk q.u.u.des) + =/ tub=(unit (unit cage)) + (do-scry %cc desk /[from]/[to]) + ?. ?=([~ ~ %tube *] tub) ~ + :- ~ + :- !<(tube:clay q.u.u.tub) + :^ duct %pass /conversion-cache/[from] + [%c %warp our desk `[%sing %c da+now /[from]/[to]]] + :: + ++ do-scry + |= [care=term =desk =path] + ^- (unit (unit cage)) + (rof [~ ~] /eyre care [our desk da+now] path) + :: + ++ error-response + |= [status=@ud =tape] + ^- (quip move server-state) + %^ return-static-data-on-duct status 'text/html' + (error-page status authenticated url.request tape) + -- + :: +request-to-app: subscribe to app and poke it with request data + :: + ++ request-to-app + |= [=identity app=term =inbound-request:eyre] + ^- (quip move server-state) + :: if the agent isn't running, we synchronously serve a 503 + :: + ?. !<(? q:(need (need (rof [~ ~] /eyre %gu [our app da+now] /$)))) + %^ return-static-data-on-duct 503 'text/html' + %: error-page + 503 + ?=(%ours -.identity) + url.request.inbound-request + "%{(trip app)} not running" + == + :: otherwise, subscribe to the agent and poke it with the request + :: + :_ state + :~ %+ deal-as + /watch-response/[eyre-id] + [identity our app %watch /http-response/[eyre-id]] + :: + %+ deal-as + /run-app-request/[eyre-id] + :^ identity our app + :+ %poke %handle-http-request + !>(`[@ta inbound-request:eyre]`[eyre-id inbound-request]) + == + :: +cancel-request: handles a request being externally aborted + :: + ++ cancel-request + ^- [(list move) server-state] + :: + ?~ connection=(~(get by connections.state) duct) + :: nothing has handled this connection + :: + [~ state] + :: + =. connections.state (~(del by connections.state) duct) + :: + ?- -.action.u.connection + %gen [~ state] + %app + :_ state + :_ ~ + =, u.connection + %- (trace 1 |.("leaving subscription to {<app.action>}")) + (deal-as /watch-response/[eyre-id] identity our app.action %leave ~) + :: + ?(%authentication %eauth %logout) + ::NOTE expiry timer will clean up cancelled eauth attempts + [~ state] + :: + %channel + on-cancel-request:by-channel + :: + ?(%scry %four-oh-four %name %host %ip %boot %sponsor) + :: it should be impossible for these to be asynchronous + :: + !! + == + :: +return-static-data-on-duct: returns one piece of data all at once + :: + ++ return-static-data-on-duct + |= [code=@ content-type=@t data=octs] + ^- [(list move) server-state] + :: + %- handle-response + :* %start + :- status-code=code + ^= headers + :~ ['content-type' content-type] + ['content-length' (crip (a-co:co p.data))] + == + data=[~ data] + complete=%.y + == + :: +authentication: per-event authentication as this Urbit's owner + :: + :: Right now this hard codes the authentication page using the old +code + :: system, but in the future should be pluggable so we can use U2F or + :: WebAuthn or whatever is more secure than passwords. + :: + ++ authentication + |% + :: +handle-request: handles an http request for the login page + :: + ++ handle-request + |= [secure=? host=(unit @t) =address [session-id=@uv =identity] =request:http] + ^- [(list move) server-state] + :: parse the arguments out of request uri + :: + =+ request-line=(parse-request-line url.request) + =/ redirect (get-header:http 'redirect' args.request-line) + =/ with-eauth=(unit ?) + ?: =(~ eauth-url:eauth) ~ + `?=(^ (get-header:http 'eauth' args.request-line)) + :: if we received a simple get: show the login page + :: + ::NOTE we never auto-redirect, to avoid redirect loops with apps that + :: send unprivileged users to the login screen + :: + ?: =('GET' method.request) + %^ return-static-data-on-duct 200 'text/html' + (login-page redirect our identity with-eauth %.n) + :: if we are not a post, return an error + :: + ?. =('POST' method.request) + %^ return-static-data-on-duct 405 'text/html' + (login-page ~ our identity with-eauth %.n) + :: we are a post, and must process the body type as form data + :: + ?~ body.request + %^ return-static-data-on-duct 400 'text/html' + (login-page ~ our identity with-eauth %.n) + :: + =/ parsed=(unit (list [key=@t value=@t])) + (rush q.u.body.request yquy:de-purl:html) + ?~ parsed + %^ return-static-data-on-duct 400 'text/html' + (login-page ~ our identity with-eauth %.n) + :: + =/ redirect=(unit @t) (get-header:http 'redirect' u.parsed) + ?^ (get-header:http 'eauth' u.parsed) + ?~ ship=(biff (get-header:http 'name' u.parsed) (cury slaw %p)) + %^ return-static-data-on-duct 400 'text/html' + (login-page redirect our identity `& %.n) + ::TODO redirect logic here and elsewhere is ugly + =/ redirect (fall redirect '') + =/ base=(unit @t) + ?~ host ~ + `(cat 3 ?:(secure 'https://' 'http://') u.host) + (start:server:eauth u.ship base ?:(=(redirect '') '/' redirect)) + :: + =. with-eauth (bind with-eauth |=(? |)) + ?~ password=(get-header:http 'password' u.parsed) + %^ return-static-data-on-duct 400 'text/html' + (login-page redirect our identity with-eauth %.n) + :: check that the password is correct + :: + ?. =(u.password code) + %^ return-static-data-on-duct 400 'text/html' + (login-page redirect our identity with-eauth %.y) + :: clean up the session they're changing out from + :: + =^ moz state + (close-session session-id |) + :: initialize the new session + :: + =^ fex state (start-session %local) + :: associate the new session with the request that caused the login + :: + :: if we don't do this here, +handle-response will include the old + :: session's cookie, confusing the client. + :: + =. connections.state + %+ ~(jab by connections.state) duct + |= o=outstanding-connection + o(session-id session.fex) + :: store the hostname used for this login, later reuse it for eauth + :: + =? endpoint.auth.state + :: avoid overwriting public domains with localhost + :: + ?& ?=(^ host) + ?| ?=(~ auth.endpoint.auth.state) + !=('localhost' (fall (rush u.host host-sans-port) '')) + == == + %- (trace 2 |.("eauth: storing endpoint at {(trip u.host)}")) + =/ new-auth=(unit @t) + `(cat 3 ?:(secure 'https://' 'http://') u.host) + =, endpoint.auth.state + :+ user new-auth + :: only update the timestamp if the derived endpoint visibly changed. + :: that is, it's not hidden behind a user-provided hardcoded url, + :: and the new value is different from the old.) + :: + ?:(|(?=(^ user) =(new-auth auth)) time now) + :: + =; out=[moves=(list move) server-state] + out(moves [give-session-tokens :(weld moz moves.fex moves.out)]) + ::NOTE that we don't provide a 'set-cookie' header here. + :: +handle-response does that for us. + ::TODO that should really also handle the content-length header for us, + :: somewhat surprising that it doesn't... + %- handle-response + =/ bod=octs + (as-octs:mimes:html (scot %uv session.fex)) + =/ col=[key=@t value=@t] + ['content-length' (crip (a-co:co p.bod))] + ?~ redirect + [%start 200^~[col] `bod &] + =/ actual-redirect ?:(=(u.redirect '') '/' u.redirect) + [%start 303^~['location'^actual-redirect col] `bod &] + :: +handle-logout: handles an http request for logging out + :: + ++ handle-logout + |= [[session-id=@uv =identity] =request:http] + ^- [(list move) server-state] + :: whatever we end up doing, we always respond with a redirect + :: + =/ response=$>(%start http-event:http) + =/ redirect=(unit @t) + %+ get-header:http 'redirect' + args:(parse-request-line url.request) + :* %start + response-header=[303 ['location' (fall redirect '/~/login')]~] + data=~ + complete=%.y + == + :: read options from the body + :: all: log out all sessions with this identity? + :: sid: which session do we log out? (defaults to requester's) + :: hos: host to log out from, for eauth logins (sid signifies the nonce) + :: + =/ arg=header-list:http + ?~ body.request ~ + (fall (rush q.u.body.request yquy:de-purl:html) ~) + =/ all=? + ?=(^ (get-header:http 'all' arg)) + =/ sid=(unit @uv) + ?. ?=(%ours -.identity) `session-id + ?~ sid=(get-header:http 'sid' arg) `session-id + :: if you provided the parameter, but it doesn't parse, we just + :: no-op. otherwise, a poorly-implemented frontend might result in + :: accidental log-outs, which would be very annoying. + :: + (slaw %uv u.sid) + =/ hos=(unit @p) + ?. ?=(%ours -.identity) ~ + (biff (get-header:http 'host' arg) (cury slaw %p)) + ?~ sid + (handle-response response) + :: if this is an eauth remote logout, send the %shut + :: + =* auth auth.state + ?: ?=(^ hos) + =^ moz state (handle-response response) + :- [(send-plea:client:eauth u.hos %0 %shut u.sid) moz] + =/ book (~(gut by visiting.auth) u.hos *logbook) + =. qeu.book (~(put to qeu.book) u.sid) + =. visiting.auth (~(put by visiting.auth) u.hos book) + state + :: if the requester is logging themselves out, make them drop the cookie + :: + =? headers.response-header.response =(u.sid session-id) + :_ headers.response-header.response + ['set-cookie' (session-cookie-string session-id ~)] + :: close the session as requested, then send the response + :: + =^ moz1 state (close-session u.sid all) + =^ moz2 state (handle-response response) + [[give-session-tokens (weld moz1 moz2)] state] + :: +session-id-from-request: attempt to find a session token + :: + :: looks in the authorization header first. if there is no such header, + :: looks in the cookie header(s) instead. + :: + ++ session-id-from-request + |= =request:http + ^- (unit @uv) + :: is there an authorization header? + :: + ?^ auth=(get-header:http 'authorization' header-list.request) + (rush u.auth ;~(pfix (jest 'Bearer 0v') viz:ag)) + :: are there cookies passed with this request? + :: + =/ cookie-header=@t + %+ roll header-list.request + |= [[key=@t value=@t] c=@t] + ?. =(key 'cookie') + c + (cat 3 (cat 3 c ?~(c 0 '; ')) value) + :: is the cookie line valid? + :: + ?~ cookies=(rush cookie-header cock:de-purl:html) + ~ + :: is there an urbauth cookie? + :: + ?~ urbauth=(get-header:http (crip "urbauth-{(scow %p our)}") u.cookies) + ~ + :: if it's formatted like a valid session cookie, produce it + :: + `(unit @)`(rush u.urbauth ;~(pfix (jest '0v') viz:ag)) + :: +request-is-logged-in: checks to see if the request has non-guest id + :: + ++ request-is-logged-in + |= =request:http + ^- ? + ?~ session-id=(session-id-from-request request) + | + ?~ session=(~(get by sessions.auth.state) u.session-id) + | + &(!?=(%fake -.identity.u.session) (lte now expiry-time.u.session)) + :: +request-is-authenticated: checks to see if the request is "us" + :: + :: We are considered authenticated if this request has an urbauth + :: Cookie for the local identity that is not expired. + :: + ++ request-is-authenticated + |= =request:http + ^- ? + :: does the request pass a session cookie? + :: + ?~ session-id=(session-id-from-request request) + %.n + :: is this a session that we know about? + :: + ?~ session=(~(get by sessions.auth.state) `@uv`u.session-id) + %.n + :: does this session have our id, and is it still valid? + :: + &(?=(%ours -.identity.u.session) (lte now expiry-time.u.session)) + :: +start-session: create a new session with %local or %guest identity + :: + ++ start-session + |= kind=?(%local %guest [%eauth who=@p]) + ^- [[session=@uv =identity moves=(list move)] server-state] + =; [key=@uv sid=identity] + =/ timeout=@dr + =, session-timeout + ?:(?=(%guest kind) guest auth) + :- :+ key sid + :: if no session existed previously, we must kick off the + :: session expiry timer + :: + ?^ sessions.auth.state ~ + [duct %pass /sessions/expire %b %wait (add now timeout)]~ + =- state(sessions.auth -) + %+ ~(put by sessions.auth.state) key + [sid (add now timeout) ~] + :: create a new session with a fake identity + :: + =/ sik=@uv new-session-key + :- sik + ?: ?=(%local kind) [%ours ~] + ?: ?=([%eauth @] kind) [%real who.kind] + :- %fake + :: pre-scramble our ship name into its displayed value, and + :: truncate it to be at most moon-length, so that we can overlay + :: it onto the end of a comet name for visual consistency. + :: to prevent escalation, make sure the guest identity isn't ours. + :: + |- + =; nom=@p + ?. =(our nom) nom + $(eny (shas %next-name eny)) + %+ end 3^16 + %^ cat 3 + (end 3^8 (fein:ob our)) + (~(raw og (shas %fake-name eny)) 128) + :: +session-for-request: get the session details for the request + :: + :: returns the @ case if an invalid session is provided. + :: creates a guest session if the request does not have any session. + :: there is no need to call +give-session-tokens after this, because + :: guest sessions do not make valid "auth session" tokens. + :: + ++ session-for-request + |= =request:http + ^- [$@(session=@uv [session=@uv =identity moves=(list move)]) server-state] + ?~ sid=(session-id-from-request request) + (start-session %guest) + ?~ ses=(~(get by sessions.auth.state) u.sid) + [u.sid state] + ?: (gth now expiry-time.u.ses) + [u.sid state] + [[u.sid identity.u.ses ~] state] + :: +close-session: delete a session and its associated channels + :: + :: if :all is true, deletes all sessions that share the same identity. + :: if this closes an %ours session, the caller is responsible for + :: also calling +give-session-tokens afterwards. + :: + ++ close-session + |= [session-id=@uv all=?] + ^- [(list move) server-state] + ?~ ses=(~(get by sessions.auth.state) session-id) + [~ state] + :: delete the session(s) and find the associated ids & channels + :: + =^ [siz=(list @uv) channels=(list @t)] sessions.auth.state + =* sessions sessions.auth.state + :: either delete just the specific session and its channels, + :: + ?. all + :- [[session-id]~ ~(tap in channels.u.ses)] + (~(del by sessions) session-id) + :: or delete all sessions with the identity from :session-id + :: + %+ roll ~(tap by sessions) + |= $: [sid=@uv s=session] + [[siz=(list @uv) caz=(list @t)] sez=(map @uv session)] + == + ^+ [[siz caz] sez] + ?. =(identity.s identity.u.ses) + :: identity doesn't match, so re-store this session + :: + [[siz caz] (~(put by sez) sid s)] + :: identity matches, so register this session as closed + :: + [[[sid siz] (weld caz ~(tap in channels.s))] sez] + :: close all affected channels and send their responses + :: + =| moves1=(list move) + |- ^- (quip move server-state) + ?^ channels + %- %+ trace 1 + |.("{(trip i.channels)} discarding channel due to closed session") + =^ moz state + (discard-channel:by-channel i.channels |) + $(moves1 (weld moves1 moz), channels t.channels) + :: lastly, %real sessions require additional cleanup + :: + ?. ?=(%real -.identity.u.ses) [moves1 state] + =^ moves2 visitors.auth.state + %+ roll ~(tap by visitors.auth.state) + |= [[nonce=@uv visa=visitor] [moz=(list move) viz=(map @uv visitor)]] + ?^ +.visa [moz (~(put by viz) nonce visa)] + :_ viz + %+ weld moz + ?~ duct.visa ~ + [(send-boon:server:eauth(duct u.duct.visa) %0 %shut nonce)]~ + [(weld `(list move)`moves1 `(list move)`moves2) state] + :: +code: returns the same as |code + :: + ++ code + ^- @ta + =/ res=(unit (unit cage)) + (rof [~ ~] /eyre %j [our %code da+now] /(scot %p our)) + (rsh 3 (scot %p ;;(@ q.q:(need (need res))))) + :: +session-cookie-string: compose session cookie + :: + ++ session-cookie-string + |= [session=@uv extend=(unit ?(%auth %guest))] + ^- @t + %- crip + =; max-age=tape + "urbauth-{(scow %p our)}={(scow %uv session)}; Path=/; Max-Age={max-age}" + %- a-co:co + ?~ extend 0 + =, session-timeout + (div (msec:milly ?-(u.extend %auth auth, %guest guest)) 1.000) + :: + :: + ++ eauth + =* auth auth.state + |% + ++ server + |% + :: +start: initiate an eauth login attempt for the :ship identity + :: + ++ start + |= [=ship base=(unit @t) last=@t] + ^- [(list move) server-state] + %- (trace 2 |.("eauth: starting eauth into {(scow %p ship)}")) + =/ nonce=@uv + |- + =+ n=(~(raw og (shas %eauth-nonce eny)) 64) + ?. (~(has by visitors.auth) n) n + $(eny (shas %try-again n)) + =/ visit=visitor [~ `[duct now] ship base last ~] + =. visitors.auth (~(put by visitors.auth) nonce visit) + :_ state + :: we delay serving an http response until we receive a scry %tune + :: + :~ (send-keen %keen ship nonce now) + (start-timeout /visitors/(scot %uv nonce)) + == + :: +on-tune: receive a client-url remote scry result + :: + ++ on-tune + |= [ship=@p nonce=@uv url=@t] + ^- [(list move) server-state] + %- (trace 2 |.("eauth: %tune from {(scow %p ship)}")) + :: guarantee the ship still controls the nonce + :: + =/ visa=visitor (~(got by visitors.auth) nonce) + ?> &(?=(^ +.visa) =(ship ship.visa)) + :: redirect the visitor to their own confirmation page + :: + =. visitors.auth (~(put by visitors.auth) nonce visa(pend ~)) + %- handle-response(duct http:(need pend.visa)) + =; url=@t [%start 303^['location' url]~ ~ &] + %+ rap 3 + :~ url + '?server=' (scot %p our) + '&nonce=' (scot %uv nonce) + == + :: +on-plea: receive an eauth network message from a client + :: + ++ on-plea + |= [=ship plea=eauth-plea] + ^- [(list move) server-state] + %- (trace 2 |.("eauth: {(trip +<.plea)} from {(scow %p ship)}")) + =; res=[(list move) server-state] + =^ moz state res + [[[duct %give %done ~] moz] state] + ?- +<.plea + %open + :: this attempt may or may not have been started in +start yet + :: + =/ visa=visitor + %+ ~(gut by visitors.auth) nonce.plea + [~ ~ ship ~ '/' ~] + ?> ?=(^ +.visa) + ?> =(ship ship.visa) + ::NOTE that token might still be empty, in which case the http + :: client will probably signal an abort when they return + :: + =. duct.visa `duct + =. toke.visa token.plea + =. visitors.auth (~(put by visitors.auth) nonce.plea visa) + :: if the eauth attempt was started on our side, we may know the + :: specific base url the user used; make sure they go back there + :: + =/ url=@t + %- need + ?~ base.visa eauth-url + eauth-url(user.endpoint.auth base.visa) + [[(send-boon %0 %okay nonce.plea url)]~ state] + :: + %shut + :: the visitor wants the associated session gone + :: + ?~ visa=(~(get by visitors.auth) nonce.plea) [~ state] + =. visitors.auth (~(del by visitors.auth) nonce.plea) + =? sessions.auth ?=(@ +.u.visa) + (~(del by sessions.auth) sesh.u.visa) + [[(send-boon %0 %shut nonce.plea)]~ state] + == + :: +cancel: the client aborted the eauth attempt, so clean it up + :: + ++ cancel + |= [nonce=@uv last=@t] + ^- [(list move) server-state] + :: if the eauth attempt doesn't exist, or it was already completed, + :: we cannot cancel it + :: + ?~ visa=(~(get by visitors.auth) nonce) [~ state] + ?@ +.u.visa [~ state] + :: delete the attempt, and go back to the login page + :: + %- (trace 2 |.("eauth: cancelling login")) + =. visitors.auth (~(del by visitors.auth) nonce) + =^ moz state + =/ url=@t + %^ cat 3 '/~/login?eauth&redirect=' + (crip (en-urlt:html (trip last))) + (handle-response %start 303^['location' url]~ ~ &) + :_ state + %+ weld moz + ?~ duct.u.visa ~ + [(send-boon(duct u.duct.u.visa) %0 %shut nonce)]~ + :: +expire: host-side cancel an eauth attempt if it's still pending + :: + ++ expire + |= nonce=@uv + ^- [(list move) server-state] + ?~ visa=(~(get by visitors.auth) nonce) + [~ state] + ?@ +.u.visa [~ state] + %- (trace 2 |.("eauth: expiring")) + =^ moz state + ?~ pend.u.visa [~ state] + %- return-static-data-on-duct(duct http.u.pend.u.visa) + [503 'text/html' (eauth-error-page %server last.u.visa)] + =? moz ?=(^ pend.u.visa) + [(send-keen %yawn ship.u.visa nonce keen.u.pend.u.visa) moz] + =. visitors.auth (~(del by visitors.auth) nonce) + :_ state + %+ weld moz + ?~ duct.u.visa ~ + [(send-boon(duct u.duct.u.visa) %0 %shut nonce)]~ + :: +finalize: eauth attempt was approved: mint the client a new session + :: + :: gives the http response on the current duct + :: + ++ finalize + |= [=plea=^duct nonce=@uv =ship last=@t] + ^- [(list move) server-state] + %- (trace 2 |.("eauth: finalizing login for {(scow %p ship)}")) + :: clean up the session they're changing out from, + :: mint the new session, + :: associate it with the nonce, + :: and the finalization request, + :: and send the visitor the cookie + final redirect + :: + =^ moz1 state + (close-session session-id:(~(got by connections.state) duct) |) + =^ [sid=@uv * moz2=(list move)] state + (start-session %eauth ship) + =. visitors.auth + %+ ~(jab by visitors.auth) nonce + |=(v=visitor v(+ sid)) + =. connections.state + %+ ~(jab by connections.state) duct + |= o=outstanding-connection + o(session-id sid) + =^ moz3 state + =; hed (handle-response %start 303^hed ~ &) + :~ ['location' last] + ['set-cookie' (session-cookie-string sid `%auth)] + == + [:(weld moz1 moz2 moz3) state] + :: +on-fail: we crashed or received an empty %tune, clean up + :: + ++ on-fail + |= [=ship nonce=@uv] + ^- [(list move) server-state] + :: if the eauth attempt doesn't exist, or it was already completed, + :: we can no-op here + :: + ?~ visa=(~(get by visitors.auth) nonce) [~ state] + ?@ +.u.visa [~ state] + :: delete the attempt, and go back to the login page + :: + %- (trace 2 |.("eauth: failed login")) + =. visitors.auth (~(del by visitors.auth) nonce) + =^ moz state + ?~ pend.u.visa [~ state] + %- return-static-data-on-duct(duct http.u.pend.u.visa) + [503 'text/html' (eauth-error-page %server last.u.visa)] + :_ state + %+ weld moz + ?~ duct.u.visa ~ + [(send-boon(duct u.duct.u.visa) %0 %shut nonce)]~ + :: + ::TODO +on-request? + :: + ++ send-keen + |= [kind=?(%keen %yawn) =ship nonce=@uv =time] + ^- move + %- (trace 2 |.("eauth: %{(trip kind)} into {(scow %p ship)}")) + :: we round down the time to make it more likely to hit cache, + :: at the expense of not working if the endpoint changed within + :: the last +eauth-cache-rounding. + :: + =/ =wire /eauth/keen/(scot %p ship)/(scot %uv nonce) + =. time (sub time (mod time eauth-cache-rounding)) + =/ =spar:ames [ship /e/x/(scot %da time)//eauth/url] + [duct %pass wire %a ?-(kind %keen keen+[~ spar], %yawn yawn+spar)] + :: + ++ send-boon + |= boon=eauth-boon + ^- move + %- (trace 2 |.("eauth: sending {(trip +<.boon)}")) + [duct %give %boon boon] + -- + :: + ++ client + |% + :: +start: as the client, approve or abort an eauth attempt + :: + :: assumes the duct is of an incoming eauth start/approve request + :: + ++ start + |= [host=ship nonce=@uv grant=?] + ^- [(list move) server-state] + =/ token=@uv (~(raw og (shas %eauth-token eny)) 128) + :: we always send an %open, because we need to redirect the user + :: back to the host. and we always set a timeout, because we may + :: not get a response quickly enough. + :: + :- :~ (send-plea host %0 %open nonce ?:(grant `token ~)) + (start-timeout /visiting/(scot %p host)/(scot %uv nonce)) + == + :: make sure we aren't attempting with this nonce already, + :: then remember the secret so we can include it in the redirect + :: + =/ book (~(gut by visiting.auth) host *logbook) + ?< (~(has by map.book) nonce) + =. visiting.auth + %+ ~(put by visiting.auth) host + :- (~(put to qeu.book) nonce) + (~(put by map.book) nonce [`duct ?:(grant `token ~)]) + state + :: +on-done: receive n/ack for plea we sent + :: + ++ on-done + |= [host=ship good=?] + ^- [(list move) server-state] + %- %- trace + ?: good + [2 |.("eauth: ack from {(scow %p host)}")] + [1 |.("eauth: nack from {(scow %p host)}")] + =/ book (~(gut by visiting.auth) host *logbook) + ?~ ~(top to qeu.book) + %. [~ state] + (trace 0 |.("eauth: done on empty queue from {(scow %p host)}")) + =^ nonce=@uv qeu.book ~(get to qeu.book) + ?: good + =. visiting.auth + ?: =([~ ~] book) + (~(del by visiting.auth) host) + (~(put by visiting.auth) host book) + [~ state] + =/ port (~(get by map.book) nonce) + ?~ port [~ state] + :: delete the attempt/session, serve response if needed + :: + =. visiting.auth + =. map.book + (~(del by map.book) nonce) + ?: =([~ ~] book) + (~(del by visiting.auth) host) + (~(put by visiting.auth) host book) + :: + ?@ u.port [~ state] + ?~ pend.u.port [~ state] + %^ return-static-data-on-duct(duct u.pend.u.port) 503 'text/html' + (eauth-error-page ~) + :: +on-boon: receive an eauth network response from a host + :: + :: crashes on unexpected circumstances, in response to which we + :: should abort the eauth attempt + :: + ++ on-boon + |= [host=ship boon=eauth-boon] + ^- [(list move) server-state] + %- (trace 2 |.("eauth: %{(trip +<.boon)} from {(scow %p host)}")) + ?- +<.boon + %okay + =/ book (~(got by visiting.auth) host) + =/ port (~(got by map.book) nonce.boon) + ?> ?=(^ port) + ?> ?=(^ pend.port) + :: update the outgoing sessions map, deleting if we aborted + :: + =. visiting.auth + ?^ toke.port + %+ ~(put by visiting.auth) host + :- qeu.book + ::NOTE optimistic + (~(put by map.book) nonce.boon now) + =. map.book + (~(del by map.book) nonce.boon) + ?: =([~ ~] book) + (~(del by visiting.auth) host) + (~(put by visiting.auth) host book) + :: always serve a redirect, with either the token, or abort signal + :: + =; url=@t + %- handle-response(duct u.pend.port) + [%start 303^['location' url]~ ~ &] + %+ rap 3 + :* url.boon + '?nonce=' (scot %uv nonce.boon) + ?~ toke.port ['&abort']~ + ~['&token=' (scot %uv u.toke.port)] + == + :: + %shut + :: the host has deleted the corresponding session + :: + =. visiting.auth + =/ book + (~(gut by visiting.auth) host *logbook) + =. map.book + (~(del by map.book) nonce.boon) + ?: =([~ ~] book) + (~(del by visiting.auth) host) + (~(put by visiting.auth) host book) + [~ state] + == + :: + ++ expire + |= [host=ship nonce=@uv] + ^- [(list move) server-state] + =/ book (~(gut by visiting.auth) host *logbook) + =/ port (~(get by map.book) nonce) + :: if the attempt was completed, we don't expire it + :: + ?~ port [~ state] + ?@ u.port [~ state] + :: delete pending attempts, serve response if needed + :: + %- %+ trace 1 + |.("eauth: attempt into {(scow %p host)} expired") + =. visiting.auth + =. map.book + (~(del by map.book) nonce) + ?: =([~ ~] book) + (~(del by visiting.auth) host) + (~(put by visiting.auth) host book) + :: + ?~ pend.u.port [~ state] + %^ return-static-data-on-duct(duct u.pend.u.port) 503 'text/html' + (eauth-error-page ~) + :: + ++ send-plea + |= [=ship plea=eauth-plea] + ^- move + ::NOTE no nonce in the wire, to avoid proliferating flows + =/ =wire /eauth/plea/(scot %p ship) + %- (trace 2 |.("eauth: {(trip +<.plea)} into {(scow %p ship)}")) + [[/eyre/eauth/synthetic]~ %pass wire %a %plea ship %e /eauth/0 plea] + :: + ++ confirmation-page + |= [server=ship nonce=@uv] + ^- octs + %- as-octs:mimes:html + %- crip + %- en-xml:html + =/ favicon %+ + weld "<svg width='10' height='10' viewBox='0 0 10 10' xmlns='http://www.w3.org/2000/svg'>" + "<circle r='3.09' cx='5' cy='5' /></svg>" + ;html + ;head + ;meta(charset "utf-8"); + ;meta(name "viewport", content "width=device-width, initial-scale=1, shrink-to-fit=no"); + ;link(rel "icon", type "image/svg+xml", href (weld "data:image/svg+xml;utf8," favicon)); + ;title:"Urbit" + ;style:"{(trip auth-styling)}" + ;style:''' + form { + border: 1px solid var(--black20); + border-radius: 4px; + padding: 1rem; + align-items: stretch; + font-size: 14px; + } + .red { + background: var(--black05) !important; + color: var(--black60) !important; + border: 1px solid var(--black60) !important; + } + code { + font-weight: bold; + font-family: "Source Code Pro", monospace; + } + button { + display: inline-block; + } + ''' + == + ;body + ;form(action "/~/eauth", method "post") + ; Hello, {(scow %p our)}. + ; You are trying to log in to: + ;code:"{(scow %p server)}" + ;input(type "hidden", name "server", value (scow %p server)); + ;input(type "hidden", name "nonce", value (scow %uv nonce)); + ;button(type "submit", name "grant", value "grant"):"approve" + ;button(type "submit", name "reject", class "red"):"reject" + == + == + == + -- + :: +on-request: http request to the /~/eauth endpoint + :: + ++ on-request + |= [[session-id=@uv =identity] =request:http] + ^- [(list move) server-state] + :: we may need the requester to log in before proceeding + :: + =* login + =; url=@t (handle-response %start 303^['location' url]~ ~ &) + %^ cat 3 '/~/login?redirect=' + (crip (en-urlt:html (trip url.request))) + :: or give them a generic, static error page in unexpected cases + :: + =* error %^ return-static-data-on-duct 400 'text/html' + (eauth-error-page ~) + :: GET requests either render the confirmation page, + :: or finalize an eauth flow + :: + ?: ?=(%'GET' method.request) + =/ args=(map @t @t) (malt args:(parse-request-line url.request)) + =/ server=(unit @p) (biff (~(get by args) 'server') (cury slaw %p)) + =/ nonce=(unit @uv) (biff (~(get by args) 'nonce') (cury slaw %uv)) + =/ token=(unit @uv) (biff (~(get by args) 'token') (cury slaw %uv)) + =/ abort=? (~(has by args) 'abort') + :: + ?~ nonce error + :: + ?^ server + :: request for confirmation page + :: + ?. ?=(%ours -.identity) login + =/ book (~(gut by visiting.auth) u.server *logbook) + =/ door (~(get by map.book) u.nonce) + ?~ door + :: nonce not yet used, render the confirmation page as normal + :: + %^ return-static-data-on-duct 200 'text/html' + (confirmation-page:client u.server u.nonce) + :: if we're still awaiting a redirect target, we choose to serve + :: this latest request instead + :: + ?@ u.door error + ?~ pend.u.door error + =. map.book (~(put by map.book) u.nonce u.door(pend `duct)) + =. visiting.auth (~(put by visiting.auth) u.server book) + %- return-static-data-on-duct(duct u.pend.u.door) + [202 'text/plain' (as-octs:mimes:html 'continued elsewhere...')] + :: important to provide an error response for unexpected states + :: + =/ visa=(unit visitor) (~(get by visitors.auth) u.nonce) + ?~ visa error + ?@ +.u.visa error + =* error %^ return-static-data-on-duct 400 'text/html' + (eauth-error-page %server last.u.visa) + :: request for finalization, must either abort or provide a token + :: + ::NOTE yes, this means that unauthenticated clients can abort + :: any eauth attempt they know the nonce for, but that should + :: be pretty benign + ?: abort (cancel:^server u.nonce last.u.visa) + ?~ token error + :: if this request provides a token, but the client didn't, complain + :: + ?~ toke.u.visa error + :: verify the request + :: + ?. =(u.token u.toke.u.visa) + %- (trace 1 |.("eauth: token mismatch")) + error + ?~ duct.u.visa error + (finalize:^server u.duct.u.visa u.nonce ship.u.visa last.u.visa) + :: + ?. ?=(%'POST' method.request) + %^ return-static-data-on-duct 405 'text/html' + (eauth-error-page ~) + ?. =(%ours -.identity) login + :: POST requests are always submissions of the confirmation page + :: + =/ args=(map @t @t) + (malt (fall (rush q:(fall body.request *octs) yquy:de-purl:html) ~)) + =/ server=(unit @p) (biff (~(get by args) 'server') (cury slaw %p)) + =/ nonce=(unit @uv) (biff (~(get by args) 'nonce') (cury slaw %uv)) + =/ grant=? =(`'grant' (~(get by args) 'grant')) + :: + =* error %^ return-static-data-on-duct 400 'text/html' + (eauth-error-page ~) + ?~ server error + ?~ nonce error + =/ book (~(gut by visiting.auth) u.server *logbook) + ?: (~(has by map.book) u.nonce) error + (start:client u.server u.nonce grant) + :: + ++ eauth-url + ^- (unit @t) + =/ end=(unit @t) (clap user.endpoint.auth auth.endpoint.auth head) + ?~ end ~ + `(cat 3 u.end '/~/eauth') + :: + ++ start-timeout + |= =path + ^- move + [duct %pass [%eauth %expire path] %b %wait (add now eauth-timeout)] + -- + -- + :: +channel: per-event handling of requests to the channel system + :: + :: Eyre offers a remote interface to your Urbit through channels, which + :: are persistent connections on the server which can be disconnected and + :: reconnected on the client. + :: + ++ by-channel + :: moves: the moves to be sent out at the end of this event, reversed + :: + =| moves=(list move) + |% + :: +handle-request: handles an http request for the subscription system + :: + ++ handle-request + |= [[session-id=@uv =identity] =address =request:http] + ^- [(list move) server-state] + :: parse out the path key the subscription is on + :: + =+ request-line=(parse-request-line url.request) + ?. ?=([@t @t @t ~] site.request-line) + :: url is not of the form '/~/channel/' + :: + %^ return-static-data-on-duct 400 'text/html' + (error-page 400 & url.request "malformed channel url") + :: channel-id: unique channel id parsed out of url + :: + =+ channel-id=i.t.t.site.request-line + :: + ?: =('PUT' method.request) + :: PUT methods starts/modifies a channel, and returns a result immediately + :: + (on-put-request channel-id identity request) + :: + ?: =('GET' method.request) + (on-get-request channel-id [session-id identity] request) + ?: =('POST' method.request) + :: POST methods are used solely for deleting channels + (on-put-request channel-id identity request) + :: + %- (trace 0 |.("session not a put")) + %^ return-static-data-on-duct 405 'text/html' + (error-page 405 & url.request "bad method for session endpoint") + :: +on-cancel-request: cancels an ongoing subscription + :: + :: One of our long lived sessions just got closed. We put the associated + :: session back into the waiting state. + :: + ++ on-cancel-request + ^- [(list move) server-state] + :: lookup the session id by duct + :: + %- (trace 1 |.("{<duct>} moving channel to waiting state")) + :: + ?~ maybe-channel-id=(~(get by duct-to-key.channel-state.state) duct) + ((trace 0 |.("{<duct>} no channel to move")) `state) + :: + =/ maybe-session + (~(get by session.channel-state.state) u.maybe-channel-id) + ?~ maybe-session + ((trace 1 |.("{<maybe-session>} session doesn't exist")) `state) + :: + =/ heartbeat-cancel=(list move) + ?~ heartbeat.u.maybe-session ~ + :~ %^ cancel-heartbeat-move + u.maybe-channel-id + date.u.heartbeat.u.maybe-session + duct.u.heartbeat.u.maybe-session + == + :: + =/ expiration-time=@da (add now channel-timeout) + :: + :- %+ weld heartbeat-cancel + [(set-timeout-move u.maybe-channel-id expiration-time) moves] + %_ state + session.channel-state + %+ ~(jab by session.channel-state.state) u.maybe-channel-id + |= =channel + :: if we are canceling a known channel, it should have a listener + :: + ?> ?=([%| *] state.channel) + channel(state [%& [expiration-time duct]], heartbeat ~) + :: + duct-to-key.channel-state + (~(del by duct-to-key.channel-state.state) duct) + == + :: +update-timeout-timer-for: sets a timeout timer on a channel + :: + :: This creates a channel if it doesn't exist, cancels existing timers + :: if they're already set (we cannot have duplicate timers), and (if + :: necessary) moves channels from the listening state to the expiration + :: state. + :: + ++ update-timeout-timer-for + |= [mode=?(%json %jam) =identity channel-id=@t] + ^+ ..update-timeout-timer-for + :: when our callback should fire + :: + =/ expiration-time=@da (add now channel-timeout) + :: if the channel doesn't exist, create it and set a timer + :: + ?~ maybe-channel=(~(get by session.channel-state.state) channel-id) + :: + %_ ..update-timeout-timer-for + session.channel-state.state + %+ ~(put by session.channel-state.state) channel-id + [mode identity [%& expiration-time duct] 0 now ~ ~ ~ ~] + :: + moves + [(set-timeout-move channel-id expiration-time) moves] + == + :: if the channel has an active listener, we aren't setting any timers + :: + ?: ?=([%| *] state.u.maybe-channel) + ..update-timeout-timer-for + :: we have a previous timer; cancel the old one and set the new one + :: + %_ ..update-timeout-timer-for + session.channel-state.state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + channel(state [%& [expiration-time duct]]) + :: + moves + :* (cancel-timeout-move channel-id p.state.u.maybe-channel) + (set-timeout-move channel-id expiration-time) + moves + == + == + :: + ++ set-heartbeat-move + |= [channel-id=@t heartbeat-time=@da] + ^- move + :^ duct %pass /channel/heartbeat/[channel-id] + [%b %wait heartbeat-time] + :: + ++ cancel-heartbeat-move + |= [channel-id=@t heartbeat-time=@da =^duct] + ^- move + :^ duct %pass /channel/heartbeat/[channel-id] + [%b %rest heartbeat-time] + :: + ++ set-timeout-move + |= [channel-id=@t expiration-time=@da] + ^- move + [duct %pass /channel/timeout/[channel-id] %b %wait expiration-time] + :: + ++ cancel-timeout-move + |= [channel-id=@t expiration-time=@da =^duct] + ^- move + :^ duct %pass /channel/timeout/[channel-id] + [%b %rest expiration-time] + :: +on-get-request: handles a GET request + :: + :: GET requests connect to a channel for the server to send events to + :: the client in text/event-stream format. + :: + ++ on-get-request + |= [channel-id=@t [session-id=@uv =identity] =request:http] + ^- [(list move) server-state] + :: if the channel doesn't exist, we cannot serve it. + :: this 404 also lets clients know if their channel was reaped since + :: they last connected to it. + :: + ?. (~(has by session.channel-state.state) channel-id) + %^ return-static-data-on-duct 404 'text/html' + (error-page 404 | url.request ~) + :: + =/ mode=?(%json %jam) + (find-channel-mode %'GET' header-list.request) + =^ [exit=? =wall moves=(list move)] state + :: the request may include a 'Last-Event-Id' header + :: + =/ maybe-last-event-id=(unit @ud) + ?~ maybe-raw-header=(get-header:http 'last-event-id' header-list.request) + ~ + (rush u.maybe-raw-header dum:ag) + =/ channel + (~(got by session.channel-state.state) channel-id) + :: we put some demands on the get request, and may need to do some + :: cleanup for prior requests. + :: + :: find the channel creator's identity, make sure it matches + :: + ?. =(identity identity.channel) + =^ mos state + %^ return-static-data-on-duct 403 'text/html' + (error-page 403 | url.request ~) + [[& ~ mos] state] + :: make sure the request "mode" doesn't conflict with a prior request + :: + ::TODO or could we change that on the spot, given that only a single + :: request will ever be listening to this channel? + ?. =(mode mode.channel) + =^ mos state + %^ return-static-data-on-duct 406 'text/html' + =; msg=tape (error-page 406 %.y url.request msg) + "channel already established in {(trip mode.channel)} mode" + [[& ~ mos] state] + :: when opening an event-stream, we must cancel our timeout timer + :: if there's no duct already bound. else, kill the old request, + :: we will replace its duct at the end of this arm + :: + =^ cancel-moves state + ?: ?=([%& *] state.channel) + :_ state + (cancel-timeout-move channel-id p.state.channel)^~ + =. duct-to-key.channel-state.state + (~(del by duct-to-key.channel-state.state) p.state.channel) + =/ cancel-heartbeat + ?~ heartbeat.channel ~ + :_ ~ + %+ cancel-heartbeat-move channel-id + [date duct]:u.heartbeat.channel + =- [(weld cancel-heartbeat -<) ->] + (handle-response(duct p.state.channel) [%cancel ~]) + :: flush events older than the passed in 'Last-Event-ID' + :: + =? state ?=(^ maybe-last-event-id) + (acknowledge-events channel-id u.maybe-last-event-id) + ::TODO that did not remove them from the channel queue though! + :: we may want to account for maybe-last-event-id, for efficiency. + :: (the client _should_ ignore events it heard previously if we do + :: end up re-sending them, but _requiring_ that feels kinda risky) + :: + :: combine the remaining queued events to send to the client + :: + =; event-replay=wall + [[| - cancel-moves] state] + %- zing + %- flop + =/ queue events.channel + =| events=(list wall) + |- + ^+ events + ?: =(~ queue) + events + =^ head queue ~(get to queue) + =, p.head + ::NOTE these will only fail if the mark and/or json types changed, + :: since conversion failure also gets caught during first receive. + :: we can't do anything about this, so consider it unsupported. + =/ said + (channel-event-to-tape channel request-id channel-event) + ?~ said $ + $(events [(event-tape-to-wall id +.u.said) events]) + ?: exit [moves state] + :: send the start event to the client + :: + =^ http-moves state + %- handle-response + :* %start + :- 200 + :~ ['content-type' 'text/event-stream'] + ['cache-control' 'no-cache'] + ['connection' 'keep-alive'] + == + :: + :: if we wouldn't otherwise send any data, send an early heartbeat + :: instead. some clients won't consider the connection established + :: until they've heard some bytes come over the wire. + :: + ?. =(~ wall) (wall-to-octs wall) + (some (as-octs:mimes:html ':\0a')) + :: + complete=%.n + == + :: associate this duct with this session key + :: + =. duct-to-key.channel-state.state + (~(put by duct-to-key.channel-state.state) duct channel-id) + :: associate this channel with the session cookie + :: + =. sessions.auth.state + %+ ~(jab by sessions.auth.state) + session-id + |= =session + session(channels (~(put in channels.session) channel-id)) + :: initialize sse heartbeat + :: + =/ heartbeat-time=@da (add now ~s20) + =/ heartbeat (set-heartbeat-move channel-id heartbeat-time) + :: record the mode & duct for future output, + :: and record heartbeat-time for possible future cancel + :: + =. session.channel-state.state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + %_ channel + mode mode + state [%| duct] + heartbeat (some [heartbeat-time duct]) + == + :: + [[heartbeat :(weld http-moves moves)] state] + :: +acknowledge-events: removes events before :last-event-id on :channel-id + :: + ++ acknowledge-events + |= [channel-id=@t last-event-id=@u] + ^- server-state + %_ state + session.channel-state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + ^+ channel + =^ acked events.channel + (prune-events events.channel last-event-id) + =. unacked.channel + (subtract-acked-events acked unacked.channel) + channel(last-ack now) + == + :: +on-put-request: handles a PUT request + :: + :: PUT requests send commands from the client to the server. We receive + :: a set of commands in JSON format in the body of the message. + :: channels don't exist until a PUT request is sent. it's valid for + :: this request to contain an empty list of commands. + :: + ++ on-put-request + |= [channel-id=@t =identity =request:http] + ^- [(list move) server-state] + :: if the channel already exists, and is not of this identity, 403 + :: + :: the creation case happens in the +update-timeout-timer-for below + :: + ?: ?~ c=(~(get by session.channel-state.state) channel-id) | + !=(identity identity.u.c) + %^ return-static-data-on-duct 403 'text/html' + (error-page 403 | url.request ~) + :: error when there's no body + :: + ?~ body.request + %^ return-static-data-on-duct 400 'text/html' + (error-page 400 %.y url.request "no put body") + :: + =/ mode=?(%json %jam) + (find-channel-mode %'PUT' header-list.request) + :: if we cannot parse requests from the body, give an error + :: + =/ maybe-requests=(each (list channel-request) @t) + (parse-channel-request mode u.body.request) + ?: ?=(%| -.maybe-requests) + %^ return-static-data-on-duct 400 'text/html' + (error-page 400 & url.request (trip p.maybe-requests)) + :: check for the existence of the channel-id + :: + :: if we have no session, create a new one set to expire in + :: :channel-timeout from now. if we have one which has a timer, update + :: that timer. + :: + =. ..on-put-request (update-timeout-timer-for mode identity channel-id) + :: for each request, execute the action passed in + :: + =+ requests=p.maybe-requests + :: gall-moves: put moves here first so we can flop for ordering + :: errors: if we accumulate any, discard the gall-moves and revert + :: + =| gall-moves=(list move) + =| errors=(map @ud @t) + =/ og-state state + =/ from=ship + ?+(-.identity who.identity %ours our) + |- + :: + ?~ requests + ?: =(~ errors) + :: everything succeeded, mark the request as completed + :: + =^ http-moves state + %- handle-response + :* %start + [status-code=204 headers=~] + data=~ + complete=%.y + == + :: + [:(weld (flop gall-moves) http-moves moves) state] + :: some things went wrong. revert all operations & give 400 + :: + %- (trace 1 |.("{<channel-id>} reverting due to errors")) + =. state og-state + =^ http-moves state + %^ return-static-data-on-duct 400 'text/html' + %- as-octs:mimes:html + %+ rap 3 + %+ turn (sort ~(tap by errors) dor) + |= [id=@ud er=@t] + (rap 3 (crip (a-co:co id)) ': ' er '<br/>' ~) + [(weld http-moves moves) state] + :: + ?- -.i.requests + %ack + :: client acknowledges that they have received up to event-id + :: + %_ $ + state (acknowledge-events channel-id event-id.i.requests) + requests t.requests + == + :: + ?(%poke %poke-json) + =, i.requests + :: + ?. |(=(from our) =(ship our)) + =+ [request-id 'non-local operation'] + $(errors (~(put by errors) -), requests t.requests) + :: + =. gall-moves + =/ =wire /channel/poke/[channel-id]/(scot %ud request-id.i.requests) + :_ gall-moves + ^- move + %+ deal-as + /channel/poke/[channel-id]/(scot %ud request-id) + :^ from ship app + ^- task:agent:gall + :+ %poke-as mark + ?- -.i.requests + %poke [%noun !>(noun)] + %poke-json [%json !>(json)] + == + :: + $(requests t.requests) + :: + %subscribe + =, i.requests + :: + ?. |(=(from our) =(ship our)) + =+ [request-id 'non-local operation'] + $(errors (~(put by errors) -), requests t.requests) + :: + ::TODO could error if the subscription is a duplicate + =. gall-moves + :_ gall-moves + ^- move + %- (trace 1 |.("subscribing to {<app>} on {<path>}")) + %+ deal-as + (subscription-wire channel-id request-id from ship app) + [from ship app %watch path] + :: + =. session.channel-state.state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + =- channel(subscriptions -) + %+ ~(put by subscriptions.channel) + request-id + [ship app path duct] + :: + $(requests t.requests) + :: + %unsubscribe + =, i.requests + :: + ?. |(=(from our) =(ship our)) + =+ [request-id 'non-local operation'] + $(errors (~(put by errors) -), requests t.requests) + :: + =/ usession (~(get by session.channel-state.state) channel-id) + ?~ usession + $(requests t.requests) + =/ subscriptions subscriptions:u.usession + :: + ?~ maybe-subscription=(~(get by subscriptions) subscription-id) + :: the client sent us a weird request referring to a subscription + :: which isn't active. + :: + %. $(requests t.requests) + =* msg=tape "{(trip channel-id)} {<subscription-id>}" + (trace 0 |.("missing subscription in unsubscribe {msg}")) + :: + =. gall-moves + :_ gall-moves + ^- move + =, u.maybe-subscription + %- (trace 1 |.("leaving subscription to {<app>}")) + %+ deal-as(duct duc) + (subscription-wire channel-id subscription-id from ship app) + [from ship app %leave ~] + :: + =. session.channel-state.state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + %_ channel + subscriptions (~(del by subscriptions.channel) subscription-id) + unacked (~(del by unacked.channel) subscription-id) + == + :: + $(requests t.requests) + :: + %delete + %- (trace 1 |.("{<channel-id>} discarding due to %delete PUT")) + =^ moves state + (discard-channel channel-id |) + =. gall-moves + (weld gall-moves moves) + $(requests t.requests) + :: + == + :: +on-gall-response: sanity-check a gall response, send as event + :: + ++ on-gall-response + |= [channel-id=@t request-id=@ud extra=wire =sign:agent:gall] + ^- [(list move) server-state] + :: if the channel doesn't exist, we should clean up subscriptions + :: + :: this is a band-aid solution. you really want eyre to have cleaned + :: these up on-channel-delete in the first place. + :: until the source of that bug is discovered though, we keep this + :: in place to ensure a slightly tidier home. + :: + ?. ?& !(~(has by session.channel-state.state) channel-id) + ?=(?(%fact %watch-ack) -.sign) + ?=([@ @ *] extra) + == + (emit-event channel-id request-id sign) + =/ =ship (slav %p i.extra) + =* app=term i.t.extra + =* msg=tape "{(trip channel-id)} {(trip app)}" + %- (trace 0 |.("removing watch for non-existent channel {msg}")) + :_ state + :_ ~ + ^- move + =/ [as=@p old=?] + ?+ t.t.extra ~|([%strange-wire extra] !!) + ~ [our &] + [@ ~] [(slav %p i.t.t.extra) |] + == + =/ =wire (subscription-wire channel-id request-id as ship app) + %+ deal-as + ::NOTE we previously used a wire format that had the local identity + :: implicit, instead of explicit at the end of the wire. if we + :: detect we used the old wire here, we must re-use that format + :: (without id in the wire) for sending the %leave. + ?:(old (snip wire) wire) + [as ship app %leave ~] + :: +emit-event: records an event occurred, possibly sending to client + :: + :: When an event occurs, we need to record it, even if we immediately + :: send it to a connected browser so in case of disconnection, we can + :: resend it. + :: + :: This function is responsible for taking the event sign and converting + :: it into a text/event-stream. The :sign then may get sent, and is + :: stored for later resending until acknowledged by the client. + :: + ++ emit-event + |= [channel-id=@t request-id=@ud =sign:agent:gall] + ^- [(list move) server-state] + :: + =/ channel=(unit channel) + (~(get by session.channel-state.state) channel-id) + ?~ channel + :_ state :_ ~ + [duct %pass /flog %d %flog %crud %eyre-no-channel >id=channel-id< ~] + :: it's possible that this is a sign emitted directly alongside a fact + :: that triggered a clog & closed the subscription. in that case, just + :: drop the sign. + :: poke-acks are not paired with subscriptions, so we can process them + :: regardless. + :: + ?: ?& !?=(%poke-ack -.sign) + !(~(has by subscriptions.u.channel) request-id) + == + [~ state] + :: attempt to convert the sign to json. + :: if conversion succeeds, we *can* send it. if the client is actually + :: connected, we *will* send it immediately. + :: + =/ maybe-channel-event=(unit channel-event) + (sign-to-channel-event sign u.channel request-id) + ?~ maybe-channel-event [~ state] + =/ =channel-event u.maybe-channel-event + =/ said=(unit (quip move tape)) + (channel-event-to-tape u.channel request-id channel-event) + =? moves ?=(^ said) + (weld moves -.u.said) + =* sending &(?=([%| *] state.u.channel) ?=(^ said)) + :: + =/ next-id next-id.u.channel + :: if we can send it, store the event as unacked + :: + =? events.u.channel ?=(^ said) + %- ~(put to events.u.channel) + [next-id request-id channel-event] + :: if it makes sense to do so, send the event to the client + :: + =? moves sending + ^- (list move) + :_ moves + ::NOTE assertions in this block because =* is flimsy + ?> ?=([%| *] state.u.channel) + :+ p.state.u.channel %give + ^- gift + :* %response %continue + :: + ^= data + %- wall-to-octs + (event-tape-to-wall next-id +:(need said)) + :: + complete=%.n + == + =? next-id ?=(^ said) +(next-id) + :: update channel's unacked counts, find out if clogged + :: + =^ clogged unacked.u.channel + :: only apply clog logic to facts. + :: and of course don't count events we can't send as unacked. + :: + ?: ?| !?=(%fact -.sign) + ?=(~ said) + == + [| unacked.u.channel] + =/ num=@ud + (~(gut by unacked.u.channel) request-id 0) + :_ (~(put by unacked.u.channel) request-id +(num)) + ?& (gte num clog-threshold) + (lth (add last-ack.u.channel clog-timeout) now) + == + :: if we're clogged, or we ran into an event we can't serialize, + :: kill this gall subscription. + :: + =* msg=tape "on {(trip channel-id)} for {(scow %ud request-id)}" + =/ kicking=? + ?: clogged + ((trace 0 |.("clogged {msg}")) &) + ?. ?=(~ said) | + ((trace 0 |.("can't serialize event, kicking {msg}")) &) + =? moves kicking + :_ moves + ::NOTE this shouldn't crash because we + :: - never fail to serialize subscriptionless signs (%poke-ack), + :: - only clog on %facts, which have a subscription associated, + :: - and already checked whether we still have that subscription. + =+ (~(got by subscriptions.u.channel) request-id) + %- (trace 1 |.("leaving subscription to {<app>}")) + %+ deal-as + (subscription-wire channel-id request-id identity.u.channel ship app) + [identity.u.channel ship app %leave ~] + :: update channel state to reflect the %kick + :: + =? u.channel kicking + %_ u.channel + subscriptions (~(del by subscriptions.u.channel) request-id) + unacked (~(del by unacked.u.channel) request-id) + events %- ~(put to events.u.channel) + :+ next-id + request-id + (need (sign-to-channel-event [%kick ~] u.channel request-id)) + == + :: if a client is connected, send the kick event to them + :: + =? moves &(kicking ?=([%| *] state.u.channel)) + :_ moves + :+ p.state.u.channel %give + ^- gift + :* %response %continue + :: + ^= data + %- wall-to-octs + %+ event-tape-to-wall next-id + +:(need (channel-event-to-tape u.channel request-id %kick ~)) + :: + complete=%.n + == + =? next-id kicking +(next-id) + :: + :- (flop moves) + %_ state + session.channel-state + %+ ~(put by session.channel-state.state) channel-id + u.channel(next-id next-id) + == + :: +sign-to-channel-event: strip the vase from a sign:agent:gall + :: + ++ sign-to-channel-event + |= [=sign:agent:gall =channel request-id=@ud] + ^- (unit channel-event) + ?. ?=(%fact -.sign) `sign + ?~ desk=(app-to-desk channel request-id) ~ + :- ~ + [%fact u.desk [p q.q]:cage.sign] + :: +app-to-desk + :: + ++ app-to-desk + |= [=channel request-id=@ud] + ^- (unit desk) + =/ sub (~(get by subscriptions.channel) request-id) + ?~ sub + ((trace 0 |.("no subscription for request-id {(scow %ud request-id)}")) ~) + =/ des=(unit (unit cage)) + (rof [~ ~] /eyre %gd [our app.u.sub da+now] /$) + ?. ?=([~ ~ *] des) + ((trace 0 |.("no desk for app {<app.u.sub>}")) ~) + `!<(=desk q.u.u.des) + :: +channel-event-to-tape: render channel-event from request-id in specified mode + :: + ++ channel-event-to-tape + |= [=channel request-id=@ud =channel-event] + ^- (unit (quip move tape)) + ?- mode.channel + %json %+ bind (channel-event-to-json channel request-id channel-event) + |=((quip move json) [+<- (trip (en:json:html +<+))]) + %jam =- `[~ (scow %uw (jam -))] + [request-id channel-event] + == + :: +channel-event-to-json: render channel event as json channel event + :: + ++ channel-event-to-json + ~% %eyre-channel-event-to-json ..part ~ + |= [=channel request-id=@ud event=channel-event] + ^- (unit (quip move json)) + :: for facts, we try to convert the result to json + :: + =/ [from=(unit [=desk =mark]) jsyn=(unit sign:agent:gall)] + ?. ?=(%fact -.event) [~ `event] + ?: ?=(%json mark.event) + ?~ jsin=((soft json) noun.event) + %. [~ ~] + (slog leaf+"eyre: dropping fake json for {(scow %ud request-id)}" ~) + [~ `[%fact %json !>(u.jsin)]] + :: find and use tube from fact mark to json + :: + :: + =* have=mark mark.event + =/ convert=(unit vase) + =/ cag=(unit (unit cage)) + (rof [~ ~] /eyre %cf [our desk.event da+now] /[have]/json) + ?. ?=([~ ~ *] cag) ~ + `q.u.u.cag + ?~ convert + ((trace 0 |.("no convert from {(trip have)} to json")) [~ ~]) + ~| "conversion failed from {(trip have)} to json" + [`[desk.event have] `[%fact %json (slym u.convert noun.event)]] + ?~ jsyn ~ + %- some + :- ?~ from ~ + :_ ~ + :^ duct %pass /conversion-cache/[mark.u.from] + [%c %warp our desk.u.from `[%sing %f da+now /[mark.u.from]/json]] + =* sign u.jsyn + =, enjs:format + %- pairs + ^- (list [@t json]) + :- ['id' (numb request-id)] + ?- -.sign + %poke-ack + :~ ['response' [%s 'poke']] + :: + ?~ p.sign + ['ok' [%s 'ok']] + ['err' (wall (render-tang-to-wall 100 u.p.sign))] + == + :: + %fact + :+ ['response' [%s 'diff']] + :- 'json' + ~| [%unexpected-fact-mark p.cage.sign] + ?> =(%json p.cage.sign) + !<(json q.cage.sign) + :: + ?~ from ~ + ['mark' [%s mark.u.from]]~ + :: + %kick + ['response' [%s 'quit']]~ + :: + %watch-ack + :~ ['response' [%s 'subscribe']] + :: + ?~ p.sign + ['ok' [%s 'ok']] + ['err' (wall (render-tang-to-wall 100 u.p.sign))] + == + == + :: + ++ event-tape-to-wall + ~% %eyre-tape-to-wall ..part ~ + |= [event-id=@ud =tape] + ^- wall + :~ (weld "id: " (a-co:co event-id)) + (weld "data: " tape) + "" + == + :: + ++ on-channel-heartbeat + |= channel-id=@t + ^- [(list move) server-state] + :: + =/ res + %- handle-response + :* %continue + data=(some (as-octs:mimes:html ':\0a')) + complete=%.n + == + =/ http-moves -.res + =/ new-state +.res + =/ heartbeat-time=@da (add now ~s20) + :_ %_ new-state + session.channel-state + %+ ~(jab by session.channel-state.state) channel-id + |= =channel + channel(heartbeat (some [heartbeat-time duct])) + == + (snoc http-moves (set-heartbeat-move channel-id heartbeat-time)) + :: +discard-channel: remove a channel from state + :: + :: cleans up state, timers, and gall subscriptions of the channel + :: + ++ discard-channel + |= [channel-id=@t expired=?] + ^- [(list move) server-state] + :: + =/ usession=(unit channel) + (~(get by session.channel-state.state) channel-id) + ?~ usession + [~ state] + =/ session=channel u.usession + :: + :_ %_ state + session.channel-state + (~(del by session.channel-state.state) channel-id) + :: + duct-to-key.channel-state + ?. ?=(%| -.state.session) duct-to-key.channel-state.state + (~(del by duct-to-key.channel-state.state) p.state.session) + == + =/ heartbeat-cancel=(list move) + ?~ heartbeat.session ~ + :~ %^ cancel-heartbeat-move + channel-id + date.u.heartbeat.session + duct.u.heartbeat.session + == + =/ expire-cancel=(list move) + ?: expired ~ + ?. ?=(%& -.state.session) ~ + =, p.state.session + [(cancel-timeout-move channel-id date duct)]~ + %+ weld heartbeat-cancel + %+ weld expire-cancel + :: produce a list of moves which cancels every gall subscription + :: + %+ turn ~(tap by subscriptions.session) + |= [request-id=@ud ship=@p app=term =path duc=^duct] + ^- move + %- (trace 1 |.("{<channel-id>} leaving subscription to {<app>}")) + %+ deal-as(duct duc) + (subscription-wire channel-id request-id identity.session ship app) + [identity.session ship app %leave ~] + -- + :: +handle-gall-error: a call to +poke-http-response resulted in a %coup + :: + ++ handle-gall-error + |= =tang + ^- [(list move) server-state] + :: + ?~ connection-state=(~(get by connections.state) duct) + %. `state + (trace 0 |.("{<duct>} error on invalid outstanding connection")) + =* connection u.connection-state + =/ moves-1=(list move) + ?. ?=(%app -.action.connection) + ~ + :_ ~ + =, connection + %- (trace 1 |.("leaving subscription to {<app.action>}")) + (deal-as /watch-response/[eyre-id] identity our app.action %leave ~) + :: + =^ moves-2 state + %^ return-static-data-on-duct 500 'text/html' + :: + %- internal-server-error :* + authenticated.inbound-request.connection + url.request.inbound-request.connection + tang + == + [(weld moves-1 moves-2) state] + :: +handle-response: check a response for correctness and send to earth + :: + :: All outbound responses including %http-server generated responses need to go + :: through this interface because we want to have one centralized place + :: where we perform logging and state cleanup for connections that we're + :: done with. + :: + ++ handle-ws-response + |= [wid=@ event=websocket-event] + ^- [(list move) server-state] + ~& eyre-handle-ws-response=event + :: TODO remove if not accepted? + =. connections.state + ?. ?=(%reject -.event) connections.state + (~(del by connections.state) duct) + + :: TODO do all verification shit that handle-response is doing + [[duct %give %websocket-response [wid event]]~ state] + + ++ handle-response + |= =http-event:http + ^- [(list move) server-state] + :: verify that this is a valid response on the duct + :: + ?~ connection-state=(~(get by connections.state) duct) + ((trace 0 |.("{<duct>} invalid outstanding connection")) `state) + :: + |^ ^- [(list move) server-state] + :: + ?- -.http-event + :: + %start + ?^ response-header.u.connection-state + ((trace 0 |.("{<duct>} error multiple start")) error-connection) + :: extend the request's session's + cookie's life + :: + =^ response-header sessions.auth.state + =, authentication + =* session-id session-id.u.connection-state + =* sessions sessions.auth.state + =* inbound inbound-request.u.connection-state + =* headers headers.response-header.http-event + :: + ?~ ses=(~(get by sessions) session-id) + :: if the session has expired since the request was opened, + :: tough luck, we don't create/revive sessions here + :: + [response-header.http-event sessions] + =/ kind ?:(?=(%fake -.identity.u.ses) %guest %auth) + =/ timeout + =, session-timeout + ?:(?=(%guest kind) guest auth) + :_ %+ ~(put by sessions) session-id + u.ses(expiry-time (add now timeout)) + =- response-header.http-event(headers -) + =/ cookie=(pair @t @t) + ['set-cookie' (session-cookie-string session-id `kind)] + |- + ?~ headers + [cookie ~] + ?: &(=(key.i.headers p.cookie) =(value.i.headers q.cookie)) + headers + [i.headers $(headers t.headers)] + :: + =* connection u.connection-state + :: + :: if the request was a simple cors request from an approved origin + :: append the necessary cors headers to the response + :: + =/ origin=(unit origin) + %+ get-header:http 'origin' + header-list.request.inbound-request.connection + =? headers.response-header + ?& ?=(^ origin) + (~(has in approved.cors-registry.state) u.origin) + == + %^ set-header:http 'Access-Control-Allow-Origin' u.origin + %^ set-header:http 'Access-Control-Allow-Credentials' 'true' + headers.response-header + :: + =. response-header.http-event response-header + =. connections.state + ?: complete.http-event + :: XX optimize by not requiring +put:by in +request + :: + (~(del by connections.state) duct) + :: + %- (trace 2 |.("{<duct>} start")) + %+ ~(put by connections.state) duct + %= connection + response-header `response-header + bytes-sent ?~(data.http-event 0 p.u.data.http-event) + == + :: + pass-response + :: + %continue + ?~ response-header.u.connection-state + %. error-connection + (trace 0 |.("{<duct>} error continue without start")) + :: + =. connections.state + ?: complete.http-event + %- (trace 2 |.("{<duct>} completed")) + (~(del by connections.state) duct) + :: + %- (trace 2 |.("{<duct>} continuing")) + ?~ data.http-event + connections.state + :: + %+ ~(put by connections.state) duct + =* size p.u.data.http-event + =* conn u.connection-state + conn(bytes-sent (add size bytes-sent.conn)) + :: + pass-response + :: + %cancel + :: todo: log this differently from an ise. + :: + ((trace 1 |.("cancel http event")) error-connection) + == + :: + ++ pass-response + ^- [(list move) server-state] + [[duct %give %response http-event]~ state] + :: + ++ error-connection + :: todo: log application error + :: + :: remove all outstanding state for this connection + :: + =. connections.state + (~(del by connections.state) duct) + :: respond to outside with %error + :: + ^- [(list move) server-state] + :_ state + :- [duct %give %response %cancel ~] + ?. ?=(%app -.action.u.connection-state) + ~ + :_ ~ + =, u.connection-state + %- %+ trace 1 + |.("leaving subscription to {<app.action>}") + (deal-as /watch-response/[eyre-id] identity our app.action %leave ~) + -- + :: +set-response: remember (or update) a cache mapping + :: + ++ set-response + |= [url=@t entry=(unit cache-entry)] + ^- [(list move) server-state] + =/ aeon ?^(prev=(~(get by cache.state) url) +(aeon.u.prev) 1) + =. cache.state (~(put by cache.state) url [aeon entry]) + :_ state + ::NOTE during boot, userspace might've sent us this before we received + :: our first %born, with which we initialize the outgoing-duct. + :: it's fine to hold off on the %grow here, we'll re-send them + :: whenever we finally receive the %born. + ?: =(~ outgoing-duct.state) ~ + [outgoing-duct.state %give %grow /cache/(scot %ud aeon)/(scot %t url)]~ + :: +add-binding: conditionally add a pairing between binding and action + :: + :: Adds =binding =action if there is no conflicting bindings. + :: + ++ add-binding + |= [=binding =action] + ^- [(list move) server-state] + =^ success bindings.state + :: prevent binding in reserved namespaces + :: + ?: ?| ?=([%'~' *] path.binding) :: eyre + ?=([%'~_~' *] path.binding) :: runtime + ?=([%'_~_' *] path.binding) :: scries + == + [| bindings.state] + [& (insert-binding [binding duct action] bindings.state)] + :_ state + [duct %give %bound & binding]~ + :: +remove-binding: removes a binding if it exists and is owned by this duct + :: + ++ remove-binding + |= =binding + :: + ^- server-state + %_ state + bindings + %+ skip bindings.state + |= [item-binding=^binding item-duct=^duct =action] + ^- ? + &(=(item-binding binding) =(item-duct duct)) + == + :: +get-action-for-binding: finds an action for an incoming web request + :: + ++ get-action-for-binding + |= [raw-host=(unit @t) url=@t] + ^- [=action suburl=@t] + :: process :raw-host + :: + :: If we are missing a 'Host:' header, if that header is a raw IP + :: address, or if the 'Host:' header refers to [our].urbit.org, we want + :: to return ~ which means we're unidentified and will match against any + :: wildcard matching. + :: + :: Otherwise, return the site given. + :: + =/ host=(unit @t) + ?~ raw-host + ~ + :: Parse the raw-host so that we can ignore ports, usernames, etc. + :: + =+ parsed=(rush u.raw-host simplified-url-parser) + ?~ parsed + ~ + :: if the url is a raw IP, assume default site. + :: + ?: ?=([%ip *] -.u.parsed) + ~ + :: if the url is "localhost", assume default site. + :: + ?: =([%site 'localhost'] -.u.parsed) + ~ + :: render our as a tape, and cut off the sig in front. + :: + =/ with-sig=tape (scow %p our) + ?> ?=(^ with-sig) + ?: =(u.raw-host (crip t.with-sig)) + :: [our].urbit.org is the default site + :: + ~ + :: + raw-host + :: url is the raw thing passed over the 'Request-Line'. + :: + :: todo: this is really input validation, and we should return a 500 to + :: the client. + :: + =/ request-line (parse-request-line url) + =/ parsed-url=(list @t) site.request-line + =? parsed-url ?=([%'~' %channel-jam *] parsed-url) + parsed-url(i.t %channel) + :: + =/ bindings bindings.state + |- + :: + ?~ bindings + [[%four-oh-four ~] url] + :: + ?. (host-matches site.binding.i.bindings raw-host) + $(bindings t.bindings) + ?~ suffix=(find-suffix path.binding.i.bindings parsed-url) + $(bindings t.bindings) + :: + :- action.i.bindings + %^ cat 3 + %+ roll + ^- (list @t) + (join '/' (flop ['' u.suffix])) + (cury cat 3) + ?~ ext.request-line '' + (cat 3 '.' u.ext.request-line) + :: +give-session-tokens: send valid local session tokens to unix + :: + ++ give-session-tokens + ^- move + :- outgoing-duct.state + :+ %give %sessions + %- sy + %+ murn ~(tap by sessions.auth.state) + |= [sid=@uv session] + ?. ?=(%ours -.identity) ~ + (some (scot %uv sid)) + :: +new-session-key + :: + ++ new-session-key + |- ^- @uv + =/ candidate=@uv (~(raw og (shas %session-key eny)) 128) + ?. (~(has by sessions.auth.state) candidate) + candidate + $(eny (shas %try-again candidate)) + :: + ++ deal-as + |= [=wire identity=$@(@p identity) =ship =dude:gall =task:agent:gall] + ^- move + =/ from=@p + ?@ identity identity + ?+(-.identity who.identity %ours our) + [duct %pass wire %g %deal [from ship /eyre] dude task] + :: + ++ trace + |= [pri=@ print=(trap tape)] + ?: (lth verb.state pri) same + (slog leaf+"eyre: {(print)}" ~) + -- +:: +++ forwarded-params + |= =header-list:http + ^- (unit (list (map @t @t))) + %+ biff + (get-header:http 'forwarded' header-list) + unpack-header:http +:: +++ forwarded-for + |= forwards=(list (map @t @t)) + ^- (unit address) + ?. ?=(^ forwards) ~ + =* forward i.forwards + ?~ for=(~(get by forward) 'for') ~ + ::NOTE per rfc7239, non-ip values are also valid. they're not useful + :: for the general case, so we ignore them here. if needed, + :: request handlers are free to inspect the headers themselves. + :: + %+ rush u.for + ;~ sfix + ;~(pose (stag %ipv4 ip4) (stag %ipv6 (ifix [sel ser] ip6))) + ;~(pose ;~(pfix col dim:ag) (easy ~)) + == +:: +++ forwarded-secure + |= forwards=(list (map @t @t)) + ^- (unit ?) + ?. ?=(^ forwards) ~ + =* forward i.forwards + ?~ proto=(~(get by forward) 'proto') ~ + ?+ u.proto ~ + %http `| + %https `& + == +:: +++ forwarded-host + |= forwards=(list (map @t @t)) + ^- (unit @t) + ?. ?=(^ forwards) ~ + (~(get by i.forwards) 'host') +:: +++ parse-request-line + |= url=@t + ^- [[ext=(unit @ta) site=(list @t)] args=(list [key=@t value=@t])] + (fall (rush url ;~(plug apat:de-purl:html yque:de-purl:html)) [[~ ~] ~]) +:: +insert-binding: add a new binding, replacing any existing at its path +:: +++ insert-binding + |= $: new=[=binding =duct =action] + bindings=(list [=binding =duct =action]) + == + ^+ bindings + ?~ bindings [new]~ + =* bid binding.i.bindings + :: replace already bound paths + :: + ?: =([site path]:bid [site path]:binding.new) + ~> %slog.[0 leaf+"eyre: replacing existing binding at {<`path`path.bid>}"] + [new t.bindings] + :: if new comes before bid, prepend it. + :: otherwise, continue our search. + :: + =; new-before-bid=? + ?: new-before-bid [new bindings] + [i.bindings $(bindings t.bindings)] + ?: =(site.binding.new site.bid) + (aor path.bid path.binding.new) + (aor (fall site.bid '') (fall site.binding.new '')) +:: +++ channel-wire + |= [channel-id=@t request-id=@ud] + ^- wire + /channel/subscription/[channel-id]/(scot %ud request-id) +:: +++ subscription-wire + |= [channel-id=@t request-id=@ud as=$@(@p identity) =ship app=term] + ^- wire + =/ from=@p + ?@ as as + ?+(-.as who.as %ours our) + %+ weld (channel-wire channel-id request-id) + ::NOTE including the originating identity is important for the band-aid + :: solution currently present in +on-gall-response, where we may + :: need to issue a %leave after we've forgotten the identity with + :: which the subscription was opened. + /(scot %p ship)/[app]/(scot %p from) +:: +++ scry-mime + |= [now=@da rof=roof =gang ext=(unit @ta) pax=path] + |^ ^- (each mime tape) + :: parse + :: + =/ u=(unit [view=term bem=beam]) + ?. ?=([@ @ @ @ *] pax) ~ + ?~ view=(slaw %tas i.t.pax) ~ + ?~ path=(expand-path t.t.pax) ~ + ?~ beam=(de-beam u.path) ~ + `[u.view u.beam] + ?~ u [%| "invalid scry path"] + :: perform scry + :: + ?~ res=(rof gang /eyre u.u) [%| "failed scry"] + ?~ u.res [%| "no scry result"] + =* mark p.u.u.res + =* vase q.u.u.res + :: convert to mime via ext + :: + =/ dysk (conversion-desk u.u) + ?: ?=(%| -.dysk) [%| p.dysk] + =/ ext (fall ext %mime) + =/ mym (convert vase mark ext p.dysk) + ?: ?=(%| -.mym) [%| p.mym] + =/ mym (convert p.mym ext %mime p.dysk) + ?: ?=(%| -.mym) [%| p.mym] + [%& !<(mime p.mym)] + :: + ++ expand-path + |= a=path + ^- (unit path) + =/ vez (vang | (en-beam [our %base da+now] ~)) + (rush (spat a) (sear plex:vez (stag %clsg ;~(pfix fas poor:vez)))) + :: + ++ conversion-desk + |= [view=term =beam] + ^- (each desk tape) + ?: =(%$ q.beam) [%& %base] + ?+ (end 3 view) [%& %base] + %c + [%& q.beam] + %g + =/ res (rof [~ ~] /eyre %gd [our q.beam da+now] /$) + ?. ?=([~ ~ *] res) + [%| "no desk for app {<q.beam>}"] + [%& !<(=desk q.u.u.res)] + == + :: + ++ convert + |= [=vase from=mark to=mark =desk] + ^- (each ^vase tape) + ?: =(from to) [%& vase] + =/ tub (rof [~ ~] /eyre %cc [our desk da+now] /[from]/[to]) + ?. ?=([~ ~ %tube *] tub) + [%| "no tube from {(trip from)} to {(trip to)}"] + =/ tube !<(tube:clay q.u.u.tub) + =/ res (mule |.((tube vase))) + ?: ?=(%| -.res) + [%| "failed tube from {(trip from)} to {(trip to)}"] + [%& +.res] + -- +-- +:: end the =~ +:: +. == +:: begin with a default +axle as a blank slate +:: +=| ax=axle +:: a vane is activated with current date, entropy, and a namespace function +:: +|= [now=@da eny=@uvJ rof=roof] +:: allow jets to be registered within this core +:: +~% %http-server ..part ~ +|% +++ call + ~/ %eyre-call + |= [=duct dud=(unit goof) wrapped-task=(hobo task)] + ^- [(list move) _http-server-gate] + :: + =/ task=task ((harden task) wrapped-task) + ~& > eyre-task=[-.task duct=duct] + :: + :: XX handle more error notifications + :: + ?^ dud + :_ http-server-gate + :: always print the error trace + :: + :- [duct %slip %d %flog %crud [-.task tang.u.dud]] + ^- (list move) + :: if a request caused the crash, respond with a 500 + :: + ?. ?=(?(%request %request-local) -.task) ~ + ^~ + =/ data (as-octs:mimes:html 'crud!') + =/ head + :~ ['content-type' 'text/html'] + ['content-length' (crip (a-co:co p.data))] + == + [duct %give %response %start 500^head `data &]~ + :: due to an error handling bug in earlier versions of +take, + :: we may need to make sure the timeout timer for sessions still exists. + :: see also urbit/urbit#7103 + :: + ?: check-session-timer.server-state.ax + :: we do this cleanup exactly once + :: + =. check-session-timer.server-state.ax | + :: if there are no sessions after running the +call, + :: we don't need a timer, so we don't need to set it + :: + ::NOTE hazard, must get state from .etc going forward + =/ [moz=(list move) etc=_http-server-gate] $ + :_ etc + ^- (list move) + ?: =(~ sessions.auth.server-state.ax.etc) moz + :: if .moz is already setting the timer, + :: we don't need to do it here + :: + ?: %+ lien moz + |= m=move + ?=([* %pass [%sessions %expire ~] *] m) + moz + :: find out from behn if there isn't already a timer set. + :: this is not ideal, but we have no other way of knowing, + :: and don't want to set duplicate timers... + :: + ?: ?~ res=(rof [~ ~] /eyre %bx [our %$ da+now] /debug/timers) | + ?~ u.res | + %+ lien !<((list [@da ^duct]) q.u.u.res) + |= [@da d=^duct] + ?=([[%eyre %sessions %expire ~] *] d) + moz + :: we need a timer, but aren't setting one, and don't have one, + :: so prepend a session expire timer to the .moz + :: + [[duct %pass /sessions/expire %b %wait now] moz] + :: %init: tells us what our ship name is + :: + ?: ?=(%init -.task) + :: initial value for the login handler + :: + =. bindings.server-state.ax + =- (roll - insert-binding) + ^- (list [binding ^duct action]) + :~ [[~ /~/login] duct [%authentication ~]] + [[~ /~/eauth] duct [%eauth ~]] + [[~ /~/logout] duct [%logout ~]] + [[~ /~/channel] duct [%channel ~]] + [[~ /~/scry] duct [%scry ~]] + [[~ /~/name] duct [%name ~]] + [[~ /~/host] duct [%host ~]] + [[~ /~/ip] duct [%ip ~]] + [[~ /~/boot] duct [%boot ~]] + [[~ /~/sponsor] duct [%sponsor ~]] + == + [~ http-server-gate] + :: %trim: in response to memory pressure + :: + :: Cancel all inactive channels + :: XX cancel active too if =(0 trim-priority) ? + :: + ?: ?=(%trim -.task) + =* event-args [[eny duct now rof] server-state.ax] + =* by-channel by-channel:(per-server-event event-args) + =* channel-state channel-state.server-state.ax + :: + =/ inactive=(list @t) + =/ full=(set @t) ~(key by session.channel-state) + =/ live=(set @t) + (~(gas in *(set @t)) ~(val by duct-to-key.channel-state)) + ~(tap in (~(dif in full) live)) + :: + ?: =(~ inactive) + [~ http-server-gate] + :: + =/ len=tape (scow %ud (lent inactive)) + ~> %slog.[0 leaf+"eyre: trim: closing {len} inactive channels"] + :: + =| moves=(list (list move)) + |- ^- [(list move) _http-server-gate] + =* channel-id i.inactive + ?~ inactive + [(zing (flop moves)) http-server-gate] + :: discard channel state, and cancel any active gall subscriptions + :: + =^ mov server-state.ax (discard-channel:by-channel channel-id |) + $(moves [mov moves], inactive t.inactive) + :: + :: %vega: notifies us of a completed kernel upgrade + :: + ?: ?=(%vega -.task) + [~ http-server-gate] + :: %born: new unix process + :: + ?: ?=(%born -.task) + :: close previously open connections + :: + :: When we have a new unix process, every outstanding open connection is + :: dead. For every duct, send an implicit close connection. + :: + =^ closed-connections=(list move) server-state.ax + =/ connections=(list [=^duct *]) + ~(tap by connections.server-state.ax) + :: + =| closed-connections=(list move) + |- + ?~ connections + [closed-connections server-state.ax] + :: + =/ event-args + [[eny duct.i.connections now rof] server-state.ax] + =/ cancel-request cancel-request:(per-server-event event-args) + =^ moves server-state.ax cancel-request + :: + $(closed-connections (weld moves closed-connections), connections t.connections) + :: save duct for future %give to unix + :: + =. outgoing-duct.server-state.ax duct + :: send all cache mappings to runtime + :: + =/ cache-moves=(list move) + %+ turn ~(tap by cache.server-state.ax) + |= [url=@t cache-val=[aeon=@ud val=(unit cache-entry)]] + [duct %give %grow /cache/(scot %u aeon.cache-val)/(scot %t url)] + :: + :_ http-server-gate + :* :: hand back default configuration for now + :: + [duct %give %set-config http-config.server-state.ax] + :: provide a list of valid auth tokens + :: + =< give-session-tokens + (per-server-event [eny duct now rof] server-state.ax) + :: + (zing ~[closed-connections cache-moves]) + == + :: + ?: ?=(%code-changed -.task) + ~> %slog.[0 leaf+"eyre: code-changed: throwing away local sessions"] + =* event-args [[eny duct now rof] server-state.ax] + :: find all the %ours sessions, we must close them + :: + =/ siz=(list @uv) + %+ murn ~(tap by sessions.auth.server-state.ax) + |= [sid=@uv session] + ?:(?=(%ours -.identity) (some sid) ~) + =| moves=(list (list move)) + |- ^- [(list move) _http-server-gate] + ?~ siz + [(zing (flop moves)) http-server-gate] + :: discard the session, clean up its channels + :: + =^ mov server-state.ax + (close-session:authentication:(per-server-event event-args) i.siz |) + $(moves [mov moves], siz t.siz) + :: + ?: ?=(%eauth-host -.task) + ?: =(user.endpoint.auth.server-state.ax host.task) + [~ http-server-gate] + =. user.endpoint.auth.server-state.ax host.task + =. time.endpoint.auth.server-state.ax now + [~ http-server-gate] + :: + :: all other commands operate on a per-server-event + :: + =/ event-args [[eny duct now rof] server-state.ax] + =/ server (per-server-event event-args) + :: + ?- -.task + :: %live: notifies us of the ports of our live http servers + :: + %live + =. ports.server-state.ax +.task + :: enable http redirects if https port live and cert set + :: + =. redirect.http-config.server-state.ax + &(?=(^ secure.task) ?=(^ secure.http-config.server-state.ax)) + [~ http-server-gate] + :: %rule: updates our http configuration + :: + %rule + ?- -.http-rule.task + :: %cert: install tls certificate + :: + %cert + =* config http-config.server-state.ax + ?: =(secure.config cert.http-rule.task) + [~ http-server-gate] + =. secure.config cert.http-rule.task + =. redirect.config + ?& ?=(^ secure.ports.server-state.ax) + ?=(^ cert.http-rule.task) + == + :_ http-server-gate + =* out-duct outgoing-duct.server-state.ax + ?~ out-duct ~ + [out-duct %give %set-config config]~ + :: %turf: add or remove domain name + :: + %turf + =* domains domains.server-state.ax + =/ mod=(set turf) + ?- -.action.http-rule.task + %put (~(put in domains) turf.action.http-rule.task) + %del (~(del in domains) turf.action.http-rule.task) + %new turfs.action.http-rule.task + == + ?: &(!?=(%new -.action.http-rule.task) =(domains mod)) + [~ http-server-gate] + =. domains mod + :_ http-server-gate + =/ cmd + [%acme %poke `cage`[%acme-order !>(mod)]] + [duct %pass /acme/order %g %deal [our our /eyre] cmd]~ + == + :: + %plea + ~| path.plea.task + ?> ?=([%eauth %'0' ~] path.plea.task) + =+ plea=;;(eauth-plea payload.plea.task) + =^ moves server-state.ax + (on-plea:server:eauth:authentication:server ship.task plea) + [moves http-server-gate] + :: + %request + =^ moves server-state.ax (request:server +.task) + [moves http-server-gate] + :: + %request-local + =^ moves server-state.ax (request-local:server +.task) + [moves http-server-gate] + :: + %cancel-request + =^ moves server-state.ax cancel-request:server + [moves http-server-gate] + :: + %connect + =^ moves server-state.ax + %+ add-binding:server binding.task + [%app app.task] + [moves http-server-gate] + :: + %serve + =^ moves server-state.ax + %+ add-binding:server binding.task + [%gen generator.task] + [moves http-server-gate] + :: + %disconnect + =. server-state.ax (remove-binding:server binding.task) + [~ http-server-gate] + :: + %approve-origin + =. cors-registry.server-state.ax + =, cors-registry.server-state.ax + :+ (~(del in requests) origin.task) + (~(put in approved) origin.task) + (~(del in rejected) origin.task) + [~ http-server-gate] + :: + %reject-origin + =. cors-registry.server-state.ax + =, cors-registry.server-state.ax + :+ (~(del in requests) origin.task) + (~(del in approved) origin.task) + (~(put in rejected) origin.task) + [~ http-server-gate] + :: + %spew + =. verb.server-state.ax veb.task + `http-server-gate + :: + %set-response + =^ moves server-state.ax (set-response:server +.task) + [moves http-server-gate] + %websocket-event + ~& websocket-event=+.task + =^ moves server-state.ax (ws-event:server +.task) + [moves http-server-gate] + + + %websocket-handshake + =^ moves server-state.ax (ws-handshake:server +.task) + [moves http-server-gate] + == +:: +++ take + ~/ %eyre-take + |= [=wire =duct dud=(unit goof) =sign] + ~& >>> duct=duct + ~& >> take-wire-eyre=wire + ^- [(list move) _http-server-gate] + => %= . + sign + ?: ?=(%gall -.sign) + ?> ?=(%unto +<.sign) + sign + sign + == + :: :wire must at least contain two parts, the type and the build + :: + ?> ?=([@ *] wire) + :: + |^ ^- [(list move) _http-server-gate] + :: + ?: ?=(%eauth i.wire) + eauth + ?^ dud + ~|(%eyre-take-dud (mean tang.u.dud)) + ?+ i.wire + ~|([%bad-take-wire wire] !!) + :: + %run-app-request run-app-request + %watch-response watch-response + %sessions sessions + %channel channel + %acme acme-ack + %conversion-cache `http-server-gate + %run-ws-app-request run-ws-app-request + %ws-watch-response watch-ws-response + == + :: + ++ watch-ws-response + =/ event-args [[eny duct now rof] server-state.ax] + ?> ?=([@ *] t.wire) + ~& >> ws-sign=[`@t`-.sign `@t`+<.sign ((soft @t) +>-.sign)] + ?+ sign `http-server-gate + [%gall %unto %watch-ack *] + ?~ p.p.sign + :: received a positive acknowledgment: take no action + :: + [~ http-server-gate] + :: we have an error; propagate it to the client + :: + ~& gall-error=u.p.p.sign + =/ handle-gall-error + handle-gall-error:(per-server-event event-args) + =^ moves server-state.ax (handle-gall-error u.p.p.sign) + [moves http-server-gate] + [%gall %unto %fact *] + =/ mark p.cage.p.sign + ~& > eyre-ws-response-fact=mark + ?. ?=(%websocket-response mark) + =/ handle-gall-error + handle-gall-error:(per-server-event event-args) + =^ moves server-state.ax + (handle-gall-error leaf+"eyre bad mark {(trip mark)}" ~) + [moves http-server-gate] + ~& websocket-vase=q.q.cage.p.sign + =/ event !<([@ websocket-event] q.cage.p.sign) + =/ handle-ws-response handle-ws-response:(per-server-event event-args) + =^ moves server-state.ax + (handle-ws-response event) + [moves http-server-gate] + + == + ++ run-ws-app-request + ~& run-ws-app-req=sign + + `http-server-gate + + ++ run-app-request + :: + ?> ?=([%gall %unto *] sign) + :: + :: + :: ~& run-app-req-eyre=p.sign + ?> ?=([%poke-ack *] p.sign) + ?> ?=([@ *] t.wire) + ?~ p.p.sign + :: received a positive acknowledgment: take no action + :: + [~ http-server-gate] + :: we have an error; propagate it to the client + :: + =/ event-args [[eny duct now rof] server-state.ax] + =/ handle-gall-error + handle-gall-error:(per-server-event event-args) + =^ moves server-state.ax + (handle-gall-error u.p.p.sign) + [moves http-server-gate] + :: + ++ watch-response + :: + =/ event-args [[eny duct now rof] server-state.ax] + :: + ?> ?=([@ *] t.wire) + ~& >> http-sign=[`@t`-.sign `@t`+<.sign ((soft @t) +>-.sign)] + ?: ?=([%gall %unto %watch-ack *] sign) + ?~ p.p.sign + :: received a positive acknowledgment: take no action + :: + [~ http-server-gate] + :: we have an error; propagate it to the client + :: + ~& eyre-watch-response-gall-error=duct + =/ handle-gall-error + handle-gall-error:(per-server-event event-args) + =^ moves server-state.ax (handle-gall-error u.p.p.sign) + [moves http-server-gate] + :: + ?: ?=([%gall %unto %kick ~] sign) + =/ handle-response handle-response:(per-server-event event-args) + =^ moves server-state.ax + (handle-response %continue ~ &) + [moves http-server-gate] + :: + ?> ?=([%gall %unto %fact *] sign) + =/ =mark p.cage.p.sign + ~& eyre-watch-response-fact=mark + =/ =vase q.cage.p.sign + ?. ?= ?(%http-response-header %http-response-data %http-response-cancel) + mark + =/ handle-gall-error + handle-gall-error:(per-server-event event-args) + =^ moves server-state.ax + (handle-gall-error leaf+"eyre bad mark {(trip mark)}" ~) + [moves http-server-gate] + :: + =/ =http-event:http + ?- mark + %http-response-header [%start !<(response-header:http vase) ~ |] + %http-response-data [%continue !<((unit octs) vase) |] + %http-response-cancel [%cancel ~] + == + =/ handle-response handle-response:(per-server-event event-args) + =^ moves server-state.ax + (handle-response http-event) + [moves http-server-gate] + :: + ++ channel + :: + =/ event-args [[eny duct now rof] server-state.ax] + :: channel callback wires are triples. + :: + ?> ?=([@ @ @t *] wire) + :: + ?+ i.t.wire + ~|([%bad-channel-wire wire] !!) + :: + %timeout + ?> ?=([%behn %wake *] sign) + ?^ error.sign + [[duct %slip %d %flog %crud %wake u.error.sign]~ http-server-gate] + =* id i.t.t.wire + %- %+ trace:(per-server-event event-args) 1 + |.("{(trip id)} cancelling channel due to timeout") + =^ moves server-state.ax + (discard-channel:by-channel:(per-server-event event-args) id &) + [moves http-server-gate] + :: + %heartbeat + =/ on-channel-heartbeat + on-channel-heartbeat:by-channel:(per-server-event event-args) + =^ moves server-state.ax + (on-channel-heartbeat i.t.t.wire) + [moves http-server-gate] + :: + ?(%poke %subscription) + ?> ?=([%gall %unto *] sign) + ~| eyre-sub=wire + ?> ?=([@ @ @t @ *] wire) + ?< ?=(%raw-fact -.p.sign) + =* channel-id i.t.t.wire + =* request-id i.t.t.t.wire + =* extra-wire t.t.t.t.wire + =/ on-gall-response + on-gall-response:by-channel:(per-server-event event-args) + :: ~& [%gall-response sign] + =^ moves server-state.ax + %- on-gall-response + [channel-id (slav %ud request-id) extra-wire p.sign] + [moves http-server-gate] + == + :: + ++ sessions + :: + ?> ?=([%behn %wake *] sign) + :: + ?^ error.sign + :_ http-server-gate + :: we must not drop the timer! so we kick the can down the road a day, + :: and hope it will run successfully later... + :: + :~ [duct %slip %d %flog %crud %wake u.error.sign] + [duct %pass /sessions/expire %b %wait (add now ~d1)] + == + ::NOTE we are not concerned with expiring channels that are still in + :: use. we require acks for messages, which bump their session's + :: timer. channels have their own expiry timer, too. + :: remove cookies that have expired + :: + =* sessions sessions.auth.server-state.ax + =. sessions.auth.server-state.ax + %- ~(gas by *(map @uv session)) + %+ skip ~(tap in sessions) + |= [cookie=@uv session] + (lth expiry-time now) + :: if there's any cookies left, set a timer for the next expected expiry + :: + ^- [(list move) _http-server-gate] + :_ http-server-gate + :- =< give-session-tokens + (per-server-event [eny duct now rof] server-state.ax) + ?: =(~ sessions) ~ + =; next-expiry=@da + [duct %pass /sessions/expire %b %wait next-expiry]~ + %+ roll ~(tap by sessions) + |= [[@uv session] next=@da] + ?: =(*@da next) expiry-time + (min next expiry-time) + :: + ++ eauth + =* auth auth.server-state.ax + =* args [[eny duct now rof] server-state.ax] + ^- [(list move) _http-server-gate] + ~| [wire +<.sign] + ?+ t.wire !! + [%plea @ ~] + =/ =ship (slav %p i.t.t.wire) + :: + ?: |(?=(^ dud) ?=([%ames %lost *] sign)) + %- %+ trace:(per-server-event args) 0 + ?~ dud |.("eauth: lost boon from {(scow %p ship)}") + |.("eauth: crashed on %{(trip +<.sign)} from {(scow %p ship)}") + ::NOTE when failing on pending attempts, we just wait for the timer + :: to clean up. when failing on live sessions, well, we should + :: just be careful not to crash when receiving %shut boons. + :: (we do not want to have the nonce in the wire, so this is the + :: best handling we can do. the alternative is tracking) + [~ http-server-gate] + :: + ?: ?=([%ames %done *] sign) + =^ moz server-state.ax + %. [ship ?=(~ error.sign)] + on-done:client:eauth:authentication:(per-server-event args) + [moz http-server-gate] + :: + ?> ?=([%ames %boon *] sign) + =/ boon ;;(eauth-boon payload.sign) + =^ moz server-state.ax + %. [ship boon] + on-boon:client:eauth:authentication:(per-server-event args) + [moz http-server-gate] + :: + [%keen @ @ ~] + =/ client=@p (slav %p i.t.t.wire) + =/ nonce=@uv (slav %uv i.t.t.t.wire) + :: + ?^ dud + =^ moz server-state.ax + %. [client nonce] + on-fail:server:eauth:authentication:(per-server-event args) + [moz http-server-gate] + :: + ?> ?& ?=([%ames %sage *] sign) + =(client ship.p.sage.sign) + == + =/ url=(unit @t) + ?~ q.sage.sign ~ + ;;((unit @t) q.q.sage.sign) + =^ moz server-state.ax + ?~ url + %. [client nonce] + on-fail:server:eauth:authentication:(per-server-event args) + %. [client nonce u.url] + on-tune:server:eauth:authentication:(per-server-event args) + [moz http-server-gate] + :: + [%expire %visiting @ @ ~] + ?> ?=([%behn %wake *] sign) + =/ server=@p (slav %p i.t.t.t.wire) + =/ nonce=@uv (slav %uv i.t.t.t.t.wire) + =^ moz server-state.ax + %. [server nonce] + expire:client:eauth:authentication:(per-server-event args) + [~ http-server-gate] + :: + [%expire %visitors @ ~] + =/ nonce=@uv (slav %uv i.t.t.t.wire) + =^ moz server-state.ax + (expire:server:eauth:authentication:(per-server-event args) nonce) + [moz http-server-gate] + == + :: + ++ acme-ack + ?> ?=([%gall %unto *] sign) + :: + ?> ?=([%poke-ack *] p.sign) + ?~ p.p.sign + :: received a positive acknowledgment: take no action + :: + [~ http-server-gate] + :: received a negative acknowledgment: XX do something + :: + [((slog u.p.p.sign) ~) http-server-gate] + -- +:: +++ http-server-gate ..$ +:: +load: migrate old state to new state (called on vane reload) +:: +++ load + => |% + +$ axle-any + $% [date=%~2020.10.18 server-state=server-state-0] + [date=%~2022.7.26 server-state=server-state-0] + [date=%~2023.2.17 server-state=server-state-1] + [date=%~2023.3.16 server-state=server-state-2] + [date=%~2023.4.11 server-state-3] + [date=%~2023.5.15 server-state-4] + [date=%~2024.8.20 server-state-4] + [date=%~2025.1.31 server-state] + == + :: + +$ server-state-0 + $: bindings=(list [=binding =duct =action]) + =cors-registry + connections=(map duct outstanding-connection-3) + auth=authentication-state-3 + channel-state=channel-state-2 + domains=(set turf) + =http-config + ports=[insecure=@ud secure=(unit @ud)] + outgoing-duct=duct + == + :: + +$ server-state-1 + $: bindings=(list [=binding =duct =action]) + =cors-registry + connections=(map duct outstanding-connection-3) + auth=authentication-state-3 + channel-state=channel-state-2 + domains=(set turf) + =http-config + ports=[insecure=@ud secure=(unit @ud)] + outgoing-duct=duct + verb=@ :: <- new + == + :: + +$ server-state-2 + $: bindings=(list [=binding =duct =action]) + cache=(map url=@t [aeon=@ud val=(unit cache-entry)]) :: <- new + =cors-registry + connections=(map duct outstanding-connection-3) + auth=authentication-state-3 + channel-state=channel-state-2 + domains=(set turf) + =http-config + ports=[insecure=@ud secure=(unit @ud)] + outgoing-duct=duct + verb=@ + == + +$ channel-state-2 + $: session=(map @t channel-2) + duct-to-key=(map duct @t) + == + +$ channel-2 + $: state=(each timer duct) + next-id=@ud + last-ack=@da + events=(qeu [id=@ud request-id=@ud channel-event=channel-event-2]) + unacked=(map @ud @ud) + subscriptions=(map @ud [ship=@p app=term =path duc=duct]) + heartbeat=(unit timer) + == + +$ channel-event-2 + $% $>(%poke-ack sign:agent:gall) + $>(%watch-ack sign:agent:gall) + $>(%kick sign:agent:gall) + [%fact =mark =noun] + == + :: + +$ server-state-3 + $: bindings=(list [=binding =duct =action]) + cache=(map url=@t [aeon=@ud val=(unit cache-entry)]) + =cors-registry + connections=(map duct outstanding-connection-3) + auth=authentication-state-3 + channel-state=channel-state-3 + domains=(set turf) + =http-config + ports=[insecure=@ud secure=(unit @ud)] + outgoing-duct=duct + verb=@ + == + +$ outstanding-connection-3 + $: =action + =inbound-request + response-header=(unit response-header:http) + bytes-sent=@ud + == + +$ authentication-state-3 sessions=(map @uv session-3) + +$ session-3 + $: expiry-time=@da + channels=(set @t) + == + +$ channel-state-3 + $: session=(map @t channel-3) + duct-to-key=(map duct @t) + == + +$ channel-3 + $: mode=?(%json %jam) + state=(each timer duct) + next-id=@ud + last-ack=@da + events=(qeu [id=@ud request-id=@ud =channel-event]) + unacked=(map @ud @ud) + subscriptions=(map @ud [ship=@p app=term =path duc=duct]) + heartbeat=(unit timer) + == + :: + +$ server-state-4 + $: bindings=(list [=binding =duct =action]) + cache=(map url=@t [aeon=@ud val=(unit cache-entry)]) + =cors-registry + connections=(map duct outstanding-connection) + auth=authentication-state + =channel-state + domains=(set turf) + =http-config + ports=[insecure=@ud secure=(unit @ud)] + outgoing-duct=duct + verb=@ + == + -- + |= old=axle-any + ^+ http-server-gate + ?- -.old + :: + :: adds /~/name + :: + %~2020.10.18 + %= $ + date.old %~2022.7.26 + :: + bindings.server-state.old + %+ insert-binding + [[~ /~/name] outgoing-duct.server-state.old [%name ~]] + bindings.server-state.old + == + :: + :: enables https redirects if certificate configured + :: inits .verb + :: + %~2022.7.26 + =. redirect.http-config.server-state.old + ?& ?=(^ secure.ports.server-state.old) + ?=(^ secure.http-config.server-state.old) + == + $(old [%~2023.2.17 server-state.old(|8 [|8 verb=0]:server-state.old)]) + :: + :: inits .cache + :: + %~2023.2.17 + $(old [%~2023.3.16 [bindings ~ +]:server-state.old]) + :: + :: inits channel mode and desks in unacked events + :: + %~2023.3.16 + :: + :: Prior to this desks were not part of events.channel. + :: When serializing we used to rely on the desk stored in + :: subscriptions.channel, but this state is deleted when we clog. + :: This migration adds the desk to events.channel, but we can not + :: scry in +load to populate the desks in the old events, + :: so we just kick all subscriptions on all channels. + %= $ + date.old %~2023.4.11 + :: + server-state.old + %= server-state.old + session.channel-state + %- ~(run by session.channel-state.server-state.old) + |= c=channel-2 + =; new-events + :- %json + c(events new-events, unacked ~, subscriptions ~) + =| events=(qeu [id=@ud request-id=@ud =channel-event]) + =/ l ~(tap in ~(key by subscriptions.c)) + |- + ?~ l events + %= $ + l t.l + next-id.c +(next-id.c) + events (~(put to events) [next-id.c i.l %kick ~]) + == + == + == + :: + :: guarantees & stores a session for each request, and a @p identity for + :: each session and channel + :: + %~2023.4.11 + %= $ + date.old %~2023.5.15 + :: + connections.old + %- ~(run by connections.old) + |= outstanding-connection-3 + ^- outstanding-connection + [action inbound-request [*@uv [%ours ~]] response-header bytes-sent] + :: + auth.old + :_ [~ ~ [~ ~ now]] + %- ~(run by sessions.auth.old) + |= s=session-3 + ^- session + [[%ours ~] s] + :: + session.channel-state.old + %- ~(run by session.channel-state.old) + |= c=channel-3 + ^- channel + [-.c [%ours ~] +.c] + :: + bindings.old + %+ insert-binding [[~ /~/host] outgoing-duct.old [%host ~]] + %+ insert-binding [[~ /~/eauth] outgoing-duct.old [%eauth ~]] + bindings.old + == + :: + :: adds /~/boot, /~/sponsor and /~/ip + :: + %~2023.5.15 + %= $ + date.old %~2024.8.20 + :: + bindings.old + %+ insert-binding + [[~ /~/boot] outgoing-duct.old [%boot ~]] + %+ insert-binding + [[~ /~/sponsor] outgoing-duct.old [%sponsor ~]] + %+ insert-binding + [[~ /~/ip] outgoing-duct.old [%ip ~]] + bindings.old + == + :: + %~2024.8.20 + %= $ + date.old %~2025.1.31 + verb.old [verb.old check-session-timer=&] + == + :: + %~2025.1.31 + http-server-gate(ax old) + :: + == +:: +stay: produce current state +:: +++ stay `axle`ax +:: +scry: request a path in the urbit namespace +:: +++ scry + ~/ %eyre-scry + ^- roon + |= [lyc=gang pov=path car=term bem=beam] + ^- (unit (unit cage)) + =* ren car + =* why=shop &/p.bem + =* syd q.bem + =/ lot=coin $/r.bem + =* tyl s.bem + :: + ?. ?=(%& -.why) + ~ + =* who p.why + :: + ?. ?=(%$ -.lot) + [~ ~] + ?. =(our who) + ?. =([%da now] p.lot) + ~ + ~& [%r %scry-foreign-host who] + ~ + :: + ?: ?=([%eauth %url ~] tyl) + ?. &(?=(%x ren) ?=(%$ syd)) ~ + =* endpoint endpoint.auth.server-state.ax + ?. ?=(%da -.p.lot) [~ ~] + :: we cannot answer for something prior to the last set time, + :: or something beyond the present moment. + :: + ?: ?| (lth q.p.lot time.endpoint) + (gth q.p.lot now) + == + ~ + :^ ~ ~ %noun + !> ^- (unit @t) + =< eauth-url:eauth:authentication + (per-server-event [eny *duct now rof] server-state.ax) + :: + ?: ?=([%cache @ @ ~] tyl) + ?. &(?=(%x ren) ?=(%$ syd)) ~ + =, server-state.ax + ?~ aeon=(slaw %ud i.t.tyl) [~ ~] + ?~ url=(slaw %t i.t.t.tyl) [~ ~] + ?~ entry=(~(get by cache) u.url) ~ + ?. =(u.aeon aeon.u.entry) ~ + ?~ val=val.u.entry ~ + ?: &(auth.u.val !=([~ ~] lyc)) ~ + ``noun+!>(u.val) + :: + ?: &(?=(%x ren) ?=([%range @ @ @ *] tyl)) + |^ + =/ beg=(unit @ud) (slaw %ud i.t.tyl) + =/ end=(unit @ud) (slaw %ud i.t.t.tyl) + =* vew i.t.t.t.tyl + =* rest t.t.t.t.tyl + =/ mym (scry-mime now rof lyc ~ [%$ vew (en-beam -.bem rest)]) + ?: ?=(%| -.mym) ~ + =* mime p.mym + ?~ range=(get-range [beg end] p.q.mime) + :^ ~ ~ %noun + !> ^- cache-entry + :- ?=(^ lyc) + :+ %payload + :- 416 + ['content-range' (cat 3 'bytes */' (crip (a-co:co p.q.mime)))]^~ + `(as-octs:mimes:html 'requested range not satisfiable') + :: + =/ =octs + %- as-octs:mimes:html + (cut 3 [p.u.range +((sub q.u.range p.u.range))] q.q.mime) + :^ ~ ~ %noun + !> ^- cache-entry + :- ?=(^ lyc) + :+ %payload + :- ?:(=(p.q.mime p.octs) 200 206) + :~ ['accept-ranges' 'bytes'] + ['content-type' (rsh 3 (spat p.mime))] + ['content-length' (crip (a-co:co p.octs))] + :- 'content-range' + %+ rap 3 + :~ 'bytes ' + (crip (a-co:co p.u.range)) '-' + (crip (a-co:co q.u.range)) '/' + (crip (a-co:co p.q.mime)) + == + == + data=[~ octs] + :: + ++ get-range + |= [req=(pair (unit @ud) (unit @ud)) len=@ud] + ^- (unit (pair @ud @ud)) + ?+ req ~ + [^ ~] + ?: (gth u.p.req (dec len)) ~ + `[u.p.req (dec len)] + :: + [~ ^] + ?. (gth u.q.req 0) ~ + `[(sub len (min len u.q.req)) (dec len)] + :: + [^ ^] + ?: |((gth u.p.req (dec len)) (gth u.p.req u.q.req)) + ~ + `[u.p.req (min (dec len) u.q.req)] + == + -- + :: private endpoints + :: + ?. ?=([~ ~] lyc) ~ + :: + ?: &(?=(%x ren) ?=(%$ syd)) + =, server-state.ax + ?+ tyl ~ + [%$ %whey ~] =- ``mass+!>(`(list mass)`-) + :~ bindings+&+bindings.server-state.ax + cache+&+cache.server-state.ax + auth+&+auth.server-state.ax + connections+&+connections.server-state.ax + channels+&+channel-state.server-state.ax + axle+&+ax + == + :: + [%cors ~] ``noun+!>(cors-registry) + [%cors %requests ~] ``noun+!>(requests.cors-registry) + [%cors %approved ~] ``noun+!>(approved.cors-registry) + [%cors %rejected ~] ``noun+!>(rejected.cors-registry) + :: + [%cors ?(%approved %rejected) @ ~] + =* kind i.t.tyl + =* orig i.t.t.tyl + ?~ origin=(slaw %t orig) [~ ~] + ?- kind + %approved ``noun+!>((~(has in approved.cors-registry) u.origin)) + %rejected ``noun+!>((~(has in rejected.cors-registry) u.origin)) + == + :: + [%authenticated %cookie @ ~] + ?~ cookies=(slaw %t i.t.t.tyl) [~ ~] + :^ ~ ~ %noun + !> ^- ? + %- =< request-is-authenticated:authentication + (per-server-event [eny *duct now rof] server-state.ax) + %*(. *request:http header-list ['cookie' u.cookies]~) + :: + [%'_~_' *] + =/ mym (scry-mime now rof lyc (deft:de-purl:html tyl)) + ?: ?=(%| -.mym) [~ ~] + ``noun+!>(p.mym) + == + ?. ?=(%$ ren) ~ + ?+ syd ~ + %bindings ``noun+!>(bindings.server-state.ax) + %cache ``noun+!>(cache.server-state.ax) + %connections ``noun+!>(connections.server-state.ax) + %authentication-state ``noun+!>(auth.server-state.ax) + %channel-state ``noun+!>(channel-state.server-state.ax) + %domains ``noun+!>(domains.server-state.ax) + %ports ``noun+!>(ports.server-state.ax) + :: + %host + %- (lift (lift |=(a=hart:eyre [%hart !>(a)]))) + ^- (unit (unit hart:eyre)) + =. p.lot ?.(=([%da now] p.lot) p.lot [%tas %real]) + ?+ p.lot + [~ ~] + :: + [%tas %fake] + ``[& [~ 8.443] %& /localhost] + :: + [%tas %real] + =* domains domains.server-state.ax + =* ports ports.server-state.ax + =/ =host:eyre [%& ?^(domains n.domains /localhost)] + =/ port=(unit @ud) + ?. ?=(^ secure.ports) + ?:(=(80 insecure.ports) ~ `insecure.ports) + ?:(=(443 u.secure.ports) ~ secure.ports) + ``[?=(^ secure.ports) port host] + == + == +-- |