diff --git a/src/main/authorization.cl b/src/main/authorization.cl new file mode 100644 index 0000000..022d5e5 --- /dev/null +++ b/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)))))) diff --git a/src/package.cl b/src/package.cl index 6a01d29..948bd6a 100644 --- a/src/package.cl +++ b/src/package.cl @@ -156,6 +156,17 @@ #:response-pragma #:response-www-authenticate #:response-set-cookie + #:authorization + #:cookie + #:date + #:from + #:if-modified-since + #:pragma + #:referer + #:user-agent + #:location + #:www-authenticate + #:set-cookie ;; Entity #:entity #:render-entity-headers @@ -235,6 +246,18 @@ #:sessioned-resource-session-leader #:handle-missing-session #:with-session-data + ;; Authorization + #:clash-validation-error + #:validation-mixin + #:with-validation-data + #:validator + #:validate-access + #:user-database + #:user-database-get-user-data + #:www-validator + #:www-validator-realm + #:www-validator-user-database + #:www-basic-validator ;; Logging #:server-profiling-mixin #:server-profiling-mixin-connection-time