(module request mzscheme
(require (lib "contract.ss")
(lib "plt-match.ss")
(lib "pretty.ss")
(lib "base64.ss" "net")
(lib "cut.ss" "srfi" "26")
(planet "ssax.ss" ("lizorkin" "ssax.plt" 1))
(file "base.ss")
(file "config.ss")
(file "ssl-url.ss")
(file "throttle.ss"))
(define http-code-regexp
#rx"^HTTP/[0-9.]+[ ]+([0-9][0-9][0-9])")
(define (http-authorization-header username password)
(let ([username-bytes (string->bytes/utf-8 username)]
[password-bytes (string->bytes/utf-8 password)])
(string-append
"Authorization: Basic "
(bytes->string/utf-8 (base64-encode (bytes-append username-bytes #":" password-bytes))))))
(define (send-request url)
(when (dump-request-urls?)
(display url)
(newline))
(let* ([url (string->url url)]
[req-headers (list (http-authorization-header (current-username) (current-password)))]
[in (call-with-throttle (current-throttle) (cut get-impure-port url req-headers))]
[res-headers (purify-port in)])
(match (regexp-match http-code-regexp res-headers)
[(list _ "200")
(let ([sxml (ssax:xml->sxml in null)])
(close-input-port in)
(when (dump-sxml-responses?)
(pretty-print sxml))
(caddr sxml))]
[(list _ "401")
(close-input-port in)
(raise (make-exn:delicious:auth "Bad username/password."
(current-continuation-marks)))]
[(list _ "503")
(close-input-port in)
(raise (make-exn:fail:delicious:throttled "Throttled: please wait a bit before trying again."
(current-continuation-marks)))]
[(list _ code)
(close-input-port in)
(raise (make-exn:fail:delicious (format "Could not handle response (HTTP code ~a)." code)
(current-continuation-marks)))])))
(provide/contract
[send-request (-> string? (or/c null? pair?))])
)