Merge 84f1237 into 49936b2

request/private/base.rkt

@@ -7,7 +7,6 @@
 
 (provide http-requester)
 
-
 (define (http-get url #:headers [headers '()])
   (call-response/input-url url (get-impure-port _ headers)))
 
@@ -24,4 +23,4 @@
   (requester http-get
              http-put
              http-post
-             http-delete))
+             http-delete))

request/private/base.scrbl

@@ -29,3 +29,15 @@
   responses while this struct is used when
   @italic{receiving} them.
 }
+
+@defrequester[json-requester]{
+  Wraps @racket[http-requester] and modifies the request to
+  include two headers: "Content-Type: application/json" and
+  "Accept: application/json". The body of the request is automatically converted
+  from a @racket[jsexpr?] to a JSON string. Locations are @racket[url?]s,
+  headers are @racket[string?]s as in the impure port functions, bodies are
+  @racket[jsexpr?], and responses are instances of the
+  @racket[json-response] struct. If the response comes back with non-JSON or it
+  cannot otherwise be parsed correctly into a @racket[jsexpr?] it will throw
+  @racket[exn:fail:json?]
+}

request/private/call-response.rkt

@@ -2,7 +2,8 @@
 
 (require typed/net/url
          typed/net/head
-         fancy-app)
+         fancy-app
+         typed/json)
 
 (provide (struct-out http-response)
          HttpResponse
@@ -25,7 +26,6 @@
 (: not-whitespace? (-> Char Boolean))
 (define (not-whitespace? char)
   (not (char-whitespace? char)))
-
 (: split-combined-header (-> String (Values String String)))
 (define (split-combined-header HTTP-header+MIME-headers)
   (define chars (string->list HTTP-header+MIME-headers))
@@ -51,7 +51,6 @@
   (define raw-body (port->string impure-port))
   (http-response status-code headers raw-body))
 
-
 (: call-response/input-url (-> Url (-> Url Input-Port) HttpResponse))
 (define (call-response/input-url url connect)
   (call/input-url url connect impure-port->response))

request/private/exn.rkt

@@ -11,7 +11,6 @@
          http-requester/exn
          http-exn-of-code?)
 
-
 (define message-codes
   (hash 400 "Bad Request"
         401 "Unauthorized"

request/private/exn.scrbl

@@ -15,6 +15,13 @@
   wrapped by @racket[requester-http-exn].
 }
 
+@defstruct*[(exn:fail:json exn:fail)
+            ([response string?])]{
+  This exception is thrown by @racket[json-requester]s
+  when they cannot parse the response as valid JSON. The original response
+  is returned as a string in the body of the exception.
+}
+
 @defproc[(requester-http-exn [requester requester?])
          requester?]{
   Given a @racket[requester] whose responses are @racket[http-response]s,

request/private/http-location.rkt

@@ -2,6 +2,7 @@
 
 (require net/url
          fancy-app
+         "json.rkt"
          "struct.rkt"
          "wrap.rkt")
 
@@ -29,8 +30,8 @@
    (domain+relative-path->http-url domain _) requester))
 
 (define (make-https-requester requester)
- (wrap-requester-location
-  (http-url->https-url _) requester))
+  (wrap-requester-location
+   (http-url->https-url _) requester))
 
 (define (make-host+port-requester host port requester)
   (make-domain-requester (host+port->domain host port) requester))
@@ -40,22 +41,24 @@
            rackunit
            "base.rkt"
            "call-response.rkt")
-
+  
   (define domain "httpbin.org")
   (define http-url (domain+relative-path->http-url domain "/"))
   (define http-req (make-domain-requester domain http-requester))
   (define https-req (make-domain-requester
                      domain (make-https-requester http-requester)))
-
+
+  (check-pred requester? http-req)
+  (check-pred requester? https-req)
+
   (define http-resp (get http-req "/get"))
   (define https-resp (get https-req "/get"))
-
+  
   (check-pred url? http-url)
   (check-equal? (url-scheme http-url) "http")
   (check-equal?
    (hash-ref (string->jsexpr (http-response-body https-resp)) 'url)
    "https://httpbin.org/get")
 
-  (check-pred requester? http-req)
   (check-equal? (http-response-code http-resp) 200)
   (check-equal? (http-response-code https-resp) 200))

request/private/json.rkt

@@ -0,0 +1,95 @@
+#lang racket
+
+(require json
+         "base.rkt"
+         "exn.rkt"
+         "struct.rkt"
+         "wrap.rkt")
+
+(provide (struct-out exn:fail:json)
+         json-requester)
+
+(struct exn:fail:json exn () #:transparent)
+
+(define json-headers
+  '("Accept: application/json" "Content-Type: application/json"))
+
+(define (make-json-exn handler-response)
+  (exn:fail:json (~a handler-response) (current-continuation-marks)))
+
+(define (wrap-json-body body)
+  (if (jsexpr? body)
+      (jsexpr->bytes body)
+      body))
+
+(define (handle-json-response response)
+  (define json-resp 
+    (with-handlers ([exn:fail:read? (λ (e) #f)])
+      (string->jsexpr response)))
+  (if (not json-resp)
+      (raise (make-json-exn response))
+      json-resp))
+
+(define json-requester
+  (wrap-requester-response
+   handle-json-response
+   (wrap-requester-body
+    wrap-json-body
+    (add-requester-headers
+     json-headers http-requester/exn))))
+
+(module+ integraton-test
+  (require net/url
+           rackunit)
+
+  (check-pred requester? json-requester)
+
+  (define (make-url path)
+    (string->url (format "http://httpbin.org/~a" path)))
+
+  (define (get-headers response)
+    (hash-ref response 'headers))
+
+  (define (get-data response)
+    (hash-ref response 'data))
+
+  (define json-get (requester-get json-requester))
+  (define json-put (requester-put json-requester))
+  (define json-post (requester-post json-requester))
+  (define json-delete (requester-delete json-requester))
+
+  (define get-200 ((requester-get json-requester)
+                   (make-url "get") #:headers '("x-men: colossus")))
+
+  (check-pred jsexpr? get-200)
+  (check-equal? (hash-ref (get-headers get-200) 'Content-Type)
+               "application/json")
+  (check-equal? (hash-ref (get-headers get-200) 'Accept)
+               "application/json")
+  (check-equal? (hash-ref (get-headers get-200) 'X-Men)
+                "colossus")
+
+  (define put-200 (json-put (make-url "put") (hash 'foo "bar")))
+  (check-pred jsexpr? put-200)
+  (check-equal? (get-data put-200) "{\"foo\":\"bar\"}")
+
+  (define post-200 (json-post (make-url "post") (hash 'foo "bar")))
+  (check-pred jsexpr? post-200)
+  (check-equal? (get-data post-200) "{\"foo\":\"bar\"}")
+
+  (define delete-200 (json-delete (make-url "delete")))
+  (check-pred jsexpr? delete-200)
+
+  ;; get HTML which should throw exn:fail:json
+  (check-exn
+   exn:fail:json?
+   (λ () ((requester-get json-requester) (make-url "html"))))
+
+  ;; httpbin returns a non-JSON body for 418 Teapot
+  (check-exn
+   exn:fail:network:http:code?
+   (λ () (json-get (make-url "status/418"))))
+
+  (check-exn
+   exn:fail:network:http:code?
+   (λ () (json-get (make-url "status/406")))))