144 lines
5.5 KiB
Scheme
144 lines
5.5 KiB
Scheme
#lang scheme/base
|
|
(require mzlib/list
|
|
net/url
|
|
scheme/contract)
|
|
(require "dispatch.ss"
|
|
"../private/util.ss"
|
|
"../configuration/responders.ss"
|
|
web-server/http
|
|
web-server/http/response)
|
|
|
|
(define denied?/c (request? . -> . (or/c false/c string?)))
|
|
(define authorized?/c (string? (or/c false/c bytes?) (or/c false/c bytes?) . -> . (or/c false/c string?)))
|
|
|
|
(provide/contract
|
|
[interface-version dispatcher-interface-version/c]
|
|
[denied?/c contract?]
|
|
[make (->* (denied?/c)
|
|
(#:authentication-responder
|
|
(url? header? . -> . response/c))
|
|
dispatcher/c)]
|
|
[authorized?/c contract?]
|
|
[make-basic-denied?/path
|
|
(authorized?/c . -> . denied?/c)]
|
|
[password-file->authorized?
|
|
(path-string? . -> . (values (-> void)
|
|
authorized?/c))])
|
|
|
|
(define interface-version 'v1)
|
|
(define (make denied?
|
|
#:authentication-responder
|
|
[authentication-responder
|
|
(gen-authentication-responder "forbidden.html")])
|
|
(lambda (conn req)
|
|
(define uri (request-uri req))
|
|
(define method (request-method req))
|
|
(cond
|
|
[(denied? req)
|
|
=> (lambda (realm)
|
|
(request-authentication conn method uri
|
|
authentication-responder
|
|
realm))]
|
|
[else
|
|
(next-dispatcher)])))
|
|
|
|
(define (make-basic-denied?/path
|
|
authorized?)
|
|
(lambda (req)
|
|
(define path (url-path->string (url-path (request-uri req))))
|
|
(cond
|
|
[(request->basic-credentials req)
|
|
=> (lambda (user*pass)
|
|
(authorized? path
|
|
(car user*pass)
|
|
(cdr user*pass)))]
|
|
[else
|
|
(authorized? path #f #f)])))
|
|
|
|
(define (password-file->authorized? password-file)
|
|
(define last-read-time (box #f))
|
|
(define password-cache (box #f))
|
|
(define (update-password-cache!)
|
|
(when (and (file-exists? password-file) (memq 'read (file-or-directory-permissions password-file)))
|
|
(let ([cur-mtime (file-or-directory-modify-seconds password-file)])
|
|
(when (or (not (unbox last-read-time))
|
|
(cur-mtime . > . (unbox last-read-time))
|
|
(not (unbox password-cache)))
|
|
(set-box! last-read-time cur-mtime)
|
|
(set-box! password-cache (read-passwords password-file))))))
|
|
(define (read-password-cache)
|
|
(update-password-cache!)
|
|
(unbox password-cache))
|
|
(values update-password-cache!
|
|
(lambda (path user pass)
|
|
(define denied? (read-password-cache))
|
|
(if denied?
|
|
(denied? path (if user (lowercase-symbol! user) #f) pass)
|
|
; Fail un-safe
|
|
#f))))
|
|
|
|
;; pass-entry = (make-pass-entry str regexp (list sym str))
|
|
(define-struct pass-entry (domain pattern users))
|
|
|
|
(define-struct (exn:password-file exn) ())
|
|
|
|
;; : host -> (str sym str -> (or/c str #f))
|
|
;; to produce a function that checks if a given url path is accessible by a given user with a given
|
|
;; password. If not, the produced function returns a string, prompting for the password.
|
|
;; If the password file does not exist, all accesses are allowed. If the file is malformed, an
|
|
;; exn:password-file is raised.
|
|
(define (read-passwords password-path)
|
|
(with-handlers ([void (lambda (exn)
|
|
(raise (make-exn:password-file
|
|
(format "could not load password file ~a" password-path)
|
|
(current-continuation-marks))))])
|
|
(let ([passwords
|
|
(with-input-from-file
|
|
password-path
|
|
(lambda ()
|
|
(let ([raw (second (read))])
|
|
(unless (password-list? raw)
|
|
(raise "malformed passwords"))
|
|
(map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
|
|
raw))))])
|
|
|
|
;; string symbol bytes -> (or/c #f string)
|
|
(lambda (request-path user-name password)
|
|
(ormap (lambda (x)
|
|
(and (regexp-match (pass-entry-pattern x) request-path)
|
|
(let ([name-pass (assq user-name (pass-entry-users x))])
|
|
(if (and name-pass
|
|
(string=?
|
|
(cadr name-pass)
|
|
(bytes->string/utf-8 password)))
|
|
#f
|
|
(pass-entry-domain x)))))
|
|
passwords)))))
|
|
|
|
;; password-list? : TST -> bool
|
|
|
|
;; Note: andmap fails for dotted pairs at end.
|
|
;; This is okay, since #f ends up raising a caught exception anyway.
|
|
(define (password-list? passwords)
|
|
(and (list? passwords)
|
|
(andmap (lambda (domain)
|
|
(and (pair? domain) (pair? (cdr domain)) (list (cddr domain))
|
|
(string? (car domain))
|
|
(string? (cadr domain))
|
|
(andmap (lambda (x)
|
|
(and (pair? x) (pair? (cdr x)) (null? (cddr x))
|
|
(symbol? (car x)) (string? (cadr x))))
|
|
(cddr domain))))
|
|
passwords)))
|
|
|
|
;; request-authentication : connection Method URL iport oport host str bool -> bool
|
|
;; GregP: at first look, it seems that this gets called when the user
|
|
;; has supplied bad authentication credentials.
|
|
(define (request-authentication conn method uri authentication-responder realm)
|
|
(output-response/method
|
|
conn
|
|
(authentication-responder
|
|
uri
|
|
(make-basic-auth-header realm))
|
|
method))
|