[bknr-cvs] r2497 - in branches/trunk-reorg: bknr/datastore/src/utils bknr/web/src/images bknr/web/src/sysclasses bknr/web/src/web xhtmlgen
hhubner at common-lisp.net
hhubner at common-lisp.net
Thu Feb 14 16:11:05 UTC 2008
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")
- , at body
- (sax:end-document *html-sink*))))
+ (with-xhtml (*html-stream*)
+ , at 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
+ , at body)
+ (sax:end-document *html-sink*))))
+
(defun get-process (form)
(let ((ent (gethash form *html-process-table*)))
(unless ent
More information about the Bknr-cvs
mailing list