Author: hhubner Date: Thu Feb 14 11:11:03 2008 New Revision: 2497 Modified: branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: if-modified-since fixed for images password checking fixed login works again, needs more testing xhtmlgen fixed, new macro with-xhtml to set up doctype Modified: branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp Thu Feb 14 11:11:03 2008 @@ -66,7 +66,7 @@ (unless (string-equal (subseq saltpw 0 3) "$1$") (error "not a md5 password ~a" saltpw)) (let ((salt (extract-salt saltpw))) - (string-equal (crypt-md5 password salt) saltpw))) + (string-equal (crypt-md5 (coerce password 'simple-string) salt) saltpw))) ;; 0 6 12 (4) ;; 1 7 13 (4) Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp Thu Feb 14 11:11:03 2008 @@ -34,7 +34,8 @@ (defmethod object-handler-get-object ((handler image-handler)) (let ((id-or-name (parse-url))) - (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name))) + (when id-or-name + (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name)))) (defclass browse-image-handler (image-handler) ()) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Thu Feb 14 11:11:03 2008 @@ -167,21 +167,8 @@ (error-404)) (defmethod handle-object ((page-handler imageproc-handler) image) - (format t "if-modfied-since not implemented for hunchentoot~%") (with-http-response (:content-type (image-content-type (image-type-keyword image))) - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler))))) - #+(or) - (with-http-response (:content-type (image-content-type (image-type-keyword image))) - (let ((ims (header-in :if-modified-since)) - (changed-time (blob-timestamp image))) - (setf (header-out :last-modified) (rfc-1123-date changed-time)) - (if (and ims - (<= changed-time (date-to-universal-time ims))) - (progn - (setf (return-code) +http-not-modified+) - (format t "; image ~A not changed~%" image) - (with-http-body ())) - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler)))))))) + (handle-if-modified-since (blob-timestamp image)) + (setf (header-out "Last-Modified") (rfc-1123-date (blob-timestamp image))) + (imageproc image (cdr (decoded-handler-path page-handler))))) Modified: branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp (original) +++ branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp Thu Feb 14 11:11:03 2008 @@ -110,10 +110,11 @@ (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) - (if (string-equal "$1$" (subseq upw 0 3)) + (if (equal "$1$" (and (> (length upw) 3) (subseq upw 0 3))) (verify-md5-password password (user-password user)) - (equal upw - (crypt password (subseq upw 0 +salt-length+))))))) + (when (> (length upw) +salt-length+) + (equal upw + (crypt password (subseq upw 0 +salt-length+)))))))) (defmethod user-disabled ((user user)) (user-has-flag user :disabled)) Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp Thu Feb 14 11:11:03 2008 @@ -21,15 +21,24 @@ "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" (session-value 'bknr-session)) -(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer)) +(define-condition login-failure (serious-condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Login failed")))) + +(defun find-user-from-request-parameters () (with-query-params (__username __password) - (when (and __username (not (equal __username ""))) - (let ((user (find-user __username))) - (when user - (if (and (not (user-disabled user)) + (unless (and __username __password + (not (equal __username "")) + (not (equal __password ""))) + (return-from find-user-from-request-parameters nil)) + (let ((user (find-user __username))) + (when (and user + (not (user-disabled user)) (verify-password user __password)) - user - (warn "login failure for user ~a~%" user))))))) + (return-from find-user-from-request-parameters user))) + (error 'login-failure))) (defmethod authorize ((authorizer bknr-authorizer)) ;; Catch any errors that occur during request body processing Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Feb 14 11:11:03 2008 @@ -221,10 +221,6 @@ t))) (defmethod invoke-handler ((handler page-handler)) - (start-session) - (unless (session-value 'bknr-session) - (setf (session-value 'bknr-session) - (make-instance 'bknr-session :user (find-user "anonymous")))) (let* ((*website* (page-handler-site handler)) (*req-var-hash* (or *req-var-hash* (make-hash-table)))) @@ -255,10 +251,28 @@ (defvar *handlers* nil) +(defun ensure-bknr-session () + "Ensure that the BKNR-SESSION session variable is set and that it +belongs to the user that is specified in the request." + (let ((request-user (find-user-from-request-parameters))) + (unless (and (session-value 'bknr-session) + (equal (bknr-session-user) + (find-user-from-request-parameters))) + (setf (session-value 'bknr-session) + (make-instance 'bknr-session :user (or request-user + (find-user "anonymous"))))))) + (defun bknr-dispatch (request) (declare (ignore request)) - (when-let ((handler (find-if #'handler-matches (website-handlers *website*)))) - (curry #'invoke-handler handler))) + (let ((handler (find-if #'handler-matches (website-handlers *website*)))) + (cond + (handler + (start-session) + (ensure-bknr-session) + (when (authorize (website-authorizer *website*)) + (curry #'invoke-handler handler))) + (t + 'error-404)))) (defmethod publish-handler ((website website) (handler page-handler)) (setf *handlers* (append *handlers* (list handler)))) @@ -309,6 +323,12 @@ (defclass prefix-handler (page-handler) ()) +#+(or) +(defmethod initialize-instance :after ((handler prefix-handler) &key) + (unless (eql #\/ (aref (page-handler-prefix handler) + (1- (length (page-handler-prefix handler))))) + (warn "prefix handler ~A does not have prefix ending with / - may match unexpectedly" handler))) + (defmethod handler-matches ((handler prefix-handler)) (and (>= (length (script-name)) (length (page-handler-prefix handler))) Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Thu Feb 14 11:11:03 2008 @@ -24,10 +24,10 @@ (let ((vars (loop for param in params when (and (symbolp param) (not (null param))) - collect (list param `(get-parameter ,(symbol-name param))) + collect (list param `(get-parameter ,(string-downcase (symbol-name param)))) when (consp param) collect (list (car param) - `(or (get-parameter ,(symbol-name (car param))) + `(or (get-parameter ,(string-downcase (symbol-name (car param)))) ,(second param)))))) (if vars `(let ,vars @@ -54,14 +54,8 @@ (defmacro with-http-body ((&key external-format) &body body) `(with-output-to-string (*html-stream*) - (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3))) - (sax:start-document *html-sink*) - (sax:start-dtd *html-sink* - "html" - "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") - ,@body - (sax:end-document *html-sink*)))) + (with-xhtml (*html-stream*) + ,@body))) (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Feb 14 11:11:03 2008 @@ -4,6 +4,6 @@ (:use :common-lisp) (:export #:html #:html-stream - #:*html-sink* - #:set-string-encoding)) + #:with-xhtml + #:*html-sink*)) Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Feb 14 11:11:03 2008 @@ -53,13 +53,26 @@ (,body) (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3))) (,body) - (sax:end-document *html-sink*)))))) + (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) ,(process-html-forms forms env) (sax:end-document *html-sink*))) +(defmacro with-xhtml ((&optional stream &key (indentation 3)) &body body) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation ,indentation))) + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd *html-sink*) + (multiple-value-prog1 + (html + ,@body) + (sax:end-document *html-sink*)))) + (defun get-process (form) (let ((ent (gethash form *html-process-table*))) (unless ent