#lang racket
(require net/base64
xml
(planet gh/http/request)
(planet gh/http/head)
"keys.rkt"
"exn.rkt"
"util.rkt"
)
(provide r53-endpoint
create-hosted-zone
delete-hosted-zone
list-hosted-zones
domain-name->zone-id
get-hosted-zone
list-resource-record-sets
change-resource-record-sets
)
(define r53-endpoint (make-parameter (endpoint "route53.amazonaws.com" #t)))
(define/contract (date+authorize h)
(dict? . -> . dict?)
(define d (seconds->gmt-string))
(define a (format
"AWS3-HTTPS AWSAccessKeyId=~a,Algorithm=HmacSHA256,Signature=~a"
(public-key)
(sha256-encode d)))
(dict-set* h
'Date d
'X-Amzn-Authorization a))
(define/contract (create-hosted-zone name unique [comment ""])
((string? string?) (string?) . ->* . xexpr?)
(define p "/2012-02-29/hostedzone")
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize (hash 'Content-Type "application/xml")))
(define bstr (string->bytes/utf-8
(xexpr->string
`(CreateHostedZoneRequest
([xmlns "https://route53.amazonaws.com/doc/2012-02-29/"])
(Name () ,name)
(CallerReference () ,unique)
(HostedZoneConfig () (Comment () ,comment))))))
(call/output-request "1.1" "POST" u bstr (bytes-length bstr) h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(define/contract (delete-hosted-zone id)
(string? . -> . xexpr?)
(define p (string-append "/2012-02-29" id))
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize '()))
(call/input-request "1.1" "DELETE" u h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(define/contract (list-hosted-zones)
(-> xexpr?)
(define p "/2012-02-29/hostedzone")
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize '()))
(call/input-request "1.1" "GET" u h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(define/contract (get-hosted-zone id)
(string? . -> . xexpr?)
(define p (string-append "/2012-02-29" id))
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize '()))
(call/input-request "1.1" "GET" u h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(define/contract (domain-name->zone-id name)
(string? . -> . (or/c #f string?))
(let ([name (match name [(pregexp "\\.$") name]
[else (string-append name ".")])])
(for/or ([x (tags (list-hosted-zones) 'HostedZone)])
(define s (first-tag-value x 'Name))
(cond [(and s (string=? s name)) (first-tag-value x 'Id)]
[else #f]))))
(define record-type/c
(or/c 'A 'AAAA 'CNAME 'MX 'NS 'PTR 'SOA 'SPF 'SRV 'TXT))
(define/contract (list-resource-record-sets zone-id
#:max-items [max-items #f]
#:name [name #f]
#:type [type #f]
#:id [id #f])
((string?)
(#:max-items (or/c #f exact-positive-integer?)
#:name (or/c #f string?)
#:type (or/c #f record-type/c)
#:id (or/c #f string?))
. ->* . (listof xexpr?))
(let loop ([max-items max-items]
[name name]
[type type]
[id id])
(define d (apply dict-set* (cons (hash)
(true-value-pairs 'maxitems max-items
'name name
'type type
'identifier id))))
(define qp (dict->form-urlencoded d))
(define p (string-append "/2012-02-29" zone-id "/rrset?" qp))
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize '()))
(define x (call/input-request "1.1" "GET" u h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(define rs (or (tags x 'ResourceRecordSet) '()))
(define len (length rs))
(append rs
(cond [(and (< len max-items)
(string-ci=? "true" (first-tag-value x 'IsTruncated)))
(loop (min max-items len)
(first-tag-value x 'NextRecordName)
(first-tag-value x 'NextRecordType)
(first-tag-value x 'NextRecordId))]
[else '()]))))
(define/contract (change-resource-record-sets zone-id changes)
(string? xexpr? . -> . xexpr?)
(define p (string-append "/2012-02-29" zone-id "/rrset"))
(define u (endpoint->uri (r53-endpoint) p))
(define h (date+authorize (hash 'Content-Type "application/xml")))
(define bstr (string->bytes/utf-8 (xexpr->string changes)))
(displayln bstr)
(call/output-request "1.1" "POST" u bstr (bytes-length bstr) h
(lambda (in h)
(check-response in h)
(read-entity/xexpr in h))))
(module+ test
(require "run-suite.rkt")
(def/run-test-suite
(test-case
"Route53 create/delete hosted zone"
(ensure-have-keys)
(define x (create-hosted-zone (test/domain.com)
(format "unique-~a" (current-seconds))
"some comment"))
(check-true (xexpr? x))
(define zid (first-tag-value x 'Id))
(check-true (string? zid))
(delete-hosted-zone zid))
(test-case
"Route53 read-only record sets"
(ensure-have-keys)
(define zs (list-hosted-zones))
(define zid (first-tag-value zs 'Id)) (define name (first-tag-value zs 'Name)) (check-true (match (get-hosted-zone zid)
[`(GetHostedZoneResponse
((xmlns "https://route53.amazonaws.com/doc/2012-02-29/"))
(HostedZone ()
(Id () ,zid)
,_ ...)
,_ ...)
#t]
[_ #f]))
(check-true (match (list-resource-record-sets zid
#:name name
#:max-items 1)
[`((ResourceRecordSet ()
(Name () ,name)
,_ ...))
#t]
[_ #f]))
(check-equal? (list-resource-record-sets zid
#:name "zzzzzzzzzzzz.com."
#:max-items 100)
'())
)))