Switch branches/tags
save2011_02_16 release_acl90b21rc5 release_acl90b20_release_point release_acl90b20rc4 release_acl90b19rc3 release_acl90b18rc2 release_acl90b15_release_point release_acl90b15rc1 release_acl90b13t1 release_acl90b11t1 release_acl90b9t1 release_acl90b8t1 release_acl90b6_release_point release_acl90b6rc2 release_acl90b_release_point release_acl90a52rc1 release_acl90a44rc2 release_acl90a43rc1 release_acl90a39 release_acl90a39rc2 release_acl90a32 release_acl90a27 release_acl90a25 release_acl90a24 release_acl90a23 release_acl90a20 release_acl90a18 install-spider_2012-11-29T20-34-03 install-spider_2012-11-14T13-43-28 install-spider_2012-11-14T08-05-32 install-spider_2012-10-30T13-50-49 install-spider_2012-10-12T11-40-36 install-spider_2012-09-18T18-29-59 install-spider_2012-09-12T15-43-10 install-spider_2012-09-12T15-24-10 install-spider_2012-09-12T14-50-31 install-spider_2012-09-06T14-19-49 install-spider_2012-08-28T12-31-12 install-spider_2012-08-27T20-00-25 install-spider_2012-08-27T19-52-01 install-spider_2012-08-27T19-33-52 install-spider_2012-08-22T17-09-50 install-spider_2012-08-21T17-46-52 install-spider_2012-08-17T14-51-58 install-spider_2012-08-08T15-08-02 install-spider_2012-08-08T14-51-20 install-spider_2012-07-23T16-04-01 install-spider_2012-07-18T17-20-52 install-spider_2012-07-12T08-56-47 install-spider_2012-07-05T13-48-05 install-spider_2012-06-21T09-51-57 install-spider_2012-06-06T13-05-15 install-spider_2012-06-05T14-14-49 install-spider_2012-06-04T08-53-44 install-spider_2012-06-04T07-50-26 install-spider_2012-06-03T14-12-55 install-spider_2012-05-31T13-48-36 install-spider_2012-05-30T11-57-41 install-spider_2012-05-21T12-22-17 install-spider_2012-05-16T09-36-52 install-spider_2012-05-11T14-24-54 install-spider_2012-05-11T13-14-50 install-spider_2012-05-11T12-56-55 install-spider_2012-05-11T10-52-54 install-spider_2012-05-11T10-39-51 install-spider_2012-05-11T10-24-19 install-spider_2012-05-11T10-09-34 install-spider_2012-05-11T09-11-17 install-spider_2012-05-10T16-09-49 install-spider_2012-05-10T15-42-21 install-spider_2012-05-08T15-25-39 install-spider_2012-05-07T13-53-30 install-spider_2012-05-07T12-10-19 install-spider_2012-04-13T11-45-09 install-spider_2012-04-02T16-02-14 install-spider_2012-03-29T10-05-37 install-spider_2012-03-27T17-01-57 install-spider_2012-03-22T19-06-00 install-spider_2012-03-21T05-20-21 install-spider_2012-03-13T17-00-15 install-duck_2012-11-29T20-32-40 install-duck_2012-11-15T10-49-25 install-duck_2012-10-30T13-49-28 install-duck_2012-10-12T11-39-14 install-duck_2012-09-18T18-28-40 install-duck_2012-09-12T15-42-08 install-duck_2012-09-12T15-31-13 install-duck_2012-09-12T15-23-04 install-duck_2012-09-12T14-49-24 install-duck_2012-09-06T14-18-29 install-duck_2012-08-28T12-30-03 install-duck_2012-08-27T19-59-23 install-duck_2012-08-27T19-51-02 install-duck_2012-08-27T19-32-52 install-duck_2012-08-22T17-08-59 install-duck_2012-08-21T17-44-57 install-duck_2012-08-17T14-50-34 install-duck_2012-08-08T15-07-05 install-duck_2012-08-08T14-49-51 install-duck_2012-07-23T16-02-40
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
224 lines (172 sloc) 6.48 KB
;; -*- mode: common-lisp; package: net.aserve -*-
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2012 Franz Inc, Oakland, CA - All rights reserved.
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Lesser General Public License for more details.
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;; $Id:,v 1.11 2007/04/17 22:05:04 layer Exp $
;; Description:
;; classes and functions for authorizing access to entities
;;- This code in this file obeys the Lisp Coding Standard found in
(in-package :net.aserve)
(defclass authorizer ()
;; denotes information on authorizing access to an entity
;; this is meant to be subclassed with the appropriate slots
;; for the type of authorization to be done
;; - password authorization.
(defclass password-authorizer (authorizer)
((allowed :accessor password-authorizer-allowed
;; list of conses (name . password)
;; which are valid name, password pairs for this entity
:initarg :allowed
:initform nil)
(realm :accessor password-authorizer-realm
:initarg :realm
:initform "AllegroServe")
(defmethod authorize ((auth password-authorizer)
(req http-request)
(ent entity))
;; check if this is valid request, return t if ok
;; and :done if we've sent a request for a new name and password
(multiple-value-bind (name password) (get-basic-authorization req)
(if* name
then (dolist (pair (password-authorizer-allowed auth))
(if* (and (equal (car pair) name)
(equal (cdr pair) password))
then (return-from authorize t))))
;; valid name/password not given, ask for it
(with-http-response (req *dummy-computed-entity*
:response *response-unauthorized*
:content-type "text/html"
:format :text)
(set-basic-authorization req
(password-authorizer-realm auth))
; this is done to preventing a chunking response which
; confuse the proxy (for now)..
(if* (member ':use-socket-stream (request-reply-strategy req))
then (setf (request-reply-strategy req)
(with-http-body (req *dummy-computed-entity*)
(html (:html (:body (:h1 "Access is not authorized"))))
;; location authorization
;; we allow access based on where the request is made from.
;; the pattern list is a list of items to match against the
;; ip address of the request. When the first match is made the
;; request is either accepted or denied.
;; the possible items in the list of patterns
;; :accept accept immediately
;; :deny deny immediately
;; (:accept ipaddress [bits]) accept if left 'bits' of the
;; ipaddress match
;; (:deny ipaddress [bits]) deny if the left 'bits' of the
;; ipaddress match
;; bits defaults to 32
;; the ipaddress can be an
;; integer - the 32 bit ip address
;; string
;; "" - the dotted notation for an ip address
;; "" - the name of a machine
;; when the ipaddress is a string it is converted to an integer
;; the first time it is examined.
;; When the string is a machine name then the conversion may or
;; may not work due to the need to access a nameserver to do
;; the lookup.
(defclass location-authorizer (authorizer)
((patterns :accessor location-authorizer-patterns
;; list of patterns to match
:initarg :patterns
:initform nil)))
(defmethod authorize ((auth location-authorizer)
(req http-request)
(ent entity))
(let ((request-ipaddress (socket:remote-host (request-socket req))))
(dolist (pattern (location-authorizer-patterns auth))
(if* (atom pattern)
then (case pattern
(:accept (return-from authorize t))
(:deny (return-from authorize nil))
(t (warn "bogus authorization pattern: ~s" pattern)
(return-from authorize nil)))
else (let ((decision (car pattern))
(ipaddress (cadr pattern))
(bits (if* (cddr pattern)
then (caddr pattern)
else 32)))
(if* (not (member decision '(:accept :deny)))
then (warn "bogus authorization pattern: ~s" pattern)
(return-from authorize nil))
(if* (stringp ipaddress)
then ; check for dotted ip address first
(let ((newaddr (socket:dotted-to-ipaddr ipaddress
:errorp nil)))
(if* (null newaddr)
then ; success!
(setq newaddr (socket:lookup-hostname ipaddress))))
(if* newaddr
then (setf (cadr pattern)
(setq ipaddress newaddr))
else ; can't compute the address
; so we'll not accept and we will deny
; just to be safe
(warn "can't resolve host name ~s" ipaddress)
(return-from authorize nil))))
(if* (not (and (integerp bits) (<= 1 bits 32)))
then (warn "bogus authorization pattern: ~s" pattern)
(return-from authorize nil))
; now we're finally ready to test things
(let ((mask (if* (eql bits 32)
then -1
else (ash -1 (- 32 bits)))))
(if* (eql (logand request-ipaddress mask)
(logand ipaddress mask))
then ; matched,
(case decision
(:accept (return-from authorize t))
(:deny (return-from authorize nil))))))))
t ; the default is to accept
;; - function authorization
(defclass function-authorizer (authorizer)
((function :accessor function-authorizer-function
:initarg :function
:initform nil)))
(defmethod authorize ((auth function-authorizer)
(req http-request)
(ent entity))
(let ((fun (function-authorizer-function auth)))
(if* fun
then (funcall fun req ent auth))))