session: add support for middleware

Author: Bogdanp

http-easy-lib/http-easy/middleware.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+
+(require "private/middleware.rkt")
+(provide (all-from-out "private/middleware.rkt"))

http-easy-lib/http-easy/private/middleware.rkt

@@ -0,0 +1,56 @@
+#lang racket/base
+
+(require net/url
+         racket/contract/base
+         "contract.rkt"
+         "response.rkt")
+
+(provide
+ middleware/c
+ middleware-continuation/c
+ (contract-out
+  [compose-middleware
+   (case->
+    (-> middleware/c middleware/c)
+    (-> middleware/c middleware/c middleware/c)
+    (-> middleware/c middleware/c #:rest middleware/c middleware/c))]))
+
+(define middleware-continuation/c
+  (-> url?
+      #:method method/c
+      #:headers headers/c
+      #:params query-params/c
+      #:auth (or/c #f auth-procedure/c)
+      #:data (or/c #f bytes? string? input-port? payload-procedure/c)
+      #:history (listof response?)
+      #:attempts exact-nonnegative-integer?
+      #:redirects exact-nonnegative-integer?
+      response?))
+
+(define middleware/c
+  (-> url?
+      middleware-continuation/c
+      #:method method/c
+      #:headers headers/c
+      #:params query-params/c
+      #:auth (or/c #f auth-procedure/c)
+      #:data (or/c #f bytes? string? input-port? payload-procedure/c)
+      #:history (listof response?)
+      #:attempts exact-nonnegative-integer?
+      #:redirects exact-nonnegative-integer?
+      response?))
+
+(define compose-middleware
+  (case-lambda
+    [(a) a]
+    [(a b)
+     (make-keyword-procedure
+      (lambda (kws kw-args u go . args)
+        (keyword-apply
+         a kws kw-args u
+         (make-keyword-procedure
+          (lambda (kws kw-args u . args) ;; noqa
+            (keyword-apply b kws kw-args u go args)))
+         args)))]
+    [(a b . args)
+     (apply compose-middleware (compose-middleware a b) args)]))

http-easy-lib/http-easy/private/session.rkt

@@ -14,6 +14,7 @@
          "contract.rkt"
          "error.rkt"
          "logger.rkt"
+         "middleware.rkt"
          "payload.rkt"
          "pool.rkt"
          "proxy.rkt"
@@ -36,7 +37,8 @@
         [#:pool-config pool-config?
          #:ssl-context (or/c #f ssl-client-context? (promise/c ssl-client-context?))
          #:cookie-jar (or/c #f (is-a?/c cookie-jar<%>))
-         #:proxies (listof proxy?)]
+         #:proxies (listof proxy?)
+         #:middleware (or/c #f middleware/c)]
         session?)]
   [session?
    (-> any/c boolean?)]
@@ -75,14 +77,16 @@
    ssl-ctx
    cookies
    proxies
+   middleware
    [closed? #:mutable])
   #:transparent)
 
 (define (make-session
          #:pool-config [conf (make-pool-config)]
          #:ssl-context [ssl-ctx (delay/sync (ssl-secure-client-context))]
          #:cookie-jar [cookies #f]
-         #:proxies [proxies null])
+         #:proxies [proxies null]
+         #:middleware [middleware #f])
   (define the-session
     (session
      #;cust (make-custodian)
@@ -92,6 +96,7 @@
      #;ssql-ctx ssl-ctx
      #;cookies cookies
      #;proxies proxies
+     #;middleware middleware
      #;closed? #f))
   (will-register executor the-session session-close!)
   (log-http-easy-debug "session opened")
@@ -170,15 +175,16 @@
       [(supplied? json) (json-payload json)]
       [else data]))
 
-  (define (go u
-              #:method [method method] ;; noqa
-              #:headers [headers headers] ;; noqa
-              #:params [params params] ;; noqa
-              #:auth [auth auth] ;; noqa
-              #:data [data the-data] ;; noqa
-              #:history [history null]
-              #:attempts [attempts-remaining max-attempts]
-              #:redirects [redirects-remaining max-redirects])
+  (define (go
+           #:method method ;; noqa
+           #:headers headers ;; noqa
+           #:params params ;; noqa
+           #:auth auth ;; noqa
+           #:data data ;; noqa
+           #:history history
+           #:attempts attempts-remaining
+           #:redirects redirects-remaining
+           u)
     (let*-values ([(headers) (hash-set headers 'user-agent user-agent)]
                   [(headers) (maybe-add-cookie-header sess u headers)]
                   [(headers params)
@@ -209,7 +215,16 @@
                                [(positive? attempts-remaining)
                                 (log-http-easy-debug "retrying~n  attempts remaining: ~a" (sub1 attempts-remaining))
                                 (parameterize-break enable-breaks?
-                                  (go u #:attempts (sub1 attempts-remaining) #:history history))]
+                                  (go+middleware
+                                   u
+                                   #:method method
+                                   #:headers headers
+                                   #:params params
+                                   #:auth auth
+                                   #:data data
+                                   #:history history
+                                   #:attempts (sub1 attempts-remaining)
+                                   #:redirects redirects-remaining))]
                                [else
                                 (log-http-easy-warning "out of retries; bubbling up exception")
                                 (raise e)]))])
@@ -280,14 +295,18 @@
              (response-drain! resp (timeout-config-request timeouts))
              (response-close! resp)
              (parameterize-break enable-breaks?
-               (go dest-url
-                   #:method (case (response-status-code resp)
-                              [(301 302 303) 'get]
-                              [(307 308)     method])
-                   #:headers (hash-remove headers 'authorization)
-                   #:auth (and (same-origin? dest-url u) auth)
-                   #:history (cons resp history)
-                   #:redirects (sub1 redirects-remaining)))]
+               (go+middleware
+                dest-url
+                #:method (case (response-status-code resp)
+                           [(301 302 303) 'get]
+                           [(307 308)     method])
+                #:headers (hash-remove headers 'authorization)
+                #:params params
+                #:auth (and (same-origin? dest-url u) auth)
+                #:data data
+                #:history (cons resp history)
+                #:attempts attempts-remaining
+                #:redirects (sub1 redirects-remaining)))]
             [(or close? (not stream?))
              (response-drain! resp (timeout-config-request timeouts))
              (response-close! resp)
@@ -298,7 +317,25 @@
              (will-register executor resp response-close!)
              resp])))))
 
-  (go (->url urlish)))
+  (define go+middleware
+    (cond
+      [(session-middleware sess)
+       => (lambda (m)
+            (make-keyword-procedure
+             (lambda (kws kw-args u . args)
+               (keyword-apply m kws kw-args u go args))))]
+      [else go]))
+
+  (go+middleware
+   (->url urlish)
+   #:method method
+   #:headers headers
+   #:params params
+   #:auth auth
+   #:data the-data
+   #:history null
+   #:attempts max-attempts
+   #:redirects max-redirects))
 
 ;; https://www.rfc-editor.org/rfc/rfc2616#section-14.30
 (define (ensure-absolute-url orig location)

http-easy-lib/info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define license 'BSD-3-Clause)
-(define version "0.10")
+(define version "0.11")
 (define collection "net")
 (define deps
   '(["base" #:version "8.1.0.4"]

http-easy-test/info.rkt

@@ -12,7 +12,8 @@
     "plot-gui-lib"
     "plot-lib"
     "rackunit-lib"
-    ("resource-pool-lib" #:version "0.1")
+    ["resource-pool-lib" #:version "0.1"]
     "threading-lib"
     "web-server-lib"))
-(define update-implies '("http-easy"))
+(define update-implies
+  '("http-easy"))

http-easy-test/net/http-easy/http-easy.rkt

@@ -3,6 +3,7 @@
 (require json
          net/cookies
          net/http-easy
+         net/http-easy/middleware
          net/url
          racket/class
          racket/match
@@ -27,6 +28,8 @@
                   request-bindings/raw
                   request-headers/raw
                   request-post-data/raw
+                  response/empty
+                  response/jsexpr
                   response/output
                   see-other
                   temporarily/same-method)
@@ -570,7 +573,89 @@
        (check-exn
         #rx"session-lease: session closed"
         (lambda ()
-          (session-request s "https://example.com"))))))))
+          (session-request s "https://example.com")))))
+
+    (let* ([timings (make-hash)]
+           [timing-middleware
+            (make-keyword-procedure
+             (lambda (kws kw-args u k)
+               (define-values (res cpu-time real-time gc-time)
+                 (time-apply
+                  (lambda ()
+                    (keyword-apply k kws kw-args u null))
+                  null))
+               (hash-update!
+                #;ht timings
+                #;key u
+                #;update-proc
+                (lambda (timings)
+                  (cons (list cpu-time real-time gc-time) timings))
+                #;failure-result null)
+               (car res)))]
+           [token-box (box "token-1")]
+           [oauth-middleware
+            (make-keyword-procedure
+             (lambda (kws kw-args u k)
+               (match (keyword-apply k kws kw-args u null)
+                 [(response #:status-code 401)
+                  (set-box! token-box "token-2")
+                  (keyword-apply k kws kw-args u null)]
+                 [resp resp])))]
+           [oauth-handler
+            (lambda (req)
+              (define heads
+                (request-headers/raw req))
+              (define token
+                (let* ([v (headers-assq* #"authorization" heads)]
+                       [v (header-value v)])
+                  (bytes->string/utf-8 v #f 7)))
+              (match token
+                ["token-1"
+                 (response/jsexpr
+                  #:code 401
+                  (hasheq 'error "token expired"))]
+                ["token-2"
+                 (response/jsexpr
+                  (hasheq 'message "ok"))]
+                ["token-3"
+                 (response/jsexpr
+                  #:code 401
+                  (hasheq 'error "invalid token"))]))])
+      (test-suite
+       "middleware"
+
+       (test-case "instrumentation"
+         (call-with-web-server
+          (lambda (_req)
+            (response/empty))
+          (lambda (addr)
+            (parameterize ([current-session (make-session #:middleware timing-middleware)])
+              (define res (get addr))
+              (check-equal? (response-status-code res) 204)
+              (check-not-false (hash-ref timings (string->url addr)))))))
+
+       (test-case "oauth refresh"
+         (call-with-web-server
+          oauth-handler
+          (lambda (addr)
+            (set-box! token-box "token-1")
+            (define (oauth url headers params)
+              ((bearer-auth (unbox token-box)) url headers params))
+            (parameterize ([current-session (make-session #:middleware oauth-middleware)])
+              (check-equal? (response-status-code (get #:auth oauth addr)) 200)))))
+
+       (test-case "composition"
+         (call-with-web-server
+          oauth-handler
+          (lambda (addr)
+            (set-box! token-box "token-1")
+            (define (oauth url headers params)
+              ((bearer-auth (unbox token-box)) url headers params))
+            (define composed-middleware
+              (compose-middleware oauth-middleware timing-middleware))
+            (parameterize ([current-session (make-session #:middleware composed-middleware)])
+              (check-equal? (response-status-code (get #:auth oauth addr)) 200)
+              (check-= (length (hash-ref timings (string->url addr))) 2 0))))))))))
 
 (module+ test
   (require rackunit/text-ui)