Author: hhubner Date: 2006-03-10 09:53:13 -0500 (Fri, 10 Mar 2006) New Revision: 1910 Modified: branches/xml-class-rework/bknr/src/packages.lisp branches/xml-class-rework/bknr/src/sysclasses/user.lisp branches/xml-class-rework/bknr/src/web/authorizer.lisp branches/xml-class-rework/bknr/src/web/event-log.lisp branches/xml-class-rework/bknr/src/web/handlers.lisp branches/xml-class-rework/bknr/src/web/menu.lisp branches/xml-class-rework/bknr/src/web/user-handlers.lisp branches/xml-class-rework/bknr/src/web/web-macros.lisp branches/xml-class-rework/bknr/src/web/web-visitor.lisp Log: Numerous smaller changes to make running a bknr based site under a non-root path possible. This is not finished and I basically gave up the idea. Modified: branches/xml-class-rework/bknr/src/packages.lisp =================================================================== --- branches/xml-class-rework/bknr/src/packages.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/packages.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -280,6 +280,7 @@ #:website-url #:website-session-info #:website-base-href + #:website-make-path #:host #:publish-site #:publish-handler Modified: branches/xml-class-rework/bknr/src/sysclasses/user.lisp =================================================================== --- branches/xml-class-rework/bknr/src/sysclasses/user.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/sysclasses/user.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -155,9 +155,12 @@ (deftransaction set-user-crypted-password (user crypted-password) (setf (user-password user) crypted-password)) -(defun set-user-password (user password) +(defmethod set-user-password ((user user) password) (set-user-crypted-password user (crypt-md5 password (make-salt)))) +(defmethod set-user-password ((user string) password) + (set-user-crypted-password (find-user user) (crypt-md5 password (make-salt)))) + ;;; owned objects (define-persistent-class owned-object (store-object) Modified: branches/xml-class-rework/bknr/src/web/authorizer.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -90,5 +90,5 @@ (format t "; request NOT authorized~%") ;; unauthorized, come up with 401 response to the web browser - (redirect "/login" req) + (redirect (website-make-path *website* "login") req) :deny) Modified: branches/xml-class-rework/bknr/src/web/event-log.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/event-log.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/event-log.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -50,7 +50,7 @@ `(html ((:td :class "lognavi") ((:input :type "checkbox" :name "show-class" :value ,class-name ,@(if checked '(:checked "checked")))) - (cmslink (format nil "/event-log?show-only-class=~a" ,class-name) + (cmslink (format nil "event-log?show-only-class=~a" ,class-name) (:princ-safe (regex-replace ,class-name "-event$" "")))))) (defun serve-event-log-request (req) @@ -107,7 +107,7 @@ "count: " (html-text-input print-count 3) " hours: " (html-text-input print-hours 3) " " ((:input :type "submit" :name "filter" :value "filter")) - " " (cmslink ("/event-class-documentation" :target "documentation") " documentation "))) + " " (cmslink ("event-class-documentation" :target "documentation") " documentation "))) #+(or) (:tr ((:td :class "lognavi") "message: " ((:input :type "text" :size "80" :name "message"))))) ;; Query the database. Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -85,6 +85,9 @@ (dolist (handler (website-handlers website)) (format t "~A => ~A~%" (uri-path (page-handler-url handler)) handler))) +(defmethod website-make-path ((website website) relative-path) + (format nil "~A~A" (website-base-href website) relative-path)) + (defgeneric publish-handler (website handler)) (defgeneric publish-site (website)) @@ -222,7 +225,7 @@ (progn (setf (session-variable :login-redirect-uri) (redirect-uri (request-uri req))) - (redirect "/login" req)) + (redirect (website-make-path *website* "login") req)) (handler-bind ((error #'(lambda (e) (funcall (website-show-error-page-function *website*) e) (do-error-log-request req e) Modified: branches/xml-class-rework/bknr/src/web/menu.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/menu.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/menu.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -39,7 +39,7 @@ (defun in-subtree (url subtree-url) (search subtree-url url)) -(define-bknr-tag site-menu (&key config menu-name container-class active-class inactive-class) +(define-bknr-tag site-menu (&key config menu-name title container-class active-class inactive-class) (declare (ignore menu-name)) (let* ((menu (bknr.impex:parse-xml-file #+cmu (ext:unix-namestring (merge-pathnames config *default-pathname-defaults*)) @@ -47,6 +47,8 @@ *menu-def-classes*))) (html ((:div :class container-class) + (when title + (html ((:div :class "title") (:princ-safe title)))) (dolist (item (menu-items menu)) (let ((item-is-active (in-subtree (puri:uri-path (net.aserve:request-uri *req*)) (item-url item)))) (with-slots (url title active-image inactive-image) item Modified: branches/xml-class-rework/bknr/src/web/user-handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/user-handlers.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/user-handlers.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -20,73 +20,20 @@ (:princ (format nil "edit ~a" (user-login user)))))) ;;; handlers -(defparameter *login-default-url* "/") - -(defclass login-handler (page-handler) - ((name :initform :login))) - -(defclass logout-handler (login-handler) - ((name :initform :logout))) - -(defmethod handle ((page-handler login-handler) req) - (with-query-params (req __username) - (let (login-failed-message) - (when (and __username - (equal __username (user-login (bknr-request-user req)))) - ;; request has successfully been authorized, redirect to asked uri - (let ((url (or (session-variable :login-redirect-uri) - *login-default-url*))) - (redirect url req) - (return-from handle))) - (when __username - (setf login-failed-message "invalid username or invalid password")) - (with-bknr-http-response (req) - (with-http-body (req *ent*) - (html - (:html - (:head - (loop for stylesheet in (bknr.web::website-style-sheet-urls *website*) - do (html ((:link :rel "stylesheet" :type "text/css" :href stylesheet)))) - ((:script :language "JavaScript") "function setFocus() { document.forms[0].elements[0].focus(); }") - (:title "please login to " (:princ-safe (website-name *website*)))) - ((:body :class "cms" :onload "setFocus();") - ((:div :align "center") - (bknr.images:banner :keyword :bknr) - ((:form :method "post") - (let* ((user-images (loop for user in (all-users) - for image = (random-elt (bknr.images:user-images user)) - when image - collect (list user image))) - (rows (group-by user-images 4))) - (when user-images - (html ((:table :class "login-images") - (dolist (row rows) - (html - (:tr (loop for (user image) in row - do (html - (:td - ((:a :href "#" - :onClick (format nil"javascript:document.forms[0].elements['__username'].value='~a'" (user-login user))) - ((:img :src (format nil "/image/~a/thumbnail,,120,120" - (store-object-id image))))))))))))))) - (when login-failed-message - (html (:p (:princ-safe login-failed-message)))) - (:table - (:tr ((:td :colspan "2") "please log in to " (:princ-safe (website-name *website*)))) - (:tr (:td "username") (:td ((:input :type "text" :name "__username" :size "20")))) - (:tr (:td "password") (:td ((:input :type "password" :name "__password" :size "20"))))) - ((:input :type "submit" :name "login" :value " login ")) - ((:input :type "button" :name "info" :value " info " :onclick "self.location.href='/info'")) - ((:input :type "button" :name "message" :value "message" :onclick "self.location.href='/message'")))))))))))) -(defmethod handle ((page-handler logout-handler) req) +(defclass logout-handler (page-handler) + ()) + +(defmethod handle ((handler logout-handler) req) (bknr.web::drop-session (bknr-request-session req)) - (with-query-params (req url) + (format t "url: ~A referer: ~A~%" (query-param req "url") (header-slot-value req :referer)) + (let ((url (or (query-param req "url") + (header-slot-value req :referer)))) (if url - (redirect url req) - (progn (with-bknr-page (req :title "logged out") - (html (:h2 "you are logged out"))) - (change-class req 'http-request))))) + (redirect url req) + (progn (with-bknr-page (req :title "logged out") + (html (:h2 "you are logged out"))) + (change-class req 'http-request))))) (defclass user-handler (edit-object-handler) ((require-user-flag :initform :admin))) @@ -179,5 +126,4 @@ (define-bknr-webserver-module user ("/user" user-handler) - ("/login" login-handler) ("/logout" logout-handler)) \ No newline at end of file Modified: branches/xml-class-rework/bknr/src/web/web-macros.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -152,5 +152,5 @@ (warn ,@warning))) (defmacro cmslink (url &body body) - `(html ((:a :class "cmslink" :href ,url) + `(html ((:a :class "cmslink" :href (website-make-path *website* ,url)) ,@body))) Modified: branches/xml-class-rework/bknr/src/web/web-visitor.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-visitor.lisp 2006-03-08 06:51:00 UTC (rev 1909) +++ branches/xml-class-rework/bknr/src/web/web-visitor.lisp 2006-03-10 14:53:13 UTC (rev 1910) @@ -35,7 +35,7 @@ (html-link (web-visitor-event-user event))) " from " (when (web-visitor-event-host event) - (cmslink (format nil "/host?host=~a" (host-ip-address (web-visitor-event-host event))) + (cmslink (format nil "host?host=~a" (host-ip-address (web-visitor-event-host event))) (:princ-safe (host-name (web-visitor-event-host event))))))) (defmethod as-xml ((event web-visitor-event))