1
1
mirror of https://github.com/urbit/shrub.git synced 2024-12-30 07:35:19 +03:00
shrub/pkg/arvo/app/dns-bind.hoon

921 lines
26 KiB
Plaintext
Raw Normal View History

2019-06-26 04:41:08 +03:00
/- *dns-bind, dns, hall
/+ tapp, stdio
::
2019-06-26 04:41:08 +03:00
:: tapp types and boilerplate
::
2019-06-26 04:41:08 +03:00
=> |%
++ collector-app `dock`[~zod %dns-collector]
+$ app-state
$: %0
:: nem: authoritative state
::
nem=(unit nameserver)
==
2019-06-26 04:41:08 +03:00
+$ peek-data _!!
+$ in-poke-data
$% [%dns-authority =authority]
[%dns-bind =ship =target]
[%handle-http-request =inbound-request:eyre]
2019-07-19 22:45:20 +03:00
[%noun noun=*]
==
2019-06-26 04:41:08 +03:00
+$ out-poke-data
$% [%dns-bind =ship =target]
[%dns-complete =ship =binding:dns]
[%drum-unlink =dock]
==
+$ in-peer-data
$% [%dns-request =request:dns]
==
2019-06-26 04:41:08 +03:00
+$ out-peer-data ~
++ tapp
%: ^tapp
app-state
peek-data
in-poke-data
out-poke-data
in-peer-data
out-peer-data
==
++ tapp-async tapp-async:tapp
++ stdio (^stdio out-poke-data out-peer-data)
--
::
2019-06-26 04:41:08 +03:00
:: oauth2 implementation
::
2019-06-26 04:41:08 +03:00
=> |%
:: +oauth2-config: as one would expect
::
+$ oauth2-config
$: auth-url=@t
exchange-url=@t
domain=turf
initial-path=path
redirect-path=path
scopes=(list @t)
==
2019-06-26 04:41:08 +03:00
:: +oauth2: library core
::
++ oauth2
|_ [our=@p now=@da config=oauth2-config code=@t =hart:eyre secrets=@t]
2019-06-26 04:41:08 +03:00
::
++ local-uri
|= [our=ship =path]
2019-06-26 04:41:08 +03:00
^- @t
:: XX can't scry in +mule
::
2019-07-04 02:01:45 +03:00
:: =/ =hart:eyre .^(hart:eyre %e /(scot %p our)/host/real)
(crip (en-purl:html [hart [~ path] ~]))
::
:: XX can't scry in +mule
::
:: ++ code
:: ^- @t
:: %- crip
:: +:(scow %p .^(@p %j /(scot %p our)/code/(scot %da now)/(scot %p our)))
2019-06-26 04:41:08 +03:00
::
:: to initialize these values: |init-oauth2 /com/googleapis
::
++ oauth2-secrets
^- [client-id=@t client-secret=@t]
=; =wain
?> ?=([@t @t ~] wain)
[i.wain i.t.wain]
::
%- to-wain:format
%- need
%+ de:crub:crypto code
%+ slav %uw
:: XX can't scry in +mule
::
:: .^(@ %cx :(weld /(scot %p our)/home/(scot %da now)/sec domain.config /atom))
secrets
2019-06-26 04:41:08 +03:00
::
++ initial-uri (local-uri our initial-path.config)
++ redirect-uri (local-uri our redirect-path.config)
::
++ redirect-to-provider
^- @t
=/ url (need (de-purl:html auth-url.config))
=. r.url
:* ['access_type' 'offline']
['response_type' 'code']
['prompt' 'consent']
['client_id' client-id:oauth2-secrets]
['redirect_uri' redirect-uri]
['scope' (rap 3 (join ' ' scopes.config))]
r.url
==
(crip (en-purl:html url))
::
++ retrieve-access-token
|= code=@t
^- request:http
=/ hed
:~ ['Accept' 'application/json']
['Content-Type' 'application/x-www-form-urlencoded']
==
=/ bod
%- some %- as-octt:mimes:html
%- tail %- tail:en-purl:html
:~ ['client_id' client-id:oauth2-secrets]
:: note: required, unused parameter
::
['redirect_uri' redirect-uri]
['client_secret' client-secret:oauth2-secrets]
['grant_type' 'authorization_code']
['code' code]
==
[%'POST' exchange-url.config hed bod]
::
++ parse-token-response
|= =octs
^- (unit [access=@t expires=@u refresh=@t])
%. q.octs
;~ biff
de-json:html
=, dejs-soft:format
(ot 'access_token'^so 'expires_in'^ni 'refresh_token'^so ~)
==
:: XX implement
::
++ refresh-token !!
--
--
::
2019-06-26 04:41:08 +03:00
:: helpers
::
2019-06-26 04:41:08 +03:00
=> |%
:: +name: fully-qualified domain name for :ship
::
++ name
|= [=ship =turf]
(cat 3 (en-turf:html (weld turf /(crip +:(scow %p ship)))) '.')
:: +lame: domain name for :ship (without trailing '.')
::
++ lame
|= [=ship =turf]
(en-turf:html (weld turf /(crip +:(scow %p ship))))
:: +endpoint: append :path to :purl
::
++ endpoint
|= [=purl:eyre =path]
^+ purl
purl(q.q (weld q.q.purl path))
:: +params: append :params to :purl
::
++ params
|= [=purl:eyre =quay:eyre]
^+ purl
purl(r (weld r.purl quay))
:: +json-octs: deserialize json and apply reparser
::
++ json-octs
|* [bod=octs wit=fist:dejs:format]
=/ jon (de-json:html q.bod)
?~ jon ~
(wit u.jon)
:: +ship-turf: parse ship from first subdomain
::
++ ship-turf
|= [nam=@t aut-dom=turf]
^- (unit ship)
=/ dom=(unit host:eyre)
(rush nam ;~(sfix thos:de-purl:html dot))
?: ?| ?=(~ dom)
?=(%| -.u.dom)
?=(~ p.u.dom)
==
~
=/ who
(rush (head (flop p.u.dom)) fed:ag)
?~ who ~
?. =(aut-dom (flop (tail (flop p.u.dom))))
~
:: galaxies always excluded
::
?: ?=(%czar (clan:title u.who))
~
who
--
::
2019-06-26 04:41:08 +03:00
:: service providers
::
2019-06-26 04:41:08 +03:00
=> |%
:: +provider: initialize provider-specific core
::
++ provider
|= aut=authority
?- -.pro.aut
%fcloud ~(. fcloud aut)
%gcloud ~(. gcloud aut)
==
:: |fcloud: Cloudflare provider
::
++ fcloud
=> |%
++ parse-raw-record
|= aut-dom=turf
^- $- json
(unit [=ship id=@ta tar=target])
=, dejs:format
%+ cu
|= [id=@t typ=@t nam=@t dat=@t]
^- (unit [=ship id=@ta tar=target])
:: XX fix this
::
=/ him (ship-turf (cat 3 nam '.') aut-dom)
?: ?=(~ him)
~
?+ typ
~
::
%'A'
=/ adr (rush dat lip:ag)
?~ adr ~
`[u.him `@ta`id %direct %if u.adr]
::
%'CNAME'
:: XX fix this
::
=/ for (ship-turf (cat 3 dat '.') aut-dom)
?~ for ~
`[u.him `@ta`id %indirect u.for]
==
:: XX parse dates, proxied, ttl?
::
%- ot :~
'id'^so
'type'^so
'name'^so
'content'^so
==
--
::
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://api.cloudflare.com/client/v4'))
:: +headers: standard HTTP headers for all |fcloud requests
::
++ headers
|= aut=authority
?> ?=(%fcloud -.pro.aut)
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['X-Auth-Email' [email.auth.pro.aut ~]]
['X-Auth-Key' [key.auth.pro.aut ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
[(endpoint base /zones/[zone.pro.aut]) %get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%fcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
(crip +:(scow %if p.tar))
(lame p.tar dom.aut)
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (lame him dom.aut)]
['type' %s type]
['content' %s data]
:: XX make configureable?
::
['ttl' %n ~.1]
['proxied' %b %.n]
==
:: +create: provider-specific record-creation request
::
++ create
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
(record him tar)
?~ pre
:- (endpoint base /zones/[zone.pro.aut]/['dns_records'])
[%post (headers aut) `bod]
:- (endpoint base /zones/[zone.pro.aut]/['dns_records']/[id.u.pre])
[%put (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
|= page=(unit @t)
^- hiss:eyre
?> ?=(%fcloud -.pro.aut)
:: XX more url params:
:: ?type ?per-page ?order ?direction
::
:- %+ params
(endpoint base /zones/[zone.pro.aut]/['dns_records'])
?~(page ~ ['page' u.page]~)
[%get (headers aut) ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= $: success=?
response=(list (unit [=ship id=@ta tar=target]))
paginate=[page=@ud per-page=@ud count=@ud total-count=@ud]
==
^- (pair (list [=ship id=@ta tar=target]) (unit @t))
?. success [~ ~]
:- (murn response same)
:: XX calculate next page number if applicable
::
~
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(ar (parse-raw-record dom.aut))
:- 'result_info'
%- ot :~
'page'^ni
'per_page'^ni
'count'^ni
'total_count'^ni
==
==
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
?> ?=(%fcloud -.pro.aut)
=, dejs:format
%+ cu
|= [success=? response=(unit [=ship id=@ta tar=target])]
^- (unit [=ship id=@ta tar=target])
?. success ~
response
:: XX parse errors and messages?
::
%- ot :~
'success'^bo
'result'^(parse-raw-record dom.aut)
==
--
:: |gcloud: GCP provider
::
++ gcloud
|_ aut=authority
:: +base: provider service endpoint
::
++ base
^- purl:eyre
(need (de-purl:html 'https://www.googleapis.com/dns/v1/projects'))
:: +headers: standard HTTP headers for all |gcloud requests
::
++ headers
|= aut=authority
?> ?=(%gcloud -.pro.aut)
?. ?=(^ auth.pro.aut)
~| %gcloud-missing-auth !!
%- ~(gas by *math:eyre)
:~ ['Content-Type' ['application/json' ~]]
['Authorization' [`@t`(cat 3 'Bearer ' access.u.auth.pro.aut) ~]]
==
:: +zone: provider-specific zone info request
::
++ zone
^- hiss:eyre
?> ?=(%gcloud -.pro.aut)
:- (endpoint base /[project.pro.aut]/['managedZones']/[zone.pro.aut])
[%get (headers aut) ~]
:: +record: JSON-formatted provider-specific dns record
::
++ record
|= [him=ship tar=target]
^- json
?> ?=(%gcloud -.pro.aut)
=/ type
?:(?=(%direct -.tar) 'A' 'CNAME')
=/ data
?: ?=(%direct -.tar)
[%s (crip +:(scow %if p.tar))]
[%s (name p.tar dom.aut)]
:- %o
%- ~(gas by *(map @t json))
:~ ['name' %s (name him dom.aut)]
['type' %s type]
:: XX make configureable?
::
['ttl' %n ~.300]
['rrdatas' %a data ~]
==
:: +create: provider-specific record-creation request
::
++ create
=, eyre
|= [him=ship tar=target pre=(unit [id=@ta tar=target])]
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/changes
=/ bod=octs
%- as-octt:mimes:html
%- en-json:html
:- %o
%- ~(gas by *(map @t json))
:- ['additions' %a (record him tar) ~]
?~ pre ~
[['deletions' %a (record him tar.u.pre) ~] ~]
[url %post (headers aut) `bod]
:: +existing: list existing records stored by provider
::
++ existing
=, eyre
|= page=(unit @t)
^- hiss
?> ?=(%gcloud -.pro.aut)
=/ url=purl
%+ endpoint base
/[project.pro.aut]/['managedZones']/[zone.pro.aut]/rrsets
=/ hed=math (headers aut)
=? hed ?=(^ page)
(~(put by hed) 'pageToken' [u.page]~)
[url %get hed ~]
:: +parse-list: existing records stored by provider
::
++ parse-list
^- $- json
(pair (list [=ship id=@ta tar=target]) (unit @t))
?> ?=(%gcloud -.pro.aut)
=, dejs:format
=> |%
++ page (uf ~ (mu so))
++ records
%+ uf ~
%+ cu
|*(a=(list (unit)) (murn a same))
(ar parse-record)
--
:: XX parse but don't produce
:: 'kind'^(su (jest "dns#resourceRecordSetsListResponse'))
::
(ou 'rrsets'^records 'nextPageToken'^page ~)
:: +parse-record: single record stored by provider
::
++ parse-record
^- $- json
(unit [=ship id=@ta tar=target])
2019-06-26 04:41:08 +03:00
?> ?=(%gcloud -.pro.aut)
=, dejs:format
%+ cu
2019-06-26 04:41:08 +03:00
|= [typ=@t nam=@t dat=(list @t)]
^- (unit [=ship id=@ta tar=target])
2019-06-26 04:41:08 +03:00
:: gcloud doesn't expose UUIDs for bindings
::
2019-06-26 04:41:08 +03:00
=/ id %$
=/ him (ship-turf nam dom.aut)
?: |(?=(~ him) ?=(~ dat) ?=(^ t.dat))
~
?+ typ
~
::
%'A'
2019-06-26 04:41:08 +03:00
=/ adr (rush i.dat lip:ag)
?~ adr ~
2019-06-26 04:41:08 +03:00
`[u.him id %direct %if u.adr]
::
%'CNAME'
2019-06-26 04:41:08 +03:00
=/ for (ship-turf i.dat dom.aut)
?~ for ~
2019-06-26 04:41:08 +03:00
`[u.him id %indirect u.for]
==
::
%- ot :~
2019-06-26 04:41:08 +03:00
:: 'kind'^(su (jest "dns#resourceRecordSet'))
::
'type'^so
'name'^so
2019-06-26 04:41:08 +03:00
'rrdatas'^(ar so)
==
--
2019-06-26 04:41:08 +03:00
--
::
:: monadic helpers (XX move to stdio?)
::
=> |%
:: +backoff: exponential backoff timer
::
2019-06-26 04:41:08 +03:00
++ backoff
|= [try=@ud limit=@dr]
=/ m (async:stdio ,~)
^- form:m
;< eny=@uvJ bind:m get-entropy:stdio
;< now=@da bind:m get-time:stdio
%- wait:stdio
%+ add now
%+ min limit
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny) 1.000))
::
2019-06-26 04:41:08 +03:00
++ request
|= =hiss:eyre
=/ m (async:stdio (unit httr:eyre))
^- form:m
;< ~ bind:m (send-hiss:stdio hiss)
take-maybe-sigh:stdio
::
2019-06-26 04:41:08 +03:00
++ request-retry
|= [=hiss:eyre max=@ud limit=@dr]
=/ m (async:stdio (unit httr:eyre))
=/ try=@ud 0
|- ^- form:m
=* loop $
?: =(try max)
(pure:m ~)
;< ~ bind:m (backoff try limit)
;< rep=(unit httr:eyre) bind:m (request hiss)
:: XX needs a better predicate. LTE will make this easier
::
?: &(?=(^ rep) =(200 p.u.rep))
(pure:m (some u.rep))
loop(try +(try))
--
::
:: application actions
::
=> |%
++ confirm-authority
|= =authority
=/ m (async:stdio ?)
^- form:m
;< rep=(unit httr:eyre) bind:m
(request-retry zone:(provider authority) 5 ~m10)
(pure:m &(?=(^ rep) =(200 p.u.rep)))
::
++ retrieve-existing
|= =authority
=/ m (async:stdio (map ship bound))
^- form:m
=| existing=(map ship bound)
=| next-page=(unit @t)
;< now=@da bind:m get-time:stdio
|- ^- form:m
=* loop $
;< rep=(unit httr:eyre) bind:m
(request-retry (existing:(provider authority) next-page) 5 ~m10)
?: ?| ?=(~ rep)
?=(~ r.u.rep)
==
(pure:m existing)
::
=* octs u.r.u.rep
=+ ^- [dat=(list [=ship id=@ta =target]) page=(unit @t)]
:: XX gross
::
2019-06-26 04:41:08 +03:00
=- ?~(- [~ ~] -)
(json-octs octs parse-list:(provider authority))
=. existing
|- ^+ existing
?~ dat
existing
=/ =bound [now id.i.dat target.i.dat ~]
$(dat t.dat, existing (~(put by existing) ship.i.dat bound))
?~ page
(pure:m existing)
loop(next-page page)
::
2019-06-26 04:41:08 +03:00
++ create-binding
|= [=authority =ship =target existing=(unit bound)]
=/ m (async:stdio (unit bound))
^- form:m
?: &(?=(^ existing) =(target cur.u.existing))
(pure:m existing)
::
2019-06-26 04:41:08 +03:00
=/ pre=(unit [@ta ^target])
?~(existing ~ (some [id cur]:u.existing))
;< rep=(unit httr:eyre) bind:m
(request (create:(provider authority) ship target pre))
:: XX retryable?
::
2019-06-26 04:41:08 +03:00
?. &(?=(^ rep) =(200 p.u.rep))
2019-07-19 22:45:20 +03:00
?: &(?=(^ rep) =(401 p.u.rep))
:: XX automate
::
~& %authentication-failure
~& (skim q.u.rep |=((pair @t @t) ?=(%www-authenticate p)))
(pure:m ~)
::
~& [%create-bind-failed rep]
2019-06-26 04:41:08 +03:00
(pure:m ~)
::
2019-06-26 04:41:08 +03:00
=* httr u.rep
=/ id=@ta
?. ?=(%fcloud -.pro.authority) ~.
?. ?=(^ r.httr)
~| [%authority-create-confirm-id rep] !!
=/ dat=(unit [^ship id=@ta ^target])
(json-octs u.r.httr parse-record:(provider authority))
?~(dat ~. id.u.dat)
::
;< now=@da bind:m get-time:stdio
2019-06-26 04:41:08 +03:00
=/ =bound
[now id target ?~(existing ~ [[wen cur] hit]:u.existing)]
(pure:m (some bound))
::
2019-06-26 04:41:08 +03:00
++ initialize-authority
|= [aut=authority state=app-state]
=/ m tapp-async
^- form:m
?> ?=(^ nem.state)
=* nam u.nem.state
;< good=? bind:m (confirm-authority aut)
?. good
~& %dns-authority-failed
(pure:m state(nem ~))
::
2019-06-26 04:41:08 +03:00
:: XX wait-effect
::
;< existing=(map ship bound) bind:m (retrieve-existing aut)
=. bon.nam (~(uni by bon.nam) existing)
=. nem.state (some nam)
::
:: XX wait-effect
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
2019-06-26 04:41:08 +03:00
(pure:m state)
--
::
:: |oauth2-core: configured oauth functionality (for |gcloud only)
::
2019-06-26 04:41:08 +03:00
=> |%
++ oauth2-core
|= [=bowl:gall code=@t =hart:eyre secrets=@t]
2019-06-26 04:41:08 +03:00
=/ =oauth2-config
:* auth-url='https://accounts.google.com/o/oauth2/v2/auth'
exchange-url='https://www.googleapis.com/oauth2/v4/token'
domain=/com/googleapis
redirect-path=/dns/oauth
initial-path=/dns/oauth/result
:~ 'https://www.googleapis.com/auth/ndev.clouddns.readwrite'
'https://www.googleapis.com/auth/cloud-platform.read-only'
== ==
~(. oauth2 our.bowl now.bowl oauth2-config code hart secrets)
2019-06-26 04:41:08 +03:00
--
::
2019-06-26 04:41:08 +03:00
:: the app itself
::
2019-06-26 04:41:08 +03:00
=* default-tapp default-tapp:tapp
%- create-tapp-all:tapp
^- tapp-core-all:tapp
2019-06-26 04:41:08 +03:00
|_ [=bowl:gall state=app-state]
::
++ handle-peek handle-peek:default-tapp
++ handle-peer handle-peer:default-tapp
::
++ handle-init
=/ m tapp-async
^- form:m
2019-06-26 08:36:06 +03:00
;< success=? bind:m (bind-route:stdio [~ /dns/oauth] dap.bowl)
~| %dns-unable-to-bind-route
?> success
;< ~ bind:m (poke-app:stdio [[our %hood] [%drum-unlink our dap]]:bowl)
(pure:m state)
::
2019-06-26 04:41:08 +03:00
++ handle-poke
|= =in-poke-data
=/ m tapp-async
^- form:m
?. (team:title [our src]:bowl)
~| %bind-yoself !!
?- -.in-poke-data
2019-07-19 22:45:20 +03:00
%noun
?: ?=(%debug noun.in-poke-data)
~& bowl
:: XX redact secrets
::
~& state
(pure:m state)
::
:: XX heavy-handed, will duplicate subscriptions
:: should track bones
::
?: ?=(%resubscribe noun.in-poke-data)
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
::
~& %poke-unknown
(pure:m state)
2019-06-26 04:41:08 +03:00
::
%dns-authority
?. =(~ nem.state)
~| %authority-reset-wat-do !!
=* aut authority.in-poke-data
=/ nam=nameserver [aut ~ ~]
=. nem.state (some nam)
:: XX move this into the provider interface
::
2019-06-26 04:41:08 +03:00
?: ?& ?=(%gcloud -.pro.aut)
?=(~ auth.pro.aut)
==
~& %do-the-oauth-thing
~& initial-uri:(oauth2-core bowl scry.pro.aut)
2019-06-26 04:41:08 +03:00
(pure:m state)
::
2019-06-26 04:41:08 +03:00
(initialize-authority aut state)
::
%dns-bind
?~ nem.state
~| %bind-not-authority !!
=* nam u.nem.state
=* who ship.in-poke-data
=* tar target.in-poke-data
?: ?=(%indirect -.tar)
2019-06-26 04:41:08 +03:00
~| %indirect-unsupported !!
:: defer %indirect where target isn't yet bound
::
2019-06-26 04:41:08 +03:00
:: ?: ?& ?=(%indirect -.tar)
:: !(~(has by bon.nam) p.tar)
:: ==
:: =. dep.nam (~(put ju dep.nam) p.tar [who tar])
:: =. nem.state (some nam)
:: (pure:m state)
=/ existing (~(get by bon.nam) who)
;< new=(unit bound) bind:m (create-binding aut.nam who tar existing)
?~ new
~& [%bind-failed in-poke-data]
(pure:m state)
=/ =turf
(weld dom.aut.nam /(crip +:(scow %p who)))
;< ~ bind:m
(poke-app:stdio collector-app [%dns-complete who +.tar turf])
2019-06-26 04:41:08 +03:00
=. bon.nam (~(put by bon.nam) who u.new)
=. nem.state (some nam)
::
2019-06-26 04:41:08 +03:00
:: XX wait-effect
::
2019-06-26 04:41:08 +03:00
=/ dep=(list [=ship =target])
~(tap in (~(get ju dep.nam) who))
|- ^- form:m
=* loop $
?~ dep
=. dep.nam (~(del by dep.nam) who)
=. nem.state (some nam)
(pure:m state)
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship target]:i.dep)
loop(dep t.dep)
::
:: XX need to %handle-http-cancel as well
2019-06-26 04:41:08 +03:00
::
%handle-http-request
:: always stash request bone for giving response
::
=/ =bone ost.bowl
2019-06-26 04:41:08 +03:00
:: XX maybe always (set-raw-contract %request) so transaction failure is captured?
::
2019-06-26 04:41:08 +03:00
=* inbound-request inbound-request.in-poke-data
?~ nem.state
~& :* %not-an-authority
%http-request
=> inbound-request
[authenticated secure address [method url]:request]
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%403 ~] ~ %.y])
2019-06-26 04:41:08 +03:00
(pure:m state)
::
2019-06-26 04:41:08 +03:00
=* nam u.nem.state
?> ?=(%gcloud -.pro.aut.nam)
::
=/ parsed=(unit (pair pork:eyre quay:eyre))
%+ rush
url.request.inbound-request
;~(plug ;~(pose apat:de-purl:html (easy *pork:eyre)) yque:de-purl:html)
::
?. ?=(^ parsed)
~| [%invalid-url url.request.inbound-request] !!
=* url q.p.u.parsed
=* ext p.p.u.parsed
=* params q.u.parsed
::
?+ url
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%404 ~] ~ %.y])
2019-06-26 04:41:08 +03:00
(pure:m state)
::
[%dns %oauth ~]
=/ link (trip redirect-to-provider:(oauth2-core bowl scry.pro.aut.nam))
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p make sure that the oauth credential is configured
with a redirect uri of {(trip redirect-uri:(oauth2-core bowl scry.pro.aut.nam))}
==
;a(href link): {link}
==
==
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%200 ~] bod %.y])
2019-06-26 04:41:08 +03:00
(pure:m state)
::
[%dns %oauth %result ~]
=/ code (~(got by (my params)) %code)
:: XX make path configurable
::
=/ hed [['Location' '/dns/oauth/success'] ~]
::
2019-06-26 04:41:08 +03:00
;< ~ bind:m
(send-request:stdio (retrieve-access-token:(oauth2-core bowl scry.pro.aut.nam) code))
;< rep=(unit client-response:iris) bind:m
2019-06-26 04:41:08 +03:00
take-maybe-response:stdio
:: XX retry
::
2019-06-26 04:41:08 +03:00
?> ?& ?=(^ rep)
?=(%finished -.u.rep)
?=(^ full-file.u.rep)
==
=/ data (parse-token-response:oauth2 data.u.full-file.u.rep)
=. auth.pro.aut.nam (some [access refresh]:(need data))
=. nem.state (some nam)
:: XX use expiry to set refresh timer
::
:: XX may need to send this as a card so we don't wait
::
;< ~ bind:m
(send-effect-on-bone:stdio bone [%http-response %start [%301 hed] ~ %.y])
2019-06-26 04:41:08 +03:00
(initialize-authority aut.nam state)
::
[%dns %oauth %success ~]
=/ bod=(unit octs)
%- some
%- as-octt:mimes:html
%- en-xml:html
;html
;head
;title: :dns oauth
==
;body
;p: you may close the browser window
;p
;span: XX remove me
:: XX make path configurable
::
;a(href "/dns/oauth"): again
==
==
==
2019-06-26 04:41:08 +03:00
;< ~ bind:m (send-effect:stdio %http-response %start [%201 ~] bod %.y)
(pure:m state)
==
2019-06-26 04:41:08 +03:00
==
::
++ handle-diff
|= [=dock =path =in-peer-data]
=/ m tapp-async
^- form:m
?. =(dock collector-app)
(pure:m state)
=* req request.in-peer-data
=/ =target [%direct address.req]
;< ~ bind:m (poke-app:stdio [our dap]:bowl [%dns-bind ship.req target])
(pure:m state)
::
++ handle-take
|= =sign:tapp
=/ m tapp-async
^- form:m
?. ?=(%quit -.sign)
:: XX handle stuff
::
(pure:m state)
::
?. ?& =(dock.sign collector-app)
=(path.sign /requests)
==
~& [%unexpected-quit-wat-do [dock path]:sign]
(pure:m state)
::
;< ~ bind:m (peer-app:stdio collector-app /requests)
(pure:m state)
--