urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-15 04:22:48 +03:00
Code Issues Packages Projects Releases Wiki Activity
6d0e074e4e
shrub/app/acme.hoon

1374 lines
40 KiB
Plaintext
Raw Blame History

/- asn1, hall
/+ base64, der, primitive-rsa, *pkcs, *jose
=, eyre
=* rsa primitive-rsa
::
|%
:: +en-base64url: url-safe base64 encoding, without padding
::
++ en-base64url
~(en base64 | &)
:: +de-base64url: url-safe base64 decoding, without padding
::
++ de-base64url
~(de base64 | &)
:: |octn: encode/decode unsigned atoms as big-endian octet stream
::
++ octn
|%
++ en |=(a=@u `octs`[(met 3 a) (swp 3 a)])
++ de |=(a=octs `@u`(rev 3 p.a q.a))
--
:: |body: acme api response body types
::
++ body
|%
+$ acct [id=@t wen=@t sas=@t]
::
+$ order
$: exp=@t
sas=@t
aut=(list purl)
fin=(unit purl)
cer=(unit purl)
==
::
+$ auth
$: dom=turf
sas=@t
exp=@t
cal=challenge
==
::
+$ challenge [typ=@t sas=@t url=purl tok=@t err=(unit error)]
::
+$ error [type=@t detail=@t]
--
::
:: |grab: acme api response json reparsers
::
++ grab
=, dejs:format
|%
:: +json-purl: parse url
::
++ json-purl (su auri:de-purl:html)
:: +json-date: parse iso-8601
::
:: XX actually parse
::
++ json-date so
:: +directory: parse ACME service directory
::
++ directory
%- ot
:~ 'newAccount'^json-purl
'newNonce'^json-purl
'newOrder'^json-purl
'revokeCert'^json-purl
'keyChange'^json-purl
==
:: +acct: parse ACME service account
::
++ acct
^- $-(json acct:body)
:: ignoring key, contact, initialIp
::
(ot 'id'^no 'createdAt'^json-date 'status'^so ~)
:: +order: parse certificate order
::
++ order
^- $-(json order:body)
%- ou
:~ 'expires'^(un json-date)
'status'^(un so)
'authorizations'^(uf ~ (ar json-purl))
'finalize'^(uf ~ (mu json-purl))
'certificate'^(uf ~ (mu json-purl))
==
:: +auth: parse authorization
::
++ auth
=> |%
:: +iden: extract +turf from service identifier
::
++ iden
|= [typ=@t hot=host]
^- turf
?>(&(?=(%dns typ) ?=([%& *] hot)) p.hot)
:: +http-trial: extract %http-01 challenge
::
++ trial
|= a=(list challenge:body)
^- challenge:body
=/ b (skim a |=([typ=@t *] ?=(%http-01 typ)))
?>(?=(^ b) i.b)
--
^- $-(json auth:body)
%- ot
:~ 'identifier'^(cu iden (ot type+so value+(su thos:de-purl:html) ~))
'status'^so
'expires'^json-date
'challenges'^(cu trial (ar challenge))
==
:: +challenge: parse domain validation challenge
::
++ challenge
^- $-(json challenge:body)
%- ou
:~ 'type'^(un so)
'status'^(un so)
'url'^(un json-purl)
'token'^(un so)
'error'^(uf ~ (mu error))
==
:: +error: parse ACME service error response
::
++ error
^- $-(json error:body)
(ot type+so detail+so ~)
--
--
::
:::: acme state
::
|%
:: +move: output effect
::
+$ move [bone card]
:: +card: output effect payload
::
+$ card
$% [%hiss wire ~ %httr %hiss hiss:eyre]
[%poke wire dock poke]
[%rule wire %cert (unit [wain wain])]
[%wait wire @da]
[%well wire path (unit mime)]
==
:: +poke: outgoing app pokes
::
+$ poke
$% [%hall-action %phrase audience:hall (list speech:hall)]
==
:: +nonce-next: next effect to emit upon receiving nonce
::
+$ nonce-next
$? %register
%new-order
%finalize-order
%finalize-trial
==
:: +acct: an ACME service account
::
+$ acct
$: :: key: account keypair
::
key=key:rsa
:: reg: account registration
::
:: XX wen=@da once parser is fixed
::
reg=(unit [wen=@t kid=@t])
==
:: +config: finalized configuration
::
+$ config
$: :: dom: domains
::
dom=(set turf)
:: key: certificate keypair
::
key=key:rsa
:: cer: signed certificate
::
cer=wain
:: exp: expiration date
::
exp=@da
:: dor: source ACME service order URL
::
dor=purl
==
:: +trial: domain validation challenge
::
+$ trial
$% :: %http only for now
::
$: %http
:: ego: ACME service challenge url
::
ego=purl
:: tok: challenge token
::
tok=@t
:: sas: challenge status
::
sas=?(%recv %pend %auth)
== ==
:: +auth: domain authorization
::
+$ auth
$: :: ego: ACME service authorization url
::
ego=purl
:: dom: domain under authorization
::
dom=turf
:: cal: domain validation challenge
::
cal=trial
==
:: +order-auth: domain authorization state for order processing
::
+$ order-auth
$: :: pending: remote authorization urls
::
pending=(list purl)
:: active: authorization in progress
::
active=(unit [idx=@ auth])
:: done: finalized authorizations (XX or failed?)
::
done=(list auth)
==
:: +order: ACME certificate order
::
+$ order
$: :: dom: domains
::
dom=(set turf)
:: try: attempt number
::
try=@ud
:: sas: order state
::
sas=$@(%wake [%rest wen=@da])
:: exp: expiration date
::
:: XX @da once ISO-8601 parser
::
exp=@t
:: ego: ACME service order url
::
ego=purl
:: fin: ACME service order finalization url
::
fin=purl
:: key: certificate keypair
::
key=key:rsa
:: csr: DER-encoded PKCS10 certificate signing request
::
csr=@ux
:: aut: authorizations required by this order
::
aut=order-auth
==
:: +history: archive of past ACME service interactions
::
+$ history
$: :: act: list of revoked account keypairs
::
act=(list acct)
:: fig: list of expired configurations
::
fig=(list config)
:: fal: list of failed order attempts
::
fal=(list order)
==
:: +directory: ACME v2 service directory
::
+$ directory
$: :: register: registration url (newAccount)
::
register=purl
:: nonce: nonce creation url (newNonce)
::
nonce=purl
:: new-order: order creation url (newOrder)
::
new-order=purl
:: revoke: certificate revocation url (revokeCert)
::
revoke=purl
:: rekey: account key revocation url (keyChange)
::
rekey=purl
==
:: +acme: complete app state
::
+$ acme
$: :: dir: ACME service directory
::
dir=directory
:: act: ACME service account
::
act=acct
:: liv: active, live configuration
::
liv=(unit config)
:: hit: ACME account history
::
hit=history
:: nonces: list of unused nonces
::
nonces=(list @t)
:: rod: active, in-progress order
::
rod=(unit order)
:: next-order: queued domains for validation
::
next-order=(unit (map turf [idx=@ud valid=?]))
:: cey: certificate key XX move?
::
cey=key:rsa
==
--
::
:::: acme app
::
:: directory-base: LetsEncrypt service directory url
::
=/ directory-base=purl
=- (need (de-purl:html -))
'https://acme-staging-v02.api.letsencrypt.org/directory'
:: mov: list of outgoing moves for the current transaction
::
=| mov=(list move)
::
|_ [bow=bowl:gall acme]
:: +this: self
::
:: XX Should be a +* core alias, see urbit/arvo#712
::
++ this .
:: +emit: emit a move
::
++ emit
|= car=card
this(mov [[ost.bow car] mov])
:: +abet: finalize transaction
::
++ abet
^- (quip move _this)
[(flop mov) this(mov ~)]
:: +backoff: calculate exponential backoff
::
++ backoff
|= try=@ud
^- @dr
?: =(0 try) ~s0
%+ add
(mul ~s1 (bex (dec try)))
(mul ~s0..0001 (~(rad og eny.bow) 1.000))
:: +acme-wire: create :acme http-request wire
::
++ acme-wire
|= [try=@ud act=@tas =wire]
^- ^wire
(weld /acme/try/(scot %ud try)/[act] wire)
:: +notify: send :hall notification
::
++ notify
|= [=cord =tang]
^- card
=/ msg=speech:hall
:+ %app dap.bow
=/ line [%lin & cord]
?~(tang line [%fat [%tank tang] line])
=/ act
[%phrase (sy [our.bow %inbox] ~) [msg ~]]
[%poke / [our.bow %hall] %hall-action act]
:: +request: unauthenticated http request
::
++ request
|= [wir=wire req=hiss]
^- card
[%hiss wir ~ %httr %hiss req]
:: +signed-request: JWS JSON POST
::
++ signed-request
|= [url=purl non=@t bod=json]
^- hiss
:^ url %post
(my content-type+['application/jose+json' ~] ~)
:- ~
^- octs
=; pro=json
(as-octt:mimes:html (en-json:html (sign:jws key.act pro bod)))
:- %o %- my :~
nonce+s+non
url+s+(crip (en-purl:html url))
?^ reg.act
kid+s+kid.u.reg.act
jwk+(pass:en:jwk key.act)
==
:: +stateful-request: emit signed, nonce'd request
::
++ stateful-request
|= [[try=@ud act=@tas =wire] =purl =json]
^+ this
?~ nonces
(nonce:effect [act wire])
%- emit(nonces t.nonces)
%+ request (acme-wire try act wire)
(signed-request purl i.nonces json)
:: +bad-nonce: check if an http response is a badNonce error
::
++ bad-nonce
|= rep=httr
^- ?
:: XX always 400?
::
?. =(400 p.rep) |
?~ r.rep |
=/ jon=(unit json) (de-json:html q.u.r.rep)
?~ jon |
=('urn:ietf:params:acme:error:badNonce' type:(error:grab u.jon))
:: +failure-message: generic http failure message
::
++ failure-message
|= =purl
^- cord
%+ rap 3
:~ 'unable to reach '
(crip (en-purl:html purl)) '. '
'please confirm your urbit has network connectivity.'
==
:: |effect: send moves to advance
::
++ effect
|_ try-count=(unit @ud)
:: +try: this effect attempt number
::
++ try (fall try-count 1)
:: +validate-domain: confirm that a pending domain resolves to us
::
++ validate-domain
|= idx=@ud
^+ this
~| %validate-domain-effect-fail
?. ?=(^ next-order) ~|(%no-next-order !!)
=/ pending
(skip ~(tap by u.next-order) |=([turf @ud valid=?] valid))
?: =(~ pending)
new-order:effect
=/ next=[=turf idx=@ud valid=?]
~| [%no-next-domain idx=idx]
(head (skim pending |=([turf idx=@ud ?] =(idx ^idx))))
:: XX should confirm that :turf points to us
:: confirms that domain exists (and an urbit is on :80)
::
=/ =purl
:- [sec=| por=~ host=[%& turf.next]]
[[ext=`~.udon path=/static] query=~]
=/ =wire
(acme-wire try %validate-domain /idx/(scot %ud idx.next))
(emit (request wire purl %get ~ ~))
:: +directory: get ACME service directory
::
++ directory
^+ this
:: XX now in wire?
::
(emit (request (acme-wire try %directory /) directory-base %get ~ ~))
:: +nonce: get a new nonce for the next request
::
++ nonce
|= nex=wire
~| [%bad-nonce-next nex]
?> ?& ?=(^ nex)
?=(nonce-next i.nex)
==
^+ this
:: XX now in wire?
::
=/ =wire
(acme-wire try %nonce [%next nex])
(emit (request wire nonce.dir %get ~ ~))
:: +register: create ACME service account
::
:: Note: accepts services ToS.
:: XX add rekey mechanism
::
++ register
^+ this
=/ =json [%o (my [['termsOfServiceAgreed' b+&] ~])]
:: XX date in wire?
::
=/ wire-params [try %register /]
(stateful-request wire-params register.dir json)
:: +renew: renew certificate
::
++ renew
^+ this
~| %renew-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ liv) ~|(%no-live-config !!)
=< new-order:effect
(queue-next-order & dom.u.liv)
:: +new-order: create a new certificate order
::
++ new-order
^+ this
~| %new-order-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=([~ ^] next-order) ~|(%no-domains !!)
=/ =json
:- %o %- my :~
:- %identifiers
:- %a
%+ turn
~(tap in ~(key by `(map turf *)`u.next-order))
|=(a=turf [%o (my type+s+'dns' value+s+(join '.' a) ~)])
==
=/ wire-params [try %new-order /(scot %da now.bow)]
(stateful-request wire-params new-order.dir json)
:: +cancel-order: cancel failed order, set retry timer
::
++ cancel-order
^+ this
~| %cancel-order-effect-fail
:: ?> ?=(^ rod)
:: XX get failure reason
::
=/ try=@ud ?~(rod 1 try.u.rod)
:: backoff faster than usual
::
=/ lul=@dr (max ~h1 (backoff (add 4 try)))
=/ msg=cord
(cat 3 'retrying certificate request in ' (scot %dr lul))
=. ..this (emit (notify msg ~))
=. ..this (retry:effect try %new-order / lul)
:: domains might already be validated
::
=. ..this (queue-next-order & ?>(?=(^ rod) dom.u.rod))
cancel-current-order
:: +finalize-order: finalize completed order
::
++ finalize-order
^+ this
~| %finalize-order-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(~ pending.aut.u.rod) ~|(%pending-authz !!)
?. ?=(~ active.aut.u.rod) ~|(%active-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=/ =json
[%o (my csr+s+(en-base64url (met 3 csr.u.rod) `@`csr.u.rod) ~)]
=/ wire-params [try %finalize-order /(scot %da now.bow)]
(stateful-request wire-params fin.u.rod json)
:: +check-order: check completed order for certificate availability
::
++ check-order
^+ this
~| %check-order-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(~ pending.aut.u.rod) ~|(%pending-authz !!)
?. ?=(~ active.aut.u.rod) ~|(%active-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=/ =wire
(acme-wire try %check-order /(scot %da now.bow))
(emit (request wire ego.u.rod %get ~ ~))
:: +certificate: download PEM-encoded certificate
::
++ certificate
|= url=purl
^+ this
~| %certificate-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
=/ hed (my accept+['applicate/x-pem-file' ~] ~)
=/ =wire
(acme-wire try %certificate /(scot %da now.bow))
(emit (request wire url %get hed ~))
:: +install: tell %eyre about our certificate
::
++ install
^+ this
~| %install-effect-fail
?> ?=(^ liv)
=/ key=wain (ring:en:pem:pkcs8 key.u.liv)
(emit %rule /install %cert `[key `wain`cer.u.liv])
:: +get-authz: get next ACME service domain authorization object
::
++ get-authz
^+ this
~| %get-authz-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(^ pending.aut.u.rod) ~|(%no-pending-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=/ =wire
(acme-wire try %get-authz /(scot %da now.bow))
(emit (request wire i.pending.aut.u.rod %get ~ ~))
:: XX check/finalize-authz ??
::
:: +save-trial: save ACME domain validation challenge to /.well-known/
::
++ save-trial
^+ this
~| %save-trial-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(^ active.aut.u.rod) ~|(%no-active-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=* aut u.active.aut.u.rod
%- emit
:^ %well
:: XX idx in wire?
::
/acme/save-trial/(scot %da now.bow)
/acme-challenge/[tok.cal.aut]
:+ ~
/text/plain
%- as-octs:mimes:html
(rap 3 [tok.cal.aut '.' (pass:thumb:jwk key.act) ~])
:: +test-trial: confirm that ACME domain validation challenge is available
::
++ test-trial
^+ this
~| %test-trial-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(^ active.aut.u.rod) ~|(%no-active-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=* aut u.active.aut.u.rod
=/ pat=path /'.well-known'/acme-challenge/[tok.cal.aut]
:: note: requires port 80, just as the ACME service will
::
=/ url=purl [[sec=| por=~ hos=[%& dom.aut]] [ext=~ pat] hed=~]
:: =/ url=purl [[sec=| por=`8.081 hos=[%& /localhost]] [ext=~ pat] hed=~]
:: XX idx in wire?
::
=/ =wire
(acme-wire try %test-trial /(scot %da now.bow))
(emit (request wire url %get ~ ~))
:: +finalize-trial: notify ACME service that challenge is ready
::
++ finalize-trial
^+ this
~| %finalize-trial-effect-fail
?. ?=(^ reg.act) ~|(%no-account !!)
?. ?=(^ rod) ~|(%no-active-order !!)
?. ?=(^ active.aut.u.rod) ~|(%no-active-authz !!)
:: XX revisit wrt rate limits
::
?> ?=(%wake sas.u.rod)
=* aut u.active.aut.u.rod
:: empty object included for signature
:: XX include index in wire?
::
=/ wire-params [try %finalize-trial /(scot %da now.bow)]
(stateful-request wire-params ego.cal.aut [%o ~])
:: XX delete-trial?
::
:: +retry: retry effect after timeout
::
++ retry
|= [try=@ud act=@tas =wire lull=@dr]
:: XX validate wire
::
(emit %wait (acme-wire +(try) act wire) (add now.bow lull))
--
:: |event: accept event, emit next effect(s)
::
:: XX should these next effects be triggered at call sites instead?
::
++ event
|_ try=@ud
:: +validate-domain: accept a pending domain confirmation response
::
++ validate-domain
|= [=wire rep=httr]
^+ this
?> ?=([%idx @ *] wire)
?. ?=(^ next-order)
this
=/ idx (slav %ud i.t.wire)
=/ valid =(200 p.rep)
=/ item=(list [=turf idx=@ud valid=?])
(skim ~(tap by u.next-order) |=([turf idx=@ud ?] =(^idx idx)))
?. ?& ?=([^ ~] item)
!valid.i.item
==
this
=. u.next-order
(~(put by u.next-order) turf.i.item [idx valid])
?. valid
?: (lth try 10)
=/ lul=@dr (min ~h1 (backoff try))
(retry:effect try %validate-domain /idx/(scot %ud idx) lul)
:: XX remove next-order, cancel pending requests
:: XX include suggestion to fix
::
=/ msg=cord
%+ rap 3
:~ 'unable to reach ' (scot %p our.bow)
' via http at ' (join '.' turf.i.item) ':80'
==
(emit(next-order ~) (notify msg [(sell !>(rep)) ~]))
?: ?=(~ (skip ~(val by u.next-order) |=([@ud valid=?] valid)))
new-order:effect
(validate-domain:effect +(idx))
:: +directory: accept ACME service directory, trigger registration
::
++ directory
|= [wir=wire rep=httr]
^+ this
?. =(200 p.rep)
?: (lth try 10)
(retry:effect try %directory / (min ~m30 (backoff try)))
(emit (notify (failure-message directory-base) [(sell !>(rep)) ~]))
=. dir (directory:grab (need (de-json:html q:(need r.rep))))
?~(reg.act register:effect this)
:: +nonce: accept new nonce and trigger next effect
::
:: Nonce has already been saved in +sigh-httr. The next effect
:: is specified in the wire.
::
++ nonce
|= [=wire rep=httr]
^+ this
~| [%unrecognized-nonce-wire wire]
?> &(?=(^ wire) ?=([%next ^] wire))
=* nex i.t.wire
~| [%unknown-nonce-next nex]
?> ?=(nonce-next nex)
?. =(204 p.rep)
?: (lth try 10)
(retry:effect try %nonce t.wire (min ~m30 (backoff try)))
(emit (notify (failure-message nonce.dir) [(sell !>(rep)) ~]))
?- nex
%register register:effect
%new-order new-order:effect
%finalize-order finalize-order:effect
%finalize-trial finalize-trial:effect
==
:: +register: accept ACME service registration
::
++ register
|= [wir=wire rep=httr]
^+ this
?. |(=(200 p.rep) =(201 p.rep))
:: XX possible 204?
::
?: (lth try 10)
(retry:effect try %register / (min ~h1 (backoff try)))
(emit (notify (failure-message register.dir) [(sell !>(rep)) ~]))
=/ loc=@t
q:(head (skim q.rep |=((pair @t @t) ?=(%location p))))
:: XX @da once parser is fixed
::
=/ wen=@t
?~ r.rep
(scot %da now.bow)
=/ bod=acct:body
(acct:grab (need (de-json:html q.u.r.rep)))
?> ?=(%valid sas.bod)
wen.bod
=. reg.act `[wen loc]
?: =(~ next-order)
this
(validate-domain:effect 0)
:: XX rekey
::
:: +new-order: order created, begin processing authorizations
::
++ new-order
|= [wir=wire rep=httr]
^+ this
?. =(201 p.rep)
:: XX possible 204?
::
?: (lth try 10)
(retry:effect try %new-order / (min ~h1 (backoff try)))
:: XX next steps, retrying in ??
::
(emit (notify (failure-message register.dir) [(sell !>(rep)) ~]))
?> ?=(^ next-order)
=/ loc=@t
q:(head (skim q.rep |=((pair @t @t) ?=(%location p))))
=/ ego=purl (need (de-purl:html loc))
:: XX parse identifiers, confirm equal to pending domains
:: XX check status
::
=/ bod=order:body
(order:grab (need (de-json:html q:(need r.rep))))
=/ dom=(set turf) ~(key by u.next-order)
:: XX maybe generate key here?
::
=/ csr=@ux +:(en:der:pkcs10 cey ~(tap in dom))
=/ dor=order
[dom try=1 sas=%wake exp.bod ego (need fin.bod) cey csr [aut.bod ~ ~]]
get-authz:effect(rod `dor, next-order ~)
:: +finalize-order: order finalized, poll for certificate
::
++ finalize-order
|= [wir=wire rep=httr]
^+ this
?: =(504 p.rep)
:: retry timeouts frequently
::
(retry:effect try %finalize-order / (min ~m10 (backoff try)))
:: check-order regardless of status code
::
check-order:effect
:: +check-order: check order status, dispatch appropriately
::
++ check-order
|= [wir=wire rep=httr]
^+ this
~| [%strange-check-order wir]
?> ?=(^ rod)
?. =(200 p.rep)
?: (lth try 10)
(retry:effect try %check-order / (min ~m10 (backoff try)))
:: XX next steps, retrying in, delete order ??
::
(emit (notify (failure-message ego.u.rod) [(sell !>(rep)) ~]))
=/ bod=order:body
(order:grab (need (de-json:html q:(need r.rep))))
?+ sas.bod
~& [%check-order-status-unknown sas.bod]
this
:: order failed (at any stage)
::
%invalid
~& [%check-order-fail %invalid wir rep]
:: XX check authz, get the failure reason
:: XX possible to retry any reasons?
::
=< cancel-order:effect
(emit (notify 'certificate order failed' [(sell !>(rep)) ~]))
:: initial order state
::
%pending
check-order:effect
:: validations completed
::
%ready
finalize-order:effect
:: finalization requested
::
%processing
check-order:effect
:: certificate issued
::
%valid
:: XX update order state
:: XX =< delete-trial
::
~| impossible-order+[wir rep bod]
(certificate:effect (need cer.bod))
==
::
:: +certificate: accept PEM-encoded certificate
::
++ certificate
|= [wir=wire rep=httr]
^+ this
~| [%strange-certificate-response wir]
?> ?=(^ rod)
?. =(200 p.rep)
:: will re-attempt certificate download per order status
::
?: (lth try 10)
(retry:effect try %check-order / (min ~m10 (backoff try)))
:: XX next steps, retrying in, get url somehow ??
::
=/ msg=cord
%+ rap 3
:~ 'unable to download certificate. '
'please confirm that your urbit has network connectivity.'
==
(emit (notify msg [(sell !>(rep)) ~]))
=/ cer=wain (to-wain:format q:(need r.rep))
=/ fig=config
:: XX expiration date
::
[dom.u.rod key.u.rod cer (add now.bow ~d90) ego.u.rod]
:: archive live config
::
=? fig.hit ?=(^ liv) [u.liv fig.hit]
:: save new live config, clear active order
::
=> .(liv (some fig), rod ~)
?> ?=(^ liv)
:: notify :hall
::
=> =/ msg=cord
%+ rap 3
:~ 'received https certificate for '
(join ', ' (turn ~(tap in dom.u.liv) |=(a=turf (join '.' a))))
==
(emit (notify msg ~))
:: set renewal timer, install certificate in %eyre
::
=< install:effect
(retry:effect 0 %renew / ~d60)
:: +get-authz: accept ACME service authorization object
::
++ get-authz
|= [wir=wire rep=httr]
^+ this
~| [%strange-authorization wir]
?> ?=(^ rod)
?> ?=(^ pending.aut.u.rod)
?. =(200 p.rep)
?: (lth try 10)
(retry:effect try %get-authz / (min ~m10 (backoff try)))
:: XX next steps, retrying in ??
::
(emit (notify (failure-message i.pending.aut.u.rod) [(sell !>(rep)) ~]))
=/ bod=auth:body
(auth:grab (need (de-json:html q:(need r.rep))))
=/ cal=trial
:: XX parse token to verify url-safe base64?
::
[%http url.cal.bod tok.cal.bod %recv]
:: XX check that URLs are the same
::
=/ tau=auth [i.pending.aut.u.rod dom.bod cal]
:: XX get idx from wire instead?
::
=/ idx=@ud +((lent done.aut.u.rod))
=/ rod-aut=order-auth
%= aut.u.rod
pending t.pending.aut.u.rod
active `[idx tau]
==
=< test-trial:effect
save-trial:effect(aut.u.rod rod-aut)
:: XX check/finalize-authz ??
::
:: +test-trial: accept response from challenge test
::
:: Note that +save-trial:effect has no corresponding event.
::
++ test-trial
|= [wir=wire rep=httr]
~| [%strange-test-trial wir]
?> ?=(^ rod)
?> ?=(^ active.aut.u.rod)
=* aut u.active.aut.u.rod
^+ this
?. =(200 p.rep)
?: (lth try 10)
(retry:effect try %test-trial / (min ~m10 (backoff try)))
:: XX next steps, check connectivity, etc. ??
::
=< cancel-order:effect
=/ msg=cord
%+ rap 3
:~ 'unable to retrieve self-hosted domain validation token '
'via ' (join '.' dom.aut) '. '
'please confirm your urbit has network connectivity.'
==
(emit (notify msg [(sell !>(rep)) ~]))
=/ bod
%- as-octs:mimes:html
(rap 3 [tok.cal.aut '.' (pass:thumb:jwk key.act) ~])
?. ?& ?=(^ r.rep)
=(bod u.r.rep)
==
:: XX save-trial again?
:: XX probably a DNS misconfiguration
::
=/ =tang
:~ ?~(r.rep leaf+"~" (sell !>(u.r.rep)))
leaf+"actual:"
(sell !>((some bod)))
leaf+"expected:"
==
(emit (notify 'domain validation value is wrong' tang))
finalize-trial:effect
:: +finalize-trial:
::
++ finalize-trial
|= [wir=wire rep=httr]
^+ this
~| [%strange-finalize-trial wir]
?> ?=(^ rod)
?> ?=(^ active.aut.u.rod)
=* aut u.active.aut.u.rod
?. =(200 p.rep)
:: XX possible 204? assume pending?
:: XX handle "challenge is not pending"
::
?: =(504 p.rep)
:: retry timeouts frequently
::
?: (lth try 10)
(retry:effect try %finalize-trial / (min ~m10 (backoff try)))
:: XX next steps, check connectivity, etc. ??
::
(emit (notify (failure-message ego.cal.aut) [(sell !>(rep)) ~]))
:: XX get challenge, confirm urn:ietf:params:acme:error:connection
::
:: =/ err=error:body
:: (error:grab (need (de-json:html q:(need r.rep))))
:: ?: =('urn:ietf:params:acme:error:malformed' status.err)
::
=< cancel-order:effect
=/ msg=cord
'unable to finalize domain validation challenge'
(emit (notify msg [(sell !>(rep)) ~]))
=/ bod=challenge:body
(challenge:grab (need (de-json:html q:(need r.rep))))
:: XX check for other possible values in 200 response
:: note: may have already been validated
::
?> ?=(?(%pending %valid) sas.bod)
=/ rod-aut=order-auth
aut.u.rod(active ~, done [+.aut(sas.cal %pend) done.aut.u.rod])
?~ pending.aut.u.rod
check-order:effect(aut.u.rod rod-aut)
get-authz:effect(aut.u.rod rod-aut)
:: XX delete-trial?
::
:: +retry: retry effect after timeout
::
++ retry
|= =wire
^+ this
?> ?=([%try @ @tas *] wire)
=/ try (slav %ud i.t.wire)
=* fec ~(. effect (some +(try)))
=* act i.t.t.wire
=* spur t.t.t.wire
?+ act
~&([%unknown-retry act] this)
%validate-domain
?> ?=([%idx @ ~] spur)
(validate-domain:fec (slav %ud i.t.spur))
%directory directory:fec
%nonce ?> ?=(^ spur)
(nonce:fec t.spur)
%register register:fec
%renew renew:fec
%new-order new-order:fec
%finalize-order finalize-order:fec
%check-order check-order:fec
%certificate check-order:fec :: intentional
%get-authz get-authz:fec
%test-trial test-trial:fec
%finalize-trial finalize-trial:fec
==
--
:: +sigh-tang: handle http request failure
::
++ sigh-tang
|= [=wire =tang]
^- (quip move _this)
?> ?=([%acme ^] wire)
:: XX may God forgive me for this
::
=< abet
=- ?:(?=(%& -.-) p.- this)
%- mule |.
(retry:event t.wire)
:: +sigh-recoverable-error: handle http rate-limit response
::
++ sigh-recoverable-error
|= [=wire %429 %rate-limit lim=(unit @da)]
^- (quip move _this)
~& [%sigh-recoverable wire lim]
?> ?=([%acme ^] wire)
abet:(retry:event t.wire)
:: +sigh-httr: accept http response
::
++ sigh-httr
|= [=wire rep=httr]
^- (quip move _this)
?> ?=([%acme ^] wire)
=< abet
:: add nonce to pool, if present
::
=/ nonhed (skim q.rep |=((pair @t @t) ?=(%replay-nonce p)))
=? nonces ?=(^ nonhed) [q.i.nonhed nonces]
::
?> ?=([%try @ @tas *] t.wire)
=/ try (slav %ud i.t.t.wire)
=* ven ~(. event try)
=* act i.t.t.t.wire
=* spur t.t.t.t.wire
:: request nonce if expired-invalid
::
?: (bad-nonce rep)
(nonce:effect spur)
:: XX replace with :hall notification
::
~| [%sigh-fail wire]
%. [spur rep]
?+ act
~&([%unknown-http-response act] !!)
%validate-domain
validate-domain:ven
%directory directory:ven
%nonce nonce:ven
%register register:ven
:: XX rekey
::
%new-order new-order:ven
%finalize-order finalize-order:ven
%check-order check-order:ven
%certificate certificate:ven
%get-authz get-authz:ven
:: XX check/finalize-authz ??
::
%test-trial test-trial:ven
%finalize-trial finalize-trial:ven
:: XX delete-trial?
::
==
:: +wake: timer wakeup event
::
++ wake
|= [wir=wire ~]
^- (quip move _this)
?> ?=([%acme *] wir)
abet:(retry:event t.wir)
:: +poke-acme-order: create new order for a set of domains
::
++ poke-acme-order
|= a=(set turf)
abet:(add-order a)
:: +poke-noun: for debugging
::
++ poke-noun
|= a=*
^- (quip move _this)
=< abet
?+ a
~&(+<+.this this)
%dbug ~& [%private (ring:en:pem:pkcs1 key.act)]
~& [%public (pass:en:pem:pkcs1 key.act)]
this
%init init
%reg register:effect
%order new-order:effect
%auth get-authz:effect
%trial test-trial:effect
%final finalize-order:effect
%poll check-order:effect
%our (add-order (sy /org/urbit/(crip +:(scow %p our.bow)) ~))
%rule install:effect
%fake fake
%none none
==
:: +none: uninstall cert for testing
::
:: XX remove
::
++ none
^+ this
(emit %rule /uninstall %cert ~)
:: +fake: install fake cert for testing
::
:: XX remove
::
++ fake
^+ this
=/ key=wain
:~ '-----BEGIN RSA PRIVATE KEY-----'
'MIIEpAIBAAKCAQEAisQPzzmGWNZSNNAwY59XrqK/bU0NKNZS2ETOiJeSpzPAHYl+'
'c39V96/QUR0tra2zQI4QD6kpMYX/7R5nwuvsA4o7ypfYupNrlzLPThCKEHpZomDD'
'0Bb3T8u7YGrMjEX5cOmZIU2T/iy4GK/wWuBIy2TEp/0J+RoSCIr8Df/A7GIM8bwn'
'v23Vq0kE2xBqqaT5LjvuQoXfiLJ42F33DDno9lVikKEyt55D/08rH41KpXvn3tWZ'
'46tZK6Ds7Zr1hEV1LbDx1CXDzQ6gKObBe54DWDV3h7TJhr0BSW68dFJhro7Y60Ns'
'zTcFqY1RC9F0ePtsnKGFzMOe/U+fPvsGe2oWvwIDAQABAoIBACCf19ewfpWETe98'
'wuOpIsQ8HyVjaCShvvh5tNUITcJhuFk5ajFdTqjc/O0VHxgmLm6O99e2vaiXCISH'
'EX4SWXq7lTMcYCf9YN47Y+HGoa8eFNTIS0ExJRPtojAY695O1UZmpUnfI1wux1mG'
'g8vZz0OCfXnBVAbsyjCX/IqOBp2MVzfMyMuaF/oQ2xiX4AZ1hDIMDpUTGw7OKX15'
'JAUlTZUhzifmijPg1gViD8Lf5w42nlwYPC5j6wWKpJSx76CNUxLdJAaaZb3QYE96'
'zu/jOCdy25sPHIux3XTdV6fqZ2iTvt31+bcnSAvmbDpmcujsZPVRXRu5OO/0xBh6'
'GGlTLAECgYEAwSyNkbNk0mBRxet68IW02wXYaxIEVUWqhSeE2MGaXg4h9VSgh83q'
'7wly0ujy9Sj79aF2frkpMbIoeeGIOTIYI4RCYuBKx+/NNWFoggu4UK5xOMr0dfQK'
'2Ggr2agUH3KExvOpAW3rvWzepLl8ppySLNipLcFQHOJ0kxwPd2ig3Z8CgYEAt+WM'
'JoW9dLxUu/zTih5Dacubl+fnnm8BsypKmv88mzcqEVwXOo6Z6bmlw0NeWxmlwHu7'
'vs+XQ8MDUDvQvIul8sFagZk7RvWcXTlaHtPQ1D8/ztrg5d58TwxpwXshBytfR6NA'
'tIZa+tNvzQF5AKVlB+lZEWF6E6FoI5NmGDAZ8uECgYB4FV4cCMzQCphK1Muj4TpA'
'PS3/wT94Usph4+Mta4yuk1KA047HXTaCSflbKvx9cnDOjQTAWhJFll6bBZxNEdr3'
'mSw7kvppt6R1Xow861Q0s3wmteOpv39Ob9Nyho2bzvDDTIzvGonFQ3xUIgpe+E3W'
'GwlwLA/FJPEa0gK7VAtMOQKBgQCgcPtX2LM0l+Ntp+V/yWuTb/quC7w+tCbNhAZX'
'OHxOB1ECmFAD3MpX6oq+05YM8VF1n/5rOX6Ftiy74ZP6C/Sa2Sr3ixL2k+76PsFr'
'x+2YYB5xgPFaXEQkS3YxQhXMxYB5ZetcFSRnVfVi7Pf/Ik4FGweEbIEvg1DySPV4'
'AO+CwQKBgQCFnjHsFeNZVvtiL2wONT6osjRCpMvaUiVecMW9oUBtjpLHI2gQr7+4'
'dvCm2Sj7uq9OWO0rBz1px/kI+ONjhwsFPLK5v8hyVDoIE791Qg3qAY1a6JOXRl9P'
'6TBc3dQ2qUVqt8gi9RLCDFJU18Td6La4mkJSP5YrioGtwUJow0F07Q=='
'-----END RSA PRIVATE KEY-----'
==
=/ cert=wain
:~ '-----BEGIN CERTIFICATE-----'
'MIIF8jCCBNqgAwIBAgITAPrPc8Udwmv5dJ+hx2Uh+gZF1TANBgkqhkiG9w0BAQsF'
'ADAiMSAwHgYDVQQDDBdGYWtlIExFIEludGVybWVkaWF0ZSBYMTAeFw0xODA3MDMx'
'ODAyMTZaFw0xODEwMDExODAyMTZaMB8xHTAbBgNVBAMTFHpvZC5keW5kbnMudXJi'
'aXQub3JnMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAisQPzzmGWNZS'
'NNAwY59XrqK/bU0NKNZS2ETOiJeSpzPAHYl+c39V96/QUR0tra2zQI4QD6kpMYX/'
'7R5nwuvsA4o7ypfYupNrlzLPThCKEHpZomDD0Bb3T8u7YGrMjEX5cOmZIU2T/iy4'
'GK/wWuBIy2TEp/0J+RoSCIr8Df/A7GIM8bwnv23Vq0kE2xBqqaT5LjvuQoXfiLJ4'
'2F33DDno9lVikKEyt55D/08rH41KpXvn3tWZ46tZK6Ds7Zr1hEV1LbDx1CXDzQ6g'
'KObBe54DWDV3h7TJhr0BSW68dFJhro7Y60NszTcFqY1RC9F0ePtsnKGFzMOe/U+f'
'PvsGe2oWvwIDAQABo4IDIjCCAx4wDgYDVR0PAQH/BAQDAgWgMB0GA1UdJQQWMBQG'
'CCsGAQUFBwMBBggrBgEFBQcDAjAMBgNVHRMBAf8EAjAAMB0GA1UdDgQWBBTokXAU'
'vPwcrbkLxcVBCNNQ588pfjAfBgNVHSMEGDAWgBTAzANGuVggzFxycPPhLssgpvVo'
'OjB3BggrBgEFBQcBAQRrMGkwMgYIKwYBBQUHMAGGJmh0dHA6Ly9vY3NwLnN0Zy1p'
'bnQteDEubGV0c2VuY3J5cHQub3JnMDMGCCsGAQUFBzAChidodHRwOi8vY2VydC5z'
'dGctaW50LXgxLmxldHNlbmNyeXB0Lm9yZy8wHwYDVR0RBBgwFoIUem9kLmR5bmRu'
'cy51cmJpdC5vcmcwgf4GA1UdIASB9jCB8zAIBgZngQwBAgEwgeYGCysGAQQBgt8T'
'AQEBMIHWMCYGCCsGAQUFBwIBFhpodHRwOi8vY3BzLmxldHNlbmNyeXB0Lm9yZzCB'
'qwYIKwYBBQUHAgIwgZ4MgZtUaGlzIENlcnRpZmljYXRlIG1heSBvbmx5IGJlIHJl'
'bGllZCB1cG9uIGJ5IFJlbHlpbmcgUGFydGllcyBhbmQgb25seSBpbiBhY2NvcmRh'
'bmNlIHdpdGggdGhlIENlcnRpZmljYXRlIFBvbGljeSBmb3VuZCBhdCBodHRwczov'
'L2xldHNlbmNyeXB0Lm9yZy9yZXBvc2l0b3J5LzCCAQIGCisGAQQB1nkCBAIEgfME'
'gfAA7gB1ALDMg+Wl+X1rr3wJzChJBIcqx+iLEyxjULfG/SbhbGx3AAABZGGGG6QA'
'AAQDAEYwRAIgJHrIawVea5/++wteocdbt1QUBxysW7uJqYgvnOWOQMgCIGRlioyE'
'vzunUm/HZre3fF2jBsJr45C1tz5FTe/cYQwmAHUA3Zk0/KXnJIDJVmh9gTSZCEmy'
'Sfe1adjHvKs/XMHzbmQAAAFkYYYjLQAABAMARjBEAiAWovIKERYeNbJlAKvNorwn'
'RnSFP0lJ9sguwcpbcsYJ1gIgRJxTolkMOr0Fwq62q4UYnpREY8zu4hiL90Mhntky'
'EwYwDQYJKoZIhvcNAQELBQADggEBAMYxvA+p4Qj0U23AHAe61W3+M6T1M0BfrGE2'
'jJCaq4c3d7b9NEN1qFJHl8t/+Z/7RHUIzbm4CIOZynSM8mBxg2NgXymvXQkRrrBo'
'fhO9u8Yxizx4+KOtiigt9JBVlpyCm6I9uifM+7rZYh45s2IkfDBPKd+M1tfIUOne'
'YgUt1YguEkM2xqRG16JyHA0Xwn6mn+4pWiTdfNzlqol6vyGT7WfIvmV7cdGoYKjB'
'wOt/g1wWMTwhSWBCVqCyn+f2rl8u3wbXrIUeRng2ryNVXO03nukTp7OLN3HUO6PR'
'hC4NdS4o2geBNZr8RJiORtCelDaJprY7lhh2MFzVpsodc2eB5sQ='
'-----END CERTIFICATE-----'
''
'-----BEGIN CERTIFICATE-----'
'MIIEqzCCApOgAwIBAgIRAIvhKg5ZRO08VGQx8JdhT+UwDQYJKoZIhvcNAQELBQAw'
'GjEYMBYGA1UEAwwPRmFrZSBMRSBSb290IFgxMB4XDTE2MDUyMzIyMDc1OVoXDTM2'
'MDUyMzIyMDc1OVowIjEgMB4GA1UEAwwXRmFrZSBMRSBJbnRlcm1lZGlhdGUgWDEw'
'ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDtWKySDn7rWZc5ggjz3ZB0'
'8jO4xti3uzINfD5sQ7Lj7hzetUT+wQob+iXSZkhnvx+IvdbXF5/yt8aWPpUKnPym'
'oLxsYiI5gQBLxNDzIec0OIaflWqAr29m7J8+NNtApEN8nZFnf3bhehZW7AxmS1m0'
'ZnSsdHw0Fw+bgixPg2MQ9k9oefFeqa+7Kqdlz5bbrUYV2volxhDFtnI4Mh8BiWCN'
'xDH1Hizq+GKCcHsinDZWurCqder/afJBnQs+SBSL6MVApHt+d35zjBD92fO2Je56'
'dhMfzCgOKXeJ340WhW3TjD1zqLZXeaCyUNRnfOmWZV8nEhtHOFbUCU7r/KkjMZO9'
'AgMBAAGjgeMwgeAwDgYDVR0PAQH/BAQDAgGGMBIGA1UdEwEB/wQIMAYBAf8CAQAw'
'HQYDVR0OBBYEFMDMA0a5WCDMXHJw8+EuyyCm9Wg6MHoGCCsGAQUFBwEBBG4wbDA0'
'BggrBgEFBQcwAYYoaHR0cDovL29jc3Auc3RnLXJvb3QteDEubGV0c2VuY3J5cHQu'
'b3JnLzA0BggrBgEFBQcwAoYoaHR0cDovL2NlcnQuc3RnLXJvb3QteDEubGV0c2Vu'
'Y3J5cHQub3JnLzAfBgNVHSMEGDAWgBTBJnSkikSg5vogKNhcI5pFiBh54DANBgkq'
'hkiG9w0BAQsFAAOCAgEABYSu4Il+fI0MYU42OTmEj+1HqQ5DvyAeyCA6sGuZdwjF'
'UGeVOv3NnLyfofuUOjEbY5irFCDtnv+0ckukUZN9lz4Q2YjWGUpW4TTu3ieTsaC9'
'AFvCSgNHJyWSVtWvB5XDxsqawl1KzHzzwr132bF2rtGtazSqVqK9E07sGHMCf+zp'
'DQVDVVGtqZPHwX3KqUtefE621b8RI6VCl4oD30Olf8pjuzG4JKBFRFclzLRjo/h7'
'IkkfjZ8wDa7faOjVXx6n+eUQ29cIMCzr8/rNWHS9pYGGQKJiY2xmVC9h12H99Xyf'
'zWE9vb5zKP3MVG6neX1hSdo7PEAb9fqRhHkqVsqUvJlIRmvXvVKTwNCP3eCjRCCI'
'PTAvjV+4ni786iXwwFYNz8l3PmPLCyQXWGohnJ8iBm+5nk7O2ynaPVW0U2W+pt2w'
'SVuvdDM5zGv2f9ltNWUiYZHJ1mmO97jSY/6YfdOUH66iRtQtDkHBRdkNBsMbD+Em'
'2TgBldtHNSJBfB3pm9FblgOcJ0FSWcUDWJ7vO0+NTXlgrRofRT6pVywzxVo6dND0'
'WzYlTWeUVsO40xJqhgUQRER9YLOLxJ0O6C8i0xFxAMKOtSdodMB3RIwt7RFQ0uyt'
'n5Z5MqkYhlMI3J1tPRTp1nEt9fyGspBOO05gi148Qasp+3N+svqKomoQglNoAxU='
'-----END CERTIFICATE-----'
==
=/ k=key:rsa (need (ring:de:pem:pkcs1 key))
=/ k8=wain (ring:en:pem:pkcs8 k)
(emit %rule /install %cert `[k8 cert])
:: +poke-path: for debugging
::
++ poke-path
|=(a=path abet:(add-order (sy a ~)))
:: +prep: initialize and adapt state
::
:: ++ prep _[~ this]
++ prep
|= old=(unit acme)
^- (quip move _this)
?~ old
[~ this]
[~ this(+<+ u.old)]
:: +rekey: create new 2.048 bit RSA key
::
:: XX do something about this iteration
::
++ rekey
|= eny=@
=| i=@
|- ^- key:rsa
=/ k (new-key:rsa 2.048 eny)
=/ m (met 0 n.pub.k)
:: ?: =(0 (mod m 8)) k
?: =(2.048 m) k
~& [%key iter=i width=m]
$(i +(i), eny +(eny))
:: +init: initialize :acme state
::
:: We defer the initial request for independence from the causal event,
:: which is necessary to init on the boot event. Which we no longer do,
:: but we're preserving the pattern for future flexibility.
::
++ init
=< (retry:effect 0 %directory / `@dr`1)
%= this
act [(rekey eny.bow) ~]
cey (rekey (mix eny.bow (shaz now.bow)))
==
:: +queue-next-order: enqueue domains for validation
::
++ queue-next-order
|= [valid=? dom=(set turf)]
^+ this
%= this next-order
:- ~
%+ roll
~(tap in dom)
|= [=turf state=(map turf [idx=@ud valid=?])]
(~(put by state) turf [~(wyt by state) valid])
==
:: +cancel-current-order: and archive failure for future autopsy
::
:: XX we may have pending moves out for this order
:: put dates in wires, check against order creation date?
:: or re-use order-id?
::
++ cancel-current-order
^+ this
?~ rod this
%= this
rod ~
fal.hit [u.rod fal.hit]
==
:: +add-order: add new certificate order
::
++ add-order
|= dom=(set turf)
^+ this
?: =(~ dom)
~|(%acme-empty-certificate-order !!)
?: ?=(?(%earl %pawn) (clan:title our.bow))
this
=. ..this (queue-next-order | dom)
=. ..this cancel-current-order
:: notify :hall
::
=. ..this
=/ msg=cord
%+ rap 3
:~ 'requesting an https certificate for '
(join ', ' (turn ~(tap in dom) |=(a=turf (join '.' a))))
==
(emit (notify msg ~))
:: if registered, create order
::
?^ reg.act
(validate-domain:effect 0)
:: if initialized, defer
::
?.(=(act *acct) this init)
--
Reference in New Issue View Git Blame Copy Permalink