[bknr-cvs] r1910 - in branches/xml-class-rework/bknr/src: . sysclasses web
bknr at bknr.net
bknr at bknr.net
Fri Mar 10 14:53:13 UTC 2006
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 , at warning)))
(defmacro cmslink (url &body body)
- `(html ((:a :class "cmslink" :href ,url)
+ `(html ((:a :class "cmslink" :href (website-make-path *website* ,url))
, at 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))
More information about the Bknr-cvs
mailing list