sunet/scheme/httpd/access-control.scm

76 lines
2.1 KiB
Scheme
Raw Normal View History

2000-09-26 10:35:26 -04:00
;;; http server in the Scheme Shell -*- Scheme -*-
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
2000-09-26 10:35:26 -04:00
;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
2002-08-27 05:03:22 -04:00
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
2000-09-26 10:35:26 -04:00
;;; 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
(define (access-denier . hosts)
(lambda (info)
(and (any (lambda (host)
(host-matches? info host))
hosts)
2000-09-26 10:35:26 -04:00
'deny)))
(define (access-allower . hosts)
(lambda (info)
(and (any (lambda (host)
2000-09-26 10:35:26 -04:00
(host-matches? info host))
hosts)
2000-09-26 10:35:26 -04:00
'allow)))
(define (access-controller . controls)
(lambda (info)
(let loop ((controls controls))
2000-09-26 11:32:01 -04:00
(and (pair? controls)
(or ((car controls) info)
(loop (cdr controls)))))))
2000-09-26 10:35:26 -04:00
(define (access-controlled-handler control ph)
(lambda (path req)
(if (eq?
2002-11-29 09:49:22 -05:00
(control (host-info (socket-remote-address (request-socket req))))
2000-09-26 10:35:26 -04:00
'deny)
(http-error (status-code forbidden) req)
2000-09-26 10:35:26 -04:00
(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))))
2000-09-26 10:35:26 -04:00
(else ; (string? host)
(any (lambda (name)
(string-match host (string-map char-downcase name)))
(cons (host-info:name info)
(host-info:aliases info))))))
2000-09-26 10:35:26 -04:00
(define normalize-host
(let ((split (infix-splitter (make-regexp "\\.")))
2000-09-26 10:35:26 -04:00
(number (make-regexp "[0-9]+")))
(lambda (host)
(let ((components (split host)))
(if (every (lambda (component)
(regexp-exec number component))
components)
2000-09-26 10:35:26 -04:00
(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)))))