Digest auth

svn: r13418

collects/tests/web-server/dispatchers/dispatch-passwords-test.ss

@@ -74,7 +74,7 @@
     (test-equal? "not authorized"
                  (let ([v (runt #t #f)])
                    (list (header-field v) (header-value v)))
-                 (list #"WWW-Authenticate" #" Basic realm=\"secret stuff\""))
+                 (list #"WWW-Authenticate" #"Basic realm=\"secret stuff\""))
     (test-exn "does not apply"
               exn:dispatcher?
               (lambda ()

collects/tests/web-server/http/all-http-tests.ss

@@ -1,9 +1,11 @@
 #lang scheme/base
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         "cookies-test.ss")
+         "cookies-test.ss"
+         "digest-auth-test.ss")
 (provide all-http-tests)
 
 (define all-http-tests
   (test-suite
    "HTTP"
-   cookies-tests))
+   cookies-tests
+   digest-auth-tests))

collects/tests/web-server/http/digest-auth-test.ss

@@ -0,0 +1,135 @@
+#lang scheme
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+         web-server/http
+         net/url)
+(provide digest-auth-tests)
+
+(define RFC-Example-bytes
+  (string->bytes/utf-8 #<<END
+Digest username="Mufasa",
+                      realm="testrealm@host.com",
+                      nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093",
+                      uri="/dir/index.html",
+                      qop=auth,
+                      nc=00000001,
+                      cnonce="0a4f113b",
+                      response="6629fae49393a05397450978507c4ef1",
+                      opaque="5ccc069c403ebaf9f0171e9517f40e41"
+END
+                       ))
+(define RFC-Example-alist
+  '([username . "Mufasa"]
+    [realm . "testrealm@host.com"]
+    [nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093"]
+    [uri . "/dir/index.html"]
+    [qop . "auth"]
+    [nc . "00000001"]
+    [cnonce . "0a4f113b"]
+    [response . "6629fae49393a05397450978507c4ef1"]
+    [opaque . "5ccc069c403ebaf9f0171e9517f40e41"]))
+
+(define Safari-Example-bytes
+  #"Digest username=\"username\", realm=\"Digest Auth Test: g10971\", nonce=\"MTIzMzc2ODU3NCA4MjA2MTAyMDNhYzYyYTRiMTdmOTY4NzVjOWI1MzEwOQ==\", uri=\"/servlets/standalone.ss\", response=\"c3e45e8499e37bf0872930b35fcae291\", cnonce=\"94db38ffd6e360db658e0dbcbf5e43b9\", nc=00000001, qop=\"auth\"")
+(define Safari-Example-alist
+  '([username . "username"]
+    [realm . "Digest Auth Test: g10971"]
+    [nonce . "MTIzMzc2ODU3NCA4MjA2MTAyMDNhYzYyYTRiMTdmOTY4NzVjOWI1MzEwOQ=="]
+    [uri . "/servlets/standalone.ss"]
+    [response . "c3e45e8499e37bf0872930b35fcae291"]
+    [cnonce . "94db38ffd6e360db658e0dbcbf5e43b9"]
+    [nc . "00000001"]
+    [qop . "auth"]))
+
+(define (make-req hs)
+  (make-request 
+   #"GET" (string->url "http://test.com/foo")
+   hs
+   empty #f
+   "host" 80 "client"))
+
+(define (header->cons h)
+  (cons (header-field h) (header-value h)))
+
+(define digest-auth-tests
+  (test-suite
+   "Digest Authentication"
+   
+   (test-suite
+    "make-digest-auth-header"
+    
+    (test-case "Field"
+               (check-equal? (header-field (make-digest-auth-header "realm" "secret-key" "opaque"))
+                             #"WWW-Authenticate"))
+    
+    (test-case "Value"
+               (check-pred (lambda (v)
+                             (regexp-match #rx"Digest realm=\"realm\", qop=\"auth\", nonce=\".+\" opaque=\"opaque\"" v))
+                           (header-value (make-digest-auth-header "realm" "secret-key" "opaque")))))
+   
+   (test-suite
+    "request->digest-credentials"
+    (test-case "Error"
+               (check-equal?
+                (request->digest-credentials
+                 (make-req (list (make-header #"Authorization" #"Basic bar=\"foo\""))))
+                #f))
+    
+    (test-case "RFC Example"
+               (check-equal? 
+                (request->digest-credentials 
+                 (make-req (list (make-header #"Authorization" RFC-Example-bytes))))
+                RFC-Example-alist))
+    
+    (test-case "Safari Example"
+               (check-equal? 
+                (request->digest-credentials 
+                 (make-req 
+                  (list 
+                   (make-header #"Authorization"
+                                Safari-Example-bytes))))
+                Safari-Example-alist)))
+   
+   (test-suite
+    "password->digest-HA1"
+    (test-case "Simple"
+               (check-equal? ((password->digest-HA1 string-append) "username" "realm")
+                             #"cdc6d76271d05ba4d7afeecfcb451c21"))
+    (test-case "RFC Example"
+               (check-equal? ((password->digest-HA1 (lambda (u r) "Circle Of Life")) "Mufasa" "testrealm@host.com")
+                             #"939e7578ed9e3c518a452acee763bce9"))
+    (test-case "Safari Example"
+               (check-equal? ((password->digest-HA1 (lambda (u r) "password")) "username" "Digest Auth Test: g10971")
+                             #"663c0814b20c2cdabe8baa309c6d7b82")))
+   
+   (test-suite
+    "make-check-digest-credentials"
+    (test-case "RFC Incorrect"
+               (check-equal? ((make-check-digest-credentials (lambda (u r) #"939e7578ed9e3c518a452acee76321e9"))
+                              "GET" RFC-Example-alist)
+                             #f))
+    
+    (test-case "Error"
+               (check-exn exn? 
+                          (lambda ()
+                            ((make-check-digest-credentials (lambda (u r) #"939e7578ed9e3c518a452acee76321e9"))
+                             "GET" 
+                             '([realm . "testrealm@host.com"]
+                               [nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093"]
+                               [uri . "/dir/index.html"]
+                               [qop . "auth"]
+                               [nc . "00000001"]
+                               [cnonce . "0a4f113b"]
+                               [response . "6629fae49393a05397450978507c4ef1"]
+                               [opaque . "5ccc069c403ebaf9f0171e9517f40e41"])))))
+    
+    (test-case "RFC Example"
+               (check-equal? ((make-check-digest-credentials (lambda (u r) #"939e7578ed9e3c518a452acee763bce9"))
+                              "GET" RFC-Example-alist)
+                             #t))
+    
+    (test-case "Safari Example"
+               (check-equal? ((make-check-digest-credentials (lambda (u r) #"663c0814b20c2cdabe8baa309c6d7b82"))
+                              "GET" Safari-Example-alist)
+                             #t)))
+   
+   ))

collects/tests/web-server/servlet/basic-auth-test.ss

@@ -1,26 +1,44 @@
-#lang scheme/base
+#lang scheme
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         web-server/http)
+         web-server/http
+         net/url)
 (provide basic-auth-tests)
 
+(define (make-req hs)
+  (make-request 
+   #"GET" (string->url "http://test.com/foo")
+   hs
+   empty #f
+   "host" 80 "client"))
+
+(define (header->cons h)
+  (cons (header-field h) (header-value h)))
+
 (define basic-auth-tests
   (test-suite
-   "BASIC Authentication"
+   "Basic Authentication"
+   
+   (test-case
+    "make-basic-auth-header"
+    (check-equal? (header->cons (make-basic-auth-header "realm"))
+                  (cons #"WWW-Authenticate"
+                        #"Basic realm=\"realm\"")))
    
    (test-case
     "Simple"
-    (check-equal? (extract-user-pass (list (make-header #"Authorization" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==")))
+    (check-equal? (request->basic-credentials
+                   (make-req (list (make-header #"Authorization" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="))))
                   (cons #"Aladdin" #"open sesame")))
    
    (test-case
     "Value error"
-    (check-false (extract-user-pass (list (make-header #"Authorization" #"Basic adfadQWxhZGRpb124134jpvcGVu=")))))
+    (check-false (request->basic-credentials (make-req (list (make-header #"Authorization" #"Basic adfadQWxhZGRpb124134jpvcGVu="))))))
    
    (test-case
     "No header"
-    (check-false (extract-user-pass (list))))
+    (check-false (request->basic-credentials (make-req (list)))))
    
    (test-case
     "Case"
-    (check-equal? (extract-user-pass (list (make-header #"AuthoRIZation" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==")))
+    (check-equal? (request->basic-credentials (make-req (list (make-header #"AuthoRIZation" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="))))
                   (cons #"Aladdin" #"open sesame")))))

collects/web-server/default-web-root/htdocs/servlets/examples/basic.ss

@@ -0,0 +1,12 @@
+#lang web-server/insta
+
+(define (start req)
+  (match (request->basic-credentials req)
+    [(cons user pass)
+     `(html (head (title "Basic Auth Test"))
+            (body (h1 "User: " ,(bytes->string/utf-8 user))
+                  (h1 "Pass: " ,(bytes->string/utf-8 pass))))]
+    [else
+     (make-response/basic
+      401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE
+      (list (make-basic-auth-header (format "Basic Auth Test: ~a" (gensym)))))]))

collects/web-server/default-web-root/htdocs/servlets/examples/digest.ss

@@ -0,0 +1,24 @@
+#lang web-server/insta
+(require scheme/pretty)
+
+(define private-key "private-key")
+(define opaque "opaque")
+
+(define (start req)
+  (match (request->digest-credentials req)
+    [#f
+     (make-response/basic
+      401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE
+      (list (make-digest-auth-header
+             (format "Digest Auth Test: ~a" (gensym))
+             private-key opaque)))]
+    [alist
+     (define check
+       (make-check-digest-credentials
+        (password->digest-HA1 (lambda (username realm) "pass"))))
+     (define pass?
+       (check "GET" alist))
+     `(html (head (title "Digest Auth Test"))
+            (body 
+             (h1 ,(if pass? "Pass!" "No Pass!"))
+             (pre ,(pretty-format alist))))]))

collects/web-server/dispatchers/dispatch-passwords.ss

@@ -45,10 +45,9 @@
 (define (make-basic-denied?/path
          authorized?)  
   (lambda (req)
-    (define uri (request-uri req))
+    (define path (url-path->string (url-path (request-uri req))))
-    (define path (url-path->string (url-path uri)))
     (cond
-      [(extract-user-pass (request-headers/raw req))
+      [(request->basic-credentials req)
        => (lambda (user*pass)
             (authorized? path 
                          (car user*pass)
@@ -137,5 +136,5 @@
    conn
    (authentication-responder
     uri 
-    (make-header #"WWW-Authenticate" (string->bytes/utf-8 (format " Basic realm=\"~a\"" realm))))
+    (make-basic-auth-header realm))
    method))

collects/web-server/http.ss

@@ -1,11 +1,13 @@
 #lang scheme
 (require web-server/http/basic-auth
+         web-server/http/digest-auth
          web-server/http/request-structs
          web-server/http/response-structs
          web-server/http/cookie
          web-server/http/cookie-parse
          web-server/http/redirect)
 (provide (all-from-out web-server/http/basic-auth
+                       web-server/http/digest-auth
                        web-server/http/request-structs
                        web-server/http/response-structs
                        web-server/http/cookie

collects/web-server/http/basic-auth.ss

@@ -1,10 +1,9 @@
-#lang scheme/base
+#lang scheme
-(require mzlib/contract
+(require net/base64
-         mzlib/plt-match
-         net/base64
          web-server/http/request-structs)
 
-(define (extract-user-pass headers)
+(define (request->basic-credentials req)
+  (define headers (request-headers/raw req))
   (match (headers-assq* #"Authorization" headers)
     [#f #f]
     [(struct header (_ basic-credentials))
@@ -22,5 +21,9 @@
   (let ([rx (byte-regexp #"^Basic .*")])
     (lambda (a) (regexp-match rx a))))
 
+(define (make-basic-auth-header realm)
+  (make-header #"WWW-Authenticate" (string->bytes/utf-8 (format "Basic realm=\"~a\"" realm))))
+
 (provide/contract
- [extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))])
+ [make-basic-auth-header (string? . -> . header?)]
+ [request->basic-credentials (request? . -> . (or/c false/c (cons/c bytes? bytes?)))])

collects/web-server/http/digest-auth.ss

@@ -0,0 +1,193 @@
+#lang scheme
+(require net/base64
+         file/md5
+         web-server/http/request-structs)
+
+;; Requesting
+(define (make-digest-auth-header realm private-key opaque)
+  (define timestamp
+    (number->string (current-seconds)))
+  (define nonce
+    (base64-encode 
+     (string->bytes/utf-8
+      (format "~a ~a"
+              timestamp
+              (md5 (string->bytes/utf-8 (string-append timestamp ":" private-key)))))))
+  (make-header 
+   #"WWW-Authenticate" 
+   (string->bytes/utf-8
+    (format "Digest realm=\"~a\", qop=\"auth\", nonce=\"~a\" opaque=\"~a\""
+            realm nonce opaque))))
+
+;; Receiving
+(require parser-tools/lex
+         parser-tools/yacc
+         (prefix-in : parser-tools/lex-sre))
+
+#|
+       auth-param     = token "=" ( token | quoted-string )
+       realm       = "realm" "=" realm-value
+       realm-value = quoted-string
+
+      challenge        =  "Digest" digest-challenge
+
+      digest-challenge  = 1#( realm | [ domain ] | nonce |
+                          [ opaque ] |[ stale ] | [ algorithm ] |
+                          [ qop-options ] | [auth-param] )
+
+
+      domain            = "domain" "=" <"> URI ( 1*SP URI ) <">
+      URI               = absoluteURI | abs_path
+      nonce             = "nonce" "=" nonce-value
+      nonce-value       = quoted-string
+      opaque            = "opaque" "=" quoted-string
+      stale             = "stale" "=" ( "true" | "false" )
+      algorithm         = "algorithm" "=" ( "MD5" | "MD5-sess" |
+                           token )
+      qop-options       = "qop" "=" <"> 1#qop-value <">
+      qop-value         = "auth" | "auth-int" | token
+
+       credentials      = "Digest" digest-response
+       digest-response  = 1#( username | realm | nonce | digest-uri
+                       | response | [ algorithm ] | [cnonce] |
+                       [opaque] | [message-qop] |
+                           [nonce-count]  | [auth-param] )
+
+       username         = "username" "=" username-value
+       username-value   = quoted-string
+       digest-uri       = "uri" "=" digest-uri-value
+       digest-uri-value = request-uri   ; As specified by HTTP/1.1
+       message-qop      = "qop" "=" qop-value
+       qop-value        = "auth" | "auth-int" | token
+       cnonce           = "cnonce" "=" cnonce-value
+       cnonce-value     = nonce-value
+       nonce-count      = "nc" "=" nc-value
+       nc-value         = 8LHEX
+       response         = "response" "=" request-digest
+       request-digest = <"> 32LHEX <">
+       LHEX             =  "0" | "1" | "2" | "3" |
+                           "4" | "5" | "6" | "7" |
+                           "8" | "9" | "a" | "b" |
+                           "c" | "d" | "e" | "f" 
+|#
+(define-lex-abbrevs
+  (tspecial (:or (char-set "()<>@,;:\\\"/[]?={}") whitespace #\tab))
+  (hex-char (char-set "0123456789abcdef"))
+  (token-char (:- any-char tspecial iso-control)))
+
+(define-tokens regular (TOKEN QUOTED-STRING 8LHEX 32LHEX))
+(define-empty-tokens keywords (EQUALS COMMA DIGEST USERNAME REALM OPAQUE ALGORITHM MD5 MD5-SESS NONCE URI QOP AUTH AUTH-INT CNONCE NC RESPONSE EOF))
+
+(define digest-lexer
+  (lexer
+   [(eof) (token-EOF)]
+   [whitespace (digest-lexer input-port)]
+   ["=" (token-EQUALS)]
+   ["," (token-COMMA)]
+   ["Digest" (token-DIGEST)]
+   ["username" (token-USERNAME)]
+   ["realm" (token-REALM)]
+   ["nonce" (token-NONCE)]
+   ["uri" (token-URI)]
+   ["qop" (token-QOP)]
+   ["auth" (token-AUTH)]
+   ["opaque" (token-OPAQUE)]
+   ["auth-int" (token-AUTH-INT)]
+   ["cnonce" (token-CNONCE)]
+   ["nc" (token-NC)]
+   ["response" (token-RESPONSE)]
+   [(repetition 8 8 hex-char) (token-8LHEX lexeme)]
+   #;[(:: #\" (repetition 32 32 hex-char) #\") (token-32LHEX lexeme)]
+   [(:: #\" (:* (:or (:~ #\") "\\\"")) #\")
+    (token-QUOTED-STRING (substring lexeme 1 (- (string-length lexeme) 1)))]
+   [(:+ token-char) (token-TOKEN lexeme)]))
+
+(define digest-parser
+  (parser (start credentials)
+          (tokens regular keywords)
+          (grammar (credentials [(DIGEST digest-response) $2])
+                   (digest-response [(dr-part COMMA digest-response) (cons $1 $3)]
+                                    [(dr-part) (list $1)])
+                   (dr-part [(username) $1] [(realm) $1] [(nonce) $1]
+                            [(digest-uri) $1] [(response) $1] [(algorithm) $1]
+                            [(cnonce) $1] [(opaque) $1] [(message-qop) $1]
+                            [(nonce-count) $1] [(auth-param) $1])
+                   (auth-param [(TOKEN EQUALS auth-param-value) (cons (string->symbol $1) $3)])
+                   (auth-param-value [(TOKEN) $1] [(QUOTED-STRING) $1])
+                   (username [(USERNAME EQUALS QUOTED-STRING) (cons 'username $3)])
+                   (realm [(REALM EQUALS QUOTED-STRING) (cons 'realm $3)])
+                   (nonce [(NONCE EQUALS QUOTED-STRING) (cons 'nonce $3)])
+                   (algorithm [(ALGORITHM EQUALS algorithm-value) (cons 'algorithm $3)])
+                   (algorithm-value [(MD5) "md5"] [(MD5-SESS) "md5-sess"] [(TOKEN) $1])
+                   (digest-uri [(URI EQUALS QUOTED-STRING) (cons 'uri $3)])
+                   (opaque [(OPAQUE EQUALS QUOTED-STRING) (cons 'opaque $3)])
+                   (message-qop [(QOP EQUALS qop-value) (cons 'qop $3)])
+                   (qop-value [(AUTH) "auth"] [(AUTH-INT) "auth-int"] [(TOKEN) $1] [(QUOTED-STRING) $1])
+                   (cnonce [(CNONCE EQUALS QUOTED-STRING) (cons 'cnonce $3)])
+                   (nonce-count [(NC EQUALS 8LHEX) (cons 'nc $3)])
+                   (response [(RESPONSE EQUALS QUOTED-STRING) (cons 'response $3)]))
+          (end EOF)
+          (error (lambda (a b c) (error 'digest-parser "Malformed digest: ~v ~v ~v" a b c)))))
+
+(define (do-digest-parse str)
+  (with-handlers ([exn? (lambda _ #f)])
+    (with-input-from-string 
+     str 
+     (lambda ()
+       (digest-parser (λ () (digest-lexer (current-input-port))))))))
+
+(define (request->digest-credentials req)
+  (define headers (request-headers/raw req))
+  (match (headers-assq* #"Authorization" headers)
+    [#f #f]
+    [(struct header (_ auth-bytes))
+     (do-digest-parse (bytes->string/utf-8 auth-bytes))]))
+
+(define username*realm->password/c
+  (string? string? . -> . string?))
+(define (password->digest-HA1 username*realm->password)
+  (lambda (username realm)
+    (define password
+      (username*realm->password username realm))
+    (define A1 
+      (string->bytes/utf-8
+       (format "~a:~a:~a" username realm password)))
+    (define HA1 (md5 A1))
+    HA1))
+
+(define username*realm->digest-HA1/c
+  (string? string? . -> . bytes?))
+(define (make-check-digest-credentials username*realm->HA1)
+  (lambda (method alist)
+    (define (get-binding s l)
+      (define c (assq s l))
+      (if c (cdr c)
+          (error 'make-check-digest-credentials "Missing digest field: ~a" s)))
+    (define username (get-binding 'username alist))
+    (define realm (get-binding 'realm alist))
+    (define digest-uri (get-binding 'uri alist))
+    (define nonce (get-binding 'nonce alist))
+    (define nonce-count (get-binding 'nc alist))
+    (define cnonce (get-binding 'cnonce alist))
+    (define qop (get-binding 'qop alist))
+    (define response (get-binding 'response alist))
+    (define HA1 (username*realm->HA1 username realm))    
+    (define A2
+      (string->bytes/utf-8
+       (format "~a:~a" method digest-uri)))
+    (define HA2 (md5 A2))
+    (define RESPONSE 
+      (md5 
+       (string->bytes/utf-8
+        (format "~a:~a:~a:~a:~a:~a"
+                HA1 nonce nonce-count cnonce qop HA2))))
+    (bytes=? RESPONSE
+             (string->bytes/utf-8 response))))
+
+(provide/contract
+ [make-digest-auth-header (string? string? string? . -> . header?)]
+ [request->digest-credentials (request? . -> . (or/c false/c (listof (cons/c symbol? string?))))]
+ [username*realm->password/c contract?]
+ [username*realm->digest-HA1/c contract?]
+ [password->digest-HA1 (username*realm->password/c . -> . username*realm->digest-HA1/c)]
+ [make-check-digest-credentials (username*realm->digest-HA1/c . -> . (string? (listof (cons/c symbol? string?)) . -> . boolean?))])

collects/web-server/scribblings/http.scrbl

@@ -381,13 +381,108 @@ transmission that the server @bold{will not catch}.}
 
 An implementation of HTTP Basic Authentication.
    
-@defproc[(extract-user-pass [heads (listof header?)])
+@defproc[(make-basic-auth-header [realm string?])
+         header?]{
+ Returns a header that instructs the Web browser to request a username and password from the client using
+ Basic authentication with @scheme[realm] as the realm.
+}
+                 
+@defproc[(request->basic-credentials [req request?])
          (or/c false/c (cons/c bytes? bytes?))]{
  Returns a pair of the username and password from the authentication
- header in @scheme[heads] if they are present, or @scheme[#f].
+ header in @scheme[req] if they are present, or @scheme[#f]. 
- 
- Example:
- @scheme[(extract-user-pass (request-headers/raw req))] might return @scheme[(cons #"aladin" #"open sesame")].
 }
                                                
+Example:
+@schememod[
+web-server/insta
+ 
+(define (start req)
+  (match (request->basic-credentials req)
+    [(cons user pass)
+     `(html (head (title "Basic Auth Test"))
+            (body (h1 "User: " ,(bytes->string/utf-8 user))
+                  (h1 "Pass: " ,(bytes->string/utf-8 pass))))]
+    [else
+     (make-response/basic
+      401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE
+      (list 
+       (make-basic-auth-header 
+        (format "Basic Auth Test: ~a" (gensym)))))])) 
+]
+}
+
+@; ------------------------------------------------------------
+@section[#:tag "digest-auth.ss"]{Digest Authentication}
+@(require (for-label web-server/http/digest-auth
+                     scheme/pretty))
+
+@defmodule[web-server/http/digest-auth]{
+
+An implementation of HTTP Digest Authentication.
+   
+@defproc[(make-digest-auth-header [realm string?] [private-key string?] [opaque string?])
+         header?]{
+ Returns a header that instructs the Web browser to request a username and password from the client
+ using Digest authentication with @scheme[realm] as the realm, @scheme[private-key] as the server's
+ contribution to the nonce, and @scheme[opaque] as the opaque data passed through the client.
+}
+                 
+@defproc[(request->digest-credentials [req request?])
+         (or/c false/c (listof (cons/c symbol? string?)))]{
+ Returns the Digest credentials from @scheme[req] (if they appear) as an association list.
+}         
+                                                          
+@defthing[username*realm->password/c contract?]{
+ Used to look up the password for a user is a realm.                                                
+                                                
+ Equivalent to @scheme[(string? string? . -> . string?)].                                                
+}
+
+@defthing[username*realm->digest-HA1/c contract?]{
+ Used to compute the user's secret hash.
+      
+ Equivalent to @scheme[(string? string? . -> . bytes?)].
+} 
+       
+@defproc[(password->digest-HA1 [lookup-password username*realm->password/c])
+         username*realm->digest-HA1/c]{
+ Uses @scheme[lookup-password] to find the password, then computes the secret hash of it.
+}      
+                                       
+@defproc[(make-check-digest-credentials [lookup-HA1 username*realm->digest-HA1/c])
+         (string? (listof (cons/c symbol? string?)) . -> . boolean?)]{
+ Constructs a function that checks whether particular Digest credentials (the second argument of the returned function)
+ are correct given the HTTP method provided as the first argument and the secret hash computed by @scheme[lookup-HA1].
+ 
+ This is will result in an exception if the Digest credentials are missing portions.
+} 
+                                                                     
+Example:
+@schememod[
+web-server/insta
+(require scheme/pretty)
+
+(define private-key "private-key")
+(define opaque "opaque")
+
+(define (start req)
+  (match (request->digest-credentials req)
+    [#f
+     (make-response/basic
+      401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE
+      (list (make-digest-auth-header
+             (format "Digest Auth Test: ~a" (gensym))
+             private-key opaque)))]
+    [alist
+     (define check
+       (make-check-digest-credentials
+        (password->digest-HA1 (lambda (username realm) "pass"))))
+     (define pass?
+       (check "GET" alist))
+     `(html (head (title "Digest Auth Test"))
+            (body 
+             (h1 ,(if pass? "Pass!" "No Pass!"))
+             (pre ,(pretty-format alist))))])) 
+]
 }