[bknr-cvs] r2424 - in branches/trunk-reorg: bknr/datastore/src/data bknr/modules/bug bknr/modules/mail bknr/modules/tamagotchi bknr/modules/text bknr/modules/url bknr/web/src bknr/web/src/images bknr/web/src/web projects/quickhoney/src
hhubner at common-lisp.net
hhubner at common-lisp.net
Wed Jan 30 13:02:47 UTC 2008
Author: hhubner
Date: Wed Jan 30 08:02:24 2008
New Revision: 2424
Modified:
branches/trunk-reorg/bknr/datastore/src/data/blob.lisp
branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp
branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp
branches/trunk-reorg/bknr/modules/mail/register-handler.lisp
branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp
branches/trunk-reorg/bknr/modules/text/article-handlers.lisp
branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp
branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp
branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp
branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp
branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp
branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp
branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp
branches/trunk-reorg/bknr/web/src/packages.lisp
branches/trunk-reorg/bknr/web/src/web/authorizer.lisp
branches/trunk-reorg/bknr/web/src/web/event-log.lisp
branches/trunk-reorg/bknr/web/src/web/handlers.lisp
branches/trunk-reorg/bknr/web/src/web/sessions.lisp
branches/trunk-reorg/bknr/web/src/web/tags.lisp
branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp
branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
branches/trunk-reorg/projects/quickhoney/src/init.lisp
branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
Log:
First session handling fixes.
Modified: branches/trunk-reorg/bknr/datastore/src/data/blob.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/blob.lisp (original)
+++ branches/trunk-reorg/bknr/datastore/src/data/blob.lisp Wed Jan 30 08:02:24 2008
@@ -168,7 +168,7 @@
(with-open-file (s nblobs-pathname :direction :output)
(write (n-blobs-per-directory subsystem) :stream s))))
-(defun delete-orphaned-blob-files ()
+(defun delete-orphaned-blob-files (&optional (cold-run t))
(dolist (blob-pathname (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors))
(store-blob-root-pathname))))
(handler-case
@@ -177,7 +177,9 @@
(object (find-store-object object-id)))
(labels ((delete-orphan (pathname)
(handler-case
- (delete-file pathname)
+ (if cold-run
+ (format t "cold run, not deleting ~A~%" pathname)
+ (delete-file pathname))
(error (e)
(warn "can't delete file ~A: ~A" pathname e)))))
(cond
Modified: branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -21,13 +21,13 @@
(defmethod handle-object-form ((handler bug-tracker-handler) action tracker)
(with-bknr-page (:title #?"bug-tracker for $((mailinglist-name tracker))")
- (when (admin-p (bknr-request-user))
+ (when (admin-p (bknr-session-user))
(html ((:a :href (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))
"edit bug-tracker")))
(bug-tracker-page :bug-tracker-id (store-object-id tracker))))
(defmethod file-bug-report ((handler bug-tracker-handler) tracker)
- (let ((user (bknr-request-user)))
+ (let ((user (bknr-session-user)))
;; XXX check user rights
(with-query-params (name status priority description)
(let ((bug-report (make-object 'bug-report
@@ -58,9 +58,9 @@
(defmethod handle-object-form ((handler bug-report-handler) action report)
(with-bknr-page (:title #?"bug-report")
- (when (or (equal (bknr-request-user)
+ (when (or (equal (bknr-session-user)
(bug-report-handler report))
- (admin-p (bknr-request-user)))
+ (admin-p (bknr-session-user)))
(html ((:a :href (format nil "/edit-bug-report/~a" (store-object-id report)))
"edit bug-report")))
(bug-page :bug-id (store-object-id report))))
@@ -68,7 +68,7 @@
(defmethod handle-object-form ((handler bug-report-handler) (action (eql :annotate))
report)
(if report
- (let ((user (bknr-request-user)))
+ (let ((user (bknr-session-user)))
(with-query-params (title text)
(let ((article (make-object 'article
:author user
@@ -114,7 +114,7 @@
(defmethod handle-object-form ((handler edit-bug-tracker-handler)
(action (eql :save))
tracker)
- (if (admin-p (bknr-request-user))
+ (if (admin-p (bknr-session-user))
(with-query-params (name email description)
(change-slot-values tracker 'name name 'email email 'description description)
(call-next-method))
@@ -144,8 +144,8 @@
(defmethod handle-object-form ((handler edit-bug-report-handler)
(action (eql :save))
report)
- (if (or (admin-p (bknr-request-user))
- (equal (bknr-request-user)
+ (if (or (admin-p (bknr-session-user))
+ (equal (bknr-session-user)
(bug-report-handler report)))
(with-query-params (name status priority description)
(let ((status-kw (make-keyword-from-string status))
@@ -171,8 +171,8 @@
(defmethod handle-object-form ((handler edit-bug-report-handler)
(action (eql :close))
report)
- (if (or (admin-p (bknr-request-user))
- (equal (bknr-request-user)
+ (if (or (admin-p (bknr-session-user))
+ (equal (bknr-session-user)
(bug-report-handler report)))
(progn
(change-slot-values report 'closed (get-universal-time)
@@ -187,8 +187,8 @@
(defmethod handle-object-form ((handler edit-bug-report-handler)
(action (eql :reopen))
report)
- (if (or (admin-p (bknr-request-user))
- (equal (bknr-request-user)
+ (if (or (admin-p (bknr-session-user))
+ (equal (bknr-session-user)
(bug-report-handler report)))
(progn
(change-slot-values report 'closed nil
@@ -203,8 +203,8 @@
(defmethod handle-object-form ((handler edit-bug-report-handler)
(action (eql :delete))
report)
- (if (or (admin-p (bknr-request-user))
- (equal (bknr-request-user)
+ (if (or (admin-p (bknr-session-user))
+ (equal (bknr-session-user)
(bug-report-handler report)))
(progn
(let ((tracker (bug-report-tracker report)))
@@ -220,9 +220,9 @@
(action (eql :handle))
report)
(if (or (null (bug-report-handler report))
- (admin-p (bknr-request-user)))
+ (admin-p (bknr-session-user)))
(progn
- (change-slot-values report 'handler (bknr-request-user))
+ (change-slot-values report 'handler (bknr-session-user))
(call-next-method))
(with-bknr-page (:title #?"Edit bug report")
(:p "You can not become the handler of this bug report")
Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -106,7 +106,7 @@
(with-query-params (email)
(let ((user (find-user email)))
(if user
- (if (admin-p (bknr-request-user))
+ (if (admin-p (bknr-session-user))
(html-subscription-info user)
(progn
(html (:p "Sending unsubscribe information to " (:princ-safe (user-email user))))
Modified: branches/trunk-reorg/bknr/modules/mail/register-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/mail/register-handler.lisp (original)
+++ branches/trunk-reorg/bknr/modules/mail/register-handler.lisp Wed Jan 30 08:02:24 2008
@@ -109,7 +109,7 @@
:email email
:subscribe-mailinglist mailinglist))
(website-url (and mailinglist (mailinglist-website-url mailinglist))))
- (if (admin-p (bknr-request-user))
+ (if (admin-p (bknr-session-user))
(progn
(confirm-registration registration)
(html (:h2 "registration completed")
Modified: branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -15,7 +15,7 @@
(let ((tamagotchi (object-handler-get-object handler)))
(cond ((null tamagotchi) t)
((null (tamagotchi-owner tamagotchi)) t)
- ((equal (bknr-request-user) (tamagotchi-owner tamagotchi)) t)
+ ((equal (bknr-session-user) (tamagotchi-owner tamagotchi)) t)
(t nil)))))
(defmethod object-handler-get-object ((handler tamagotchi-handler))
Modified: branches/trunk-reorg/bknr/modules/text/article-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/text/article-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/text/article-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -41,7 +41,7 @@
(progn (change-slot-values article 'subject subject 'text text)
(index-article article))
(setf article (make-object 'article
- :author (bknr-request-user)
+ :author (bknr-session-user)
:subject subject
:text text)))
(redirect (edit-object-url article))))
@@ -104,7 +104,7 @@
(let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))
(expires (parse-date-field "expiration")))
(with-query-params (subject text layout)
- (let ((snippet (make-object 'snippet :author (bknr-request-user)
+ (let ((snippet (make-object 'snippet :author (bknr-session-user)
:subject (or subject "")
:time (get-universal-time)
:text text
Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -19,7 +19,7 @@
((:p :class "articleText") (:princ (article-html-text article)))))
(defun list-billboards-page ()
- (let ((may-edit (admin-p (bknr-request-user))))
+ (let ((may-edit (admin-p (bknr-session-user))))
(with-bknr-page (:title "billboards")
(html
((:form :method "post" :action (request-uri))
@@ -53,7 +53,7 @@
(defun billboard-page ()
(let ((billboard (parse-url)))
(with-query-params (new show-all delete)
- (let ((may-edit (admin-p (bknr-request-user))))
+ (let ((may-edit (admin-p (bknr-session-user))))
(setf billboard (find-billboard (or billboard *default-billboard*)))
(if delete
(let ((article (store-object-with-id delete)))
@@ -62,7 +62,7 @@
(html "the article has been deleted")))
(if (and new may-edit)
(let ((article (make-object 'article
- :author (bknr-request-user))))
+ :author (bknr-session-user))))
(billboard-add-article billboard article)
(redirect (format nil "/edit-article/~a" (store-object-id article))))
(with-bknr-page (:title #?"billboard: $((billboard-name billboard))")
@@ -75,7 +75,7 @@
with shown
for article in (billboard-articles billboard)
do (when (or show-all
- (not (article-read article (bknr-request-user))))
+ (not (article-read article (bknr-session-user))))
(setf shown t)
(html
(:tr (:td "date")
@@ -106,6 +106,6 @@
(unless (billboard-always-show-all billboard)
(html
((:input :type "submit" :name "show-all" :value "show-all"))))
- (when (admin-p (bknr-request-user))
+ (when (admin-p (bknr-session-user))
(html
((:input :type "submit" :name "new" :value "new"))))))))))))
\ No newline at end of file
Modified: branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -85,7 +85,7 @@
())
(defmethod authorized-p ((handler edit-blog-handler))
- (let ((user (bknr-request-user))
+ (let ((user (bknr-session-user))
(blog (object-handler-get-object handler)))
(if blog
(or (admin-p user)
@@ -115,7 +115,7 @@
(index-article article)))
(let ((article (make-object 'blog-article
:time (get-universal-time)
- :author (bknr-request-user)
+ :author (bknr-session-user)
:subject subject
:text text
:keywords (list keyword))))
Modified: branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -42,7 +42,7 @@
(with-query-params (subject text lisp)
(if (and subject text)
(let ((paste (make-object 'paste
- :author (bknr-request-user)
+ :author (bknr-session-user)
:subject subject
:time (get-universal-time)
:text text
@@ -59,7 +59,7 @@
(if paste
(with-query-params (text lisp)
(let ((annotation (make-object 'keywords-article
- :author (bknr-request-user)
+ :author (bknr-session-user)
:subject ""
:time (get-universal-time)
:text text
Modified: branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -34,7 +34,7 @@
())
(defmethod authorized-p ((handler edit-wiki-handler))
- (not (anonymous-p (bknr-request-user))))
+ (not (anonymous-p (bknr-session-user))))
(defmethod handle-object-form ((handler edit-wiki-handler)
action (article (eql nil)))
@@ -53,7 +53,7 @@
(with-query-params (text comment)
(let ((version (make-version (html-quote text)
:comment (html-quote comment)
- :author (bknr-request-user)
+ :author (bknr-session-user)
:date (get-universal-time))))
(if article
(article-add-version article version)
Modified: branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -9,7 +9,7 @@
())
(defmethod authorized-p ((handler form-handler))
- (not (equal (bknr-request-user) (find-user "anonymous"))))
+ (not (equal (bknr-session-user) (find-user "anonymous"))))
#+(or)
(defmethod handle-form ((handler submit-url-handler) action)
@@ -35,12 +35,12 @@
(setf url (normalize-url url))
(ensure-form-field keywords)
(if (and cache
- (not (user-has-flag (bknr-request-user) :cache)))
+ (not (user-has-flag (bknr-session-user) :cache)))
(error (make-condition 'form-not-authorized-condition
:reason "You do not have the right to cache objects")))
(when cache
- (make-cached-url-from-url url :user (bknr-request-user) :depth 1
+ (make-cached-url-from-url url :user (bknr-session-user) :depth 1
:force nil))
(let ((url-obj (url-with-url url)))
@@ -55,7 +55,7 @@
:description description
:keywords keywords
:date (get-universal-time)
- :submitter (bknr-request-user))))
+ :submitter (bknr-session-user))))
(declare (ignore submission))
(redirect (if redirect url "/url")))))
(form-field-missing-condition (e)
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 Wed Jan 30 08:02:24 2008
@@ -86,7 +86,7 @@
(error "no file uploaded"))
(with-query-params (name keyword)
(let* ((image (import-image file-pathname
- :user (bknr-request-user)
+ :user (bknr-session-user)
:keywords (list keyword)
:keywords-from-dir nil))
(image-id (store-object-id image)))
Modified: branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp Wed Jan 30 08:02:24 2008
@@ -35,7 +35,7 @@
(class-name (apply #'find-symbol (reverse (split "::?" (query-param "class-name"))))))
(import-directory spool-dir
:class-name class-name
- :user (bknr-request-user)
+ :user (bknr-session-user)
:keywords keywords
:spool (import-handler-spool-dir handler)
:keywords-from-dir (query-param "keyfromdir"))))
Modified: branches/trunk-reorg/bknr/web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/packages.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/packages.lisp Wed Jan 30 08:02:24 2008
@@ -378,9 +378,7 @@
#:bknr-session-host
#:host-name
- #:bknr-request-user
- #:bknr-request
- #:bknr-request-session
+ #:bknr-session
#:*session*
#:anonymous-session
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 Wed Jan 30 08:02:24 2008
@@ -19,7 +19,6 @@
(defun session-from-request ()
"check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter"
- (start-session)
(session-value 'bknr-session))
(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer))
@@ -34,7 +33,6 @@
(defmethod authorize ((authorizer bknr-authorizer))
;; Catch any errors that occur during request body processing
- (start-session)
(handler-case
(when (session-value 'bknr-session)
(return-from authorize t))
Modified: branches/trunk-reorg/bknr/web/src/web/event-log.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/event-log.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/event-log.lisp Wed Jan 30 08:02:24 2008
@@ -62,7 +62,7 @@
print-hours ;; number of hours to search
print-count) ;; maximum number of events to print
(when (and message (not (equal "" message)))
- (make-event 'message-event :from (bknr-request-user) :text message))
+ (make-event 'message-event :from (bknr-session-user) :text message))
;; Parameter parsing, will move to with-query-params soon
(if (and last-printed (not (equal "" last-printed)))
(setf last-printed (parse-integer last-printed))
@@ -78,10 +78,10 @@
(let ((selected-classes (or (and show-only-class
(list (find-class (find-symbol show-only-class (find-package "bknr")))))
(selected-classes (request-query))
- (mapcar #'find-class (get-user-preferences (bknr-request-user) :event-log-classes))
+ (mapcar #'find-class (get-user-preferences (bknr-session-user) :event-log-classes))
(default-selected-classes))))
(unless show-only-class
- (set-user-preferences (bknr-request-user) :event-log-classes (mapcar #'class-name selected-classes)))
+ (set-user-preferences (bknr-session-user) :event-log-classes (mapcar #'class-name selected-classes)))
;; selected-classes contains the list of event classes to print.
(html
((:form :action "/event-log" :method "post")
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 Wed Jan 30 08:02:24 2008
@@ -155,8 +155,8 @@
(defmethod website-session-info ((website website))
(html ((:div :id "session-info")
"local time is " (:princ-safe (format-date-time))
- (if (bknr-request-user)
- (html ", logged in as " (html-link (bknr-request-user)))
+ (if (bknr-session-user)
+ (html ", logged in as " (html-link (bknr-session-user)))
(html ", not logged in")))))
(defclass page-handler ()
@@ -216,14 +216,16 @@
(with-slots (require-user-flag) page-handler
(if (and require-user-flag
(not (find require-user-flag
- (user-flags (bknr-request-user)))))
+ (user-flags (bknr-session-user)))))
nil
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))
- (*session* (bknr-request-session))
- (*user* (bknr-request-user))
(*req-var-hash* (or *req-var-hash*
(make-hash-table))))
(do-log-request)
@@ -411,7 +413,7 @@
())
(defmethod authorized-p ((handler admin-only-handler))
- (admin-p (bknr-request-user)))
+ (admin-p (bknr-session-user)))
(defclass xml-handler ()
((style-path :initarg :style-path :reader xml-handler-style-path))
@@ -487,7 +489,7 @@
(defgeneric import-handler-import-files (handler))
(defmethod import-handler-import-pathname ((handler import-handler))
- (let* ((user (bknr-request-user))
+ (let* ((user (bknr-session-user))
(spool-dir (merge-pathnames (make-pathname
:directory (list :relative (user-login user)))
(import-handler-spool-dir handler))))
Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Wed Jan 30 08:02:24 2008
@@ -2,28 +2,26 @@
(defclass bknr-session ()
((id :initarg :id :reader bknr-session-id :initform (get-universal-time))
- (user :initarg :user :reader bknr-session-user :initform nil)
+ (user :initarg :user)
(host :initarg :host :reader bknr-session-host :initform nil)))
(defmethod print-object ((session bknr-session) stream)
(print-unreadable-object (session stream :type t :identity t)
- (format stream "user ~A host ~A" (bknr-session-user session) (bknr-session-host session))
+ (with-slots (user host) session
+ (format stream "user ~A host ~A" user host))
session))
-(defmethod bknr-session-user ((user (eql nil)))
- nil)
-
-(defun bknr-request-user ()
- (bknr-session-user (session-value 'bknr-session)))
-
-(defun bknr-request-session ()
+(defun bknr-session ()
(session-value 'bknr-session))
+(defun bknr-session-user ()
+ (slot-value (bknr-session) 'user))
+
(defun do-log-request ()
(format *debug-io* "Log: ~A~%" (request-uri))
(return-from do-log-request)
#+(or)
- (let* ((session (bknr-request-session))
+ (let* ((session (bknr-session))
(user (bknr-session-user session))
(host (bknr-session-host session))
(url (request-uri))
@@ -45,7 +43,7 @@
(defun do-error-log-request (error)
(format *debug-io* "Error: ~A~%" error)
#+(or)
- (let* ((session (bknr-request-session))
+ (let* ((session (bknr-session))
(user (bknr-session-user session))
(host (bknr-session-host session))
(url (request-uri))
Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Wed Jan 30 08:02:24 2008
@@ -226,7 +226,7 @@
do (navi-button :url link
:text name)))))
(when (and (website-admin-navigation *website*)
- (admin-p (bknr-request-user)))
+ (admin-p (bknr-session-user)))
(html ((:div :class "navi")
"admin: "
(loop
Modified: branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp Wed Jan 30 08:02:24 2008
@@ -39,7 +39,7 @@
(defmethod authorized-p ((handler user-handler))
(let* ((user (object-handler-get-object handler))
- (web-user (bknr-request-user))
+ (web-user (bknr-session-user))
(action (query-param "action"))
(action-keyword (when action (make-keyword-from-string action))))
(cond ((anonymous-p web-user) nil)
@@ -87,7 +87,7 @@
(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user)
(unless user
- (setf user (bknr-request-user)))
+ (setf user (bknr-session-user)))
(when user
(with-query-params (password password-repeat
full-name
@@ -98,7 +98,7 @@
(set-user-password user password))
(change-slot-values user 'email email 'full-name full-name)))
- (when (admin-p (bknr-request-user))
+ (when (admin-p (bknr-session-user))
(let* ((all-flags (all-user-flags))
(set-flags (keywords-from-query-param-list (query-param-list "flags")))
(unset-flags (set-difference all-flags set-flags)))
@@ -112,7 +112,7 @@
(:report "You are not authorized to perform this operation"))
(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user)
- (unless (admin-p (bknr-request-user))
+ (unless (admin-p (bknr-session-user))
(error 'unauthorized-error))
(when user
(delete-user user))
Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp (original)
+++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp Wed Jan 30 08:02:24 2008
@@ -75,8 +75,8 @@
(defmethod handle ((handler login-js-handler))
(format *html-stream* "parent.login_complete(~A, ~S);~%"
- (if (admin-p (bknr-request-user)) "true" "false")
- (user-login (bknr-request-user))))
+ (if (admin-p (bknr-session-user)) "true" "false")
+ (user-login (bknr-session-user))))
(defclass clients-js-handler (javascript-handler page-handler)
())
Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original)
+++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Wed Jan 30 08:02:24 2008
@@ -2,6 +2,9 @@
(defun startup ()
(setq cxml::*default-catalog* '("/home/hans/share/xml/catalog"))
+ ;; XXX hack hack hack
+ (mapcar #'cl-gd::load-foreign-library
+ '("/usr/lib/libcrypto.so" "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd/cl-gd-glue.so"))
(when *store*
(close-store))
(make-instance 'store
Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original)
+++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Wed Jan 30 08:02:24 2008
@@ -3,6 +3,13 @@
(enable-interpol-syntax)
+(defclass admin-handler (admin-only-handler page-handler)
+ ())
+
+(defmethod handle ((handler admin-handler))
+ (with-bknr-page (:title "CMS")
+ "Please choose an administration activity from the menu above"))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -23,6 +30,7 @@
("/upload-animation" upload-animation-handler)
("/upload-button" upload-button-handler)
("/rss" rss-handler)
+ ("/admin" admin-handler)
("/" redirect-handler
:to "/frontpage")
user
More information about the Bknr-cvs
mailing list