86 lines
2.8 KiB
Common Lisp
86 lines
2.8 KiB
Common Lisp
;;;; 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))))))
|