passwords tests

svn: r6578

collects/web-server/default-web-root/passwords

@@ -1 +1,2 @@
-'(("secret stuff" "/secret(/.*)?" (bubba "bbq") (|Billy| "BoB")))
+'(("secret stuff" "/secret(/.*)?" (bubba "bbq") (|Billy| "BoB")
+  (aladdin "open sesame")))

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

@@ -15,7 +15,9 @@
   
   (define interface-version 'v1)
   (define/kw (make #:key
+                   ; XXX Take authorized? function
                    [password-file "passwords"]
+                   ; XXX Move out
                    [password-connection-timeout 300]
                    [authentication-responder 
                     (gen-authentication-responder "forbidden.html")])

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

@@ -1,8 +1,64 @@
 (module dispatch-passwords-test mzscheme
-  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+           (lib "file.ss")
+           (lib "url.ss" "net")
+           (lib "list.ss")
+           (lib "xml.ss" "xml")
+           (lib "request-structs.ss" "web-server" "private")
+           (lib "util.ss" "web-server" "private")
+           (lib "dispatch.ss" "web-server" "dispatchers")
+           (prefix passwords: (lib "dispatch-passwords.ss" "web-server" "dispatchers"))
+           "../util.ss")
   (provide dispatch-passwords-tests)
   
-  ; XXX
+  ; XXX Backwards way of testing distribution file
+  (define default-passwords (build-path (collection-path "web-server") "default-web-root" "passwords"))
+  (define test-passwords (make-temporary-file))
+  (define (write-test-passwords!)
+    (with-output-to-file test-passwords
+      (lambda ()
+        (with-input-from-file default-passwords
+          (lambda ()
+            (write (read)))))
+      'truncate/replace))
+  
+  (write-test-passwords!)
+  
+  (define (runt applies? authorized?)
+    (let/ec esc
+      (define-values (_ d) (passwords:make #:password-file test-passwords
+                                           #:password-connection-timeout +inf.0
+                                           #:authentication-responder 
+                                           (lambda (u h) (esc h))))
+      (define-values (c i o) (make-mock-connection #""))
+      (d c (make-request 'get 
+                         (if applies? 
+                             (string->url "http://host/secret/something")
+                             (string->url "http://host/not-secret"))
+                         (if authorized?
+                             (list (make-header #"Authorization" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="))
+                             empty)
+                         empty #"" "host" 80 "client"))))
+  
   (define dispatch-passwords-tests
     (test-suite
-     "Passwords")))
+     "Passwords"
+     
+     (test-exn "authorized"
+               exn:dispatcher?
+               (lambda () (runt #t #t)))
+     (test-equal? "not authorized"
+                  (runt #t #f)
+                  `(WWW-Authenticate . " Basic realm=\"secret stuff\""))
+     (test-exn "does not apply"
+               exn:dispatcher?
+               (lambda ()
+                 (runt #f #f)))
+     (test-exn "does not apply (authd)"
+               exn:dispatcher?
+               (lambda ()
+                 (runt #f #t)))
+     
+     ; XXX refresh cache
+     
+     )))

collects/web-server/tests/run

@@ -0,0 +1,16 @@
+#!/bin/bash
+FILE=$1
+T=$2
+
+if [ "x$2" == "x" ] ; then
+    T=$(basename $FILE .ss)s
+fi
+
+MODE=graphical
+
+PROG=mzscheme
+if [ "x${MODE}" == "xgraphical" ] ; then
+    PROG=mred
+fi
+
+${PROG} -mvt ${FILE} -e "(begin (require (planet \"${MODE}-ui.ss\" (\"schematics\" \"schemeunit.plt\" 2))) (test/${MODE}-ui ${T}))"