#lang racket
(define-syntax define/contract/provide
(syntax-rules ()
[(_ (id . args) contract body ...)
(begin
(define/contract (id . args) contract body ...)
(provide/contract [id contract]))]
[(_ id contract expr)
(begin
(define/contract id contract expr)
(provide/contract [id contract]))] ))
(define-syntax define/provide
(syntax-rules ()
[(_ (id . args) body ...)
(begin
(define (id . args) body ...)
(provide id))]
[(_ id expr)
(begin
(define id expr)
(provide id))] ))
(provide define/contract/provide
define/provide)
(define-syntax tr
(syntax-rules ()
[(_ e)
(if (or (string? (syntax-e #'e))
(number? (syntax-e #'e)))
(format "~a" e)
(format "~s=~a"
(syntax->datum #'e)
e))]
[(_ e0 e1 ...)
(string-append (tr e0)
" "
(tr e1 ...))]))
(provide tr)
(require xml)
(define/contract/provide (tags xpr tag [direct-child-of #f])
((xexpr/c symbol?)
(symbol?)
. ->* . (listof xexpr/c))
(define (do xpr parent)
(cond
[(empty? xpr) '()]
[else
(define this-xpr (first xpr))
(cond
[(and (list? this-xpr)
(not (empty? this-xpr)))
(define this-tag (first this-xpr))
(define found? (and (equal? this-tag tag)
(or (not direct-child-of)
(equal? direct-child-of parent))))
(append (if found?
(list this-xpr) '())
(do this-xpr this-tag) (do (rest xpr) parent))] [else
(do (rest xpr) parent)])])) (do xpr #f))
(define/provide (first-tag-value x t [def #f])
(match (tags x t)
['() def]
[(list (list _ v) ...) (first v)]
[(list (list _ _ v) ...) (first v)]
[else def]))
(define/provide (attribs->alist a)
(define (list->cons l)
(cons (first l) (second l)))
(map list->cons a))
(define/provide (alist->attribs a)
(define (cons->list c)
(list (car c) (cdr c)))
(map cons->list a))
(require net/uri-codec)
(define (percent-encode c)
(string-upcase (format "%~x" (char->integer c))))
(define (char->pair c)
(cons c (percent-encode c)))
(define chars-to-encode (list #\! #\'#\(#\) #\*))
(define h (for/hash ([c (in-list chars-to-encode)])
(values c (percent-encode c))))
(define/provide (uri-encode/rfc-3986 s)
(for/fold ([accum ""])
([c (in-string (uri-encode s))])
(string-append accum (hash-ref h c (make-string 1 c)))))
(define/contract/provide (dict->form-urlencoded xs)
(dict? . -> . string?)
(define (value x)
(match x
[(list x) (value x)]
[(? string? x) x]
[else (error 'dict->form-urlencoded
"values must be (or/c string? (list/c string?))")]))
(string-join (for/list ([(k v) (in-dict xs)])
(format "~a=~a"
k
(uri-encode/rfc-3986 (value v))))
"&"))
(struct endpoint (host ssl?) #:transparent)
(provide (struct-out endpoint))
(define/contract/provide (endpoint->host:port x)
(endpoint? . -> . string?)
(match-define (endpoint host ssl?) x)
(string-append host (if ssl? ":443" "")))
(define/contract/provide (endpoint->uri x path)
(endpoint? string? . -> . string?)
(match-define (endpoint host ssl?) x)
(string-append (if ssl? "https" "http")
"://"
host
(if ssl? ":443" "")
path))