72 lines
2.5 KiB
Scheme
72 lines
2.5 KiB
Scheme
#lang scheme/base
|
|
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
|
(planet "util.ss" ("schematics" "schemeunit.plt" 2))
|
|
(only-in mzlib/file
|
|
make-temporary-file)
|
|
net/url
|
|
mzlib/list
|
|
mzlib/serialize
|
|
(lib "request-structs.ss" "web-server" "private")
|
|
(lib "dispatch.ss" "web-server" "dispatchers")
|
|
(prefix-in passwords: (lib "dispatch-passwords.ss" "web-server" "dispatchers"))
|
|
"../util.ss")
|
|
(provide dispatch-passwords-tests)
|
|
|
|
(require/expose (lib "dispatch-passwords.ss" "web-server" "dispatchers")
|
|
(read-passwords))
|
|
|
|
(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)))))
|
|
#:exists 'truncate/replace))
|
|
|
|
(write-test-passwords!)
|
|
|
|
(define (runt applies? authorized?)
|
|
(let/ec esc
|
|
(define-values (_ d) (passwords:make #:password-file test-passwords
|
|
#: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"
|
|
|
|
(test-not-false
|
|
"Distribution file parses"
|
|
(read-passwords default-passwords))
|
|
|
|
(test-exn "authorized"
|
|
exn:dispatcher?
|
|
(lambda () (runt #t #t)))
|
|
(test-equal? "not authorized"
|
|
(let ([v (runt #t #f)])
|
|
(list (header-field v) (header-value v)))
|
|
(list #"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 test refresh cache
|
|
|
|
))
|