#lang racket
(require net/base64
json
(planet gh/http/request)
(planet gh/http/head)
"keys.rkt"
"exn.rkt"
"util.rkt"
"sigv4.rkt"
)
(provide dynamo-endpoint
dynamo-region
attribute-type/c
create-table
delete-table
describe-table
list-tables
batch-get-item
batch-write-item
get-item
delete-item
put-item
query
scan
update-item
update-table
)
(define dynamo-endpoint
(make-parameter (endpoint "dynamodb.us-east-1.amazonaws.com" #t)))
(define dynamo-region
(make-parameter "us-east-1"))
(define service "dynamodb")
(define attribute-type/c (or/c "S" "N" "B"))
(define/contract (date+authorize method uri heads body)
(string? string? dict? bytes? . -> . dict?)
(let ([heads (dict-set* heads
'Host (endpoint-host (dynamo-endpoint))
'Date (seconds->gmt-8601-string 'basic
(current-seconds))
'Content-Type "application/x-amz-json-1.0")])
(dict-set* heads
"Authorization"
(aws-v4-authorization
method
uri
heads
body
(dynamo-region)
service))))
(define/contract (raw js target)
(jsexpr? string? . -> . jsexpr?)
(define p "/")
(define u (endpoint->uri (dynamo-endpoint) p))
(define bstr (string->bytes/utf-8 (jsexpr->string js)))
(define h (date+authorize "POST"
u
(hash 'x-amz-target target)
bstr))
(call/output-request "1.1" "POST" u bstr (bytes-length bstr) h
(lambda (in h)
(check-response in h)
(bytes->jsexpr (read-entity/bytes in h)))))
(define/contract (create-table name
read-units
write-units
hash-key-name
hash-key-type
[range-key-name #f]
[range-key-type #f])
((string?
exact-positive-integer? exact-positive-integer?
string? attribute-type/c)
(string? attribute-type/c)
. ->* .
jsexpr?)
(raw (hasheq
'TableName name
'KeySchema (apply hasheq
(append
(list 'HashKeyElement
(hasheq 'AttributeName hash-key-name
'AttributeType hash-key-type))
(if (and range-key-name range-key-type)
(list 'RangeKeyElement
(hasheq 'AttributeName range-key-name
'AttributeType range-key-type))
'())))
'ProvisionedThroughput (hasheq 'ReadCapacityUnits read-units
'WriteCapacityUnits write-units))
"DynamoDB_20111205.CreateTable"))
(define/contract (delete-table name)
(string? . -> . jsexpr?)
(raw (hasheq 'TableName name)
"DynamoDB_20111205.DeleteTable"))
(define/contract (describe-table name)
(string? . -> . jsexpr?)
(raw (hasheq 'TableName name)
"DynamoDB_20111205.DescribeTable"))
(define/contract (list-tables #:limit [limit #f] #:from [from #f])
(() (#:limit exact-positive-integer? #:from string?) . ->* . jsexpr?)
(raw (apply hasheq
(append (if limit (list 'Limit limit) '())
(if from (list 'ExclusiveStartTableName from) '())))
"DynamoDB_20111205.ListTables"))
(define-for-syntax (camelCase s)
(let ([s (symbol->string (syntax->datum s))])
(apply string-append (for/list ([s (regexp-split "-" s)])
(string-append (string-upcase (substring s 0 1))
(substring s 1))))))
(define-syntax (defraw stx)
(syntax-case stx ()
[(_ name)
(identifier? #'name)
(with-syntax ([amz-target (string-append "DynamoDB_20111205."
(camelCase #'name))])
#'(define/contract (name js)
(jsexpr? . -> . jsexpr?)
(raw js amz-target)))]))
(defraw put-item)
(defraw get-item)
(defraw delete-item)
(defraw update-item)
(defraw batch-get-item)
(defraw batch-write-item)
(defraw query)
(defraw scan)
(defraw update-table)
(module+ test
(require "run-suite.rkt")
(def/run-test-suite
(test-case
"dynamo"
(define test (test/dynamo-table))
(check-not-exn (lambda () (create-table test 1 1
"HashKey" "S"
"RangeKey" "S")))
(check-not-exn (lambda () (list-tables #:limit 10)))
(check-not-exn (lambda () (describe-table test)))
(let loop ()
(define x (describe-table test))
(define status (hash-ref (hash-ref x 'Table) 'TableStatus #f))
(unless (equal? status "ACTIVE")
(printf "Table status is '~a', waiting for 'ACTIVE'...\n" status)
(sleep 15)
(loop)))
(check-not-exn
(lambda () (put-item (hasheq 'TableName test
'Item (hasheq 'HashKey (hasheq 'S "Hi")
'RangeKey (hasheq 'S "world")
'Foo (hasheq 'S "bar"))))))
(sleep 2)
(define js
(get-item (hasheq 'TableName test
'Key (hasheq 'HashKeyElement (hasheq 'S "Hi")
'RangeKeyElement (hasheq 'S "world")))))
(check-equal? (hash-ref (hash-ref js 'Item) 'Foo) (hasheq 'S "bar"))
(check-not-exn (lambda () (delete-table test))))))