Added access authorization framework that allows for flexible

validation of accesses.

src/main/authorization.cl

@@ -0,0 +1,85 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; authorization.cl --- Authorization checking resources
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(define-condition clash-validation-error (clash-error)
+  ()
+  (:default-initargs :code +HTTP-Code-Unauthorized+))
+
+(defclass validation-mixin ()
+  ((validators :initarg :validators :initform nil
+	       :accessor validation-mixin-validators)))
+
+(defvar *validation-data* nil)
+
+(defmethod access-resource :around ((resource validation-mixin) request)
+  (do* ((data nil (validate-access validator request))
+	(validators (validation-mixin-validators resource) (cdr validators))
+	(validator (car validators) (car validators)))
+       ((null validators)
+	(let ((*validation-data* data))
+	  (call-next-method)))))
+
+(defmacro with-validation-data ((var resource request) &body body)
+  (let ((resource-var (gensym)) (request-var (gensym)))
+    `(let ((,resource-var ,resource)
+	   (,request-var ,request)
+	   (,var *validation-data*))
+       (declare (ignore ,resource-var ,request-var))
+       ,@body)))
+
+(defclass validator ()
+  ())
+
+(defgeneric validate-access (validator request)
+  (:method-combination progn)
+  (:documentation
+   "Check validity of an access.  This will raise a signal to abort on
+illegal accesses."))
+
+(defclass user-database ()
+  ())
+
+(defgeneric user-database-get-user-data (user-database user-name)
+  (:documentation "Returns nil if the user-name is not valid, otherwise
+returns t, the user's password and a list of allowed access methods."))
+
+(defclass www-validator (validator)
+  ((realm :initarg :realm :accessor www-validator-realm)
+   (user-database :initarg :user-database
+		  :accessor www-validator-user-database)))
+
+(defclass www-basic-validator (www-validator)
+  ())
+
+(defmethod validate-access progn
+    ((validator www-basic-validator) request)
+  (when (header-exists-p request 'authorization)
+    (destructuring-bind (scheme &rest params)
+	(header-value request 'authorization)
+      (when (string-equal scheme "Basic")
+	(let ((user-id (cdr (assoc "userid" params :test #'string-equal)))
+	      (password (cdr (assoc "password" params :test #'string-equal)))
+	      (user-database (www-validator-user-database validator)))
+	  (when (and user-id password)
+	    (multiple-value-bind (valid real-password methods)
+		(user-database-get-user-data user-database user-id)
+	      (when (and valid (string= password real-password)
+			 (member (request-method request) methods))
+		(return-from validate-access t))))))))
+  ;; Validation failed, so we raise a validation-error
+  (error 'clash-validation-error
+	 :response-initargs
+	 `(:WWW-Authenticate 
+	   (("Basic" ,(www-validator-realm validator))))))