77 lines
2.1 KiB
Scheme
77 lines
2.1 KiB
Scheme
|
;;; http server in the Scheme Shell -*- Scheme -*-
|
||
|
|
;;; Access control
|
||
|
|
;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
|
||
|
|
|
||
|
|
;;; This code is very rudimentary at the moment and up for some expansion.
|
||
|
|
;;; Right now, it is primarily useful for running the server through a
|
||
|
|
;;; web accelerator
|
||
|
|
|
||
|
|
;;; Also notes that this code doesn't work in vanilla 0.4.4 as
|
||
|
|
;;; host-info is broken.
|
||
|
|
|
||
|
|
(define (access-denier . hosts)
|
||
|
|
(lambda (info)
|
||
|
|
(and (any? (lambda (host)
|
||
|
|
(host-matches? info host))
|
||
|
|
hosts)
|
||
|
|
'deny)))
|
||
|
|
|
||
|
|
(define (access-allower . hosts)
|
||
|
|
(lambda (info)
|
||
|
|
(and (any? (lambda (host)
|
||
|
|
(host-matches? info host))
|
||
|
|
hosts)
|
||
|
|
'allow)))
|
||
|
|
|
||
|
|
(define (access-controller . controls)
|
||
|
|
(lambda (info)
|
||
|
|
(let loop ((controls controls))
|
||
|
|
(if (null? controls)
|
||
|
|
#f
|
||
|
|
(cond
|
||
|
|
(((car controls) info) => identity)
|
||
|
|
(else (loop (cdr controls))))))))
|
||
|
|
|
||
|
|
(define (access-controlled-handler control ph)
|
||
|
|
(lambda (path req)
|
||
|
|
(if (eq?
|
||
|
|
(control (host-info (socket-remote-address (request:socket req))))
|
||
|
|
'deny)
|
||
|
|
(http-error http-reply/forbidden req)
|
||
|
|
(ph path req))))
|
||
|
|
|
||
|
|
(define (address->list address)
|
||
|
|
(list (arithmetic-shift (bitwise-and address #xff000000) -24)
|
||
|
|
(arithmetic-shift (bitwise-and address #xff0000) -16)
|
||
|
|
(arithmetic-shift (bitwise-and address #xff00) -8)
|
||
|
|
(bitwise-and address #xff)))
|
||
|
|
|
||
|
|
(define (host-matches? info host)
|
||
|
|
(cond
|
||
|
|
((list? host)
|
||
|
|
(let ((len (length host)))
|
||
|
|
(any? (lambda (address)
|
||
|
|
(equal? (take len (address->list address)) host))
|
||
|
|
(host-info:addresses info))))
|
||
|
|
(else ; (string? host)
|
||
|
|
(any? (lambda (name)
|
||
|
|
(string-match host (downcase-string name)))
|
||
|
|
(cons (host-info:name info)
|
||
|
|
(host-info:aliases info))))))
|
||
|
|
|
||
|
|
(define normalize-host
|
||
|
|
(let ((split (infix-splitter "\\."))
|
||
|
|
(number (make-regexp "[0-9]+")))
|
||
|
|
(lambda (host)
|
||
|
|
(let ((components (split host)))
|
||
|
|
(if (every? (lambda (component)
|
||
|
|
(regexp-exec number component))
|
||
|
|
components)
|
||
|
|
(map string->number components)
|
||
|
|
host)))))
|
||
|
|
|
||
|
|
(define (take n l)
|
||
|
|
(let loop ((n n) (l l) (r '()))
|
||
|
|
(if (zero? n)
|
||
|
|
(reverse r)
|
||
|
|
(loop (- n 1) (cdr l) (cons (car l) r)))))
|