;;;; 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))))))