Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 75 lines (68 sloc) 2.529 kb
874a0e45 »
2012-08-18 Initial commit.
1 #lang racket
2
3 (require xml
4 net/base64
5 (planet gh/http/request)
6 (planet gh/http/head)
7 "exn.rkt"
8 "util.rkt")
9
10 ;;; Some functions used by both SQS and SDB
11 ;;; This module probably needs a better name/organization.
12
13 (define/contract/provide (post-with-retry uri xs-post-data heads [try 1])
14 ((string? (listof (list/c symbol? string?)) dict?)
15 (exact-positive-integer?)
16 . ->* .
17 xexpr?)
18 (define data (string->bytes/utf-8 (dict->form-urlencoded xs-post-data)))
19 (log-debug (tr "POST" data))
20 (call/output-request
21 "1.1" "POST" uri data #f heads
22 (lambda (in h)
23 (define e (read-entity/xexpr in h))
24 (match (extract-http-code h)
25 [200 e]
26 [503
27 (if (<= try 5)
28 (let ([sleep-time (sqr try)]) ;wait longer each time
29 (log-info (format "SDB returned 503. Try ~a in ~a secs."
30 (add1 try) sleep-time))
31 (sleep sleep-time)
32 (post-with-retry uri xs-post-data heads (add1 try)))
33 (error 'post-with-retry "too many 503 retries; giving up"))]
34 [else
35 (raise (header&response->exn:fail:aws
36 h e (current-continuation-marks)))]))))
37
38 (define/provide (set-next-token params token)
39 (cons (list 'NextToken token)
40 (filter (lambda (x) (not (equal? (car x) 'NextToken)))
41 params)))
42
43 (define/provide (timestamp [seconds (current-seconds)])
44 (seconds->gmt-8601-string 'T/Z seconds))
45
46 ;; SDB docs:
47 ;; "To ensure that you can read all the data you sent via REST, if a
48 ;; response contains invalid XML characters, Amazon SimpleDB
49 ;; automatically Base64-encodes the UTF-8 octets of the text."
50 ;;
51 ;; Example:
52 ;; <Attribute>
53 ;; <Name encoding="base64">...</Name>
54 ;; <Value encoding="base64">...</Value>
55 ;; </Attribute>
56 ;;
57 ;; "When designing your application, make sure to scrub any data for
58 ;; invalid characters or design your application to handle
59 ;; Base64-encoded results."
60 (define/contract/provide (attribute-xexpr->attrib-pair x)
61 (xexpr? . -> . (list/c symbol? string?))
62 ;; (Attribute () (Name () x) (Value () x))
63 (match x
64 [(list 'Attribute _ name val)
65 (let ([name (maybe-decode name)]
66 [val (maybe-decode val)])
67 (list (if (string? name) (string->symbol name) name)
68 val))]))
69
70 (define/provide (maybe-decode x)
71 (match x
72 [(list (or 'Name 'Value) attrs val)
73 (match (assoc 'Encoding attrs)
74 [(list 'Encoding "base64") (base64-decode val)]
75 [else val])]))
Something went wrong with that request. Please try again.