mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 09:51:36 +03:00
896 lines
25 KiB
Plaintext
896 lines
25 KiB
Plaintext
/- *dns-bind, dns, hall
|
|
/+ tapp, stdio
|
|
::
|
|
:: tapp types and boilerplate
|
|
::
|
|
=> |%
|
|
++ collector-app `dock`[~zod %dns-collector]
|
|
+$ app-state
|
|
$: %0
|
|
:: nem: authoritative state
|
|
::
|
|
nem=(unit nameserver)
|
|
==
|
|
+$ peek-data _!!
|
|
+$ in-poke-data
|
|
$% [%dns-authority =authority]
|
|
[%dns-bind =ship =target]
|
|
[%handle-http-request =inbound-request:eyre]
|
|
==
|
|
+$ out-poke-data
|
|
$% [%dns-bind =ship =target]
|
|
[%dns-complete =ship =binding:dns]
|
|
[%drum-unlink =dock]
|
|
==
|
|
+$ in-peer-data
|
|
$% [%dns-request =request:dns]
|
|
==
|
|
+$ 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)
|
|
--
|
|
::
|
|
:: oauth2 implementation
|
|
::
|
|
=> |%
|
|
:: +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)
|
|
==
|
|
:: +oauth2: library core
|
|
::
|
|
++ oauth2
|
|
|_ [our=@p now=@da config=oauth2-config code=@t =hart:eyre secrets=@t]
|
|
::
|
|
++ local-uri
|
|
|= [our=ship =path]
|
|
^- @t
|
|
:: XX can't scry in +mule
|
|
::
|
|
:: =/ =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)))
|
|
::
|
|
:: 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
|
|
::
|
|
++ 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 !!
|
|
--
|
|
--
|
|
::
|
|
:: helpers
|
|
::
|
|
=> |%
|
|
:: +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
|
|
--
|
|
::
|
|
:: service providers
|
|
::
|
|
=> |%
|
|
:: +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])
|
|
?> ?=(%gcloud -.pro.aut)
|
|
=, dejs:format
|
|
%+ cu
|
|
|= [typ=@t nam=@t dat=(list @t)]
|
|
^- (unit [=ship id=@ta tar=target])
|
|
:: gcloud doesn't expose UUIDs for bindings
|
|
::
|
|
=/ id %$
|
|
=/ him (ship-turf nam dom.aut)
|
|
?: |(?=(~ him) ?=(~ dat) ?=(^ t.dat))
|
|
~
|
|
?+ typ
|
|
~
|
|
::
|
|
%'A'
|
|
=/ adr (rush i.dat lip:ag)
|
|
?~ adr ~
|
|
`[u.him id %direct %if u.adr]
|
|
::
|
|
%'CNAME'
|
|
=/ for (ship-turf i.dat dom.aut)
|
|
?~ for ~
|
|
`[u.him id %indirect u.for]
|
|
==
|
|
::
|
|
%- ot :~
|
|
:: 'kind'^(su (jest "dns#resourceRecordSet'))
|
|
::
|
|
'type'^so
|
|
'name'^so
|
|
'rrdatas'^(ar so)
|
|
==
|
|
--
|
|
--
|
|
::
|
|
:: monadic helpers (XX move to stdio?)
|
|
::
|
|
=> |%
|
|
:: +backoff: exponential backoff timer
|
|
::
|
|
++ 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))
|
|
::
|
|
++ request
|
|
|= =hiss:eyre
|
|
=/ m (async:stdio (unit httr:eyre))
|
|
^- form:m
|
|
;< ~ bind:m (send-hiss:stdio hiss)
|
|
take-maybe-sigh:stdio
|
|
::
|
|
++ 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
|
|
::
|
|
=- ?~(- [~ ~] -)
|
|
(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)
|
|
::
|
|
++ create-binding
|
|
|= [=authority =ship =target existing=(unit bound)]
|
|
=/ m (async:stdio (unit bound))
|
|
^- form:m
|
|
?: &(?=(^ existing) =(target cur.u.existing))
|
|
(pure:m existing)
|
|
::
|
|
=/ 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?
|
|
::
|
|
?. &(?=(^ rep) =(200 p.u.rep))
|
|
(pure:m ~)
|
|
::
|
|
=* 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)
|
|
::
|
|
=/ =address:dns
|
|
?>(?=(%direct -.target) +.target)
|
|
=/ =turf
|
|
(weld dom.authority /(crip +:(scow %p ship)))
|
|
;< ~ bind:m (poke-app:stdio collector-app [%dns-complete ship address turf])
|
|
;< now=@da bind:m get-time:stdio
|
|
=/ =bound
|
|
[now id target ?~(existing ~ [[wen cur] hit]:u.existing)]
|
|
(pure:m (some bound))
|
|
::
|
|
++ 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 ~))
|
|
::
|
|
:: 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)
|
|
(pure:m state)
|
|
--
|
|
::
|
|
:: |oauth2-core: configured oauth functionality (for |gcloud only)
|
|
::
|
|
=> |%
|
|
++ oauth2-core
|
|
|= [=bowl:gall code=@t =hart:eyre secrets=@t]
|
|
=/ =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)
|
|
--
|
|
::
|
|
:: the app itself
|
|
::
|
|
=* default-tapp default-tapp:tapp
|
|
%- create-tapp-all:tapp
|
|
^- tapp-core-all:tapp
|
|
|_ [=bowl:gall state=app-state]
|
|
::
|
|
++ handle-peek handle-peek:default-tapp
|
|
++ handle-peer handle-peer:default-tapp
|
|
::
|
|
++ handle-init
|
|
=/ m tapp-async
|
|
^- form:m
|
|
;< 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)
|
|
::
|
|
++ handle-poke
|
|
|= =in-poke-data
|
|
=/ m tapp-async
|
|
^- form:m
|
|
?. (team:title [our src]:bowl)
|
|
~| %bind-yoself !!
|
|
?- -.in-poke-data
|
|
::
|
|
%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
|
|
::
|
|
?: ?& ?=(%gcloud -.pro.aut)
|
|
?=(~ auth.pro.aut)
|
|
==
|
|
~& %do-the-oauth-thing
|
|
~& initial-uri:(oauth2-core bowl scry.pro.aut)
|
|
(pure:m state)
|
|
::
|
|
(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)
|
|
~| %indirect-unsupported !!
|
|
:: defer %indirect where target isn't yet bound
|
|
::
|
|
:: ?: ?& ?=(%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)
|
|
=. bon.nam (~(put by bon.nam) who u.new)
|
|
=. nem.state (some nam)
|
|
::
|
|
:: XX wait-effect
|
|
::
|
|
=/ 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
|
|
::
|
|
%handle-http-request
|
|
:: always stash request bone for giving response
|
|
::
|
|
=/ =bone ost.bowl
|
|
:: XX maybe always (set-raw-contract %request) so transaction failure is captured?
|
|
::
|
|
=* 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])
|
|
(pure:m state)
|
|
::
|
|
=* 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])
|
|
(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])
|
|
(pure:m state)
|
|
::
|
|
[%dns %oauth %result ~]
|
|
=/ code (~(got by (my params)) %code)
|
|
:: XX make path configurable
|
|
::
|
|
=/ hed [['Location' '/dns/oauth/success'] ~]
|
|
::
|
|
;< ~ bind:m
|
|
(send-request:stdio (retrieve-access-token:(oauth2-core bowl scry.pro.aut.nam) code))
|
|
;< rep=(unit client-response:iris) bind:m
|
|
take-maybe-response:stdio
|
|
:: XX retry
|
|
::
|
|
?> ?& ?=(^ 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])
|
|
(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
|
|
==
|
|
==
|
|
==
|
|
;< ~ bind:m (send-effect:stdio %http-response %start [%201 ~] bod %.y)
|
|
(pure:m state)
|
|
==
|
|
==
|
|
::
|
|
++ 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)
|
|
--
|