sunet/httpd-access-control.scm

;;; 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))
      (and (pair? controls)
	   (or ((car controls) info)
	       (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)))))