[bknr-cvs] r2417 - in branches/trunk-reorg: bknr/datastore/patches bknr/datastore/src bknr/datastore/src/data bknr/datastore/src/utils bknr/datastore/src/xml bknr/datastore/src/xml-impex bknr/modules bknr/modules/album bknr/modules/bug bknr/modules/class-browser bknr/modules/comics bknr/modules/feed bknr/modules/imagemap bknr/modules/mail bknr/modules/quizz bknr/modules/stats bknr/modules/tamagotchi bknr/modules/text bknr/modules/track bknr/modules/url bknr/tools bknr/web/src bknr/web/src/images bknr/web/sr

Author: hhubner Date: Tue Jan 29 07:19:19 2008 New Revision: 2417

Added: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp - copied, changed from r2270, branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp Removed: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd branches/trunk-reorg/bknr/datastore/src/data/object.lisp branches/trunk-reorg/bknr/datastore/src/data/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp branches/trunk-reorg/bknr/datastore/src/utils/class.lisp branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp branches/trunk-reorg/bknr/modules/album/album.lisp branches/trunk-reorg/bknr/modules/bknr-modules.asd branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp branches/trunk-reorg/bknr/modules/comics/comics.lisp branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp branches/trunk-reorg/bknr/modules/feed/feed.lisp branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mail.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/mail/package.lisp branches/trunk-reorg/bknr/modules/mail/register-handler.lisp branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp branches/trunk-reorg/bknr/modules/packages.lisp branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp branches/trunk-reorg/bknr/modules/stats/package.lisp branches/trunk-reorg/bknr/modules/stats/stats-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/article-tags.lisp branches/trunk-reorg/bknr/modules/text/article.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/htmlize-handler.lisp branches/trunk-reorg/bknr/modules/text/package.lisp branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp branches/trunk-reorg/bknr/modules/track/import-handler.lisp branches/trunk-reorg/bknr/modules/track/track-handlers.lisp branches/trunk-reorg/bknr/modules/track/track-tags.lisp branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp branches/trunk-reorg/bknr/modules/url/url-handlers.lisp branches/trunk-reorg/bknr/tools/make-core.lisp branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-tags.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp branches/trunk-reorg/bknr/web/src/images/session-image.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss20.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/rss-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/templates.lisp branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp branches/trunk-reorg/projects/bos/m2/m2.lisp branches/trunk-reorg/projects/bos/m2/mail-generator.lisp branches/trunk-reorg/projects/bos/web/package.lisp branches/trunk-reorg/projects/bos/web/web.lisp branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp branches/trunk-reorg/projects/eboy/src/item-handlers.lisp branches/trunk-reorg/projects/eboy/src/jerks.lisp branches/trunk-reorg/projects/eboy/src/layout.lisp branches/trunk-reorg/projects/eboy/src/navi.lisp branches/trunk-reorg/projects/eboy/src/packages.lisp branches/trunk-reorg/projects/eboy/src/peecol.lisp branches/trunk-reorg/projects/gpn/add-user-handler.lisp branches/trunk-reorg/projects/gpn/gpn-tags.lisp branches/trunk-reorg/projects/gpn/import-handler.lisp branches/trunk-reorg/projects/gpn/packages.lisp branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp branches/trunk-reorg/projects/hello-web/src/handlers.lisp branches/trunk-reorg/projects/hello-web/src/packages.lisp branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp branches/trunk-reorg/projects/mah-jongg/src/game.lisp branches/trunk-reorg/projects/mah-jongg/src/package.lisp branches/trunk-reorg/projects/quickhoney/src/config.lisp branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp branches/trunk-reorg/projects/quickhoney/src/layout.lisp branches/trunk-reorg/projects/quickhoney/src/packages.lisp branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd branches/trunk-reorg/projects/quickhoney/src/webserver.lisp branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp branches/trunk-reorg/projects/raw-data/mcp/packages.lisp branches/trunk-reorg/projects/saugnapf/src/package.lisp branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp Log: Snapshot the port of the BKNR web framework to Hunchentoot. In the process, the request argument that many of functions had has been removed. Instead, the request is accessed through the dynamic environment, which is the default mode for Hunchentoot.

This commit works with SBCL and cmucl, but I am now workin with SBCL as Slime works way better there, in particular for debugging errors in hunchentoot handlers.

All BKNR handlers are registered in the BKNR.WEB::*HANDLERS* special variable. BKNR registers only one dispatcher in Hunchtentoots *DISPATCHER-TABLE* that scans the BKNR handlers for a match. This is done to enhance debugability, as the *HANDLERS* table contains PAGE-HANDLER objects that carry information about their path etc.

Copied: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp (from r2270, branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp) ============================================================================== --- branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp (original) +++ branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp Tue Jan 29 07:19:19 2008 @@ -1,5 +1,5 @@ ;;; This patch fixes the problem with get-accessor-method-function -;;; throwing an internal error in cmucl 19a. +;;; throwing an internal error in cmucl 19 ;;; ;;; Not yet in cmucl

Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd Tue Jan 29 07:19:19 2008 @@ -18,6 +18,7 @@

:depends-on (:cl-interpol :cl-ppcre :md5 + :hunchentoot ; (for hunchentoot-mp package) :iconv)

:components ((:module "statistics" :components ((:file "package")

Modified: branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd Tue Jan 29 07:19:19 2008 @@ -17,5 +17,5 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cxml) :components ((:module "xml" :components ((:file "package") - (:file "xml"))))) + (:file "xml" :depends-on ("package"))))))

Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Tue Jan 29 07:19:19 2008 @@ -35,9 +35,11 @@ (defvar *suppress-schema-warnings* nil)

(deftransaction update-instances-for-changed-class (class) - (unless *suppress-schema-warnings* - (warn "updating ~A instances of ~A for class changes" (length (class-instances class)) class)) - (mapc #'reinitialize-instance (class-instances class))) + (let ((instance-count (length (class-instances class)))) + (when (plusp instance-count) + (unless *suppress-schema-warnings* + (warn "updating ~A instances of ~A for class changes" instance-count class)) + (mapc #'reinitialize-instance (class-instances class)))))

(defmethod instance :after ((class persistent-class) &rest args) (declare (ignore args))

Modified: branches/trunk-reorg/bknr/datastore/src/data/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,6 +4,8 @@ (:use :cl :bknr.utils :cl-interpol :cl-ppcre :bknr.indices :bknr.statistics :closer-mop ) + #+cmu + (:shadowing-import-from :common-lisp #:subtypep #:typep) (:shadowing-import-from :cl-interpol quote-meta-chars) (:export #:*store-debug* #:*store*

Modified: branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp Tue Jan 29 07:19:19 2008 @@ -18,16 +18,15 @@ (defmethod actor-start ((actor bknr-actor)) (actor-stop actor) (setf (slot-value actor 'process) - (process-run-function - (bknr-actor-name actor) - #'(lambda () - (funcall #'run-function actor))))) + (mp:make-process (lambda () + (funcall #'run-function actor)) + :name (bknr-actor-name actor))))

(defmethod actor-running-p ((actor bknr-actor)) (and (slot-boundp actor 'process) - (process-active-p (bknr-actor-process actor)))) + (mp:process-active-p (bknr-actor-process actor))))

(defmethod actor-stop ((actor bknr-actor)) (when (slot-boundp actor 'process) - (process-kill (bknr-actor-process actor)) + (mp:destroy-process (bknr-actor-process actor)) (slot-makunbound actor 'process)))

Modified: branches/trunk-reorg/bknr/datastore/src/utils/class.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/class.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/class.lisp Tue Jan 29 07:19:19 2008 @@ -5,9 +5,8 @@ (defun compute-bknr-slot (class slot) (destructuring-bind (name access &rest rest) slot (let* ((initarg (make-keyword-from-string (symbol-name name))) - (package (symbol-package class)) (accessor (intern (concatenate 'string (symbol-name class) "-" - (symbol-name name)) package))) + (symbol-name name)) *package*))) (push initarg rest) (push :initarg rest) (case access

Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Tue Jan 29 07:19:19 2008 @@ -54,6 +54,7 @@ #:group-on #:find-all #:genlist + #+no-alexandria #:rotate #:nrotate #:shift-until @@ -66,6 +67,7 @@ #:incf-hash

;; randomize + #+no-alexandria #:random-elt #:random-elts #:randomize-list

Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Tue Jan 29 07:19:19 2008 @@ -283,6 +283,7 @@ do (incf-hash (funcall key object) (nth i hash-tables)))) (apply #'values sum hash-tables)))

+#+no-alexandria (defun rotate (list) (when list (append (cdr list) (list (car list))))) @@ -350,6 +351,7 @@ (setf l (randomize l))))) l)

+#+no-alexandria (defun random-elt (choices) (when choices (elt choices (random (length choices)))))

Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp Tue Jan 29 07:19:19 2008 @@ -2,14 +2,13 @@

(defpackage :bknr.impex (:use :cl - #+clisp - :ext - :cl-user :cxml :closer-mop :bknr.utils :bknr.xml :bknr.indices) + #+cmu + (:shadowing-import-from :common-lisp #:subtypep #:typep)

(:export #:xml-class #:parse-xml-file

Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Tue Jan 29 07:19:19 2008 @@ -12,8 +12,8 @@ (defmacro with-xml-export* ((&key output indentation canonical) &body body) `(let ((*objects-written* (make-hash-table :test #'equal)) (cxml::*current-element* nil) - (cxml::*sink* (cxml:make-character-stream-sink ,output - :indentation ,indentation :canonical ,canonical))) + (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output + :indentation ,indentation :canonical ,canonical))) ,@body))

(defmacro with-xml-export (nil &body body)

Modified: branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp Tue Jan 29 07:19:19 2008 @@ -18,7 +18,7 @@ (error "Some children are not strings"))))

(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + (cadr (assoc attribute-name (node-attrs xml) :test #'equal)))

(defun node-child-string-body (xml node-name) (let ((child (find-child xml node-name)))

Modified: branches/trunk-reorg/bknr/modules/album/album.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/album/album.lisp (original) +++ branches/trunk-reorg/bknr/modules/album/album.lisp Tue Jan 29 07:19:19 2008 @@ -32,16 +32,16 @@ (defclass album-handler (prefix-handler) ())

-(defmethod handle ((handler album-handler) req) +(defmethod handle ((handler album-handler)) (multiple-value-bind (username album) - (parse-handler-url handler req) + (parse-handler-url handler) (let ((user (when username (find-user username)))) (cond ((and user album) - (with-bknr-page (req :title #?"${username} : ${album}") + (with-bknr-page (:title #?"${username} : ${album}") (album :username username :album album))) (user - (with-bknr-page (req :title #?"${username}'s albums") + (with-bknr-page (:title #?"${username}'s albums") (user-albums :username username))) - (t (with-bknr-page (req :title "No such album") + (t (with-bknr-page (:title "No such album") (:h2 "No such album")))))))

Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd ============================================================================== --- branches/trunk-reorg/bknr/modules/bknr-modules.asd (original) +++ branches/trunk-reorg/bknr/modules/bknr-modules.asd Tue Jan 29 07:19:19 2008 @@ -17,16 +17,16 @@ :depends-on (:cl-interpol :cl-ppcre :cl-gd - :aserve - :net.post-office :md5 + :closer-mop + :cl-smtp :cxml :unit-test :bknr-utils :puri :stem - :bknr - :acl-compat) + :bknr-web + :parenscript)

:components ((:file "packages")

@@ -45,6 +45,7 @@ :depends-on ("package")) (:file "blog" :depends-on ("article" "vector-search")) + #+(or) (:file "billboard" :depends-on ("article")) (:file "article-tags" @@ -53,6 +54,7 @@ :depends-on ("article")) (:file "blog-handlers" :depends-on ("blog" "article-tags" "article-handlers")) + #+(or) (:file "billboard-handlers" :depends-on ("billboard" "article-tags")) (:file "article-handlers" @@ -64,6 +66,7 @@ :depends-on ("paste-tags"))) :depends-on ("packages"))

+ #+(or) (:module "feed" :components ((:file "feed") (:file "feed-tags" :depends-on ("feed")) @@ -130,6 +133,7 @@ :depends-on ("general" "web" "packages"))

+ #+(or) (:module "track" :components ((:file "track") (:file "media" :depends-on ("track")) @@ -144,5 +148,6 @@ :depends-on ("media"))) :depends-on ("packages"))

+ #+(or) (:module "comics" :components ((:file "comics")))) :depends-on ("packages"))

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 Tue Jan 29 07:19:19 2008 @@ -5,31 +5,31 @@ (defclass bug-tracker-handler (edit-object-handler) ())

-(defmethod object-handler-get-object ((hander bug-tracker-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((hander bug-tracker-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'bug-tracker))))

-(defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil)) req) +(defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil))) (let ((bug-trackers (all-bug-trackers))) - (with-bknr-page (req :title "Bug trackers") + (with-bknr-page (:title "Bug trackers") (:h2 "all bug-trackers") (:ul (dolist (bug-tracker bug-trackers) (html (:li ((:a :href (format nil "/bug-tracker/~a" (mailinglist-name bug-tracker))) (:princ-safe (mailinglist-name bug-tracker))))))))))

-(defmethod handle-object-form ((handler bug-tracker-handler) action tracker req) - (with-bknr-page (req :title #?"bug-tracker for $((mailinglist-name tracker))") - (when (admin-p (bknr-request-user req)) +(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)) (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 req) - (let ((user (bknr-request-user req))) +(defmethod file-bug-report ((handler bug-tracker-handler) tracker) + (let ((user (bknr-request-user))) ;; XXX check user rights - (with-query-params (req name status priority description) + (with-query-params (name status priority description) (let ((bug-report (make-object 'bug-report :tracker tracker :subject name @@ -41,35 +41,35 @@ bug-report))))

(defmethod handle-object-form ((handler bug-tracker-handler) (action (eql :create-bug-report)) - tracker req) - (let ((bug-report (file-bug-report handler tracker req))) - (redirect (format nil "/bug-report/~a" (store-object-id bug-report)) req))) + tracker) + (let ((bug-report (file-bug-report handler tracker))) + (redirect (format nil "/bug-report/~a" (store-object-id bug-report)))))

(defclass bug-report-handler (edit-object-handler) ())

-(defmethod object-handler-get-object ((handler bug-report-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler bug-report-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'bug-report))))

-(defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil)) req) - (redirect "/bug-tracker" req)) +(defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil))) + (redirect "/bug-tracker"))

-(defmethod handle-object-form ((handler bug-report-handler) action report req) - (with-bknr-page (req :title #?"bug-report") - (when (or (equal (bknr-request-user req) +(defmethod handle-object-form ((handler bug-report-handler) action report) + (with-bknr-page (:title #?"bug-report") + (when (or (equal (bknr-request-user) (bug-report-handler report)) - (admin-p (bknr-request-user req))) + (admin-p (bknr-request-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))))

(defmethod handle-object-form ((handler bug-report-handler) (action (eql :annotate)) - report req) + report) (if report - (let ((user (bknr-request-user req))) - (with-query-params (req title text) + (let ((user (bknr-request-user))) + (with-query-params (title text) (let ((article (make-object 'article :author user :subject title @@ -77,16 +77,16 @@ (if article (bug-report-add-annotation report article) (delete-object article)) - (handle-object-form handler nil report req)))) - (handle-object-form handler nil report req))) + (handle-object-form handler nil report)))) + (handle-object-form handler nil report)))

(defclass edit-bug-tracker-handler (bug-tracker-handler) ())

(defmethod handle-object-form ((handler edit-bug-tracker-handler) action - (bug-tracker (eql nil)) req) + (bug-tracker (eql nil))) (let ((bug-trackers (all-bug-trackers))) - (with-bknr-page (req :title "Bug trackers") + (with-bknr-page (:title "Bug trackers") (:h2 "all bug-trackers") (:ul (dolist (bug-tracker bug-trackers) (html (:li ((:a :href (format nil "/edit-bug-tracker/~a" @@ -96,58 +96,58 @@ (bug-tracker-form))))

(defmethod handle-object-form ((handler edit-bug-tracker-handler) - (action (eql :create)) bug-tracker req) - (with-query-params (req name email description) + (action (eql :create)) bug-tracker) + (with-query-params (name email description) (if (and name email) (let ((bug-tracker (make-object 'bug-tracker :name name :email email :description description))) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)) req)) - (handle-object-form handler nil nil req)))) + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)))) + (handle-object-form handler nil nil))))

(defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :create-bug-report)) - tracker req) - (file-bug-report handler tracker req) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) + tracker) + (file-bug-report handler tracker) + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker))))

(defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :save)) - tracker req) - (if (admin-p (bknr-request-user req)) - (with-query-params (req name email description) + tracker) + (if (admin-p (bknr-request-user)) + (with-query-params (name email description) (change-slot-values tracker 'name name 'email email 'description description) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug tracker") + (with-bknr-page (:title #?"Edit bug tracker") (:p "You are not authorized to edit this bug tracker") ((:a :href "/bug-tracker") "return to bug-tracker page"))))

(defmethod handle-object-form ((handler edit-bug-tracker-handler) action - bug-tracker req) - (with-bknr-page (req :title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") + bug-tracker) + (with-bknr-page (:title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") (bug-tracker-form :bug-tracker-id (store-object-id bug-tracker))))

(defclass edit-bug-report-handler (bug-report-handler) ())

(defmethod handle-object-form ((handler edit-bug-report-handler) - action (bug-report (eql nil)) req) - (redirect "/edit-bug-tracker" req)) + action (bug-report (eql nil))) + (redirect "/edit-bug-tracker"))

(defmethod handle-object-form ((handler edit-bug-report-handler) - action bug-report req) - (with-bknr-page (req :title #?"Edit bug report") + action bug-report) + (with-bknr-page (:title #?"Edit bug report") (if bug-report (bug-form :bug-id (store-object-id bug-report)) - (redirect "/edit-bug-tracker" req)))) + (redirect "/edit-bug-tracker"))))

(defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :save)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) - (with-query-params (req name status priority description) + (with-query-params (name status priority description) (let ((status-kw (make-keyword-from-string status)) (priority-kw (make-keyword-from-string priority))) (if (eq status-kw :closed) @@ -163,68 +163,68 @@ 'priority priority-kw 'last-modified (get-universal-time))) (call-next-method))) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page"))))

(defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :close)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (change-slot-values report 'closed (get-universal-time) 'status :closed 'last-modified (get-universal-time)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page"))))

(defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :reopen)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (change-slot-values report 'closed nil 'status :reopened 'last-modified (get-universal-time)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page"))))

(defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :delete)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (let ((tracker (bug-report-tracker report))) (bug-tracker-remove-bug-report tracker report) (delete-object report) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) - (with-bknr-page (req :title #?"Edit bug report") + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))) + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page")))))

(defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :handle)) - report req) + report) (if (or (null (bug-report-handler report)) - (admin-p (bknr-request-user req))) + (admin-p (bknr-request-user))) (progn - (change-slot-values report 'handler (bknr-request-user req)) + (change-slot-values report 'handler (bknr-request-user)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You can not become the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page"))))

Modified: branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp (original) +++ branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp Tue Jan 29 07:19:19 2008 @@ -4,17 +4,17 @@ ((default-package-name :initarg :default-package-name)) (:default-initargs :default-package-name nil))

-(defmethod object-handler-get-object ((handler class-browser-handler) req) +(defmethod object-handler-get-object ((handler class-browser-handler)) (destructuring-bind (class-name &optional (package-name (slot-value handler 'default-package-name))) - (mapcar #'string-upcase (reverse (split "::" (parse-url req)))) + (mapcar #'string-upcase (reverse (split "::" (parse-url)))) (find-class (find-symbol class-name (find-package package-name)) nil)))

-(defmethod handle-object ((handler class-browser-handler) (class (eql nil)) req) - (user-error "Invalid class name ~A" (parse-url req))) +(defmethod handle-object ((handler class-browser-handler) (class (eql nil))) + (user-error "Invalid class name ~A" (parse-url)))

-(defmethod handle-object ((handler class-browser-handler) class req) - (with-http-response (req *ent*) - (with-http-body (req *ent*) +(defmethod handle-object ((handler class-browser-handler) class) + (with-http-response () + (with-http-body () (labels ((qualified-class-name (class) (let ((class-name (class-name class))) (format nil "~A::~A" (package-name (symbol-package class-name)) (symbol-name class-name)))) @@ -26,7 +26,7 @@ (when (documentation class t) (html (:p (:princ-safe (documentation class t))))) - (dolist (subclass (pcl:class-direct-subclasses class)) + (dolist (subclass (closer-mop:class-direct-subclasses class)) (show-class subclass (1+ level))))))) (html (:head

Modified: branches/trunk-reorg/bknr/modules/comics/comics.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/comics/comics.lisp (original) +++ branches/trunk-reorg/bknr/modules/comics/comics.lisp Tue Jan 29 07:19:19 2008 @@ -46,6 +46,7 @@ (concatenate 'string "http://" host image)) (t (render-uri (puri:merge-uris uri mainuri) nil)))))

+#+(or) (defmethod get-comic ((comic comic) &key force) (with-slots (name url mainurl imgregexp mainregexp) comic (let* ((date (daytag))

Modified: branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass edit-feed-handler (edit-object-handler feed-handler) ((require-user-flag :initform :feed)))

-(defmethod handle-object-form ((handler edit-feed-handler) action (feed (eql nil)) req) - (with-bknr-page (req :title "create feed") +(defmethod handle-object-form ((handler edit-feed-handler) action (feed (eql nil))) + (with-bknr-page (:title "create feed") (:h2 "Manage feeds") (:ul (loop for feed in (all-feeds) do (html (:li ((:a :href (format nil "/edit-feed/~a" @@ -15,16 +15,16 @@ (:h2 "Create feed") (feed-form)))

-(defmethod handle-object-form ((handler edit-feed-handler) action feed req) +(defmethod handle-object-form ((handler edit-feed-handler) action feed) (let ((feed-name (feed-name feed))) - (with-bknr-page (req :title #?"edit feed: ${feed-name}") + (with-bknr-page (:title #?"edit feed: ${feed-name}") (:h2 #?"Edit feed: ${feed-name}") (feed-form :feed-id (store-object-id feed)))))

-(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :create)) obj req) - (with-query-params (req name url refresh type encoding) +(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :create)) obj) + (with-query-params (name url refresh type encoding) (if (and name url type) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (feed (make-object 'feed :name name :url url @@ -34,38 +34,38 @@ :type (make-keyword-from-string type) :encoding (make-keyword-from-string encoding) :keywords keywords))) - (redirect (format nil "/edit-feed/~a" (feed-name feed)) req)) - (handle-object-form handler nil nil req)))) + (redirect (format nil "/edit-feed/~a" (feed-name feed)))) + (handle-object-form handler nil nil))))

(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :add-keywords)) - feed req) + feed) (when feed (let ((keywords (keywords-from-query-param-list - (query-param-list req "keyword")))) + (query-param-list "keyword")))) (store-object-add-keywords feed 'keywords keywords))) (call-next-method))

(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :remove-keywords)) - feed req) + feed) (when feed (let ((keywords (keywords-from-query-param-list - (query-param-list req "keyword")))) + (query-param-list "keyword")))) (store-object-remove-keywords feed 'keywords keywords))) (call-next-method))

(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :update)) - feed req) + feed) (when feed (update-feed feed :force t)) (call-next-method))

(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :save)) - feed req) + feed) (when feed - (with-query-params (req url refresh type encoding) + (with-query-params (url refresh type encoding) (when (and url (not (string-equal url (feed-url feed)))) (feed-change-url feed url)) (when refresh (change-slot-values feed 'refresh-interval (parse-integer refresh))) @@ -75,6 +75,6 @@

(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :delete)) - feed req) + feed) (when feed (delete-object feed)) - (redirect "/edit-feed" req)) + (redirect "/edit-feed"))

Modified: branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -19,18 +19,18 @@ (defclass feed-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler feed-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler feed-handler)) + (let ((id-or-name (parse-url))) (find-store-object id-or-name :class 'feed)))

-(defmethod handle-object ((handler feed-handler) (feed (eql nil)) req) - (with-bknr-page (req :title #?"bknr feed aggregator: all feeds") +(defmethod handle-object ((handler feed-handler) (feed (eql nil))) + (with-bknr-page (:title #?"bknr feed aggregator: all feeds") (feed-list (all-feeds))))

-(defmethod handle-object ((handler feed-handler) feed req) +(defmethod handle-object ((handler feed-handler) feed) (let ((feed-name (feed-name feed)) (rss-feed (feed-rss-feed feed))) - (with-bknr-page (req :title #?"bknr feed aggregator: ${feed-name}") + (with-bknr-page (:title #?"bknr feed aggregator: ${feed-name}") (feed :feed-id (store-object-id feed)) (when rss-feed (rss-feed-page (rss-channel-link (rss-feed-channel rss-feed)) @@ -42,37 +42,37 @@ ())

(defmethod object-date-list-handler-grouped-objects ((handler feed-list-handler) - object req) - (let* ((title (object-list-handler-title handler object req)) - (feeds (object-list-handler-get-objects handler object req)) - (rss-feed (merge-feeds title (render-uri (request-uri req) nil) + object) + (let* ((title (object-list-handler-title handler object)) + (feeds (object-list-handler-get-objects handler object)) + (rss-feed (merge-feeds title (render-uri (request-uri) nil) title (remove nil (mapcar #'feed-rss-feed feeds)))) (grouped-items (rss-feed-group-items rss-feed))) grouped-items))

-(defmethod handle-object ((handler feed-list-handler) foo req) - (let ((title (object-list-handler-title handler foo req)) - (rss-link (object-list-handler-rss-link handler foo req)) - (grouped-items (object-date-list-handler-grouped-objects handler foo req))) - (with-bknr-page (req :title title) +(defmethod handle-object ((handler feed-list-handler) foo) + (let ((title (object-list-handler-title handler foo)) + (rss-link (object-list-handler-rss-link handler foo)) + (grouped-items (object-date-list-handler-grouped-objects handler foo))) + (with-bknr-page (:title title) (html ((:a :href rss-link) "rss") (rss-feed-page rss-link title grouped-items)))))

(defclass feed-keyword-handler (feed-list-handler keyword-handler) ())

-(defmethod object-list-handler-title ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-title ((handler feed-keyword-handler) keyword) (format nil "feeds with keyword: ~a" keyword))

-(defmethod object-list-handler-rss-link ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-rss-link ((handler feed-keyword-handler) keyword) (format nil "/feed-keyword-rss/~a" keyword))

-(defmethod object-list-handler-get-objects ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-get-objects ((handler feed-keyword-handler) keyword) (get-keyword-feeds keyword))

#+xxx -(defmethod handle-object ((handler feed-keyword-handler) (keyword (eql nil)) req) - (with-bknr-page (req :title "all-feed-keywords") +(defmethod handle-object ((handler feed-keyword-handler) (keyword (eql nil))) + (with-bknr-page (:title "all-feed-keywords") (:ul (loop for keyword in (index-keys (current-store) :feed-keywords-key) for name = (string-downcase (symbol-name keyword)) do (html (:li @@ -84,28 +84,28 @@ (defclass feed-union-handler (feed-list-handler keywords-handler) ())

-(defmethod object-list-handler-title ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-title ((handler feed-union-handler) keywords) (format nil "feeds with keywords: ~a" keywords))

-(defmethod object-list-handler-rss-link ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-rss-link ((handler feed-union-handler) keywords) (format nil "/feed-union-rss/~A" - (parse-url req))) + (parse-url)))

-(defmethod object-list-handler-get-objects ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler feed-union-handler) keywords) (get-keywords-union-feeds keywords))

(defclass feed-intersection-handler (feed-list-handler keywords-handler) ())

-(defmethod object-list-handler-title ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-title ((handler feed-intersection-handler) keywords) (format nil "feeds with all keywords: ~a" keywords))

-(defmethod object-list-handler-rss-link ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-rss-link ((handler feed-intersection-handler) keywords) (format nil "/feed-intersection-rss/~A" - (parse-url req))) + (parse-url)))

-(defmethod object-list-handler-get-objects ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler feed-intersection-handler) keywords) (get-keywords-intersection-feeds keywords))

@@ -114,12 +114,12 @@ (defclass rss-feed-handler (object-rss-handler feed-handler) ())

-(defmethod create-object-rss-feed ((handler rss-feed-handler) (feed (eql nil)) req) +(defmethod create-object-rss-feed ((handler rss-feed-handler) (feed (eql nil))) (make-instance 'rss-feed :channel (make-instance 'rss-channel :about "no such feed" :title "no such feed")))

-(defmethod create-object-rss-feed ((handler rss-feed-handler) feed req) +(defmethod create-object-rss-feed ((handler rss-feed-handler) feed) (if (feed-rss-feed feed) (feed-rss-feed feed) (make-instance 'rss-feed @@ -132,11 +132,11 @@ (defclass rss-feed-list-handler (object-rss-handler feed-list-handler) ())

-(defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword req) - (let ((feeds (object-list-handler-get-objects handler keyword req))) - (merge-feeds (object-list-handler-title handler keyword req) - (render-uri (request-uri req) nil) - (object-list-handler-title handler keyword req) +(defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword) + (let ((feeds (object-list-handler-get-objects handler keyword))) + (merge-feeds (object-list-handler-title handler keyword) + (render-uri (request-uri) nil) + (object-list-handler-title handler keyword) (remove nil (mapcar #'feed-rss-feed feeds)))))

(defclass rss-feed-keyword-handler (rss-feed-list-handler feed-keyword-handler)

Modified: branches/trunk-reorg/bknr/modules/feed/feed.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed.lisp Tue Jan 29 07:19:19 2008 @@ -56,6 +56,7 @@ (feed-article-date feed (rss-item-link item) (get-universal-time))))))))))

+#+(or) (defmethod update-feed ((feed feed) &key (force nil)) (let ((time (get-universal-time))) (if (or (> (- time (feed-last-updated feed))

Modified: branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass show-imagemap-handler (prefix-handler) ())

-(defmethod handle ((page-handler show-imagemap-handler) req) - (let ((map-id (parse-url req))) +(defmethod handle ((page-handler show-imagemap-handler)) + (let ((map-id (parse-url))) (let ((imagemap (find-imagemap map-id))) (with-store-image (image (imagemap-image imagemap)) (with-default-image (image) @@ -15,95 +15,95 @@ (orange (allocate-color 255 140 80))) (loop for area in (imagemap-clickable-areas imagemap) do (draw-polygon (imagemap-area-polygon area) - :color (if (equal area (session-variable :map-selected-area)) red orange) + :color (if (equal area (session-value :map-selected-area)) red orange) :filled t)) - (when (session-variable :map-points) + (when (session-value :map-points) (with-thickness (3) (with-default-color (white) - (let ((edit-points (session-variable :map-points))) + (let ((edit-points (session-value :map-points))) (case (length edit-points) (0 t) (2 (draw-filled-circle (car edit-points) (cadr edit-points) 3)) (4 (apply #'draw-line edit-points)) - (t (draw-polygon (session-variable :map-points)))))))))) - (emit-image-to-browser req image :jpg))))) + (t (draw-polygon (session-value :map-points)))))))))) + (emit-image-to-browser image :jpg)))))

(defclass edit-imagemap-handler (prefix-handler) () (:default-initargs :require-user-flag :admin))

-(defmethod handle ((page-handler edit-imagemap-handler) req) +(defmethod handle ((page-handler edit-imagemap-handler)) (multiple-value-bind (map-id operation-string) - (parse-url req) - (with-bknr-page (req :title #?"imagemap editor for imagemap $(map-id)") + (parse-url) + (with-bknr-page (:title #?"imagemap editor for imagemap $(map-id)") (let ((imagemap (find-imagemap map-id :create t))) (case (make-keyword-from-string operation-string) (:add-point - (let* ((coord-string (or (caar (request-query req)) + (let* ((coord-string (or (caar (request-query)) (error "missing map coordinates"))) (point (mapcar #'parse-integer (split "," coord-string))) (clickable-area (imagemap-clickable-area-at imagemap point))) - (setf (session-variable :map-selected-area) clickable-area) + (setf (session-value :map-selected-area) clickable-area) (if clickable-area - (if (session-variable :map-points) + (if (session-value :map-points) (html (:p (:princ-safe #?"can't add point $(point) - already within another area"))) (html (:p (:princ-safe #?"area linked to $((imagemap-area-url clickable-area))") - (cmslink (self-url req :command "delete-area") + (cmslink (self-url :command "delete-area") (:princ "delete"))))) (progn - (setf (session-variable :map-points) (append point (session-variable :map-points))) + (setf (session-value :map-points) (append point (session-value :map-points))) (html (:p (:princ-safe #?"added point $(point)"))))))) (:clear-points - (setf (session-variable :map-points) nil) + (setf (session-value :map-points) nil) (html (:p "point list cleared"))) (:delete-area - (if (session-variable :map-selected-area) + (if (session-value :map-selected-area) (progn - (delete-clickable-area imagemap (session-variable :map-selected-area)) + (delete-clickable-area imagemap (session-value :map-selected-area)) (html (:p "area deleted"))) (html (:p "no area selected")))) (:make-polygon - (with-query-params (req url) - (unless (< 2 (length (session-variable :map-points))) + (with-query-params (url) + (unless (< 2 (length (session-value :map-points))) (error "select at least three points for a polygon")) (unless (and (stringp url) (not (equal "" url))) (error "enter a valid url to link the polygon to")) (add-clickable-area imagemap :url url - :polygon (session-variable :map-points)) - (setf (session-variable :map-points) nil) + :polygon (session-value :map-points)) + (setf (session-value :map-points) nil) (html (:p (:princ-safe #?"new polygon linked to $(url)"))))) (t (html (:p #?"unknown operation $(operation-string)")))) - (html ((:form :action (self-url req :command "make-polygon")) - (if (session-variable :map-points) + (html ((:form :action (self-url :command "make-polygon")) + (if (session-value :map-points) (progn (format *html-stream* "~a point~:P collected " - (/ (length (session-variable :map-points)) 2)) - (html (cmslink (self-url req :command "clear-points") + (/ (length (session-value :map-points)) 2)) + (html (cmslink (self-url :command "clear-points") (:princ "clear"))) - (when (< 4 (length (session-variable :map-points))) + (when (< 4 (length (session-value :map-points))) (html " link to url: " ((:input :type "text" :name "url" :width 40)) " " ((:input :type "submit" :value "make polygon"))))) (html "no points collected"))) - (:p ((:a :href (self-url req :command "add-point")) - ((:img :ismap "ismap" :src (self-url req :prefix "show-imagemap" :command "")))))))))) + (:p ((:a :href (self-url :command "add-point")) + ((:img :ismap "ismap" :src (self-url :prefix "show-imagemap" :command ""))))))))))

(defclass imagemap-handler (prefix-handler) ())

-(defmethod handle ((page-handler imagemap-handler) req) - (let* ((map-id (parse-url req)) +(defmethod handle ((page-handler imagemap-handler)) + (let* ((map-id (parse-url)) (imagemap (find-imagemap map-id :create t)) - (coord-string (or (caar (request-query req)) + (coord-string (or (caar (request-query)) (error "missing map coordinates")))) (let* ((point (mapcar #'parse-integer (split "," coord-string))) (clickable-area (imagemap-clickable-area-at imagemap point))) (if clickable-area - (with-bknr-http-response (req :response *response-moved-permanently*) - (setf (reply-header-slot-value req :location) (imagemap-area-url clickable-area)) - (with-http-body (req *ent*))) - (with-bknr-page (req :title "inactive clickable-area") + (with-http-response (:response *response-moved-permanently*) + (setf (header-out :location) (imagemap-area-url clickable-area)) + (with-http-body ())) + (with-bknr-page (:title "inactive clickable-area") (html "the point you clicked is not within an active clickable area"))))))

(define-bknr-tag imagemap-def (&key imagemap-name)

Modified: branches/trunk-reorg/bknr/modules/mail/mail.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mail.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mail.lisp Tue Jan 29 07:19:19 2008 @@ -93,11 +93,11 @@ :id (regex-replace-all *message-id-re* (header :message-id) #?/\1/) - :in-reply (regex-replace-all +#| :in-reply (regex-replace-all *message-id-re* (first (if (header :in-reply-to) (split #?/\s+/ (header :in-reply-to)) - (last (split #?/\s+/ (header :references)))))) + (last (split #?/\s+/ (header :references)))))) |# :headers headers :body body)))))

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 Tue Jan 29 07:19:19 2008 @@ -8,19 +8,19 @@ (defclass receive-mail-handler (page-handler) ())

-(defmethod handle ((handler receive-mail-handler) req) - (with-query-params (req from to subject body) +(defmethod handle ((handler receive-mail-handler)) + (with-query-params (from to subject body) (if (and from to subject body) (let ((mail (make-object 'mail :to to :from from :subject subject :body body))) - (with-bknr-page (req :title "mail received") + (with-bknr-page (:title "mail received") (if (handle-incoming-mail mail) (html (:p "Mail was delivered successfully")) (html (:p "Mail could not be delivered"))))) - (with-bknr-page (req :title "mail could not be received") + (with-bknr-page (:title "mail could not be received") (:p "Can not receive empty mail")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,8 +30,8 @@ () (:default-initargs :object-class 'mailinglist :query-function #'mailinglist-with-name))

-(defmethod handle-object-form ((handler post-mailinglist-handler) action (mailinglist (eql nil)) req) - (with-bknr-page (req :title "Post message to mailing list") +(defmethod handle-object-form ((handler post-mailinglist-handler) action (mailinglist (eql nil))) + (with-bknr-page (:title "Post message to mailing list") (if (class-instances 'mailinglist) (html (:h1 "Select a mailinglist to post to") @@ -45,9 +45,8 @@

(defmethod handle-object-form ((handler post-mailinglist-handler) action - (mailinglist mailinglist) - req) - (with-bknr-page (req :title #?"Post message to mailing list $((mailinglist-name mailinglist))") + (mailinglist mailinglist)) + (with-bknr-page (:title #?"Post message to mailing list $((mailinglist-name mailinglist))") (html ((:form :method "POST") (:p "Subject: " ((:input :type "text" :size "50" :name "subject"))) (:p "Text" :br @@ -56,11 +55,10 @@

(defmethod handle-object-form ((handler post-mailinglist-handler) (action (eql :post)) - mailinglist - req) - (with-bknr-page (req :title #?"Posting message to mailing list $((mailinglist-name mailinglist))") + mailinglist) + (with-bknr-page (:title #?"Posting message to mailing list $((mailinglist-name mailinglist))") (html (:h2 - (with-query-params (req subject text) + (with-query-params (subject text) (cond ((not subject) (html "No subject specified")) ((not text) (html "Text missing")) @@ -75,11 +73,11 @@ (defclass unsubscribe-handler (edit-object-handler) ())

-(defmethod authorized-p ((handler unsubscribe-handler) req) +(defmethod authorized-p ((handler unsubscribe-handler)) t)

-(defmethod object-handler-get-object ((handler unsubscribe-handler) req) - (subscription-with-hash (parse-url req))) +(defmethod object-handler-get-object ((handler unsubscribe-handler)) + (subscription-with-hash (parse-url)))

(defun html-subscription-info (user) (if (user-subscriptions user) @@ -94,9 +92,8 @@

(defmethod handle-object-form ((handler unsubscribe-handler) action - (subscription (eql nil)) - req) - (with-bknr-page (req :title "Search subscription to remove") + (subscription (eql nil))) + (with-bknr-page (:title "Search subscription to remove") (html ((:form :method "POST") "Enter email address: " ((:input :type "text" :size "50" :name "email")) @@ -104,13 +101,12 @@

(defmethod handle-object-form ((handler unsubscribe-handler) (action (eql :search)) - (subscription (eql nil)) - req) - (with-bknr-page (req :title "Send unsubscribe information") - (with-query-params (req email) + (subscription (eql nil))) + (with-bknr-page (:title "Send unsubscribe information") + (with-query-params (email) (let ((user (find-user email))) (if user - (if (admin-p (bknr-request-user req)) + (if (admin-p (bknr-request-user)) (html-subscription-info user) (progn (html (:p "Sending unsubscribe information to " (:princ-safe (user-email user)))) @@ -120,18 +116,16 @@

(defmethod handle-object-form ((handler unsubscribe-handler) action - registration - req) - (with-bknr-page (req :title "Unsubscription confirmation") + registration) + (with-bknr-page (:title "Unsubscription confirmation") (html ((:form :method "POST") (:p "Please click the button to confirm your unsubscription request.") (submit-button "confirm" "confirm")))))

(defmethod handle-object-form ((handler unsubscribe-handler) (action (eql :confirm)) - subscription - req) - (with-bknr-page (req :title "Delete subscription") + subscription) + (with-bknr-page (:title "Delete subscription") (delete-object subscription) (html (:p "The email address " (:princ-safe (user-email (subscription-user subscription))) " is now unsubscribed from the mailing list " @@ -142,8 +136,8 @@ () (:default-initargs :object-class 'mailinglist))

-(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) (mailinglist (eql nil)) req) - (with-bknr-page (req :title "Mailinglist Maintenance") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) (mailinglist (eql nil))) + (with-bknr-page (:title "Mailinglist Maintenance") (when (class-instances 'mailinglist) (html (:h1 "Select a mailinglist to edit") @@ -159,9 +153,9 @@ (:tr (:td "Name") (:td (text-field "name")))) (submit-button "create" "create")))))

-(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :create)) (mailinglist (eql nil)) req) - (with-query-params (req email name) - (with-bknr-page (req :title "Create new mailinglist") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :create)) (mailinglist (eql nil))) + (with-query-params (email name) + (with-bknr-page (:title "Create new mailinglist") (when (or (mailinglist-with-name name) (mailinglist-with-email email)) (html @@ -173,19 +167,19 @@ (:h1 "Created mailinglist " (:princ-safe (mailinglist-name list))) (cmslink (format nil "/edit-mailinglist/~A" (store-object-id list)) "[edit]"))))))

-(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) mailinglist req) - (with-bknr-page (req :title #?"Edit mailinglist $((mailinglist-name mailinglist))") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) mailinglist) + (with-bknr-page (:title #?"Edit mailinglist $((mailinglist-name mailinglist))") ((:table :border "1") (:tr (:td "Name") (:td (:princ-safe (mailinglist-name mailinglist)))) (:tr (:td "Email") (:td (:princ-safe (mailinglist-email mailinglist))))) - ((:form :action (uri-path (request-uri req)) :method "post") + ((:form :action (request-uri) :method "post") (:table (:tr (:td "Subscribe email") (:td (text-field "email")))) (submit-button "subscribe" "subscribe"))))

-(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :subscribe)) mailinglist req) - (with-query-params (req email) - (with-bknr-page (req :title #?"Subscribe user $(email)") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :subscribe)) mailinglist) + (with-query-params (email) + (with-bknr-page (:title #?"Subscribe user $(email)") (let ((user (or (user-with-email (string-downcase email)) (prog1 (make-user (md5-string (format nil "~A.~A" email (get-universal-time)))

Modified: branches/trunk-reorg/bknr/modules/mail/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,14 +4,14 @@ :cxml :cl-ppcre :cl-interpol - :net.post-office + :cl-smtp :bknr.utils :bknr.web :bknr.user :bknr.indices :bknr.datastore :bknr.impex - :net.aserve + :hunchentoot :puri :xhtml-generator) (:shadowing-import-from :cl-interpol quote-meta-chars)

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 Tue Jan 29 07:19:19 2008 @@ -6,11 +6,11 @@ () (:default-initargs :object-class 'registration-handler :query-function #'mail-handler-with-mail))

-(defmethod authorized-p ((handler register-handler) req) +(defmethod authorized-p ((handler register-handler)) t)

-(defmethod handle-object-form ((handler register-handler) action reg-handler req) - (with-bknr-page (req :title "register a user account") +(defmethod handle-object-form ((handler register-handler) action reg-handler) + (with-bknr-page (:title "register a user account") (:h2 "register a user account") ((:form :method "POST") (:table (:tr (:td "login") @@ -27,8 +27,8 @@ (submit-button "register" "register")))))))

(defmethod handle-object-form ((handler register-handler) action - (reg-handler (eql nil)) req) - (with-bknr-page (req :title "registration-handlers") + (reg-handler (eql nil))) + (with-bknr-page (:title "registration-handlers") (:ul (dolist (registration-handler (remove 'registration-handler (all-mail-handlers) @@ -44,10 +44,9 @@ ;; xxx registration-with-email and registration-with-login not defined (defmethod handle-object-form ((handler register-handler) (action (eql :register)) - reg-handler - req) - (with-query-params (req login full-name email password password2) - (with-bknr-page (req :title "Register a user account") + reg-handler) + (with-query-params (login full-name email password password2) + (with-bknr-page (:title "Register a user account") (cond ((not reg-handler) (html (:h2 "No such registration-handler"))) ((not (and login full-name email password password2)) @@ -84,17 +83,15 @@

(defmethod handle-object-form ((handler register-handler) (action (eql :unsubscribe)) - reg-handler - req) - (with-query-params (req email) - (redirect (format nil "/unsubscribe?email=~a&action=search" email) req))) + reg-handler) + (with-query-params (email) + (redirect (format nil "/unsubscribe?email=~a&action=search" email))))

(defmethod handle-object-form ((handler register-handler) (action (eql :subscribe)) - reg-handler - req) - (with-query-params (req email list) - (with-bknr-page (req :title "Create a subscription account") + reg-handler) + (with-query-params (email list) + (with-bknr-page (:title "Create a subscription account") (cond ((not reg-handler) (html (:h2 "No such registration-handler"))) ((not email) @@ -112,7 +109,7 @@ :email email :subscribe-mailinglist mailinglist)) (website-url (and mailinglist (mailinglist-website-url mailinglist)))) - (if (admin-p (bknr-request-user req)) + (if (admin-p (bknr-request-user)) (progn (confirm-registration registration) (html (:h2 "registration completed") @@ -142,17 +139,16 @@ (defclass confirm-handler (edit-object-handler) ())

-(defmethod authorized-p ((handler confirm-handler) req) +(defmethod authorized-p ((handler confirm-handler)) t)

-(defmethod object-handler-get-object ((handler confirm-handler) req) - (registration-with-hash (parse-url req))) +(defmethod object-handler-get-object ((handler confirm-handler)) + (registration-with-hash (parse-url)))

(defmethod handle-object-form ((handler confirm-handler) (action (eql :confirm)) - registration - req) - (with-bknr-page (req :title "Subscription confirmed") + registration) + (with-bknr-page (:title "Subscription confirmed") (if registration (handler-case (let ((mailinglist (registration-subscribe-mailinglist registration))) @@ -171,9 +167,8 @@

(defmethod handle-object-form ((handler confirm-handler) action - registration - req) - (with-bknr-page (req :title "Subscription confirmation") + registration) + (with-bknr-page (:title "Subscription confirmation") (html ((:form :method "POST") (:p "Please click the button to confirm your registration") (submit-button "confirm" "confirm")))))

Modified: branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp Tue Jan 29 07:19:19 2008 @@ -86,7 +86,8 @@

(defun handle-smtp-client (client-socket) (handle-session (make-instance 'smtp-client :socket client-socket))) - + +#+cmu (defun smtp-server (&key (port 2525)) (let ((server-socket (socket:make-socket :connect :passive :local-port port :reuse-address t))) (unwind-protect

Modified: branches/trunk-reorg/bknr/modules/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/packages.lisp (original) +++ branches/trunk-reorg/bknr/modules/packages.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@ :cxml :cl-ppcre :cl-interpol - :net.aserve + :hunchentoot :puri :bknr.rss :bknr.utils @@ -16,8 +16,6 @@ :bknr.impex :bknr.events :xhtml-generator - :js) + :parenscript) (:shadowing-import-from :cl-interpol quote-meta-chars) - (:shadowing-import-from :js while in create) - (:shadowing-import-from :xhtml-generator html) - (:import-from :net.html.generator *html-stream*)) + (:shadowing-import-from :parenscript while in create))

Modified: branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -5,18 +5,17 @@ (defclass edit-quizz-handler (edit-object-handler quizz-handler) ((require-user-flag :initform :quizz)))

-(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) (quizz (eql nil)) - req) - (with-bknr-page (req :title #?"edit quizz") +(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) (quizz (eql nil))) + (with-bknr-page (:title #?"edit quizz") (:ul (dolist (quizz (all-quizz)) (html (:li (html-edit-link quizz))))) (:h2 "new quizz:") (quizz-form)))

-(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) quizz req) - (with-query-params (req add-question add-mc-question) +(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) quizz) + (with-query-params (add-question add-mc-question) (let ((name (quizz-name quizz))) - (with-bknr-page (req :title #?"edit quizz: ${name}") + (with-bknr-page (:title #?"edit quizz: ${name}") (cond (add-question (html (html-edit-link quizz) @@ -40,73 +39,73 @@ "add a multiple choice question")))))))))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :create)) quizz req) - (with-query-params (req name description) + (action (eql :create)) quizz) + (with-query-params (name description) (if (and name description) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (quizz (make-object 'quizz :name name :description description :keywords keywords))) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req)))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz"))))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :save)) quizz req) + (action (eql :save)) quizz) (if quizz - (with-query-params (req description) + (with-query-params (description) (change-slot-values quizz 'description description) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz")))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-keywords)) quizz req) + (action (eql :add-keywords)) quizz) (if quizz - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-add-keywords quizz 'keywords keywords) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz")))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :remove-keywords)) quizz req) + (action (eql :remove-keywords)) quizz) (if quizz - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-remove-keywords quizz 'keywords keywords) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz")))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :delete)) quizz req) + (action (eql :delete)) quizz) (when quizz ;;; delete questions explicitely for now (dolist (question (quizz-questions quizz)) (delete-object question)) (delete-object quizz)) - (redirect "/edit-quizz" req)) + (redirect "/edit-quizz"))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-question)) quizz req) + (action (eql :add-question)) quizz) (if quizz - (with-query-params (req name question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer")))) + (with-query-params (name question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer")))) (if (and name question answers) (let ((question (make-object 'question :name name :question question :answers answers :quizz quizz))) - (redirect (edit-object-url (question-quizz question)) req)) - (redirect (edit-object-url quizz) req)))) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url (question-quizz question)))) + (redirect (edit-object-url quizz))))) + (redirect "/edit-quizz")))

(defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-mc-question)) quizz req) + (action (eql :add-mc-question)) quizz) (if quizz - (with-query-params (req name question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer"))) + (with-query-params (name question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer"))) (possible-answers (mapcar #'list (keywords-from-query-param-list - (query-param-list req "possible-keyword")) - (query-param-list req "possible-answer")))) + (query-param-list "possible-keyword")) + (query-param-list "possible-answer")))) (if (and name question answers possible-answers) (let ((question (make-object 'multiple-choice-question :name name @@ -114,22 +113,21 @@ :answers answers :possible-answers possible-answers :quizz quizz))) - (redirect (edit-object-url (question-quizz question)) req)) - (redirect (edit-object-url quizz) req)))) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url (question-quizz question)))) + (redirect (edit-object-url quizz))))) + (redirect "/edit-quizz")))

(defclass edit-question-handler (edit-object-handler question-handler) ((require-user-flag :initform :quizz)))

(defmethod handle-object-form ((handler edit-question-handler) (action (eql nil)) - (question (eql nil)) - req) - (redirect "/edit-quizz" req)) + (question (eql nil))) + (redirect "/edit-quizz"))

(defmethod handle-object-form ((handler edit-question-handler) (action (eql nil)) - question req) + question) (let ((name (question-name question))) - (with-bknr-page (req :title #?"edit question: ${name}") + (with-bknr-page (:title #?"edit question: ${name}") (typecase question (multiple-choice-question (multiple-choice-question-form :question-id (store-object-id question))) @@ -138,21 +136,21 @@ (t (error "No such question type"))))))

(defmethod handle-object-form ((handler edit-question-handler) (action (eql :delete)) - question req) + question) (let ((quizz (question-quizz question))) (when question (delete-object question)) - (redirect (edit-object-url quizz) req))) + (redirect (edit-object-url quizz))))

(defmethod handle-object-form ((handler edit-question-handler) (format-name (eql :save)) - question-obj req) + question-obj) (if question-obj - (with-query-params (req question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer"))) + (with-query-params (question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer"))) (possible-answers (mapcar #'list (keywords-from-query-param-list - (query-param-list req "possible-keyword")) - (query-param-list req "possible-answer")))) + (query-param-list "possible-keyword")) + (query-param-list "possible-answer")))) (typecase question-obj (multiple-choice-question (change-slot-values question-obj 'question question @@ -162,5 +160,5 @@ (change-slot-values question-obj 'question question 'answers answers)) (t (error "Unknown question type")))) - (redirect (edit-object-url question-obj) req)) - (redirect "/edit-quizz" req))) \ No newline at end of file + (redirect (edit-object-url question-obj))) + (redirect "/edit-quizz"))) \ No newline at end of file

Modified: branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -27,56 +27,56 @@ (defclass quizz-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler quizz-handler) req) - (find-store-object (parse-url req) :class 'quizz :query-function #'quizz-with-name)) +(defmethod object-handler-get-object ((handler quizz-handler)) + (find-store-object (parse-url) :class 'quizz :query-function #'quizz-with-name))

-(defmethod handle-object ((handler quizz-handler) (quizz (eql nil)) req) - (with-bknr-page (req :title #?"bknr quizz: all quizz") +(defmethod handle-object ((handler quizz-handler) (quizz (eql nil))) + (with-bknr-page (:title #?"bknr quizz: all quizz") (quizz-list (all-quizz))))

-(defmethod handle-object ((handler quizz-handler) quizz req) +(defmethod handle-object ((handler quizz-handler) quizz) (let ((quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"bknr quizz: ${quizz-name}") + (with-bknr-page (:title #?"bknr quizz: ${quizz-name}") (quizz :quizz-id (store-object-id quizz)))))

(defclass quizz-keyword-handler (keyword-handler) ())

(defmethod handle-object ((handler quizz-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "all-quizz-keywords") + (keyword (eql nil))) + (with-bknr-page (:title "all-quizz-keywords") (:ul (dolist (keyword (all-quizz-keywords)) (html (:ul (quizz-keyword-link keyword)))))))

-(defmethod handle-object ((handler quizz-keyword-handler) keyword req) - (with-bknr-page (req :title "quizz keyword: ${keyword}") +(defmethod handle-object ((handler quizz-keyword-handler) keyword) + (with-bknr-page (:title "quizz keyword: ${keyword}") (quizz-list (get-keyword-quizz keyword))))

(defclass question-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler question-handler) req) - (find-store-object (parse-url req) :class 'question :query-function #'question-with-name)) +(defmethod object-handler-get-object ((handler question-handler)) + (find-store-object (parse-url) :class 'question :query-function #'question-with-name))

(defclass quizz-take-handler (edit-object-handler quizz-handler) ())

-(defmethod authorized-p ((handler quizz-take-handler) req) +(defmethod authorized-p ((handler quizz-take-handler)) t)

(defmethod handle-object-form ((handler quizz-take-handler) (action (eql nil)) - (quizz (eql nil)) req) - (with-bknr-page (req :title #?"all quizz") + (quizz (eql nil))) + (with-bknr-page (:title #?"all quizz") (:ul (dolist (quizz (all-quizz)) (html (:li ((:a :href (format nil "/quizz-take/~A" (store-object-id quizz))) (:princ-safe (quizz-name quizz)))))))))

(defmethod handle-object-form ((handler quizz-take-handler) (action (eql nil)) - quizz req) + quizz) (let ((quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"take the quizz: ${quizz-name}") + (with-bknr-page (:title #?"take the quizz: ${quizz-name}") ((:form :method "POST") (mapc #'(lambda (question) (question :question-id (store-object-id question))) @@ -85,17 +85,17 @@

(defmethod handle-object-form ((handler quizz-take-handler) (action (eql :results)) - quizz req) + quizz) (if quizz - (let* ((ids (query-param-list req "question-id")) - (answers (query-param-list req "answer")) + (let* ((ids (query-param-list "question-id")) + (answers (query-param-list "answer")) (questions (mapcar #'(lambda (id) (find-store-object id :class 'question)) ids)) (score 0) correct-answers wrong-answers (quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"results for: ${quizz-name}") + (with-bknr-page (:title #?"results for: ${quizz-name}") (loop for question in questions for answer in answers when (answer-correct-p question answer) @@ -114,5 +114,5 @@ (:princ-safe answer) " is wrong. " (:princ-safe (format nil "~a" (question-answers question))) " would have been correct.")))))) - (redirect "/quizz-take" req))) + (redirect "/quizz-take")))

Modified: branches/trunk-reorg/bknr/modules/stats/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/package.lisp Tue Jan 29 07:19:19 2008 @@ -5,7 +5,7 @@ :cl-gd :cl-ppcre :cl-interpol - :net.aserve + :hunchentoot :puri :bknr.utils :bknr.web @@ -22,5 +22,4 @@ #:sessions-per-day-image-handler #:hits-per-day-image-handler #:hits-per-hour-image-handler) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*)) \ No newline at end of file + (:shadowing-import-from :cl-interpol #:quote-meta-chars)) \ No newline at end of file

Modified: branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp Tue Jan 29 07:19:19 2008 @@ -13,14 +13,14 @@ (cmslink (object-url event) (:princ-safe (format nil "error in "~a"" (web-server-log-event-url event))))))

-(defmethod object-handler-get-object ((handler error-event-handler) req) - (let ((id (parse-handler-url handler req))) +(defmethod object-handler-get-object ((handler error-event-handler)) + (let ((id (parse-handler-url handler))) (find-store-object id :class 'web-server-error-event)))

(defmethod handle-object ((handler error-event-handler) - (object (eql nil)) req) + (object (eql nil))) (let ((events (all-web-server-error-events))) - (with-bknr-page (req :title "error events") + (with-bknr-page (:title "error events") (:h1 "Error events") (:ul (dolist (event events) @@ -33,15 +33,15 @@ errorstr))))))))))

(defmethod handle-object ((handler error-event-handler) - (event web-server-error-event) req) + (event web-server-error-event)) (let ((url (web-server-log-event-url event))) - (with-bknr-page (req :title #?"Error in ${url}") + (with-bknr-page (:title #?"Error in ${url}") (:h1 #?"Error in ${url}") (with-slots (time error referer url user host backtrace) event (html (:table (:tr (:td "Date") (:td (:princ-safe (format-date-time time)))) (:tr (:td "URL") (:td (cmslink - (render-uri (merge-uris url (request-uri req)) nil) + (render-uri (merge-uris url (request-uri)) nil) (:princ-safe url)))) (:tr ((:td :colspan "2") (:princ-safe error))) (:tr ((:td :colspan "2") (:pre (:princ-safe backtrace)))))))))) @@ -49,8 +49,8 @@ (defclass stats-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler stats-handler) req) - (let* ((date (parse-handler-url handler req)) +(defmethod object-handler-get-object ((handler stats-handler)) + (let* ((date (parse-handler-url handler)) (date-components (mapcar #'(lambda (str) (parse-integer str :junk-allowed t)) (when date (split "-" date))))) (case (length date-components) @@ -63,24 +63,23 @@ (apply #'get-daily-stats date-components))) (t nil))))

-(defmethod handle-object ((handler stats-handler) (object (eql nil)) req) +(defmethod handle-object ((handler stats-handler) (object (eql nil))) (redirect (format nil "/stats/~A" (multiple-value-bind (seconds minute hour date month year) (decode-universal-time (get-universal-time)) (declare (ignore seconds minute hour date month)) - year)) - req)) + year))))

-(defmethod handle-object ((handler stats-handler) stats req) +(defmethod handle-object ((handler stats-handler) stats) (let ((type (first stats)) (date (second stats)) (web-stats (third stats))) (case type - (:year (show-year-stats (first date) web-stats req)) - (:month (show-month-stats (first date) (second date) web-stats req)) - (:day (show-day-stats (first date) (second date) (third date) web-stats req)) + (:year (show-year-stats (first date) web-stats)) + (:month (show-month-stats (first date) (second date) web-stats)) + (:day (show-day-stats (first date) (second date) (third date) web-stats)) ;; else redirect to year stats - (t (handle-object handler nil req))))) + (t (handle-object handler nil)))))

(defun stats-to-html (stats) (html (:table (:tr (:td "Total hits") @@ -110,8 +109,8 @@ (html (cmslink foo (:princ-safe foo))) (html (:princ-safe foo))))))))))))

-(defun show-year-stats (year stats req) - (with-bknr-page (req :title #?"Statistics for year ${year}") +(defun show-year-stats (year stats) + (with-bknr-page (:title #?"Statistics for year ${year}") (:h2 #?"Statistics for year ${year}:") (stats-to-html stats) (:h3 "Sessions per month:") @@ -144,8 +143,8 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User")))

-(defun show-month-stats (month year stats req) - (with-bknr-page (req :title #?"Statistics for month ${month} / ${year}") +(defun show-month-stats (month year stats) + (with-bknr-page (:title #?"Statistics for month ${month} / ${year}") (:h2 #?"Statistics for month ${month} / ${year}:") (stats-to-html stats) (:h3 "Sessions per day:") @@ -165,8 +164,8 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User")))

-(defun show-day-stats (date month year stats req) - (with-bknr-page (req :title #?"Statistics for ${date} / ${month} / ${year}") +(defun show-day-stats (date month year stats) + (with-bknr-page (:title #?"Statistics for ${date} / ${month} / ${year}") (:h2 #?"Statistics for ${date} / ${month} / ${year}:") (stats-to-html stats) (:h3 "Hits per hour:") @@ -182,7 +181,7 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User")))

-(defun log-graph (req entries &key title (color '(0 0 255)) (column-width 50)) +(defun log-graph (entries &key title (color '(0 0 255)) (column-width 50)) (let* ((length (length entries)) (image-width (+ 20 (* length column-width))) (image-height 220) @@ -211,13 +210,13 @@ (when (> num 0) (draw-string (+ 12 (* i column-width)) (- y1 15) (format nil "~A" num) :font :small :color text))))) - (emit-image-to-browser req *default-image* :gif :date (get-universal-time))))) + (emit-image-to-browser *default-image* :gif :date (get-universal-time)))))

(defclass sessions-per-month-image-handler (stats-handler) ())

-(defun make-month-log-graph (stats function req &key title) - (log-graph req (mapcar #'cons '("Jan" "Feb" "Mar" "Apr" "May" "Jun" +(defun make-month-log-graph (stats function &key title) + (log-graph (mapcar #'cons '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (mapcar #'(lambda (s) (if s (funcall function s) 0)) @@ -225,67 +224,67 @@ :title title :column-width 30))

-(defun make-day-log-graph (stats function req &key title) +(defun make-day-log-graph (stats function &key title) (let ((entries (loop for s in stats for i from 1 collect (cons (format nil "~A" i) (if s (funcall function s) 0))))) - (log-graph req entries :title title :column-width 20))) + (log-graph entries :title title :column-width 20)))

-(defmethod handle-object ((handler sessions-per-month-image-handler) stats req) +(defmethod handle-object ((handler sessions-per-month-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :year) (return-from handle-object)) (let ((month-stats (nth-value 1 (apply #'make-yearly-stats date)))) - (make-month-log-graph month-stats #'log-stats-sessions req + (make-month-log-graph month-stats #'log-stats-sessions :title "Sessions per month"))))

(defclass hits-per-month-image-handler (stats-handler) ())

-(defmethod handle-object ((handler hits-per-month-image-handler) stats req) +(defmethod handle-object ((handler hits-per-month-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :year) (return-from handle-object)) (let ((month-stats (nth-value 1 (apply #'make-yearly-stats date)))) - (make-month-log-graph month-stats #'log-stats-hits req + (make-month-log-graph month-stats #'log-stats-hits :title "Hits per month"))))

(defclass sessions-per-day-image-handler (stats-handler) ())

-(defmethod handle-object ((handler sessions-per-day-image-handler) stats req) +(defmethod handle-object ((handler sessions-per-day-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :month) (return-from handle-object)) (let ((day-stats (nth-value 1 (apply #'make-monthly-stats date)))) - (make-day-log-graph day-stats #'log-stats-sessions req :title "Sessions per day")))) + (make-day-log-graph day-stats #'log-stats-sessions :title "Sessions per day"))))

(defclass hits-per-day-image-handler (stats-handler) ())

-(defmethod handle-object ((handler hits-per-day-image-handler) stats req) +(defmethod handle-object ((handler hits-per-day-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :month) (return-from handle-object)) (let ((day-stats (nth-value 1 (apply #'make-monthly-stats date)))) - (make-day-log-graph day-stats #'log-stats-hits req :title "Hits per day")))) + (make-day-log-graph day-stats #'log-stats-hits :title "Hits per day"))))

(defclass hits-per-hour-image-handler (stats-handler) ())

-(defmethod handle-object ((handler hits-per-hour-image-handler) stats req) +(defmethod handle-object ((handler hits-per-hour-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore type date)) (let ((entries (loop with hits-per-hour = (log-stats-hits-per-hour web-stats) for hour from 0 to 23 collect (cons (format nil "~a" hour) (or (cdr (assoc hour hits-per-hour)) 0))))) - (log-graph req entries + (log-graph entries :title "Hits per hour" :column-width 30))))

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 Tue Jan 29 07:19:19 2008 @@ -9,43 +9,41 @@ (defclass tamagotchi-handler (edit-object-handler) ())

-(defmethod authorized-p ((handler tamagotchi-handler) req) - (if (string-equal (request-method req) "GET") +(defmethod authorized-p ((handler tamagotchi-handler)) + (if (string-equal (request-method) "GET") t - (let ((tamagotchi (object-handler-get-object handler req))) + (let ((tamagotchi (object-handler-get-object handler))) (cond ((null tamagotchi) t) ((null (tamagotchi-owner tamagotchi)) t) - ((equal (bknr-request-user req) (tamagotchi-owner tamagotchi)) t) + ((equal (bknr-request-user) (tamagotchi-owner tamagotchi)) t) (t nil)))))

-(defmethod object-handler-get-object ((handler tamagotchi-handler) req) - (find-store-object (parse-url req) :class 'tamagotchi :query-function #'tamagotchi-with-name)) +(defmethod object-handler-get-object ((handler tamagotchi-handler)) + (find-store-object (parse-url) :class 'tamagotchi :query-function #'tamagotchi-with-name))

(defmethod handle-object-form ((handler tamagotchi-handler) - action (tamagotchi (eql nil)) - req) - (with-bknr-page (req :title "all tamagotchis") + action (tamagotchi (eql nil))) + (with-bknr-page (:title "all tamagotchis") (:ul (dolist (tamagotchi (all-tamagotchis)) (html (:li ((:a :href (format nil "/tamagotchi/~A" (tamagotchi-name tamagotchi))) (:princ-safe (tamagotchi-name tamagotchi)))))))))

(defmethod handle-object-form ((handler tamagotchi-handler) - action tamagotchi - req) + action tamagotchi) (let ((name (tamagotchi-name tamagotchi))) - (with-bknr-page (req :title #?"tamagotchi: ${name}") + (with-bknr-page (:title #?"tamagotchi: ${name}") (tamagotchi :id (store-object-id tamagotchi)))))

(defmacro deftamagotchi-action (action transaction) `(defmethod handle-object-form ((handler tamagotchi-handler) (action (eql ,action)) - tamagotchi req) + tamagotchi) (when (and tamagotchi) ; (>= (- (get-universal-time) ; (tamagotchi-last-action-time tamagotchi)) 10)) (,transaction tamagotchi :time (get-universal-time))) - (redirect (object-url tamagotchi) req))) + (redirect (object-url tamagotchi))))

(deftamagotchi-action :feed tamagotchi-feed) (deftamagotchi-action :play tamagotchi-play)

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 Tue Jan 29 07:19:19 2008 @@ -19,32 +19,32 @@

;;; handlers -(defun article-page (req) - (with-bknr-page (req :title "article") - (article :id (parse-url req)))) +(defun article-page () + (with-bknr-page (:title "article") + (article :id (parse-url))))

(defclass edit-article-handler (edit-object-handler) ())

-(defmethod object-handler-get-object ((handler edit-article-handler) req) - (find-store-object (parse-url req) :class 'article)) +(defmethod object-handler-get-object ((handler edit-article-handler)) + (find-store-object (parse-url) :class 'article))

(defmethod handle-object-form ((handler edit-article-handler) - action article req) - (with-bknr-page (req :title "edit article") + action article) + (with-bknr-page (:title "edit article") (article-form :id (when article (store-object-id article)))))

(defmethod handle-object-form ((handler edit-article-handler) - (action (eql :save)) article req) - (with-query-params (req subject text) + (action (eql :save)) article) + (with-query-params (subject text) (if article (progn (change-slot-values article 'subject subject 'text text) (index-article article)) (setf article (make-object 'article - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :text text))) - (redirect (edit-object-url article) req))) + (redirect (edit-object-url article))))

;;; snippets (defmethod edit-object-url ((snippet snippet)) @@ -53,12 +53,12 @@ (defclass edit-snippet-handler (edit-object-handler) ())

-(defmethod object-handler-get-object ((handler edit-snippet-handler) req) - (find-store-object (parse-url req) :class 'snippet)) +(defmethod object-handler-get-object ((handler edit-snippet-handler)) + (find-store-object (parse-url) :class 'snippet))

(defmethod handle-object-form ((handler edit-snippet-handler) - action snippet req) - (with-bknr-page (req :title "edit snippet") + action snippet) + (with-bknr-page (:title "edit snippet") (snippet-form :id (when snippet (store-object-id snippet))) (unless snippet (html (:h2 "snippets: ") @@ -66,45 +66,45 @@ (html (:li (html-edit-link snippet)))))))))

(defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :delete)) snippet req) + (action (eql :delete)) snippet) (when snippet (delete-object snippet)) - (redirect "/edit-snippet" req)) + (redirect "/edit-snippet"))

(defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :remove-keywords)) snippet req) + (action (eql :remove-keywords)) snippet) (if snippet - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-remove-keywords snippet 'keywords keywords) - (redirect (edit-object-url snippet) req)) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet))) + (redirect "/edit-snippet")))

(defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :add-keywords)) snippet req) + (action (eql :add-keywords)) snippet) (if snippet - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-add-keywords snippet 'keywords keywords) - (redirect (edit-object-url snippet) req)) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet))) + (redirect "/edit-snippet")))

(defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :save)) snippet req) + (action (eql :save)) snippet) (if snippet - (with-query-params (req subject text layout) + (with-query-params (subject text layout) (unless subject (setf subject "")) - (let ((expires (parse-date-field "expiration" req))) + (let ((expires (parse-date-field "expiration"))) (change-slot-values snippet 'subject subject 'text text 'expires expires 'layout (make-keyword-from-string layout)) (index-article snippet) - (redirect (edit-object-url snippet) req))) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet)))) + (redirect "/edit-snippet")))

(defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :create)) snippet req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (expires (parse-date-field "expiration" req))) - (with-query-params (req subject text layout) - (let ((snippet (make-object 'snippet :author (bknr-request-user req) + (action (eql :create)) snippet) + (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) :subject (or subject "") :time (get-universal-time) :text text @@ -112,5 +112,5 @@ :layout (make-keyword-from-string layout) :expires expires))) (if snippet - (redirect (edit-object-url snippet) req) - (redirect "/edit-snippet" req)))))) + (redirect (edit-object-url snippet)) + (redirect "/edit-snippet"))))))

Modified: branches/trunk-reorg/bknr/modules/text/article-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-tags.lisp Tue Jan 29 07:19:19 2008 @@ -205,23 +205,23 @@ (when title (html (:h3 (:princ-safe title)))) ((:form :method "POST") - (text-field "search" :value (query-param *req* "search")) + (text-field "search" :value (query-param "search")) (submit-button "search" "Search!")))))

(define-bknr-tag blog-search-results () - (let* ((page (parse-integer (or (query-param *req* "page") "0"))) - (num-pages (ceiling (/ (length (session-variable :blog-search-results)) 10))) - (results (subseq (session-variable :blog-search-results) + (let* ((page (parse-integer (or (query-param "page") "0"))) + (num-pages (ceiling (/ (length (session-value :blog-search-results)) 10))) + (results (subseq (session-value :blog-search-results) (* page 10) (* (1+ page) 10)))) (when results - (html (:h3 "Results for "" (:princ-safe (session-variable :blog-search)) "":")) + (html (:h3 "Results for "" (:princ-safe (session-value :blog-search)) "":")) (dotimes (i num-pages) (html "&nbsp;" (if (= i page) (html (:princ-safe i)) (html ((:a :href (format nil "~A?page=~A" - (uri-path (net.aserve:request-uri *req*)) i)) + (request-uri) i)) (:princ-safe i)))) "&nbsp;")) (loop for result in results

Modified: branches/trunk-reorg/bknr/modules/text/article.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article.lisp Tue Jan 29 07:19:19 2008 @@ -61,6 +61,7 @@ (unless (article-read article user) (push user (article-read-by article))))

+#+(or) (defmethod article-to-rss-item ((article article) &key (url (parse-uri ""))) (let ((item-url (render-uri (puri:merge-uris (parse-uri (format nil "/article/~A" (store-object-id article))) url) nil)))

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 Tue Jan 29 07:19:19 2008 @@ -18,11 +18,11 @@ (html ((:p :class "articleText") (:princ (article-html-text article)))))

-(defun list-billboards-page (req) - (let ((may-edit (admin-p (bknr-request-user req)))) - (with-bknr-page (req :title "billboards") +(defun list-billboards-page () + (let ((may-edit (admin-p (bknr-request-user)))) + (with-bknr-page (:title "billboards") (html - ((:form :method "post" :action (uri-path (net.aserve:request-uri req))) + ((:form :method "post" :action (request-uri)) ((:table :width "640") (:tr (:th "name") (:th "new" :br "msgs") @@ -50,22 +50,22 @@ "&nbsp;edit&nbsp;")))))))))))))

;; xxx using old store api -(defun billboard-page (req) - (let ((billboard (parse-url req))) - (with-query-params (req new show-all delete) - (let ((may-edit (admin-p (bknr-request-user req)))) +(defun billboard-page () + (let ((billboard (parse-url))) + (with-query-params (new show-all delete) + (let ((may-edit (admin-p (bknr-request-user)))) (setf billboard (find-billboard (or billboard *default-billboard*))) (if delete (let ((article (store-object-with-id delete))) (billboard-delete-article article billboard) - (with-bknr-page (req :title "article deleted") + (with-bknr-page (:title "article deleted") (html "the article has been deleted"))) (if (and new may-edit) (let ((article (make-object 'article - :author (bknr-request-user req)))) + :author (bknr-request-user)))) (billboard-add-article billboard article) - (redirect (format nil "/edit-article/~a" (store-object-id article)) req)) - (with-bknr-page (req :title #?"billboard: $((billboard-name billboard))") + (redirect (format nil "/edit-article/~a" (store-object-id article)))) + (with-bknr-page (:title #?"billboard: $((billboard-name billboard))") (when (billboard-always-show-all billboard) (setf show-all t)) ((:form :method "post") @@ -75,7 +75,7 @@ with shown for article in (billboard-articles billboard) do (when (or show-all - (not (article-read article (bknr-request-user req)))) + (not (article-read article (bknr-request-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 req)) + (when (admin-p (bknr-request-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 Tue Jan 29 07:19:19 2008 @@ -21,92 +21,92 @@ (defclass blog-handler (object-date-list-handler) ())

-(defmethod object-handler-get-object ((handler blog-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler blog-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'blog :query-function #'blog-with-name))))

-(defmethod object-list-handler-get-objects ((handler blog-handler) blog req) - (let ((date (next-day 1 :start (object-date-list-handler-date handler blog req)))) +(defmethod object-list-handler-get-objects ((handler blog-handler) blog) + (let ((date (next-day 1 :start (object-date-list-handler-date handler blog)))) (remove-if #'(lambda (article) (> (article-time article) date)) (blog-articles blog))))

-(defmethod object-date-list-handler-grouped-objects ((handler blog-handler) blog req) - (sort (group-on (object-list-handler-get-objects handler blog req) +(defmethod object-date-list-handler-grouped-objects ((handler blog-handler) blog) + (sort (group-on (object-list-handler-get-objects handler blog) :key #'(lambda (article) (get-daytime (article-time article)))) #'> :key #'car))

-(defmethod handle-object ((handler blog-handler) (blog (eql nil)) req) - (with-bknr-page (req :title "blogs") +(defmethod handle-object ((handler blog-handler) (blog (eql nil))) + (with-bknr-page (:title "blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (cmslink (format nil "/blog/~a" (blog-name blog)) (:princ-safe (blog-name blog)))))))))

-(defmethod handle-object ((handler blog-handler) blog req) - (let ((grouped-articles (object-date-list-handler-grouped-objects handler blog req)) +(defmethod handle-object ((handler blog-handler) blog) + (let ((grouped-articles (object-date-list-handler-grouped-objects handler blog)) (name (blog-name blog))) - (with-bknr-page (req :title #?"blog: ${name}") + (with-bknr-page (:title #?"blog: ${name}") (blog-page blog grouped-articles - :start-date (object-date-list-handler-date handler blog req))))) + :start-date (object-date-list-handler-date handler blog)))))

(defclass search-blog-handler (edit-object-handler blog-handler) ())

-(defmethod authorized-p ((handler search-blog-handler) req) +(defmethod authorized-p ((handler search-blog-handler)) t)

(defmethod handle-object-form ((handler search-blog-handler) action - (blog (eql nil)) req) - (with-bknr-page (req :title "search blogs") + (blog (eql nil))) + (with-bknr-page (:title "search blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (cmslink (format nil "/search-blog/~a" (blog-name blog)) (:princ-safe (blog-name blog)))))))))

(defmethod handle-object-form ((handler search-blog-handler) action - blog req) - (with-bknr-page (req :title #?"search blog $((blog-name blog))") + blog) + (with-bknr-page (:title #?"search blog $((blog-name blog))") (cmslink (format nil "/blog/~A" (blog-name blog)) "return to " (:princ-safe (blog-name blog))) (blog-search-form :title #?"search blog $((blog-name blog))") (blog-search-results)))

(defmethod handle-object-form ((handler search-blog-handler) (action (eql :search)) - blog req) - (with-query-params (req search) + blog) + (with-query-params (search) (when (and blog search) - (setf (session-variable :blog-search-results) + (setf (session-value :blog-search-results) (search-blog blog search :threshold 0.01) - (session-variable :blog-search) search))) - (handle-object-form handler nil blog req)) + (session-value :blog-search) search))) + (handle-object-form handler nil blog))

(defclass edit-blog-handler (edit-object-handler blog-handler) ())

-(defmethod authorized-p ((handler edit-blog-handler) req) - (let ((user (bknr-request-user req)) - (blog (object-handler-get-object handler req))) +(defmethod authorized-p ((handler edit-blog-handler)) + (let ((user (bknr-request-user)) + (blog (object-handler-get-object handler))) (if blog (or (admin-p user) (member user (blog-owners blog))) t)))

-(defmethod handle-object-form ((handler edit-blog-handler) action (blog (eql nil)) req) - (with-bknr-page (req :title "edit blogs") +(defmethod handle-object-form ((handler edit-blog-handler) action (blog (eql nil))) + (with-bknr-page (:title "edit blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (html-edit-link blog)))))))

-(defmethod handle-object-form ((handler edit-blog-handler) action blog req) - (with-bknr-page (req :title "new blog article") +(defmethod handle-object-form ((handler edit-blog-handler) action blog) + (with-bknr-page (:title "new blog article") (:h2 "New article") (article-form) (:h2 "Old articles") (:ul (loop for article in (sort (copy-list (blog-articles blog)) #'> :key #'article-time) do (html (:li (html-edit-link article)))))))

-(defmethod handle-object-form ((handler edit-blog-handler) (action (eql :save)) blog req) - (with-query-params (req article-id subject text keyword) +(defmethod handle-object-form ((handler edit-blog-handler) (action (eql :save)) blog) + (with-query-params (article-id subject text keyword) (if article-id (let ((article (find-store-object article-id :class 'blog-article))) (when article @@ -115,10 +115,10 @@ (index-article article))) (let ((article (make-object 'blog-article :time (get-universal-time) - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :text text :keywords (list keyword)))) (blog-add-article blog article))) - (handle-form handler t req))) + (handle-form handler t)))

Modified: branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp Tue Jan 29 07:19:19 2008 @@ -8,8 +8,8 @@ (source-types :initarg :source-types :reader htmlize-handler-source-types :initform '("lisp" "asd" "asdf" "cl")))))

-(defmethod object-handler-get-object ((handler htmlize-handler) req) - (let* ((url-path (bknr-url-path handler req)) +(defmethod object-handler-get-object ((handler htmlize-handler)) + (let* ((url-path (bknr-url-path handler)) (source-path (htmlize-handler-source-dir handler)) (path (probe-file (merge-pathnames (if (and (> (length url-path) 0) (eql (char url-path 0) #/)) @@ -26,13 +26,13 @@ :name (pathname-name filepath) :type (pathname-type filepath))))

-(defmethod handle-object ((handler object-handler) path req) +(defmethod handle-object ((handler object-handler) path) (unless path (error "no path to generic object handler given, missing specialization?")) (if (pathname-name path) - (with-bknr-page (req :title (pathname-name path)) + (with-bknr-page (:title (pathname-name path)) (htmlize-file path *html-stream*)) - (with-bknr-page (req :title #?"Source directory: $((namestring path))") + (with-bknr-page (:title #?"Source directory: $((namestring path))") (:ul (dolist (file (directory path)) (let ((file-path (relative-link-to-file handler file))) (when (or (not (pathname-name file-path))

Modified: branches/trunk-reorg/bknr/modules/text/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,6 +4,7 @@ :cxml :cl-ppcre :cl-interpol + :hunchentoot :puri :bknr.rss :bknr.utils @@ -63,5 +64,4 @@ #:version-text #:version-author #:version-date - #:version-comment) - (:import-from :net.html.generator #:*html-stream*)) \ No newline at end of file + #:version-comment)) \ No newline at end of file

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 Tue Jan 29 07:19:19 2008 @@ -13,15 +13,15 @@ (defclass paste-handler (edit-object-handler) ())

-(defmethod authorized-p ((handler paste-handler) req) +(defmethod authorized-p ((handler paste-handler)) t)

-(defmethod object-handler-get-object ((handler paste-handler) req) - (find-store-object (parse-url req) :class 'annotated-article)) +(defmethod object-handler-get-object ((handler paste-handler)) + (find-store-object (parse-url) :class 'annotated-article))

(defmethod handle-object-form ((handler paste-handler) - action (foo (eql nil)) req) - (with-bknr-page (req :title "paste") + action (foo (eql nil))) + (with-bknr-page (:title "paste") (:h2 "new paste:") (paste-form) (:h2 "old pastes:") @@ -29,43 +29,43 @@ (html (:li (html-edit-link paste)))))))

(defmethod handle-object-form ((handler paste-handler) - action paste req) + action paste) (let ((subject (article-subject paste))) - (with-bknr-page (req :title #?"paste: ${subject}") + (with-bknr-page (:title #?"paste: ${subject}") (paste paste) (:h2 "annotate:") (paste-annotate-form))))

(defmethod handle-object-form ((handler paste-handler) (action (eql :create)) - foo req) - (with-query-params (req subject text lisp) + foo) + (with-query-params (subject text lisp) (if (and subject text) (let ((paste (make-object 'paste - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :time (get-universal-time) :text text :keywords (when lisp '(:lisp)) :expires (get-universal-time)))) (if paste - (redirect (edit-object-url paste) req) - (redirect "/paste" req))) - (redirect "/paste" req)))) + (redirect (edit-object-url paste)) + (redirect "/paste"))) + (redirect "/paste"))))

(defmethod handle-object-form ((handler paste-handler) (action (eql :annotate)) - paste req) + paste) (if paste - (with-query-params (req text lisp) + (with-query-params (text lisp) (let ((annotation (make-object 'keywords-article - :author (bknr-request-user req) + :author (bknr-request-user) :subject "" :time (get-universal-time) :text text :keywords (when lisp '(:lisp))))) (if annotation (annotate-article paste annotation)) - (redirect (edit-object-url paste) req))) - (redirect "/paste" req))) + (redirect (edit-object-url paste)))) + (redirect "/paste"))) \ No newline at end of file

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 Tue Jan 29 07:19:19 2008 @@ -15,53 +15,53 @@ () (:default-initargs :object-class 'wiki-article :query-function #'wiki-article-with-keyword))

-(defmethod handle-object ((handler wiki-handler) (article (eql nil)) req) - (let ((keyword (parse-url req))) +(defmethod handle-object ((handler wiki-handler) (article (eql nil))) + (let ((keyword (parse-url))) (if (null keyword) - (with-bknr-page (req :title "all wiki keywords") + (with-bknr-page (:title "all wiki keywords") (:ul (dolist (keyword (sort (wiki-keywords) #'string<)) (html (:li ((:a :href (wiki-keyword-url keyword)) (:princ-safe keyword))))))) (redirect (concatenate 'string "/edit-wiki" "/" - (parse-url req)) req)))) + (parse-url))))))

-(defmethod handle-object ((handler wiki-handler) article req) +(defmethod handle-object ((handler wiki-handler) article) (let ((keyword (wiki-article-keyword article))) - (with-bknr-page (req :title #?"wiki article: ${keyword}") + (with-bknr-page (:title #?"wiki article: ${keyword}") (wiki-article :id (store-object-id article)))))

(defclass edit-wiki-handler (edit-object-handler wiki-handler) ())

-(defmethod authorized-p ((handler edit-wiki-handler) req) - (not (anonymous-p (bknr-request-user req)))) +(defmethod authorized-p ((handler edit-wiki-handler)) + (not (anonymous-p (bknr-request-user))))

(defmethod handle-object-form ((handler edit-wiki-handler) - action (article (eql nil)) req) - (with-bknr-page (req :title "edit new wiki article") - (wiki-article-form :keyword (parse-url req)))) + action (article (eql nil))) + (with-bknr-page (:title "edit new wiki article") + (wiki-article-form :keyword (parse-url))))

(defmethod handle-object-form ((handler edit-wiki-handler) - action article req) + action article) (let ((keyword (wiki-article-keyword article))) - (with-bknr-page (req :title #?"edit wiki article blorg: ${keyword}") + (with-bknr-page (:title #?"edit wiki article blorg: ${keyword}") (:p (html-edit-link article)) (wiki-article-form :id (store-object-id article))))) (defmethod handle-object-form ((handler edit-wiki-handler) - (action (eql :save)) article req) - (with-query-params (req text comment) + (action (eql :save)) article) + (with-query-params (text comment) (let ((version (make-version (html-quote text) :comment (html-quote comment) - :author (bknr-request-user req) + :author (bknr-request-user) :date (get-universal-time)))) (if article (article-add-version article version) (setf article (make-object 'wiki-article - :subject (parse-url req) - :keyword (parse-url req) + :subject (parse-url) + :keyword (parse-url) :versions (list version)))) - (redirect (object-url article) req)))) + (redirect (object-url article)))))

(define-bknr-webserver-module wiki ("/wiki" wiki-handler)

Modified: branches/trunk-reorg/bknr/modules/track/import-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/import-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/import-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,15 +5,15 @@ (defclass mp3-import-handler (import-handler) ())

-(defmethod import-handler-spool-files ((handler mp3-import-handler) req) - (directory (merge-pathnames "**/*.mp3" (import-handler-import-pathname handler req)))) +(defmethod import-handler-spool-files ((handler mp3-import-handler)) + (directory (merge-pathnames "**/*.mp3" (import-handler-import-pathname handler))))

-(defmethod authorized-p ((handler mp3-import-handler) req) +(defmethod authorized-p ((handler mp3-import-handler)) (or (admin-p *user*) (user-has-flag *user* :music)))

-(defmethod handle-form ((handler mp3-import-handler) action req) - (with-bknr-page (req :title #?"mp3 import directory") +(defmethod handle-form ((handler mp3-import-handler) action) + (with-bknr-page (:title #?"mp3 import directory") ((:form :method "post") ((:div :class "keyword-choose" :align "center") (:h2 "Choose tags for the imported mp3s (nothing will read them from the ID3 tags):") @@ -33,32 +33,32 @@ (:div (submit-button "import" "Import")))) ((:div :class "import-list") (:h2 "Mp3s present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br))))))

-(defmethod import-handler-import-files ((handler mp3-import-handler) req) - (let ((genre (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req artist album tagsfromdir) +(defmethod import-handler-import-files ((handler mp3-import-handler)) + (let ((genre (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (artist album tagsfromdir) (let ((tags-from-dir (case tagsfromdir (:genre-artist-album '(:genre :artist :album)) (:artist-album '(:artist :album)) (:artist '(:artist)) (t nil))) - (spool-dir (import-handler-import-pathname handler req))) + (spool-dir (import-handler-import-pathname handler))) (import-mp3-directory :spool spool-dir :genre genre :album album :artist artist :tags-from-dir tags-from-dir)))))

-(defmethod handle-form ((handler mp3-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler mp3-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-tracks (remove-if-not #'(lambda (element) (typep element 'track)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"bknr import log") + (with-bknr-page (:title #?"bknr import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error

Modified: branches/trunk-reorg/bknr/modules/track/track-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/track-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/track-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -21,11 +21,11 @@ (defclass track-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler track-handler) req) - (find-store-object (parse-url req) :class 'track)) +(defmethod object-handler-get-object ((handler track-handler)) + (find-store-object (parse-url) :class 'track))

-(defmethod handle-object ((handler track-handler) (track (eql nil)) req) - (with-bknr-page (req :title #?"bknr tracks") +(defmethod handle-object ((handler track-handler) (track (eql nil))) + (with-bknr-page (:title #?"bknr tracks") (:h2 "Artists: ") (:ul (dolist (artist (all-track-artists)) (html (:li (artist-html-link artist))))) @@ -33,84 +33,84 @@ (:ul (dolist (genre (all-track-genres)) (html (:li (genre-html-link genre)))))))

-(defmethod handle-object ((handler track-handler) track req) +(defmethod handle-object ((handler track-handler) track) (let ((name (track-name track))) - (with-bknr-page (req :title #?"track: ${name}") + (with-bknr-page (:title #?"track: ${name}") (track :id (store-object-id track)))))

(defclass edit-track-handler (edit-object-handler track-handler) ())

-(defmethod authorized-p ((handler edit-track-handler) req) +(defmethod authorized-p ((handler edit-track-handler)) (or (admin-p *user*) (user-has-flag *user* :music)))

(defmethod handle-object-form ((handler edit-track-handler) action - (track (eql nil)) req) - (redirect "/edit-tracks" req)) + (track (eql nil))) + (redirect "/edit-tracks"))

(defmethod handle-object-form ((handler edit-track-handler) action - track req) + track) (let ((name (track-name track))) - (with-bknr-page (req :title #?"edit track: ${name}") + (with-bknr-page (:title #?"edit track: ${name}") (track-form :id (store-object-id track)))))

(defmethod handle-object-form ((handler edit-track-handler) (action (eql :save)) - track req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req name artist album) + track) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (name artist album) (when artist (track-set-artist track artist)) (when album (track-set-album track album)) (when name (change-slot-values track 'name name)) (when genres (track-set-genres track genres)) - (redirect (edit-object-url track) req)))) + (redirect (edit-object-url track)))))

(defmethod handle-object-form ((handler edit-track-handler) (action (eql :delete)) - track req) + track) (when track (delete-object track)) - (redirect "/edit-track" req)) + (redirect "/edit-track"))

(defclass tracks-handler (object-list-handler) ())

-(defmethod handle-object ((handler tracks-handler) object req) - (let ((tracks (object-list-handler-get-objects handler object req)) - (title (object-list-handler-title handler object req))) - (with-bknr-page (req :title title) +(defmethod handle-object ((handler tracks-handler) object) + (let ((tracks (object-list-handler-get-objects handler object)) + (title (object-list-handler-title handler object))) + (with-bknr-page (:title title) (:ul (dolist (track tracks) (html (:li (html-link track))))))))

(defclass artist-tracks-handler (tracks-handler) ())

-(defmethod object-list-handler-get-objects ((handler artist-tracks-handler) object req) - (let ((name (parse-url req))) +(defmethod object-list-handler-get-objects ((handler artist-tracks-handler) object) + (let ((name (parse-url))) (get-artist-tracks name)))

-(defmethod object-list-handler-title ((handler artist-tracks-handler) object req) - (format nil "tracks of ~a" (parse-url req))) +(defmethod object-list-handler-title ((handler artist-tracks-handler) object) + (format nil "tracks of ~a" (parse-url)))

(defclass genre-tracks-handler (keyword-handler tracks-handler) ())

-(defmethod object-list-handler-get-objects ((handler genre-tracks-handler) genre req) +(defmethod object-list-handler-get-objects ((handler genre-tracks-handler) genre) (get-genre-tracks genre))

-(defmethod object-list-handler-title ((handler genre-tracks-handler) genre req) +(defmethod object-list-handler-title ((handler genre-tracks-handler) genre) (format nil "tracks of genre ~a" genre))

(defclass search-tracks-handler (edit-object-handler tracks-handler) ())

-(defmethod authorized-p ((handler search-tracks-handler) req) +(defmethod authorized-p ((handler search-tracks-handler)) t)

-(defmethod object-list-handler-get-objects ((handler search-tracks-handler) object req) - (session-variable :current-track-result)) +(defmethod object-list-handler-get-objects ((handler search-tracks-handler) object) + (session-value :current-track-result))

-(defmethod search-tracks ((handler search-tracks-handler) req) - (with-query-params (req artist album name genre operator) +(defmethod search-tracks ((handler search-tracks-handler)) + (with-query-params (artist album name genre operator) (let ((artists (when artist (find-matching-strings artist (all-track-artists)))) (genre (when genre (make-keyword-from-string genre))) (albums (when album (find-matching-strings album (all-albums)))) @@ -131,17 +131,17 @@ (push name-tracks tracks)) (when genre (push (get-genre-tracks genre) tracks)) - (setf (session-variable :current-track-result) (reduce merge-op tracks))))) + (setf (session-value :current-track-result) (reduce merge-op tracks)))))

(defmethod handle-object-form ((handler search-tracks-handler) - (action (eql :search)) object req) - (search-tracks handler req) + (action (eql :search)) object) + (search-tracks handler) (call-next-method))

(defmethod handle-object-form ((handler search-tracks-handler) - action object req) - (let ((tracks (object-list-handler-get-objects handler object req))) - (with-bknr-page (req :title "search tracks") + action object) + (let ((tracks (object-list-handler-get-objects handler object))) + (with-bknr-page (:title "search tracks") (search-track) (:ul (dolist (track tracks) (html (:li (html-link track)))))))) @@ -149,49 +149,49 @@ (defclass edit-tracks-handler (search-tracks-handler) ())

-(defmethod object-handler-get-object ((handler edit-tracks-handler) req) +(defmethod object-handler-get-object ((handler edit-tracks-handler)) (remove nil (mapcar #'(lambda (id) (find-store-object id :class 'track)) - (query-param-list req "track-id")))) + (query-param-list "track-id"))))

(defmethod handle-object-form ((handler edit-tracks-handler) action - (tracks (eql nil)) req) - (with-bknr-page (req :title "edit tracks") + (tracks (eql nil))) + (with-bknr-page (:title "edit tracks") (search-track :title "search tracks to edit") (edit-track-collection)))

(defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :search)) - tracks req) - (search-tracks handler req) + tracks) + (search-tracks handler) (call-next-method))

(defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :add-genres)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) (dolist (track tracks) (store-object-add-keywords track 'genre genres)) - (redirect "/edit-tracks" req))) + (redirect "/edit-tracks")))

(defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :remove-genres)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) (dolist (track tracks) (store-object-remove-keywords track 'genre genres)) - (redirect "/edit-tracks" req))) + (redirect "/edit-tracks")))

(defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :save-all)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req name artist album) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (name artist album) (when artist (mapc #'(lambda (track) (track-set-artist track artist)) tracks)) (when album (mapc #'(lambda (track) (track-set-album track album)) tracks)) (when name (mapc #'(lambda (track) (change-slot-values track 'name name)) tracks)) (when genres (mapc #'(lambda (track) (track-set-genres track genres)) tracks)) - (redirect "/edit-tracks" req)))) + (redirect "/edit-tracks"))))

(defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :delete-all)) - tracks req) + tracks) (mapc #'delete-object tracks) - (redirect "/edit-tracks" req)) + (redirect "/edit-tracks"))

(defclass playlist-handler (object-handler) ()) @@ -202,17 +202,17 @@ (defmethod html-link ((playlist playlist)) (html ((:a :href (edit-object-url playlist)) (:princ-safe playlist))))

-(defmethod object-handler-get-object ((handler playlist-handler) req) - (find-store-object (parse-url req) :class 'playlist)) +(defmethod object-handler-get-object ((handler playlist-handler)) + (find-store-object (parse-url) :class 'playlist))

-(defmethod handle-object ((handler playlist-handler) (playlist (eql nil)) req) - (with-bknr-page (req :title #?"bknr playlists") +(defmethod handle-object ((handler playlist-handler) (playlist (eql nil))) + (with-bknr-page (:title #?"bknr playlists") (:ul (dolist (playlist (all-playlists)) (html (:li (html-link playlist)))))))

-(defmethod handle-object ((handler playlist-handler) playlist req) +(defmethod handle-object ((handler playlist-handler) playlist) (let ((name (playlist-name playlist))) - (with-bknr-page (req :title #?"playlist: ${name}") + (with-bknr-page (:title #?"playlist: ${name}") (:ul (dolist (track (playlist-tracks playlist)) (html (:li (html-link track))))))))

Modified: branches/trunk-reorg/bknr/modules/track/track-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/track-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/track-tags.lisp Tue Jan 29 07:19:19 2008 @@ -60,7 +60,7 @@

(define-bknr-tag search-track (&key title) (declare (ignore title)) - (with-query-params (*req* name artist album genre) + (with-query-params (name artist album genre) (let ((genre (when genre (make-keyword-from-string genre)))) (html ((:form :method "POST") ((:table :class "search-panel") @@ -73,7 +73,7 @@ (submit-button "search" "search")))))))))

(define-bknr-tag edit-track-collection (&key title - (tracks (session-variable :current-track-result))) + (tracks (session-value :current-track-result))) (when tracks (html ((:div :class "edit-tracks") ((:form :method "POST")

Modified: branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -17,6 +17,7 @@ (cond ((scan "^[a-zA-Z]+://" url) url) (t (render-uri (puri:merge-uris url base-url) nil))))

+#+(or) (defun cache-local-hrefs (data uri user depth &key (follow-links nil) (force nil)) (let ((seen (make-hash-table :test #'equal))) (flet ((make-local-cache-link (target-string start end match-start match-end @@ -49,6 +50,7 @@ (setf data (regex-replace-all *a-href-scanner* data #'make-local-cache-link))) data)))

+#+(or) (defun make-cached-url-from-url (url &key parent-url user (depth 1) (force nil) (follow-links nil)) (setf url (normalize-url url)) @@ -82,15 +84,15 @@ (defclass cached-url-handler (object-handler) ((require-user-flag :initform :cache)))

-(defmethod object-handler-get-object ((handler cached-url-handler) req) - (find-store-object (parse-url req) :class 'cached-url)) +(defmethod object-handler-get-object ((handler cached-url-handler)) + (find-store-object (parse-url) :class 'cached-url))

-(defmethod handle-object ((handler cached-url-handler) (url (eql nil)) req) - (with-bknr-page (req :title "No such cached url") +(defmethod handle-object ((handler cached-url-handler) (url (eql nil))) + (with-bknr-page (:title "No such cached url") (:p "No such cached url")))

-(defmethod handle-object ((handler cached-url-handler) url req) - (with-bknr-http-response (req :content-type (cached-url-content-type url)) - (with-http-body (req *ent*) +(defmethod handle-object ((handler cached-url-handler) url) + (with-http-response (:content-type (cached-url-content-type url)) + (with-http-body () (blob-to-stream url *html-stream*) (finish-output *html-stream*)))) \ No newline at end of file

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 Tue Jan 29 07:19:19 2008 @@ -8,13 +8,14 @@ (defclass submit-url-handler (form-handler) ())

-(defmethod authorized-p ((handler form-handler) req) - (not (equal (bknr-request-user req) (find-user "anonymous")))) +(defmethod authorized-p ((handler form-handler)) + (not (equal (bknr-request-user) (find-user "anonymous"))))

-(defmethod handle-form ((handler submit-url-handler) action req) - (with-bknr-page (req :title #?"submit url") - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) - (with-query-params (req url title redirect) +#+(or) +(defmethod handle-form ((handler submit-url-handler) action) + (with-bknr-page (:title #?"submit url") + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) + (with-query-params (url title redirect) (html (:p "Drag this link to your bookmark bar: " ((:a :href (format nil "javascript:document.location.href="~a~a?title="+escape(document.title)+"&url="+escape(document.location.href)+"&redirect=1&keyword=fastsubmit"" @@ -23,10 +24,10 @@ "bknr-url"))) (submit-url-form :url url :title title :keywords keywords :redirect redirect)))))

-(defmethod handle-form ((handler submit-url-handler) (action (eql :submit)) - req) - (with-query-params (req title url description cache redirect) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) +#+(or) +(defmethod handle-form ((handler submit-url-handler) (action (eql :submit))) + (with-query-params (title url description cache redirect) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (handler-case (progn ;;; verify form parameters (ensure-form-field title) @@ -34,12 +35,12 @@ (setf url (normalize-url url)) (ensure-form-field keywords) (if (and cache - (not (user-has-flag (bknr-request-user req) :cache))) + (not (user-has-flag (bknr-request-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 req) :depth 1 + (make-cached-url-from-url url :user (bknr-request-user) :depth 1 :force nil))

(let ((url-obj (url-with-url url))) @@ -54,11 +55,11 @@ :description description :keywords keywords :date (get-universal-time) - :submitter (bknr-request-user req)))) + :submitter (bknr-request-user)))) (declare (ignore submission)) - (redirect (if redirect url "/url") req)))) + (redirect (if redirect url "/url"))))) (form-field-missing-condition (e) - (with-bknr-page (req :title #?"submit url") + (with-bknr-page (:title #?"submit url") ((:h2 :class "error") "Please fill field " (:princ-safe (form-field-missing-condition-field e)) "!") (submit-url-form :url url :title title :description description

Modified: branches/trunk-reorg/bknr/modules/url/url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/url-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,18 +9,18 @@ (defclass url-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler url-handler) req) - (find-store-object (parse-url req) :class 'url)) +(defmethod object-handler-get-object ((handler url-handler)) + (find-store-object (parse-url) :class 'url))

-(defmethod handle-object ((handler url-handler) (url (eql nil)) req) - (redirect "/url-page" req)) +(defmethod handle-object ((handler url-handler) (url (eql nil))) + (redirect "/url-page"))

-(defmethod handle-object ((handler url-handler) url req) +(defmethod handle-object ((handler url-handler) url) (let ((submissions (sort (group-on (url-submissions url) :key #'(lambda (submission) (get-daytime (url-submission-date submission)))) #'> :key #'car))) - (with-bknr-page (req :title #?"url page for $((url-url url))") + (with-bknr-page (:title #?"url page for $((url-url url))") (:p "keywords: " (mapc #'url-keyword-link (url-keywords url))) (:p (url-submissions-page submissions :full t))))) @@ -28,77 +28,76 @@ (defclass url-redirect-handler (url-handler) ())

-(defmethod handle-object ((handler url-redirect-handler) url req) +(defmethod handle-object ((handler url-redirect-handler) url) (if url - (redirect (url-url url) req) - (redirect "/url-page" req))) + (redirect (url-url url)) + (redirect "/url-page")))

(defclass url-page-handler (object-date-list-handler) ())

(defmethod object-list-handler-title ((handler url-page-handler) - object req) + object) "bknr urls")

(defmethod object-list-handler-rss-link ((handler url-page-handler) - object req) + object) "/url-rss")

-(defmethod object-list-handler-get-objects ((handler url-page-handler) object req) +(defmethod object-list-handler-get-objects ((handler url-page-handler) object) (mapcar #'url-latest-submission (all-urls)))

(defmethod object-date-list-handler-grouped-objects ((handler url-page-handler) - object req) - (let* ((date (next-day 1 :start (object-date-list-handler-date handler object req))) + object) + (let* ((date (next-day 1 :start (object-date-list-handler-date handler object))) (submissions (remove-if #'(lambda (submission) (> (url-submission-date submission) date)) - (object-list-handler-get-objects handler object req)))) + (object-list-handler-get-objects handler object)))) (sort (group-on submissions :key #'(lambda (submission) (get-daytime (url-submission-date submission)))) #'> :key #'car)))

-(defmethod handle-object ((handler url-page-handler) object req) - (let ((submissions (object-date-list-handler-grouped-objects handler object req))) - (with-bknr-page (req :title (object-list-handler-title - handler object req)) +(defmethod handle-object ((handler url-page-handler) object) + (let ((submissions (object-date-list-handler-grouped-objects handler object))) + (with-bknr-page (:title (object-list-handler-title + handler object)) (:p "random keywords: " (url-random-keywords)) - (:p ((:a :href (object-list-handler-rss-link handler object req)) "rss") + (:p ((:a :href (object-list-handler-rss-link handler object)) "rss") " " ((:a :href "/submit-url") "submit an url")) (url-submissions-page submissions - :start-date (object-date-list-handler-date handler object req))))) + :start-date (object-date-list-handler-date handler object)))))

(defclass url-submitter-handler (url-page-handler) ())

-(defmethod object-handler-get-object ((handler url-submitter-handler) - req) - (find-store-object (parse-url req) :class 'user +(defmethod object-handler-get-object ((handler url-submitter-handler)) + (find-store-object (parse-url) :class 'user :query-function #'find-user))

(defmethod object-list-handler-get-objects ((handler url-submitter-handler) - user req) + user) (copy-list (get-user-url-submissions user)))

(defmethod object-list-handler-title ((handler url-submitter-handler) - user req) + user) (format nil "bknr urls submitted by ~a" (user-full-name user)))

(defmethod object-list-handler-rss-link ((handler url-submitter-handler) - user req) + user) (format nil "/url-submitter-rss/~A" (user-login user)))

-(defmethod handle-object ((handler url-submitter-handler) user req) - (let ((submissions (object-date-list-handler-grouped-objects handler user req))) - (with-bknr-page (req :title (object-list-handler-title - handler user req)) - ((:a :href (object-list-handler-rss-link handler user req)) "rss") +(defmethod handle-object ((handler url-submitter-handler) user) + (let ((submissions (object-date-list-handler-grouped-objects handler user))) + (with-bknr-page (:title (object-list-handler-title + handler user)) + ((:a :href (object-list-handler-rss-link handler user)) "rss") (url-submissions-page submissions :start-date (object-date-list-handler-date - handler user req) + handler user) :url (format nil "/url-submitter/~A" (user-login user))))))

@@ -106,21 +105,21 @@ ())

(defmethod object-list-handler-get-objects ((handler url-keyword-handler) - keyword req) + keyword) (mapcar #'url-latest-submission (get-keyword-urls keyword)))

(defmethod handle-object ((handler url-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "all-url-keywords") + (keyword (eql nil))) + (with-bknr-page (:title "all-url-keywords") (:ul (dolist (keyword (all-url-keywords)) (html (:li (url-keyword-link keyword)))))))

(defmethod object-list-handler-title ((handler url-keyword-handler) - keyword req) + keyword) (format nil "bknr keyword urls: ~a" keyword))

(defmethod object-list-handler-rss-link ((handler url-keyword-handler) - keyword req) + keyword) (format nil "/url-keyword-rss/~A" (string-downcase (symbol-name keyword))))

@@ -129,31 +128,31 @@ ())

(defmethod object-list-handler-get-objects ((handler url-union-handler) - keywords req) + keywords) (mapcar #'url-latest-submission (get-keywords-union-urls keywords)))

(defmethod object-list-handler-title ((handler url-union-handler) - keywords req) + keywords) (format nil "bknr union keyword urls: ~a" keywords))

(defmethod object-list-handler-rss-link ((handler url-union-handler) - keyword req) + keyword) (format nil "/url-union-rss/~A" - (parse-url req))) + (parse-url)))

(defclass url-intersection-handler (url-page-handler keywords-handler) ())

(defmethod object-list-handler-get-objects ((handler url-intersection-handler) - keywords req) + keywords) (mapcar #'url-latest-submission (get-keywords-intersection-urls keywords)))

(defmethod object-list-handler-title ((handler url-intersection-handler) - keywords req) + keywords) (format nil "bknr intersection keyword urls: ~a" keywords))

(defmethod object-list-handler-rss-link ((handler url-intersection-handler) - keyword req) + keyword) (format nil "/url-intersection-rss/~A" - (parse-url req))) + (parse-url)))

Modified: branches/trunk-reorg/bknr/tools/make-core.lisp ============================================================================== --- branches/trunk-reorg/bknr/tools/make-core.lisp (original) +++ branches/trunk-reorg/bknr/tools/make-core.lisp Tue Jan 29 07:19:19 2008 @@ -7,8 +7,10 @@ (defparameter *src-directory* (make-pathname :directory (pathname-directory *load-truename*))) (defparameter *bknr-directory* (merge-pathnames #p"bknr-svn/" (user-homedir-pathname)))

-#+cmu #-cmu19b -(load (merge-pathnames "bknr/patches/patch-around-mop-cmucl19a.lisp" *bknr-directory*)) +#+cmu +(load (merge-pathnames "bknr/datastore/patches/patch-around-mop-cmucl19.lisp" *bknr-directory*)) +#+cmu +(pushnew :rune-is-integer *features*) #-asdf (error "No ASDF found in image, please provide one through the default image or home:init.lisp")

Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Tue Jan 29 07:19:19 2008 @@ -23,6 +23,7 @@ :cl-ppcre :cl-gd :kmrcl + :alexandria :md5 :cxml :unit-test @@ -33,7 +34,7 @@ :puri :bknr-datastore :bknr-data-impex - :parenscript) + :parenscript)

:components ((:file "packages") @@ -110,7 +111,6 @@ "web-utils"))) :depends-on ("sysclasses" "packages" "rss"))

- #+notyet (:module "images" :components ((:file "image") (:file "image-tags" :depends-on ("image"))

Modified: branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,54 +5,54 @@ (defclass edit-images-handler (edit-object-handler image-handler) ((require-user-flag :initform :admin)))

-(defmethod object-handler-get-object ((handler edit-images-handler) req) +(defmethod object-handler-get-object ((handler edit-images-handler)) (remove nil (mapcar #'(lambda (id) (find-store-object id :class 'store-image :query-function #'store-image-with-name)) - (query-param-list req "image-id")))) + (query-param-list "image-id"))))

-(defmethod handle-object-form ((handler edit-images-handler) action images req) - (with-bknr-page (req :title #?"edit-images") +(defmethod handle-object-form ((handler edit-images-handler) action images) + (with-bknr-page (:title #?"edit-images") (search-image-collection :title "search images") (edit-image-collection :title "edit images")))

(defmethod handle-object-form ((handler edit-images-handler) - (action (eql :delete)) images req) + (action (eql :delete)) images) (let ((names (mapcar #'store-image-name images))) (mapc #'delete-object images) - (setf (session-variable :current-query-result) - (set-difference (session-variable :current-query-result) + (setf (session-value :current-query-result) + (set-difference (session-value :current-query-result) images)) - (with-bknr-page (req :title #?"delete images") + (with-bknr-page (:title #?"delete images") (html (:h2 "Deleted images:") (dolist (name names) (html (:princ-safe name)(:br)))))))

(defmethod handle-object-form ((handler edit-images-handler) (action (eql :add-keywords)) - images req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + images) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (dolist (image images) (store-object-add-keywords image 'keywords keywords)) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection images :title (format nil "Added keywords ~a to images:" keywords)))))

(defmethod handle-object-form ((handler edit-images-handler) (action (eql :remove-keywords)) - images req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + images) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (dolist (image images) (store-object-remove-keywords image 'keywords keywords)) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection images :title (format nil "Removed keywords ~a from images:" keywords)))))

(defmethod handle-object-form ((handler edit-images-handler) (action (eql :assign-individual-keywords)) - images req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword-img") + images) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword-img") :remove-empty nil)) (assigned-images (loop for keys on keywords by #'cddr for keyword = (if (eq (car keys) :||) @@ -63,29 +63,29 @@ image) do (store-object-add-keywords image 'keywords (list keyword)) and collect image))) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection assigned-images :title "Add keywords to images:"))))

(defmethod handle-object-form ((handler edit-images-handler) (action (eql :search)) - images req) - (let* ((keywords (remove :|| (keywords-from-query-param-list (query-param-list req "keyword")))) - (operator (query-param req "operator")) - (name (query-param req "name"))) - (with-bknr-page (req :title #?"edit-images") + images) + (let* ((keywords (remove :|| (keywords-from-query-param-list (query-param-list "keyword")))) + (operator (query-param "operator")) + (name (query-param "name"))) + (with-bknr-page (:title #?"edit-images") (search-image-collection :title "search images") - (setf (session-variable :current-query-result) + (setf (session-value :current-query-result) (if keywords (ecase (make-keyword-from-string operator) (:or (get-keywords-union-store-images keywords)) (:and (get-keywords-intersection-store-images keywords))) (all-store-images))) (when name - (setf (session-variable :current-query-result) + (setf (session-value :current-query-result) (remove-if-not #'(lambda (img) (scan name (store-image-name img))) - (session-variable :current-query-result)))) + (session-value :current-query-result)))) (edit-image-collection))))

(defclass edit-image-handler (edit-object-handler image-handler) @@ -106,24 +106,24 @@ (:div (submit-button "edit" "Edit keywords")))))))

-(defmethod handle-object-form ((handler edit-image-handler) action image req) +(defmethod handle-object-form ((handler edit-image-handler) action image) (let ((image-name (store-image-name image))) - (with-bknr-page (req :title #?"bknr image ${image-name}") + (with-bknr-page (:title #?"bknr image ${image-name}") (show-image-editor image))))

(defmethod handle-object-form ((handler edit-image-handler) - (action (eql :delete)) image req) + (action (eql :delete)) image) (let ((name (store-image-name image))) (delete-object image) - (with-bknr-page (req :title #?"delete images") + (with-bknr-page (:title #?"delete images") (html (:h2 "Deleted image " (:princ-safe name))))))

(defmethod handle-object-form ((handler edit-image-handler) - (action (eql :edit)) image req) + (action (eql :edit)) image) (let ((name (store-image-name image)) - (add-keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (remove-keywords (keywords-from-query-param-list (query-param-list req "remove-keyword")))) - (with-bknr-page (req :title #?"edit image $(name)") + (add-keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (remove-keywords (keywords-from-query-param-list (query-param-list "remove-keyword")))) + (with-bknr-page (:title #?"edit image $(name)") (when remove-keywords (store-object-remove-keywords image 'keywords remove-keywords) (html (:h2 (format *html-stream* "Removed keywords ~a from image" remove-keywords))))

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 Tue Jan 29 07:19:19 2008 @@ -2,23 +2,15 @@

(enable-interpol-syntax)

-(defun emit-image-to-browser (req image image-format &key (quality -1) (date 0) cache-sticky max-age) - (with-bknr-http-response (req :content-type (image-content-type image-format)) +(defun emit-image-to-browser (image image-format &key (quality -1) (date 0) cache-sticky max-age) + (with-http-response (:content-type (image-content-type image-format)) (when cache-sticky - (setf (reply-header-slot-value req :expires) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - (+ (get-universal-time) (* 365 24 60 60))))) + (setf (header-out :expires) (rfc-1123-date (+ (get-universal-time) (* 365 24 60 60))))) (when max-age - (setf (reply-header-slot-value req :cache-control) (format nil "max-age=~A" max-age))) + (setf (header-out :cache-control) (format nil "max-age=~A" max-age))) (unless (zerop date) - (setf (reply-header-slot-value req :last-modified) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - date))) - (with-http-body (req *ent*) + (setf (header-out :last-modified) (rfc-1123-date date))) + (with-http-body () (setf (save-alpha-p :image image) t) (if (member image-format '(:jpg :jpeg)) (write-image-to-stream *html-stream* image-format :image image :quality quality) @@ -40,63 +32,61 @@ (defclass image-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler image-handler) req) - (let ((id-or-name (parse-url req))) +(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)))

(defclass browse-image-handler (image-handler) ())

-(defmethod handle-object ((page-handler browse-image-handler) image req) +(defmethod handle-object ((page-handler browse-image-handler) image) (let ((image-name (store-image-name image)) (image-id (store-object-id image))) - (with-bknr-page (req :title #?"bknr image ${image-name}") + (with-bknr-page (:title #?"bknr image ${image-name}") (image-browser :id image-id))))

(defclass image-page-handler (object-list-handler) ())

-(defmethod object-list-handler-title ((handler image-page-handler) object req) +(defmethod object-list-handler-title ((handler image-page-handler) object) "bknr images")

-(defmethod object-list-handler-rss-link ((handler image-page-handler) object req) +(defmethod object-list-handler-rss-link ((handler image-page-handler) object) "/image-rss")

-(defmethod object-list-handler-get-objects ((handler image-page-handler) object req) +(defmethod object-list-handler-get-objects ((handler image-page-handler) object) (all-store-images))

(defun make-keyword-results (images) (loop for i on images by #'(lambda (seq) (subseq seq 30)) collect (subseq i 0 30)))

-(defmethod handle-object ((handler image-page-handler) images req) - (let ((results (make-keyword-results (object-list-handler-get-objects handler images req)))) - (with-bknr-page (req :title (object-list-handler-title handler images req)) - (cmslink (object-list-handler-rss-link handler images req) "rss") +(defmethod handle-object ((handler image-page-handler) images) + (let ((results (make-keyword-results (object-list-handler-get-objects handler images)))) + (with-bknr-page (:title (object-list-handler-title handler images)) + (cmslink (object-list-handler-rss-link handler images) "rss") (image-page results))))

(defclass upload-image-handler (form-handler) ())

(defmethod handle-form ((handler upload-image-handler) - (action null) - req) - (with-bknr-page (req :title "Image upload") + (action null)) + (with-bknr-page (:title "Image upload") (html "Please upload your image" ((:form :enctype "multipart/form-data" :method "post") "File: " ((:input :type "file" :name "file")) :br ((:input :type "submit" :name "action" :value "upload"))))))

(defmethod handle-form ((handler upload-image-handler) - (action (eql :upload)) - req) - (with-bknr-page (req :title "Image upload result") - (let ((file-pathname (cdr (find "file" (request-uploaded-files req) :key #'car :test #'equal)))) + (action (eql :upload))) + (with-bknr-page (:title "Image upload result") + (let ((file-pathname (cdr (find "file" (request-uploaded-files) :key #'car :test #'equal)))) (unless file-pathname (error "no file uploaded")) - (with-query-params (req name keyword) + (with-query-params (name keyword) (let* ((image (import-image file-pathname - :user (bknr-request-user req) + :user (bknr-request-user) :keywords (list keyword) :keywords-from-dir nil)) (image-id (store-object-id image))) @@ -113,54 +103,54 @@ ())

(defmethod handle-object ((handler image-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "No keyword was given") + (keyword (eql nil))) + (with-bknr-page (:title "No keyword was given") (html "No keyword was given!")))

-(defmethod object-list-handler-get-objects ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-get-objects ((handler image-keyword-handler) keyword) (get-keyword-store-images keyword))

-(defmethod object-list-handler-title ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-title ((handler image-keyword-handler) keyword) (format nil "bknr keyword images: ~a" keyword))

-(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword) (format nil "/keyword-rss/~A" (string-downcase (symbol-name keyword))))

(defclass image-union-handler (image-page-handler keywords-handler) ())

-(defmethod object-list-handler-get-objects ((handler image-union-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler image-union-handler) keywords) (get-keywords-union-store-images keywords))

-(defmethod object-list-handler-title ((handler image-union-handler) keywords req) +(defmethod object-list-handler-title ((handler image-union-handler) keywords) (format nil "bknr union images: ~a" keywords))

-(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords req) - (format nil "/union-rss/~A" (parse-url req))) +(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords) + (format nil "/union-rss/~A" (parse-url)))

(defclass image-intersection-handler (image-page-handler keywords-handler) ())

-(defmethod object-list-handler-get-objects ((handler image-intersection-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler image-intersection-handler) keywords) (get-keywords-intersection-store-images keywords))

-(defmethod object-list-handler-title ((handler image-intersection-handler) keywords req) +(defmethod object-list-handler-title ((handler image-intersection-handler) keywords) (format nil "bknr intersection images: ~a" keywords))

-(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords req) - (format nil "/intersection-rss/~A" (parse-url req))) +(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords) + (format nil "/intersection-rss/~A" (parse-url)))

;;; rss image feeds #| (defclass rss-image-handler (object-rss-handler image-page-handler) ())

-(defmethod create-object-rss-feed ((handler rss-image-handler) object req) +(defmethod create-object-rss-feed ((handler rss-image-handler) object) (let* ((url (website-url (page-handler-site handler))) (image-items (mapcar #'(lambda (image) (store-image-to-rss-item image :url url)) - (subseq (sort (object-list-handler-get-objects handler object req) + (subseq (sort (object-list-handler-get-objects handler object) #'> :key #'blob-timestamp) 0 20)))) (if image-items @@ -168,7 +158,7 @@ :channel (make-instance 'rss-channel :about (render-uri url nil) - :title (object-list-handler-title handler object req) + :title (object-list-handler-title handler object) :link (render-uri url nil) :items (mapcar #'rss-item-link image-items)) :items image-items) @@ -189,18 +179,18 @@ (defclass xml-image-browser-handler (image-handler xml-object-handler) ())

-(defmethod xml-object-handler-show-object ((handler xml-image-browser-handler) image req) +(defmethod xml-object-handler-show-object ((handler xml-image-browser-handler) image) (store-image-xml-info image))

(defclass xml-image-query-handler (xml-object-list-handler) ())

-(defmethod object-list-handler-get-objects ((handler xml-image-query-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler xml-image-query-handler) keywords) (if keywords (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string keywords)) (class-instances 'store-image)))

-(defmethod object-list-handler-show-object-xml ((handler xml-image-query-handler) image req) +(defmethod object-list-handler-show-object-xml ((handler xml-image-query-handler) image) (store-image-xml-info image))

(define-bknr-webserver-module images

Modified: branches/trunk-reorg/bknr/web/src/images/image-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-tags.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@

(define-bknr-tag image-page (results &key) (let* ((num-pages (length results)) - (page (parse-integer (or (query-param *req* "page") "0")))) + (page (parse-integer (or (query-param "page") "0")))) (if (>= page num-pages) (html "No such page") (let ((images (nth page results))) @@ -13,7 +13,7 @@ (html (:princ "&nbsp;") (if (= i page) (html (:princ-safe i)) - (html (cmslink (format nil "~A?page=~A" (uri-path (request-uri *req*)) i) (:princ-safe i)))) + (html (cmslink (format nil "~A?page=~A" (request-uri) i) (:princ-safe i)))) (:princ "&nbsp;")))))))

(define-bknr-tag banner (&key link keyword width height) @@ -101,11 +101,11 @@ nconc images)))))

(define-bknr-tag reset-results () - (setf (session-variable :current-query-name) nil - (session-variable :current-thumbnail-layout) nil - (session-variable :current-query-result) nil)) + (setf (session-value :current-query-name) nil + (session-value :current-thumbnail-layout) nil + (session-value :current-query-result) nil))

-(defun edit-image-collection (&key title (images (session-variable :current-query-result))) +(defun edit-image-collection (&key title (images (session-value :current-query-result))) (format t "class ~a subtypep ~a~%" (class-of (first images)) (subtypep (class-of (first images)) (find-class 'store-image))) (unless (subtypep (class-of (first images)) (find-class 'store-image)) (reset-results)

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 Tue Jan 29 07:19:19 2008 @@ -162,28 +162,24 @@ (defclass imageproc-handler (image-handler) ())

-(defmethod handle-object ((page-handler imageproc-handler) (image (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((page-handler imageproc-handler) (image (eql nil))) + (error-404))

-(defmethod handle-object ((page-handler imageproc-handler) image req) - (with-bknr-http-response (req :content-type (image-content-type (image-type-keyword image))) - (let ((ims (header-slot-value req :if-modified-since)) +(defmethod handle-object ((page-handler imageproc-handler) image) + (format t "if-modfied-since not implemented for hunchentoot~%") + (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 (net.aserve::last-modified *ent*) changed-time) - (setf (reply-header-slot-value req :last-modified) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - changed-time)) + (setf (header-out :last-modified) (rfc-1123-date changed-time)) (if (and ims - (<= changed-time (#-allegro - date-to-universal-time - #+allegro - net.aserve::date-to-universal-time ims))) + (<= changed-time (date-to-universal-time ims))) (progn - (setf (request-reply-code req) *response-not-modified*) + (setf (return-code) +http-not-modified+) (format t "; image ~A not changed~%" image) - (with-http-body (req *ent*))) - (with-http-body (req *ent*) - (imageproc image (cdr (decoded-handler-path page-handler req)))))))) + (with-http-body ())) + (with-http-body () + (imageproc image (cdr (decoded-handler-path page-handler))))))))

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 Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ (defclass image-import-handler (import-handler) ())

-(defmethod import-handler-spool-files ((handler image-import-handler) req) - (image-directory-recursive (import-handler-import-pathname handler req))) +(defmethod import-handler-spool-files ((handler image-import-handler)) + (image-directory-recursive (import-handler-import-pathname handler)))

-(defmethod handle-form ((handler image-import-handler) action req) - (with-bknr-page (req :title #?"image import directory") +(defmethod handle-form ((handler image-import-handler) action) + (with-bknr-page (:title #?"image import directory") ((:form :method "post") ((:div :class "keyword-choose") (if (class-subclasses 'store-image) @@ -26,29 +26,29 @@ (:div (submit-button "import" "Import")))) ((:div :class "import-list") (:h2 "Images present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br))))))

-(defmethod import-handler-import-files ((handler image-import-handler) req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (spool-dir (import-handler-import-pathname handler req)) - (class-name (apply #'find-symbol (reverse (split "::?" (query-param req "class-name")))))) +(defmethod import-handler-import-files ((handler image-import-handler)) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (spool-dir (import-handler-import-pathname handler)) + (class-name (apply #'find-symbol (reverse (split "::?" (query-param "class-name")))))) (import-directory spool-dir :class-name class-name - :user (bknr-request-user req) + :user (bknr-request-user) :keywords keywords :spool (import-handler-spool-dir handler) - :keywords-from-dir (query-param req "keyfromdir")))) + :keywords-from-dir (query-param "keyfromdir"))))

-(defmethod handle-form ((handler image-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler image-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-images (remove-if-not #'(lambda (element) (typep element 'store-image)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"bknr import log") + (with-bknr-page (:title #?"bknr import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error

Modified: branches/trunk-reorg/bknr/web/src/images/session-image.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/session-image.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/session-image.lisp Tue Jan 29 07:19:19 2008 @@ -6,10 +6,10 @@ (defclass session-image-handler (page-handler) ())

-(defmethod handle ((handler session-image-handler) req) - (let ((random-string (or (session-variable :random-string) +(defmethod handle ((handler session-image-handler)) + (let ((random-string (or (session-value :random-string) (format nil "~(~36,3,'0R~)" (+ 1296 (random (- 46656 1296))))))) - (setf (session-variable :random-string) random-string) + (setf (session-value :random-string) random-string) (with-image* ((* 5 *session-image-point-size*) (* 2 *session-image-point-size*)) (setf (transparent-color) (allocate-color 255 255 255)) (loop with x-min = (* 5 *session-image-point-size*) @@ -34,6 +34,6 @@ finally (with-image (result-image (- x-max x-min) (- y-max y-min)) (setf (transparent-color result-image) (allocate-color 255 255 255 :image result-image)) (copy-image *default-image* result-image x-min y-min 0 0 (image-width result-image) (image-height result-image)) - (with-bknr-http-response (req :content-type "image/png") - (with-http-body (req *ent*) + (with-http-response (:content-type "image/png") + (with-http-body () (write-image-to-stream *html-stream* :png :image result-image))))))))

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 Tue Jan 29 07:19:19 2008 @@ -175,6 +175,7 @@ :cl-gd :cl-interpol :cl-ppcre + :alexandria :hunchentoot :cxml-xmls :xhtml-generator @@ -188,10 +189,12 @@ :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:export #:*req* - #:*ent* + (:shadowing-import-from :hunchentoot #:host) + (:shadowing-import-from :alexandria #:array-index) + (:export #:*html-stream* #:*user* - #:session-variable + #:with-http-request + #:with-http-body #:request-variable #:with-query-params #:define-bknr-tag @@ -247,7 +250,7 @@ #:parse-date-field #:keyword-choose-dialog #:navi-button - #:with-bknr-http-response + #:with-http-response

#:upload #:upload-name @@ -291,6 +294,7 @@ #:host #:publish-site #:publish-handler + #:unpublish

#:handle-object #:handle-object-form @@ -368,10 +372,9 @@ #:bknr-session-user #:bknr-session-start-time #:bknr-session-last-used - #:bknr-session-variables + #:bknr-session-values + #:bknr-session-host

- #:http-session - #:http-session-host #:host-name #:bknr-request-user #:bknr-request @@ -451,4 +454,5 @@ :cxml :bknr.web :bknr.impex + :hunchentoot :xhtml-generator))

Modified: branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp Tue Jan 29 07:19:19 2008 @@ -35,6 +35,7 @@ :items items))) (error "not a valid atom feed")))

+#+(or) (defun parse-atom-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed)

Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp Tue Jan 29 07:19:19 2008 @@ -34,6 +34,7 @@ (error "no channel in 0.91 feed"))) (error "not a valid rss feed")))

+#+(or) (defun parse-rss091-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed)

Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp Tue Jan 29 07:19:19 2008 @@ -63,6 +63,7 @@ (error "no channel in 0.91 feed"))) (error "not a valid rss feed")))

+#+(or) (defun parse-rss10-feed (rss-feed) (let ((xml (parse rss-feed :compress-whitespace nil))) (when xml

Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp Tue Jan 29 07:19:19 2008 @@ -41,6 +41,7 @@ (error "no channel in 2.0 feed"))) (error "not a valid rss feed")))

+#+(or) (defun parse-rss20-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed)

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 Tue Jan 29 07:19:19 2008 @@ -3,12 +3,13 @@ (defclass bknr-authorizer () ())

-#+cmu -(defmethod http-request-remote-host ((req http-request)) - (let ((remote-host (socket:remote-host (request-socket req))) +(defmethod http-request-remote-host () + (format *debug-io* "can't determin originating host yet~%") + #+(or) + (let ((remote-host (socket:remote-host (request-socket))) (forwarded-for (regex-replace "^.*?([0-9]+.[0-9]+.[0-9]+.[0-9]+).*$" - (header-slot-value req :x-forwarded-for) + (header-slot-value :x-forwarded-for) "\1"))) (when (and forwarded-for (equal "127.0.0.1" (socket:ipaddr-to-dotted remote-host))) @@ -16,23 +17,13 @@ (setf remote-host (socket:dotted-to-ipaddr forwarded-for))) (find-host :create t :ipaddr remote-host)))

-(defun session-from-request (req) +(defun session-from-request () "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" - (with-cookies (req bknr-sessionid) - (when (and (not bknr-sessionid) - (request-query req)) - (setq bknr-sessionid (query-param req "bknr-sessionid")) - #+(or) - (when bknr-sessionid - ;; XXX convert parameter to cookie value - this against - ;; aserve's advertised protocol which demands that - ;; set-cookie-header must not be called before - ;; with-http-response - (set-cookie-header req :name "bknr-sessionid" :value bknr-sessionid :expires :never))) - (find-session bknr-sessionid))) + (start-session) + (session-value 'bknr-session))

-(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer) req) - (with-query-params (req __username __password) +(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer)) + (with-query-params (__username __password) (when (and __username (not (equal __username ""))) (let ((user (find-user __username))) (when user @@ -41,53 +32,17 @@ user (warn "login failure for user ~a~%" user)))))))

-(defmethod session-from-request-parameters ((authorizer bknr-authorizer) req) - (let ((user (find-user-from-request-parameters authorizer req))) - (when user - (make-user-session req user :old-session (session-from-request req))))) - -(defvar *global-anonymous-session* nil) - -(defun global-anonymous-session () - (or *global-anonymous-session* - (setf *global-anonymous-session* (make-instance 'http-session :host nil :user (find-user "anonymous"))))) - -(defun make-anonymous-session (req) - (make-instance 'http-session - :user (find-user "anonymous") - :host (http-request-remote-host req))) - -(defun make-user-session (req user &key old-session) - (set-user-last-login user (get-universal-time)) - (let ((new-session (make-instance 'http-session - :user user - :host (http-request-remote-host req)))) - (when old-session - ;; copy session variables from old session - (setf (bknr-session-variables new-session) - (bknr-session-variables old-session)) - (drop-session old-session)) - new-session)) - -(defmethod authorize ((authorizer bknr-authorizer) - (req http-request) - ent) +(defmethod authorize ((authorizer bknr-authorizer)) ;; Catch any errors that occur during request body processing + (start-session) (handler-case - ;; first check session cookie or bknr-sessionid parameter. the - ;; session cookie is set in the with-bknr-http-response macro to - ;; follow aserve's documented protocol for setting cookies - (let ((session (or (session-from-request-parameters authorizer req) - (session-from-request req) - (make-anonymous-session req)))) - (when session - (bknr-session-touch session) - (change-class req 'bknr-request :session session) - (return-from authorize t))) + (when (session-value 'bknr-session) + (return-from authorize t)) (error (e) (format t "; Caught error ~A during request processing~%" e) - (http-error req *response-bad-request* (princ-to-string e)))) + (setf (return-code) +http-bad-request+) + (princ-to-string e)))

;; unauthorized, come up with 401 response to the web browser - (redirect (website-make-path *website* "login") req) + (redirect "/login") :deny)

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 Tue Jan 29 07:19:19 2008 @@ -35,8 +35,8 @@ (find (class-name class) *default-event-classes-to-suppress*)) (all-subclasses (find-class 'event))))

-(defun serve-event-class-documentation-request (req) - (with-bknr-page (req :title "event class documentation") +(defun serve-event-class-documentation-request () + (with-bknr-page (:title "event class documentation") (html (:table (:tr (:th "name") (:th "documentation")) @@ -53,8 +53,8 @@ (cmslink (format nil "event-log?show-only-class=~a" ,class-name) (:princ-safe (regex-replace ,class-name "-event$" ""))))))

-(defun serve-event-log-request (req) - (with-query-params (req +(defun serve-event-log-request () + (with-query-params ( message show-only-class last-printed ;; Timestamp of last event printed (client-side session context) @@ -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 req) :text message)) + (make-event 'message-event :from (bknr-request-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)) @@ -74,14 +74,14 @@ (setf print-count "50")) (unless print-hours (setf print-hours "24")) - (with-bknr-page (req :title "event log") + (with-bknr-page (:title "event log") (let ((selected-classes (or (and show-only-class (list (find-class (find-symbol show-only-class (find-package "bknr"))))) - (selected-classes (request-query req)) - (mapcar #'find-class (get-user-preferences (bknr-request-user req) :event-log-classes)) + (selected-classes (request-query)) + (mapcar #'find-class (get-user-preferences (bknr-request-user) :event-log-classes)) (default-selected-classes)))) (unless show-only-class - (set-user-preferences (bknr-request-user req) :event-log-classes (mapcar #'class-name selected-classes))) + (set-user-preferences (bknr-request-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 Tue Jan 29 07:19:19 2008 @@ -75,7 +75,6 @@ (when *website* (warn "Warning, *website* redefined with new website definition")) (setf *website* website) - (unpublish :all t) (publish-site *website*))

(defmethod show-handlers ((website website)) @@ -91,6 +90,7 @@ (format nil "~A~A" (website-base-href website) (relative path)))

(defgeneric publish-handler (website handler)) +(defgeneric handler-matches (handler)) (defgeneric publish-site (website))

(defun handler-definition-name (handler-definition) @@ -135,7 +135,7 @@ (apply #'append (website-handler-definitions website) (mapcar #'(lambda (module-name) (or (gethash (symbol-name module-name) *website-modules*) - (warn "bknr module ~A not known" module-name))) + (error "bknr module ~A not known" module-name))) (website-modules website))))) (when (website-template-base-directory website) (setf (slot-value website 'template-handler) (make-instance 'template-handler @@ -147,14 +147,14 @@ (website-handlers website))) (mapc #'(lambda (handler) (publish-handler website handler)) - (website-handlers website))) + (website-handlers website)) + (pushnew 'bknr-dispatch *dispatch-table*))

(defmethod website-session-info ((website website)) (html ((:div :id "session-info") "local time is " (:princ-safe (format-date-time)) - (if (and (equal 'bknr-request (type-of *req*)) - (bknr-request-user *req*)) - (html ", logged in as " (html-link (bknr-request-user *req*))) + (if (bknr-request-user) + (html ", logged in as " (html-link (bknr-request-user))) (html ", not logged in")))))

(defclass page-handler () @@ -185,87 +185,95 @@ name (concatenate 'string "/" (string-downcase name))))))

-(defgeneric handle (page-handler req)) -(defgeneric authorized-p (page-handler req)) +(defmethod print-object ((handler page-handler) stream) + (print-unreadable-object (handler stream :type t) + (format stream "~A" (page-handler-prefix handler)))) + +(defgeneric handle (page-handler)) +(defgeneric authorized-p (page-handler)) (defgeneric page-handler-url (page-handler))

-(defmethod handler-path ((handler page-handler) req) - (subseq (uri-path (request-uri req)) +(defmethod handler-path ((handler page-handler)) + (subseq (request-uri) (length (page-handler-prefix handler))))

-(defmethod decoded-handler-path ((handler page-handler) req) - (mapcar #'uridecode-string +(defmethod decoded-handler-path ((handler page-handler)) + (mapcar #'url-decode (remove "" - (split "/" (handler-path handler req)) + (split "/" (handler-path handler)) :test #'equal)))

-(defmethod parse-handler-url ((handler page-handler) req) - (values-list (decoded-handler-path handler req))) +(defmethod parse-handler-url ((handler page-handler)) + (values-list (decoded-handler-path handler)))

(defmethod page-handler-url ((handler page-handler)) (merge-uris (parse-uri (page-handler-prefix handler)) (website-url (page-handler-site handler))))

-(defmethod authorized-p ((page-handler page-handler) req) +(defmethod authorized-p ((page-handler page-handler)) (with-slots (require-user-flag) page-handler (if (and require-user-flag (not (find require-user-flag - (user-flags (bknr-request-user req))))) + (user-flags (bknr-request-user))))) nil t)))

-(defmethod invoke-handler ((handler page-handler) req ent) +(defmethod invoke-handler ((handler page-handler)) (let* ((*website* (page-handler-site handler)) - (*req* req) - (*ent* ent) - (*session* (bknr-request-session req)) - (*user* (bknr-request-user req)) + (*session* (bknr-request-session)) + (*user* (bknr-request-user)) (*req-var-hash* (or *req-var-hash* (make-hash-table)))) - (do-log-request req) + (do-log-request) (unwind-protect - (if (not (authorized-p handler req)) + (if (not (authorized-p handler)) (progn - (setf (session-variable :login-redirect-uri) - (redirect-uri (request-uri req))) - (redirect (website-make-path *website* "login") req)) - (if hunchentoot:*catch-errors-p* - (handle handler req) + (setf (session-value :login-redirect-uri) + (redirect-uri (request-uri))) + (redirect (website-make-path *website* "login"))) + (if *catch-errors-p* + (handle handler) (handler-bind ((error #'(lambda (e) - (with-bknr-http-response (*req* :content-type "text/html; charset=UTF-8" - :response *response-internal-server-error*) - (with-http-body (*req* *ent*) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response +http-internal-server-error+) + (with-http-body () (website-show-error-page *website* e))) - (do-error-log-request req e) + (do-error-log-request e) (error e)))) - (handle handler req)))) + (handle handler)))) (handler-case - (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files req))) + (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files))) (error (e) (warn "error ~A ignored while deleting uploaded files" e))))))

-(defmethod handle ((page-handler page-handler) req) - (funcall (page-handler-function page-handler) req)) +(defmethod handle ((page-handler page-handler)) + (funcall (page-handler-function page-handler))) + +(defvar *handlers* nil)

-(defmethod publish-handler ((website website) (page-handler page-handler)) - (with-slots (content-type) page-handler - (publish :path (page-handler-prefix page-handler) - :content-type content-type - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website)))) +(defun bknr-dispatch (request) + (declare (ignore request)) + (when-let ((handler (find-if #'handler-matches *handlers*))) + (curry #'invoke-handler handler))) + +(defmethod publish-handler ((website website) (handler page-handler)) + (setf *handlers* (append *handlers* (list handler)))) + +(defmethod handler-matches ((handler page-handler)) + (string-equal (page-handler-prefix handler) + (script-name)))

(defclass redirect-handler (page-handler) ((to :initarg :to :reader redirect-handler-to :documentation "url to redirect to")))

-(defmethod handle ((page-handler redirect-handler) req) - (redirect (redirect-handler-to page-handler) req)) +(defmethod handle ((page-handler redirect-handler)) + (redirect (redirect-handler-to page-handler)))

(defclass random-redirect-handler (redirect-handler) ())

-(defmethod handle ((page-handler random-redirect-handler) req) - (redirect (random-elt (redirect-handler-to page-handler)) req)) +(defmethod handle ((page-handler random-redirect-handler)) + (redirect (random-elt (redirect-handler-to page-handler))))

(defclass form-handler (page-handler) ()) @@ -287,39 +295,27 @@ (signal (make-condition 'form-field-missing-condition :field ',field-name))))

-(defgeneric handle-form (page-handler action req)) +(defgeneric handle-form (page-handler action))

-(defmethod handle ((page-handler form-handler) req) - (let* ((form (query-param req "action")) +(defmethod handle ((page-handler form-handler)) + (let* ((form (query-param "action")) (form-keyword (when form (make-keyword-from-string form)))) - (handle-form page-handler form-keyword req))) + (handle-form page-handler form-keyword)))

(defclass prefix-handler (page-handler) ())

-(defmethod publish-handler ((website website) (page-handler prefix-handler)) - (with-slots (name content-type) page-handler - (let ((prefix (page-handler-prefix page-handler))) - (unless (eql (char prefix (1- (length prefix))) #/) - (setf prefix (concatenate 'string prefix "/"))) - (publish-prefix :prefix prefix - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website))))) +(defmethod handler-matches ((handler prefix-handler)) + (and (>= (length (script-name)) + (length (page-handler-prefix handler))) + (string-equal (page-handler-prefix handler) + (script-name) + :end2 (length (page-handler-prefix handler)))))

(defclass directory-handler (prefix-handler) ((destination :initarg :destination :reader page-handler-destination)))

-(defmethod publish-handler ((website website) (page-handler directory-handler)) - (with-slots (name destination) page-handler - (publish-directory :prefix (concatenate 'string (page-handler-prefix page-handler) "/") - :host (website-vhosts website) - :destination (if (pathnamep destination) - (namestring destination) - destination) - :authorizer (website-authorizer website)))) - (defclass file-handler (page-handler) ((destination :initarg :destination :reader page-handler-destination) @@ -327,68 +323,51 @@ :reader page-handler-content-type)) (:default-initargs :content-type "text/plain"))

-(defmethod publish-handler ((website website) (handler file-handler)) - (with-slots (destination content-type) handler - (publish-file :path (page-handler-prefix handler) - :host (website-vhosts website) - :file (if (pathnamep destination) (namestring destination) destination) - :authorizer (website-authorizer website) - :content-type content-type))) - (defclass object-handler (prefix-handler) ((query-function :initarg :query-function :reader object-handler-query-function) (object-class :initarg :object-class :reader object-handler-object-class)) (:default-initargs :object-class t :query-function nil))

-(defgeneric object-handler-get-object (object-handler req)) -(defgeneric handle-object (object-handler object req)) - -(defmethod publish-handler ((website website) (page-handler object-handler)) - (with-slots (name content-type) page-handler - (publish :path (page-handler-prefix page-handler) - :content-type content-type - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website)) - (call-next-method))) +(defgeneric object-handler-get-object (object-handler)) +(defgeneric handle-object (object-handler object))

-(defmethod object-handler-get-object ((handler object-handler) req) - (let ((id (parse-url req))) +(defmethod object-handler-get-object ((handler object-handler)) + (let ((id (parse-url))) (when id (find-store-object id :class (object-handler-object-class handler) :query-function (object-handler-query-function handler)))))

-(defmethod handle ((handler object-handler) req) - (let ((object (object-handler-get-object handler req))) - (handle-object handler object req))) +(defmethod handle ((handler object-handler)) + (let ((object (object-handler-get-object handler))) + (handle-object handler object)))

(defclass edit-object-handler (form-handler object-handler) ())

-(defgeneric handle-object-form (handler action object req)) +(defgeneric handle-object-form (handler action object))

-(defmethod handle-form ((handler edit-object-handler) action req) - (let ((object (object-handler-get-object handler req))) - (handle-object-form handler action object req))) +(defmethod handle-form ((handler edit-object-handler) action) + (let ((object (object-handler-get-object handler))) + (handle-object-form handler action object)))

-(defmethod handle-object-form ((handler edit-object-handler) action (object (eql nil)) req) - (with-bknr-page (req :title "No such object") +(defmethod handle-object-form ((handler edit-object-handler) action (object (eql nil))) + (with-bknr-page (:title "No such object") (html "No such object, ieeeh")))

(defclass keyword-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler keyword-handler) req) - (let ((keystr (parse-url req))) +(defmethod object-handler-get-object ((handler keyword-handler)) + (let ((keystr (parse-url))) (when keystr (make-keyword-from-string keystr))))

(defclass keywords-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler keywords-handler) req) - (let ((keystr (parse-url req))) +(defmethod object-handler-get-object ((handler keywords-handler)) + (let ((keystr (parse-url))) (if keystr (mapcar #'(lambda (k) (make-keyword-from-string (string-upcase k))) (split "," keystr)) @@ -397,18 +376,18 @@ (defclass object-list-handler (object-handler) ())

-(defgeneric object-list-handler-get-objects (handler object req)) -(defgeneric object-list-handler-title (handler object req)) -(defgeneric object-list-handler-rss-link (handler object req)) +(defgeneric object-list-handler-get-objects (handler object)) +(defgeneric object-list-handler-title (handler object)) +(defgeneric object-list-handler-rss-link (handler object))

(defclass object-date-list-handler (object-list-handler) ())

-(defgeneric object-date-list-handler-grouped-objects (handler object req)) +(defgeneric object-date-list-handler-grouped-objects (handler object))

(defmethod object-date-list-handler-date ((handler object-date-list-handler object-list-handler) - object req) - (with-query-params (req date) + object) + (with-query-params (date) (get-daytime (if date (or (parse-integer date :junk-allowed t) (get-universal-time)) @@ -417,18 +396,20 @@ (defclass admin-only-handler () ())

-(defmethod authorized-p ((handler admin-only-handler) req) - (admin-p (bknr-request-user req))) +(defmethod authorized-p ((handler admin-only-handler)) + (admin-p (bknr-request-user)))

(defclass xml-handler () ((style-path :initarg :style-path :reader xml-handler-style-path)) (:default-initargs :style-path nil))

-(defmethod handle :around ((handler xml-handler) req) - (with-bknr-http-response (req :content-type "text/xml") - (with-http-body (req *ent*) - (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t)) - (style-path (or (query-param req "style") +(defmethod handle :around ((handler xml-handler)) + (with-http-response (:content-type "text/xml") + (with-http-body () + (let ((sink (#-rune-is-integer cxml:make-character-stream-sink + #+rune-is-integer cxml:make-character-stream-sink/utf8 + *html-stream* :canonical t)) + (style-path (or (query-param "style") (xml-handler-style-path handler)))) (cxml:with-xml-output sink (when style-path @@ -441,44 +422,44 @@ (defclass xml-object-handler (object-handler xml-handler) ())

-(defmethod handle-object ((handler xml-object-handler) (object (eql nil)) req) +(defmethod handle-object ((handler xml-object-handler) (object (eql nil))) (error "invalid object id"))

-(defgeneric xml-object-handler-show-object (handler object req)) +(defgeneric xml-object-handler-show-object (handler object))

-(defmethod xml-object-handler-show-object ((handler xml-object-handler) object req) +(defmethod xml-object-handler-show-object ((handler xml-object-handler) object) (write-to-xml object :string-rod-fn #'cxml::utf8-string-to-rod))

-(defmethod handle-object ((handler xml-object-handler) object req) - (xml-object-handler-show-object handler object req)) +(defmethod handle-object ((handler xml-object-handler) object) + (xml-object-handler-show-object handler object))

(defclass xml-object-list-handler (object-handler xml-handler) ((toplevel-element-name :initarg :toplevel-element-name :reader xml-object-list-handler-toplevel-element-name)) (:default-initargs :toplevel-element-name "objects"))

-(defmethod object-handler-get-object ((handler xml-object-list-handler) req) - (multiple-value-list (parse-url req))) +(defmethod object-handler-get-object ((handler xml-object-list-handler)) + (multiple-value-list (parse-url)))

-(defgeneric object-list-handler-show-object-xml (handler object req)) +(defgeneric object-list-handler-show-object-xml (handler object))

-(defmethod object-list-handler-show-object-xml ((handler xml-object-list-handler) object req) +(defmethod object-list-handler-show-object-xml ((handler xml-object-list-handler) object) #+(or) (set-string-rod-fn #'cxml::utf8-string-to-rod) (write-to-xml object))

-(defmethod handle-object ((handler xml-object-list-handler) object req) +(defmethod handle-object ((handler xml-object-list-handler) object) (let ((element-name (xml-object-list-handler-toplevel-element-name handler))) (cxml:with-element element-name - (dolist (object (object-list-handler-get-objects handler object req)) - (object-list-handler-show-object-xml handler object req))))) + (dolist (object (object-list-handler-get-objects handler object)) + (object-list-handler-show-object-xml handler object)))))

(defclass blob-handler (object-handler) ())

-(defmethod handle-object ((handler blob-handler) (blob blob) req) - (with-bknr-http-response (req :content-type (blob-mime-type blob)) - (setf (request-reply-content-length req) (blob-size blob)) - (with-http-body (req *ent* :external-format '(unsigned-byte 8)) +(defmethod handle-object ((handler blob-handler) (blob blob)) + (with-http-response (:content-type (blob-mime-type blob)) + (setf (content-length) (blob-size blob)) + (with-http-body (:external-format '(unsigned-byte 8)) (blob-to-stream blob *html-stream*))))

(defclass import-handler (form-handler) @@ -487,12 +468,12 @@ :initform *user-spool-directory-root* :reader import-handler-spool-dir)))

-(defgeneric import-handler-import-pathname (handler req)) -(defgeneric import-handler-spool-files (handler req)) -(defgeneric import-handler-import-files (handler req)) +(defgeneric import-handler-import-pathname (handler)) +(defgeneric import-handler-spool-files (handler)) +(defgeneric import-handler-import-files (handler))

-(defmethod import-handler-import-pathname ((handler import-handler) req) - (let* ((user (bknr-request-user req)) +(defmethod import-handler-import-pathname ((handler import-handler)) + (let* ((user (bknr-request-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user))) (import-handler-spool-dir handler)))) @@ -517,7 +498,7 @@

(defmethod website-show-error-page ((website website) error) (if (website-template-handler website) - (send-error-response (website-template-handler website) *req* (princ-to-string error)) + (send-error-response (website-template-handler website) (princ-to-string error)) (html (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) (princ #\Newline *html-stream*) @@ -530,33 +511,31 @@ ((:div :class "error") (:princ-safe error)))))))

-(defun show-page-with-error-handlers (fn req &key response title) - (unless response - (setf response *response-ok*)) ; can't default because used from macros and *response-ok* is not a constant - (if hunchentoot:*catch-errors-p* - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response response) - (with-http-body (req *ent*) - (website-show-page *website* fn title))) - (handler-case - (let ((body (with-output-to-string (*html-stream*) - (website-show-page *website* fn title)))) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response response) - (with-http-body (req *ent*) - (princ body *html-stream*)))) - (serious-condition (c) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response *response-internal-server-error*) - (with-http-body (req *ent*) - (website-show-error-page *website* c))))))) +(defun show-page-with-error-handlers (fn &key (response +http-ok+) title) + (setf (return-code) response) + (handler-case + (let ((body (with-output-to-string (*html-stream*) + (website-show-page *website* fn title)))) + (with-http-response (:content-type "text/html; charset=UTF-8" :response response) + (with-http-body () + (princ body *html-stream*)))) + (serious-condition (c) + (with-http-response (:content-type "text/html; charset=UTF-8" :response +http-internal-server-error+) + (with-http-body () + (website-show-error-page *website* c))))))

(defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args))

#+(or) -(defmacro with-bknr-site-template ((req &key title) &rest body) - `(with-bknr-http-response (,req :content-type "text/html") - (with-http-body (,req ,ent) +(defmacro with-bknr-site-template ((&key title) &rest body) + `((with-http-response (:content-type "text/html") + (with-http-body () (include :template "toplevel-template" :tag-body (with-output-to-string (*html-stream*) - ,@body))))) + ,@body))))))

+(defun unpublish () + (setf *dispatch-table* (remove 'bknr-handler *dispatch-table*) + *handlers* nil)) \ No newline at end of file

Modified: branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ () (:default-initargs :query-function #'bknr.rss:find-rss-channel))

-(defmethod handle-object ((handler rss-handler) (channel (eql nil)) req) +(defmethod handle-object ((handler rss-handler) (channel (eql nil))) (error "invalid channel name"))

-(defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel) req) - (with-bknr-http-response (req :content-type "text/xml; charset=UTF-8") - (with-http-body (req *ent*) +(defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) + (with-http-response (:content-type "text/xml; charset=UTF-8") + (with-http-body () (html (:princ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>") (bknr.rss:rss-channel-xml channel *html-stream*)))))

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 Tue Jan 29 07:19:19 2008 @@ -1,190 +1,34 @@ (in-package :bknr.web)

-(defvar *bknr-session-table-lock* (mp-make-lock "Bknr Session Table")) -(defvar *bknr-sessions* (make-hash-table :test #'equal)) - -(defvar *bknr-session-next* 1) - -(defvar *bknr-session* nil - "special variable, holds the current session for the executing thread") - (defclass bknr-session () - ((id :initarg :id :accessor bknr-session-id :initform (get-universal-time)) - (user :initarg :user :accessor bknr-session-user :initform nil) - (last-used :initform (get-universal-time) :accessor bknr-session-last-used) - (variables :initform (make-hash-table) :accessor bknr-session-variables - :documentation "Application session variables indexed by keyword (XXX flat namespace, beware)"))) - -(defun session-variable (var) - (gethash var (bknr-session-variables *session*))) - -(defun (setf session-variable) (new-value var) - (setf (gethash var (bknr-session-variables *session*)) new-value)) - -(defun make-new-session-id () - ; XXX needs to be increased in order to allow more users - (md5-string (format nil "~a.~a" (incf *bknr-session-next*) (random 200000)))) - -(defmethod initialize-instance :after ((session bknr-session) &key &allow-other-keys) - (mp-with-lock-held (*bknr-session-table-lock*) - (let ((id (make-new-session-id))) - (setf (slot-value session 'id) id) - (setf (gethash (bknr-session-id session) *bknr-sessions*) session)))) - -(defmethod close-session ((session bknr-session)) - (remhash (bknr-session-id session) *bknr-sessions*)) - -(defmethod bknr-session-touch ((session bknr-session)) - (setf (bknr-session-last-used session) (get-universal-time))) - -(defmethod bknr-session-has-user-flag ((session bknr-session) flag) - (user-has-flag (bknr-session-user session) flag)) - -(defmethod bknr-session-results-get ((session bknr-session) result-type result-query find-results-fn) - (let* ((result-name (make-keyword-from-string (string-upcase (format nil "RESULT-~A" result-type)))) - (result (gethash result-name (bknr-session-variables session)))) - (if (and result - (equal (car result) result-query)) - (cdr result) - (let ((new-results (funcall find-results-fn))) - (setf (gethash result-name (bknr-session-variables session)) (cons result-query new-results)) - new-results)))) - -(defun bknr-sessions () - (loop - for session being the hash-values of *bknr-sessions* - collect session)) - -(defparameter *http-session-timeout* 3000 - "Number of seconds after which a http session which has not been used is deleted") - -(defclass http-session (bknr-session) - ((host :initarg :host :reader http-session-host) - (event-queue :accessor http-session-event-queue) - (event-handler :accessor http-session-event-handler))) - -(defmethod print-object ((session http-session) stream) - (format stream "#<http-session id ~a user ~a host ~a>" - (bknr-session-id session) (bknr-session-user session) (http-session-host session)) - session) - -(defmethod create-event-handler ((session http-session)) - (when (slot-boundp session 'event-handler) - (error "; event handler for session already created")) - #+allegro - (let ((queue (make-instance 'mp:queue))) - (setf (http-session-event-queue session) queue) - (setf (http-session-event-handler session) (register-event-handler 'event #'(lambda (event) (mp:enqueue queue event)))))) - -#+allegro -(defmethod queued-events ((session http-session) &key wait) - (when (http-session-event-handler session) - (loop - for event = (handler-case - (mp:dequeue (http-session-event-queue session) :wait wait) - (error (e) - (declare (ignore e)) - nil)) - while event - collect event - do (setq wait nil)))) - -#+allegro -(defun serve-enable-events-request (req ent) - (let ((session (bknr-request-session req))) - (unless (slot-boundp session 'event-handler) - (create-event-handler session))) - (with-bknr-page (req :title "events enabled") - (html "events are enabled now"))) - -#+allegro -(defun serve-queued-events-request (req ent) - (with-bknr-http-response (req ent :content-type "text/xml") - (with-http-body (req ent) - (princ "<automatenEvents>" *html-stream*) - (loop - for event in (queued-events (bknr-request-session req)) - do (generate-xml-with-stream *html-stream* nil (as-xml event))) - (princ "</automatenEvents>" *html-stream*)))) - -(defvar *http-sessions* nil) -(defvar *http-sessions-lock* (mp-make-lock "HTTP Session Table")) - -(defmethod close-session ((session http-session)) + ((id :initarg :id :reader bknr-session-id :initform (get-universal-time)) + (user :initarg :user :reader bknr-session-user :initform nil) + (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)) + session)) + +(defmethod bknr-session-user ((user (eql nil))) + nil) + +(defun bknr-request-user () + (bknr-session-user (session-value 'bknr-session))) + +(defun bknr-request-session () + (session-value 'bknr-session)) + +(defun do-log-request () + (format *debug-io* "Log: ~A~%" (request-uri)) + (return-from do-log-request) #+(or) - (when (slot-boundp session 'event-handler) - (deregister-event-handler (http-session-event-handler session))) - (mp-with-lock-held (*http-sessions-lock*) - (setf *http-sessions* (remove session *http-sessions*))) - (call-next-method)) - -(defmethod initialize-instance :after ((session http-session) &key &allow-other-keys) - (mp-with-lock-held (*http-sessions-lock*) - (format t "; new session: ~a~%" session) - (push session *http-sessions*)) - (change-slot-values (http-session-host session) 'last-seen (get-universal-time)) - (make-http-session-event session 'web-visitor-event)) - -(defun find-session (id) - (when id - (mp-with-lock-held (*http-sessions-lock*) - (find id *http-sessions* :test #'equal :key #'bknr-session-id)))) - -(defun make-http-session-event (http-session class) - (make-event class - :host (http-session-host http-session) - :session-id (bknr-session-id http-session) - :user (bknr-session-user http-session))) - -(defun drop-session (session) - (handler-case - (progn - (format t ";; dropping session ~a~%" session) - (make-http-session-event session 'web-visitor-left-event)) - (error (e) - (format t - "caught and ignored error ~a during drop-session (make-http-session-event)~%" e))) - (close-session session)) - -(defun drop-idle-sessions () - (mp-with-lock-held (*http-sessions-lock*) - (setf *http-sessions* - (loop for session in *http-sessions* - if (< *http-session-timeout* - (- (get-universal-time) (bknr-session-last-used session))) - do (drop-session session) - else collect session)))) - -#+(or) -(unless (cron-job-with-name "idle session scavenger") - (make-object 'cron-job - :minute '(0 10 20 30 40 50) - :job 'drop-idle-sessions)) - -(defclass bknr-request (http-request) - ((session :initarg :session :reader bknr-request-session))) - -(defmethod update-instance-for-different-class :before ((old http-request) - (new bknr-request) &key session) - ;; Clear parsed parameters in request. During authorization, - ;; parameters are not completely parsed in order to save time. In - ;; particular, uploaded files are only parsed after authorization. - ;; This is accomplished by clearing the cache for the parsed - ;; parameters when the session has been determined. - (setf (getf (request-reply-plist old) 'bknr-parsed-parameters) nil) - (setf (getf (request-reply-plist old) 'bknr-parsed-body-parameters) nil) - (setf (slot-value new 'session) session)) - -(defmethod bknr-request-user ((req bknr-request)) - (bknr-session-user (bknr-request-session req))) - -(defun do-log-request (req) - (let* ((session (bknr-request-session req)) + (let* ((session (bknr-request-session)) (user (bknr-session-user session)) - (host (http-session-host session)) - (url (uri-path (request-uri req))) - (referer (header-slot-value req :referer)) - (user-agent (header-slot-value req :user-agent)) + (host (bknr-session-host session)) + (url (request-uri)) + (referer (header-in :referer)) + (user-agent (header-in :user-agent)) (time (get-universal-time))) (prog1 (make-event 'web-server-log-event @@ -195,15 +39,17 @@ :user-agent user-agent :session-id (bknr-session-id session) :url url) - (format t "; ~a ~a ~a ~a~%" (format-date-time time) + (format t "; ~A ~A ~A ~A~%" (format-date-time time) (if user (user-login user) "anonymous") (host-name host) url))))

-(defun do-error-log-request (req error) - (let* ((session (bknr-request-session req)) +(defun do-error-log-request (error) + (format *debug-io* "Error: ~A~%" error) + #+(or) + (let* ((session (bknr-request-session)) (user (bknr-session-user session)) - (host (http-session-host session)) - (url (uri-path (request-uri req))) - (referer (header-slot-value req :referer)) + (host (bknr-session-host session)) + (url (request-uri)) + (referer (header-in :referer)) (time (get-universal-time))) (make-event 'web-server-error-event :time time

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 Tue Jan 29 07:19:19 2008 @@ -21,10 +21,7 @@ (mapc #'emit-template-node *toplevel-children*))

(define-bknr-tag redirect-request (&key target) - (with-http-response (*req* *ent* :response *response-found*) - (set-cookie-header *req* :name "bknr-sessionid" :value (bknr-session-id (bknr-request-session *req*)) :expires :never) - (setf (reply-header-slot-value *req* :location) target) - (with-http-body (*req* *ent*)))) + (redirect target))

(define-bknr-tag select-box (name options &key (size 1) default) (html ((:select :name name :size size) @@ -141,7 +138,7 @@ <bknr:logo />

" - (html ((:img :style (css-inline :float "right") :src (website-site-logo-url *website*) :alt "logo")))) + (html ((:img :style (parenscript:css-inline :float "right") :src (website-site-logo-url *website*) :alt "logo")))) (define-bknr-tag body-style (&key background-color background-image) "Outputs the body style css definition @@ -201,7 +198,7 @@

(define-bknr-tag navi-button (&key url text) (html (:princ "&nbsp;")) - (if (equal (uri-path (request-uri *req*)) + (if (equal (request-uri) url) (html (:princ-safe text)) (html (cmslink url (:princ-safe text)))) @@ -229,7 +226,7 @@ do (navi-button :url link :text name))))) (when (and (website-admin-navigation *website*) - (admin-p (bknr-request-user *req*))) + (admin-p (bknr-request-user))) (html ((:div :class "navi") "admin: " (loop @@ -258,7 +255,7 @@ (define-bknr-tag site-menu () (destructuring-bind (empty first-level &optional second-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (request-uri)) (declare (ignore empty rest)) (html ((:div :id "navcontainer") (let ((*standard-output* *html-stream*))

Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Tue Jan 29 07:19:19 2008 @@ -11,6 +11,7 @@ ;; FreeBSD "/usr/local/share/xml/catalog.ports"))

+#+cmu (eval-when (:load-toplevel :execute) (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG"))) (when env-catalog @@ -63,13 +64,11 @@ collect `(set-tag-function *template-expander* (string-downcase (symbol-name ',name)) #'(lambda ,args ,body))) ,@body))

-(defgeneric initial-template-environment (expander req)) +(defgeneric initial-template-environment (expander))

-(defmethod initial-template-environment ((expander template-expander) req) - (list* (cons :request req) - (cons :entity *ent*) - (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo))) - (all-request-params req)))) +(defmethod initial-template-environment ((expander template-expander)) + (list* (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo))) + (all-request-params))))

(defun get-template-var (var) (cdr (assoc var *template-env*))) @@ -104,7 +103,8 @@ (defun emit-template (expander stream node env) (let* ((*template-expander* expander) (*template-env* env) - (sink (cxml:make-character-stream-sink stream :canonical nil)) + (sink (#-rune-is-integer cxml:make-character-stream-sink #+rune-is-integer cxml:make-character-stream-sink/utf8 + stream :canonical nil)) (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod))) (if (node-attribute node "suppress-xml-headers") (emit-template-node node) @@ -121,10 +121,16 @@ (defun xmls-attributes-to-sax (fn attrs) (mapcar (lambda (a) (destructuring-bind (name value) a - (sax:make-attribute :qname name - :value (funcall fn value) - :specified-p t))) - attrs)) + (if (listp name) + (destructuring-bind (qname . namespace-uri) name + (sax:make-attribute :namespace-uri namespace-uri + :qname qname + :value (funcall fn value) + :specified-p t)) + (sax:make-attribute :qname name + :value (funcall fn value) + :specified-p t)))) + attrs))

(defun emit-template-node (node) (if (stringp node) @@ -136,7 +142,8 @@ ;; XML-technisch waere es korrekter, nicht auf das Praefix zu gucken, ;; sondern auf die Namespace-URI. (cond - (ns + ((and ns + (not (find #: ns))) (apply (find-tag-function *template-expander* name ns) (append (loop for (key name) in (remove-if #'(lambda (attr) (scan "^xmlns" (car attr))) attrs) collect (make-keyword-from-string key) @@ -170,21 +177,15 @@ (cxml:*cache-all-dtds* t) (cxml:*catalog* (template-handler-catalog handler)) (sax:*include-xmlns-attributes* t)) - ;; XXX wieder ein CMUCL quickfix - (cxml:parse-file #+allegro - template-pathname - #+cmu - (ext:unix-namestring template-pathname) - #+sbcl - (sb-int:unix-namestring template-pathname) - (cxml:make-recoder (cxml-xmls:make-xmls-builder) + (cxml:parse-file (namestring (probe-file template-pathname)) + (cxml:make-recoder (cxml-xmls:make-xmls-builder) #'cxml::rod-to-utf8-string) :validate nil)))

(defmethod expand-template ((handler template-handler) - template-name &key env request) + template-name &key env) (multiple-value-bind (template-pathname args template-path) - (find-template-pathname handler template-name :request request) + (find-template-pathname handler template-name) (unless template-pathname (return-from expand-template nil)) (unless (request-variable :template-args) @@ -231,8 +232,7 @@ (when (probe-file file) (values file (cdr components)))))))

-(defmethod find-template-pathname ((handler template-handler) template-name &key request) - (declare (ignore request)) +(defmethod find-template-pathname ((handler template-handler) template-name) (let ((components (remove "" (split "/" template-name) :test #'equal))) (multiple-value-bind (pathname ret-components) (find-template (template-handler-destination handler) components) @@ -257,67 +257,56 @@ (setf (gethash namestring table) cache-entry)) (cdr cache-entry)))

-(defun send-error-response (handler req message &key (response-code *response-internal-server-error*)) - (let* ((pathname (find-template-pathname handler "user-error" :request req)) - (template (get-cached-template pathname handler))) - (with-bknr-http-response (req - :content-type "text/html; charset=UTF-8" - :response response-code) - (with-http-body (req *ent*) - (emit-template handler - *html-stream* - template - (acons :error-message message - (initial-template-environment - handler req))))))) +(defun send-error-response (handler message &key (response-code +http-internal-server-error+)) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response response-code) + (with-http-body () + (emit-template handler + *html-stream* + (get-cached-template (find-template-pathname handler "user-error") handler) + (acons :error-message message + (initial-template-environment + handler))))))

-(defun invoke-with-error-handlers (fn handler req) - (if hunchentoot:*catch-errors-p* - (handler-case - (funcall fn) - (template-not-found (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c))))) +(defun invoke-with-error-handlers (fn handler) + (if *catch-errors-p* (handler-case (funcall fn) (user-error (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c)) - :response-code *response-ok*)) + (send-error-response handler (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + :response-code +http-ok+)) (template-not-found (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c)) - :response-code *response-not-found*)) + (send-error-response handler (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + :response-code +http-not-found+)) (serious-condition (c) (warn "unexpected failure: ~A" c) - (send-error-response handler req (format nil "Internal Error:~%~%~A~%" c)))))) + (send-error-response handler (format nil "Internal Error:~%~%~A~%" c)))) + (funcall fn)))

-(defmacro with-error-handlers ((handler req) &body body) - `(invoke-with-error-handlers (lambda () ,@body) ,handler ,req)) +(defmacro with-error-handlers ((handler) &body body) + `(invoke-with-error-handlers (lambda () ,@body) ,handler))

-(defmethod handle ((handler template-handler) req) - (with-error-handlers (handler req) +(defmethod handle ((handler template-handler)) + (with-error-handlers (handler) ;; Erst body ausfuehren... (let ((body (expand-template handler - (subseq (uri-path (request-uri req)) + (subseq (request-uri) (length (page-handler-prefix handler))) - :env (initial-template-environment handler req) - :request req))) + :env (initial-template-environment handler)))) ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben (if body - (with-bknr-http-response (req - :content-type "text/html; charset=UTF-8" - :response *response-ok*) - (with-http-body (req *ent*) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response +http-ok+) + (with-http-body () (write-string body *html-stream*))) - (error-404 req))))) + (error-404)))))

;; XXX documentation-handler sieht interessant aus, unbedingt reparieren (defclass documentation-handler (page-handler) @@ -327,7 +316,7 @@ :initform :documentation)))

#+(or) -(defmethod handle ((page-handler documentation-handler) req) +(defmethod handle ((page-handler documentation-handler)) (let ((symbol-docs (sort (loop for sym being the external-symbols in (documentation-handler-package page-handler) for documentation = (documentation sym 'function) @@ -336,7 +325,7 @@ (string-downcase (symbol-name sym))) documentation)) #'string<= :key #'car))) - (with-eboy-page (req :title "Template documentation" ) + (with-eboy-page (:title "Template documentation" ) (html "This page documents the available template processing tags. These tags can be used in .bknr files and will be dynamically expanded at page generation time. New tags can be defined by writing

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 Tue Jan 29 07:19:19 2008 @@ -24,24 +24,23 @@ (defclass logout-handler (page-handler) ())

-(defmethod handle ((handler logout-handler) req) - (bknr.web::drop-session (bknr-request-session req)) - (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)))) +(defmethod handle ((handler logout-handler)) + (setf (session-value 'bknr-session) nil) + (format t "url: ~A referer: ~A~%" (query-param "url") (header-in :referer)) + (let ((url (or (query-param "url") + (header-in :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) + (progn (with-bknr-page (:title "logged out") + (html (:h2 "you are logged out")))))))

(defclass user-handler (edit-object-handler) ((require-user-flag :initform :admin)))

-(defmethod authorized-p ((handler user-handler) req) - (let* ((user (object-handler-get-object handler req)) - (web-user (bknr-request-user req)) - (action (query-param req "action")) +(defmethod authorized-p ((handler user-handler)) + (let* ((user (object-handler-get-object handler)) + (web-user (bknr-request-user)) + (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p web-user) nil) ((admin-p web-user) t) @@ -51,14 +50,14 @@ t) (t nil))))

-(defmethod object-handler-get-object ((handler user-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler user-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'user :query-function #'find-user))))

-(defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) - (with-bknr-page (req :title "Manage users") +(defmethod handle-object-form ((handler user-handler) action (user (eql nil))) + (with-bknr-page (:title "Manage users") ((:table :border "1") (:tr (:th "Login") (:th "Real name") @@ -77,20 +76,20 @@ (:h2 "Create new user") (user-form)))

-(defmethod handle-object-form ((handler user-handler) action (user user) req) - (with-bknr-page (req :title #?"$((class-name (class-of user))) $((user-login user))") +(defmethod handle-object-form ((handler user-handler) action (user user)) + (with-bknr-page (:title #?"$((class-name (class-of user))) $((user-login user))") #+(or) (bknr.images:user-image :user (user-login user)) (user-form :user-id (store-object-id user))))

-(defmethod handle-object-form ((handler user-handler) (action (eql :search)) user req) - (with-query-params (req login) - (redirect (format nil "/user/~A" login) req))) +(defmethod handle-object-form ((handler user-handler) (action (eql :search)) user) + (with-query-params (login) + (redirect (format nil "/user/~A" login))))

-(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user req) +(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user) (unless user - (setf user (bknr-request-user req))) + (setf user (bknr-request-user))) (when user - (with-query-params (req password password-repeat + (with-query-params (password password-repeat full-name (email (error "must provide email address"))) (when (not (equal password password-repeat)) @@ -99,9 +98,9 @@ (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name)))

- (when (admin-p (bknr-request-user req)) + (when (admin-p (bknr-request-user)) (let* ((all-flags (all-user-flags)) - (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (set-flags (keywords-from-query-param-list (query-param-list "flags"))) (unset-flags (set-difference all-flags set-flags))) (user-add-flags user set-flags) (user-remove-flags user unset-flags))) @@ -112,26 +111,26 @@ () (:report "You are not authorized to perform this operation"))

-(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) - (unless (admin-p (bknr-request-user req)) +(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user) + (unless (admin-p (bknr-request-user)) (error 'unauthorized-error)) (when user (delete-user user)) - (redirect "/user" req)) + (redirect "/user"))

-(defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) - (with-query-params (req login email full-name password password-repeat) +(defmethod handle-object-form ((handler user-handler) (action (eql :create)) user) + (with-query-params (login email full-name password password-repeat) (if (and password (not (equal password password-repeat))) (error "please enter the same password twice") (if login - (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((flags (keywords-from-query-param-list (query-param-list "keyword"))) (user (make-user login :email email :full-name full-name :password password :flags flags))) - (redirect (edit-object-url user) req)) + (redirect (edit-object-url user))) (error "please enter a login")))))

(define-bknr-webserver-module user

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 Tue Jan 29 07:19:19 2008 @@ -7,8 +7,6 @@

(defvar *website-modules* (make-hash-table :test #'equal))

-(defvar *req* nil "Current request") -(defvar *ent* nil "Current entity") (defvar *session* nil "Current session") (defvar *user* nil "Current user") (defvar *req-var-hash* nil "Request variables") @@ -16,67 +14,57 @@ (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args))

-(defmacro with-cookies ((request &rest names) &rest body) - (let ((cookies (gensym))) - `(let ((,cookies (get-cookie-values ,request))) - (let ,(mapcar #'(lambda (name) - `(,name (cookie-value ,cookies ,(symbol-name name)))) - names) - ,@body)))) +(defmacro with-cookies ((&rest names) &rest body) + `(let ,(mapcar #'(lambda (name) + `(,name (cookie-in ,(symbol-name name)))) + names) + ,@body))

-(defmacro with-query-params ((request &rest params) &rest body) +(defmacro with-query-params ((&rest params) &rest body) (let ((vars (loop for param in params when (and (symbolp param) (not (null param))) - collect (list param `(query-param ,request ,(symbol-name param))) + collect (list param `(get-parameter ,(symbol-name param))) when (consp param) collect (list (car param) - `(or (query-param ,request ,(symbol-name (car param))) + `(or (get-parameter ,(symbol-name (car param))) ,(second param)))))) (if vars `(let ,vars ,@body) (first body))))

-(defmacro form-case (request &rest cases) +(defmacro form-case (&rest cases) `(cond ,@(mapcar #'(lambda (c) (if (eql (car c) t) `(t ,@(cdr c)) - `((query-param ,request ,(symbol-name (car c))) - (with-query-params (,request ,@(cadr c)) + `((get-parameter ,(symbol-name (car c))) + (with-query-params (,@(cadr c)) ,@(cddr c))))) cases)))

-#+(or) -(form-case req - (import (keyword1 keyword2 keyword3 keyword4) - (list 'bla 'blob)) - (t (format nil "foo~%"))) - -#+nil -(defmacro with-bknr-session ((req) &rest body) - `(let* ((*req* ,req) - (*session* (bknr-request-session *req*)) - (*user* (bknr-session-user *session*))) +(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &rest body) + `(progn + (setf (content-type) ,content-type) + (setf (return-code) ,response) ,@body))

-(defmacro with-bknr-http-response ((req &rest args) &rest body) - `(with-http-response (,req *ent* ,@args) - (if (subtypep (type-of ,req) 'bknr-request) - (set-cookie-header ,req :name "bknr-sessionid" :value (bknr-session-id (bknr-request-session ,req)) :expires :never) - (warn "; not a bknr-request ~a within with-bknr-http-response~%" ,req)) +(defvar *html-stream*) + +(defmacro with-http-body ((&key external-format) &body body) + `(with-output-to-string (*html-stream*) ,@body))

-(defmacro with-image-from-uri ((image-variable *req* *ent* prefix) &rest body) +(defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (uri-path (request-uri ,*req*))) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (request-uri)) (unless match - (http-error ,*req* ,*ent* *response-bad-request* "bad request - missing image path or loid")) + (http-error +http-bad-request+ "bad request - missing image path or loid")) (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) (unless ,image-variable - (http-error ,*req* ,*ent* *response-not-found* "image not found")) + (http-error +http-not-found+ "image not found")) ,@body)))

(defmacro define-bknr-tag (name (&rest args) &rest body)

Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Tue Jan 29 07:19:19 2008 @@ -11,22 +11,18 @@

(defparameter *upload-file-size-limit* 5000000)

-(defun error-404 (req) - (with-bknr-http-response (req :response *response-not-found*) - (with-http-body (req *ent*) +(defun error-404 () + (with-http-response (:response +http-not-found+) + (with-http-body () (html "The page you requested could not be found."))))

-(defun redirect (to req) - (with-bknr-http-response (req :response *response-found*) - (setf (reply-header-slot-value req :location) to) - (with-http-body (req *ent*)))) - (defun redirect-uri (uri) (make-instance 'uri :path (uri-path uri) :query (uri-query uri)))

-(defun get-multipart-form-data (request) - (unless (getf (request-reply-plist request) 'multipart-parsed) +#+(or) +(defun get-multipart-form-data () + (unless (aux-request-value 'multipart-parsed) (let (parameters uploaded-files file-size-limit-reached) @@ -60,82 +56,72 @@ (get-all-multipart-data request :limit *upload-file-size-limit*))))) (when file-size-limit-reached (error "upload file size limit exceeded")) - (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) parameters) - (setf (getf (request-reply-plist request) 'uploaded-files) uploaded-files)))) + (setf (aux-request-value 'bknr-parsed-body-parameters) parameters) + (setf (aux-request-value 'uploaded-files) uploaded-files))))

-(defun get-urlencoded-form-data (request) - (loop for name-value in (form-urlencoded-to-query (get-request-body request)) - do (push name-value (getf (request-reply-plist request) 'bknr-parsed-body-parameters)))) +(defun get-urlencoded-form-data () + (format t "get-urlencoded-form-data not ported~%") + #+(or) + (loop for name-value in (form-urlencoded-to-query (get-request-body)) + do (push name-value (aux-request-value 'bknr-parsed-body-parameters))))

-(defun parse-request-body (request &key uploads) - (let ((content-type (header-slot-value request :content-type))) +(defun parse-request-body (&key uploads) + (let ((content-type (header-in :content-type))) (cond ((null content-type) nil) ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) + (format t "body parameters not parsed~%") + #+(or) (get-urlencoded-form-data request)) ((and uploads (scan #?r"^(?i)multipart/form-data" content-type)) - (get-multipart-form-data request))))) - -(defgeneric get-parameters-from-body (request) - (:documentation "Generic function to read in the parameters of a -request. This is a generic function because unauthorized request -bodies must not be completely read as that is done in the request -authorization phase. In this phase, processing must be fast and may -not return errors due to exceeded upload file size limits.")) - -(defmethod get-parameters-from-body ((request http-request)) - (parse-request-body request :uploads nil)) - -(defmethod get-parameters-from-body ((request bknr-request)) - (unless (getf (request-reply-plist request) 'body-parsed) - (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) nil) - (parse-request-body request :uploads t) - (setf (getf (request-reply-plist request) 'body-parsed) t))) + (format t "uploads not read~%") + #+(or) + (get-multipart-form-data)))))

-(defun request-uploaded-files (request &key all-info) +(defun request-uploaded-files (&key all-info) "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user. If :all-info is non-nil, the full upload file information is returned as a list" - (get-parameters-from-body request) + (format t "request-uploaded-files not yet ported~%") (if all-info - (getf (request-reply-plist request) 'uploaded-files) + (aux-request-value 'uploaded-files) (mapcar (lambda (upload) (cons (upload-name upload) (upload-pathname upload))) - (getf (request-reply-plist request) 'uploaded-files)))) + (aux-request-value 'uploaded-files))))

-(defun request-uploaded-file (request parameter-name) - (cdr (find parameter-name (request-uploaded-files request) :test #'equal :key #'car))) +(defun request-uploaded-file (parameter-name) + (cdr (find parameter-name (request-uploaded-files) :test #'equal :key #'car)))

-(defun all-request-params (request) +(defun all-request-params () "Return all non-empty request parameters - This includes all parameters encoded in the URL as well as those in the request body, either as urlencoded strings or as multipart body. If a multipart body is present in the request, any uploaded files are saved in a temporary file and noted in the -request's plist. Uploaded files will be automatically deleted by the with-bknr-http-response +request's plist. Uploaded files will be automatically deleted by the with-http-response macro after the request body has been executed." - (unless (getf (request-reply-plist request) 'bknr-parsed-parameters) - (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset="?([^"; ]+).*" (header-slot-value request :content-type)) charset) + (unless (aux-request-value 'bknr-parsed-parameters) + (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset="?([^"; ]+).*" (header-in :content-type)) charset) "utf-8"))) - (get-parameters-from-body request) - (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) + (declare (ignore request-charset)) + (format t "post parameters not read~%") + #+(or) + (setf (aux-request-value 'bknr-parsed-parameters) (mapcar (lambda (param) (cons (car param) (iconv:iconv request-charset "utf-8" (cdr param)))) - (remove "" (append (form-urlencoded-to-query (uri-query (request-uri request))) - (getf (request-reply-plist request) 'bknr-parsed-body-parameters)) + (remove "" (append (form-urlencoded-to-query (uri-query (request-uri))) + (aux-request-value 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) - (getf (request-reply-plist request) 'bknr-parsed-parameters)) + (aux-request-value 'bknr-parsed-parameters))

-(defun query-param (request param-name) - (let ((value (cdr (assoc param-name (all-request-params request) :test #'string-equal)))) +(defun query-param (param-name) + (let ((value (cdr (assoc param-name (all-request-params) :test #'string-equal)))) (when (equal "" value) (setf value nil)) value))

-(defun query-param-list (request param-name) - (assoc-values param-name (request-query request) :test #'string-equal)) - -(defun cookie-value (cookies param) - (cdr (assoc param cookies :test #'string-equal))) +(defun query-param-list (param-name) + (format *debug-io* "questionable: query-param-list~%") + (assoc-values param-name (request-query) :test #'string-equal))

(defun request-variable (var) (gethash var *req-var-hash*)) @@ -148,8 +134,8 @@ collect key collect (request-variable key)))

-(defun http-error (req response message) - (with-bknr-page (req :title #?"error: $(message)" :response response) +(defun http-error (response message) + (with-bknr-page (:title #?"error: $(message)" :response response) (:princ-safe message)) (finish-output *html-stream*) (error message)) @@ -170,17 +156,17 @@ (#< "&lt;") (#> "&gt;")))))

-(defun parse-url (req) - (values-list (cddr (mapcar #'uridecode-string (split "/" (uri-path (request-uri req))))))) +(defun parse-url () + (values-list (cddr (mapcar #'url-decode (split "/" (request-uri))))))

-(defun last-url-component (req) +(defun last-url-component () (register-groups-bind (last) - ("/([^\/]+)$" (uri-path (request-uri req))) + ("/([^\/]+)$" (request-uri)) last))

-(defun parse-date-field (name req) +(defun parse-date-field (name) (let ((timespec (mapcar #'(lambda (var) (parse-integer - (query-param req (concatenate 'string name "-" var)) + (get-parameter (concatenate 'string name "-" var)) :junk-allowed t)) '("minute" "hour" "day" "month" "year")))) (unless (car timespec) @@ -191,15 +177,15 @@ (apply #'encode-universal-time 0 timespec) nil)))

-(defun bknr-url-path (handler req) +(defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" (let ((len (length (page-handler-prefix handler)))) - (subseq (uri-path (request-uri req)) len))) + (subseq (request-uri) len)))

-(defun self-url (req &key command prefix) +(defun self-url (&key command prefix) (destructuring-bind (empty old-prefix object-id &rest old-command) - (split "/" (uri-path (request-uri req))) + (split "/" (request-uri)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))"))

@@ -293,4 +279,4 @@ (princ " />"))))

(defun encode-urlencoded (string) - (url-encode string)) \ No newline at end of file +(regex-replace-all #?r"+" (url-encode string) "%20"))

Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/m2.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/m2.lisp Tue Jan 29 07:19:19 2008 @@ -352,6 +352,9 @@ retval))

(defun string-safe (string) + (format t "check encoding of sponsor name~%") + (or string "") + #+(or) (if string (escape-nl (with-output-to-string (s) (net.html.generator::emit-safe s string)))

Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp Tue Jan 29 07:19:19 2008 @@ -226,8 +226,8 @@ (unless (contract-download-only-p contract) (delete-file (contract-pdf-pathname contract :print t))))

-(defun mail-backoffice-sponsor-data (contract req) - (with-query-params (req numsqm country email name address date language) +(defun mail-backoffice-sponsor-data (contract) + (with-query-params (numsqm country email name address date language) (let ((parts (list (make-html-part (format nil " <html> <body> @@ -246,7 +246,7 @@ name address email)) - (make-contract-xml-part (store-object-id contract) (all-request-params req)) + (make-contract-xml-part (store-object-id contract) (all-request-params)) (make-vcard-part (store-object-id contract) (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) :note (format nil "Paid-by: Back office @@ -264,8 +264,8 @@ :email email))))) (mail-contract-data contract "Manually entered sponsor" parts))))

-(defun mail-manual-sponsor-data (req) - (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) +(defun mail-manual-sponsor-data () + (with-query-params (contract-id vorname name strasse plz ort email telefon donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) (parts (list (make-html-part (format nil " @@ -296,7 +296,7 @@ vorname name strasse plz ort email telefon (if donationcert-yearly "ja" "nein") *website-url* contract-id email)) - (make-contract-xml-part contract-id (all-request-params req)) + (make-contract-xml-part contract-id (all-request-params)) (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id :note (format nil "Paid-by: Manual money transfer Contract ID: ~A @@ -331,8 +331,8 @@ (remhash contract-id *worldpay-params-hash*)) (error "cannot find WorldPay callback params for contract ~A~%" contract-id)))

-(defun mail-worldpay-sponsor-data (req) - (with-query-params (req contract-id) +(defun mail-worldpay-sponsor-data () + (with-query-params (contract-id) (let* ((contract (store-object-with-id (parse-integer contract-id))) (params (get-worldpay-params contract-id)) (parts (list (make-html-part (format nil "

Modified: branches/trunk-reorg/projects/bos/web/package.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/package.lisp (original) +++ branches/trunk-reorg/projects/bos/web/package.lisp Tue Jan 29 07:19:19 2008 @@ -1,4 +1,4 @@ (in-package :cl-user)

(defpackage :bos.web - (:use :cl :net.aserve :net.html.generator)) + (:use :cl :hunchentoot :xhtml-generator))

Modified: branches/trunk-reorg/projects/bos/web/web.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/web.lisp (original) +++ branches/trunk-reorg/projects/bos/web/web.lisp Tue Jan 29 07:19:19 2008 @@ -36,6 +36,8 @@ :worldpay-test-mode *worldpay-test-mode*) (format t "~&; Starting aserve~@[ in debug mode~].~%" debug) (force-output) + (format t "Hunchentoot startup not implemented~%") + #+(or) (setq *webserver* (if debug (progn (net.aserve::debug-on :notrap)

Modified: branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,7 +6,7 @@ (defclass allocation-area-handler (admin-only-handler edit-object-handler) ())

-(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)) req) +(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil))) (with-bos-cms-page (req :title "Allocation Areas") (html (:h2 "Defined allocation areas") @@ -27,7 +27,7 @@ (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) (:p (cmslink "create-allocation-area" "Create new allocation area")))))

-(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req) +(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) (with-bos-cms-page (req :title "Allocation Area") (with-slots (active-p left top width height) allocation-area (html @@ -75,7 +75,7 @@ do (html (:td ((:a :href #?"/enlarge-overview/$(tile-x)/$(tile-y)") ((:img :width "90" :height "90" :border "0" :src #?"/overview/$(tile-x)/$(tile-y)"))))))))))))))

-(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area req) +(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area) (delete-object allocation-area) (with-bos-cms-page (req :title "Allocation area has been deleted") (:h2 "The allocation area has been deleted"))) @@ -83,7 +83,7 @@ (defclass allocation-area-gfx-handler (admin-only-handler object-handler) ())

-(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) +(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) (cl-gd:with-image* ((allocation-area-width allocation-area) (allocation-area-height allocation-area) t) (with-slots (left top width height) allocation-area @@ -123,13 +123,13 @@ do (incf dest-x copy-width)) do (incf dest-y copy-height)) (cl-gd:draw-polygon vertices :color (elt colors 1)) - (emit-image-to-browser req cl-gd:*default-image* :png))))) + (emit-image-to-browser cl-gd:*default-image* :png)))))

(defclass create-allocation-area-handler (admin-only-handler form-handler) ())

-(defmethod handle-form ((handler create-allocation-area-handler) action req) - (with-query-params (req x y left top) +(defmethod handle-form ((handler create-allocation-area-handler) action) + (with-query-params (x y left top) (cond ((and x y left top) (destructuring-bind (x y left top) (mapcar #'parse-integer (list x y left top)) @@ -140,15 +140,15 @@ (:h2 "Choose upper left corner first, then lower-right corner")) (redirect (format nil "/allocation-area/~D" (store-object-id (make-allocation-rectangle left top (- x left) (- y top)))) - req)))) + )))) ((and x y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" x y (uriencode-string "Choose lower right point of allocation area") (uriencode-string (format nil "~A?left=~A&top=~A&" - (uri-path (request-uri req)) + (uri-path (request-uri)) x y))) - req)) + )) (t (with-bos-cms-page (req :title "Create allocation area") ((:form :method "POST" :enctype "multipart/form-data")) @@ -163,16 +163,16 @@ (:tr (:td "Start-Y") (:td (text-field "start-y" :value 0 :size 5))) (:tr (:td (submit-button "rectangle" "rectangle")))))))))

-(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)) req) - (with-query-params (req start-x start-y) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle))) + (with-query-params (start-x start-y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" start-x start-y (uriencode-string "Choose upper left point of allocation area") - (uriencode-string (format nil "~A?" (uri-path (request-uri req))))) - req))) + (uriencode-string (format nil "~A?" (uri-path (request-uri))))) + )))

-(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req) - (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car)))) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) + (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) (cond ((not uploaded-text-file) (with-bos-cms-page (req :title "No Text file uploaded")

Modified: branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,19 +6,19 @@ (defvar *xml-sink*)

(defmacro with-xml-response (req &body body) - `(with-http-response (,req *ent* :content-type "text/xml") + `((with-http-response (:content-type "text/xml") (with-query-params (,req download) (when download (setf (reply-header-slot-value ,req :content-disposition) (format nil "attachment; filename=~A" download)))) - (with-http-body (,req *ent*) - (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) + (with-http-body () + (let ((*xml-sink* (make-character-stream-sink *html-stream* :canonical nil))) (with-xml-output *xml-sink* (with-element "response" ,@body))))))

(defmacro with-xml-error-handler (req &body body) - (declare (ignore req)) + (declare (ignore)) `(handler-case (progn ,@body) (error (e) @@ -30,8 +30,8 @@ (defclass boi-handler (page-handler) ())

-(defmethod authorized-p ((handler boi-handler) req) - (let ((user (bknr-request-user req))) +(defmethod authorized-p ((handler boi-handler)) + (let ((user (bknr-request-user))) (or (admin-p user) (user-has-flag user :boi))))

@@ -46,9 +46,9 @@ (error "Invalid sponsor ID (wrong type)")) sponsor))

-(defmethod handle ((handler create-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req num-sqm country sponsor-id name paid expires) +(defmethod handle ((handler create-contract-handler)) + (with-xml-error-handler () + (with-query-params (num-sqm country sponsor-id name paid expires) (setf num-sqm (ignore-errors (parse-integer num-sqm :junk-allowed t))) (unless num-sqm (error "missing or invalid num-sqm parameter")) @@ -79,9 +79,9 @@ (defclass pay-contract-handler (boi-handler) ())

-(defmethod handle ((handler pay-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id name) +(defmethod handle ((handler pay-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id name) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id)) @@ -91,7 +91,7 @@ (with-transaction (:contract-paid) (contract-set-paidp contract (format nil "~A: manually set paid by ~A" (format-date-time) - (user-login (bknr-request-user req)))) + (user-login (bknr-request-user)))) (when name (setf (user-full-name (contract-sponsor contract)) name)))) (with-xml-response () @@ -103,9 +103,9 @@ (defclass cancel-contract-handler (boi-handler) ())

-(defmethod handle ((handler cancel-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id) +(defmethod handle ((handler cancel-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,7 +9,7 @@

(defparameter *show-m2s* 5)

-(defmethod handle-object ((handler contract-handler) contract req) +(defmethod handle-object ((handler contract-handler) contract) (with-bos-cms-page (req :title "Displaying contract details") ((:table :border "0") (:tr (:td "sponsor")

Modified: branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp Tue Jan 29 07:19:19 2008 @@ -7,7 +7,7 @@ () (:default-initargs :class 'contract))

-(defmethod handle-object ((handler contract-image-handler) contract req) +(defmethod handle-object ((handler contract-image-handler) contract) "Create and return a GD image of the contract. The returned rectangular image will have the size of the contracts' bounding box. All square meters will have yellow color, the background will be transparent." @@ -17,7 +17,7 @@ ;; We manipulate pixels in a temporary array which is copied to the GD image as ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. (let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0)) - (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00")))) + (color (parse-color (or (second (decoded-handler-path handler)) "ffff00")))) (flet ((set-pixel (x y) (decf x left) (decf y top) @@ -27,4 +27,4 @@ (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (setf (cl-gd:raw-pixel) (aref work-array x y))))) - (emit-image-to-browser req cl-gd:*default-image* :png :cache-sticky t)))) \ No newline at end of file + (emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t)))) \ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ (defclass languages-handler (admin-only-handler form-handler) ())

-(defmethod handle-form ((handler languages-handler) action req) +(defmethod handle-form ((handler languages-handler) action) (with-bos-cms-page (req :title "Languages") (case action (:add (handler-case - (with-query-params (req code name) + (with-query-params (code name) (when (and code name) (make-object 'website-language :code code :name name) (html (:h2 "Language " (:princ-safe code) " (" (:princ-safe name) ") created")))) @@ -17,7 +17,7 @@ (html (:h2 "Error creating language") (:pre (:princ-safe e)))))) (:delete (handler-case - (with-query-params (req delete-code) + (with-query-params (delete-code) (when delete-code (delete-object (language-with-code delete-code)) (html (:h2 "Language " (:princ-safe delete-code) " deleted"))))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp Tue Jan 29 07:19:19 2008 @@ -18,7 +18,7 @@ (defclass map-browser-handler (prefix-handler) ())

-(defun decode-coords-in-handler-path (handler req) +(defun decode-coords-in-handler-path (handler) (labels ((ensure-valid-coordinates (x y) (setq x (parse-integer x)) (setq y (parse-integer y)) @@ -30,29 +30,29 @@ (<= 0 y 10800)) (error "invalid coordinates ~A/~A" x y)) (list x y))) - (with-query-params (req xcoord ycoord) + (with-query-params (xcoord ycoord) (when (and xcoord ycoord) (return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord)))) - (let ((handler-arguments (decoded-handler-path handler req))) + (let ((handler-arguments (decoded-handler-path handler))) (when (and handler-arguments (< 1 (length handler-arguments))) (apply #'ensure-valid-coordinates handler-arguments)))))

-(defmethod handle ((handler map-browser-handler) req) - (with-query-params (req chosen-url) +(defmethod handle ((handler map-browser-handler)) + (with-query-params (chosen-url) (when chosen-url (setf (session-variable :chosen-url) chosen-url))) - (with-query-params (req view-x view-y) - (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string req) - (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler req) - (with-query-params (req action) + (with-query-params (view-x view-y) + (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) + (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler) + (with-query-params (action) (when (equal action "save") (if (session-variable :chosen-url) (redirect (format nil "~Ax=~D&y=~D" (session-variable :chosen-url) point-x point-y) - req) + ) (with-bos-cms-page (req :title "Map Point Chooser") (html (:princ-safe "You chose " point-x " / " point-y)))) (return-from handle t))) @@ -71,14 +71,14 @@ (click-coord-y (+ (tile-nw-y start-tile) click-y))) (setq point-x click-coord-x point-y click-coord-y) - (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y) req) + (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y)) (return-from handle t))) (cond ((and click-y (not point-y)) - (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)) req)) + (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)))) (point-y (with-bos-cms-page (req :title "Map Point Chooser") - (with-query-params (req heading) + (with-query-params (heading) (when heading (html (:h2 (:princ-safe heading))))) (html @@ -131,7 +131,7 @@ ((:div :id "cursor" :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible") ((:img :src "/images/map-cursor.png"))))))) - (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) + (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) (t (with-bos-cms-page (req :title "Map Point Chooser") (html

Modified: branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -34,7 +34,7 @@ (:tr (:td "Y:") (:td (text-field "ycoord" :size "5" :value y))) (:tr ))) (:td - (with-query-params (req background areas contracts) + (with-query-params (background areas contracts) ;; xxx should use tile-layers (unless (or background areas contracts) (setq background t @@ -52,15 +52,15 @@ (defclass image-tile-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler image-tile-handler) req) - (destructuring-bind (x y &rest operations) (decoded-handler-path handler req) +(defmethod object-handler-get-object ((handler image-tile-handler)) + (destructuring-bind (x y &rest operations) (decoded-handler-path handler) (declare (ignore operations)) (setf x (parse-integer x)) (setf y (parse-integer y)) (ensure-map-tile x y)))

-(defmethod handle-object ((handler image-tile-handler) (tile (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((handler image-tile-handler) (tile (eql nil))) + (error-404))

(defun parse-operations (&rest operation-strings) (mapcar #'(lambda (operation-string) @@ -68,46 +68,48 @@ (apply #'list (make-keyword-from-string operation) arguments))) operation-strings))

-(defmethod handle-object ((handler image-tile-handler) tile req) +(defmethod handle-object ((handler image-tile-handler) tile) ;; xxx parse url another time - the parse result of ;; object-handler-get-object should really be kept in the request - (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler req) + (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) (declare (ignore x y)) (let ((changed-time (image-tile-changed-time tile)) - (ims (header-slot-value req :if-modified-since))) + (ims (header-in :if-modified-since))) + (format t "ims for hunchentoot not implemented~%") + #+(or) (setf (net.aserve::last-modified *ent*) changed-time) #+(or) (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) (if (or (not ims) (> changed-time (date-to-universal-time ims))) (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) - (emit-image-to-browser req image :png + (emit-image-to-browser image :png :date changed-time :max-age 60) (cl-gd:destroy-image image)) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () ; do nothing ))))))

(defclass enlarge-tile-handler (image-tile-handler) ())

-(defun tile-active-layers-from-request-params (tile req) +(defun tile-active-layers-from-request-params (tile) (let (active-layers (all-layer-names (mapcar #'symbol-name (image-tile-layers tile)))) (dolist (layer-name all-layer-names) - (when (query-param req layer-name) + (when (query-param layer-name) (push layer-name active-layers))) (or (reverse active-layers) all-layer-names)))

-(defun tile-url (tile x y req) +(defun tile-url (tile x y) (format nil "/overview/~D/~D~(~{/~A~}~)" x y - (tile-active-layers-from-request-params tile req))) + (tile-active-layers-from-request-params tile)))

-(defmethod handle-object ((handler enlarge-tile-handler) tile req) - (let ((ismap-coords (decode-ismap-query-string req)) +(defmethod handle-object ((handler enlarge-tile-handler) tile) + (let ((ismap-coords (decode-ismap-query-string)) (tile-x (tile-nw-x tile)) (tile-y (tile-nw-y tile))) (if ismap-coords @@ -116,10 +118,10 @@ (m2 (get-m2 x y)) (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) (if contract-id - (redirect #?"/contract/$(contract-id)" req) + (redirect #?"/contract/$(contract-id)") (with-bos-cms-page (req :title "Not sold") (html (:h2 "this square meter has not been sold yet"))))) (with-bos-cms-page (req :title "Browsing tile") - (:a ((:a :href (uri-path (request-uri req))) - ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) - (map-navigator req tile-x tile-y "/enlarge-overview/"))))) \ No newline at end of file + (:a ((:a :href (uri-path (request-uri))) + ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y))))) + (map-navigator tile-x tile-y "/enlarge-overview/"))))) \ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,10 +9,10 @@ (defclass edit-news-handler (admin-only-handler edit-object-handler) ())

-(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) +(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) (let ((language (session-variable :language))) (with-bos-cms-page (req :title "Choose news item to edit") - (content-language-chooser req) + (content-language-chooser) (if (all-news-items) (html (:h2 "Choose existing news item") @@ -28,13 +28,13 @@ ((:form :method "post") (submit-button "new" "new")))))

-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) - (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req)) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil))) + (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item)))))

-(defmethod handle-object-form ((handler edit-news-handler) action news-item req) +(defmethod handle-object-form ((handler edit-news-handler) action news-item) (let ((language (session-variable :language))) (with-bos-cms-page (req :title "Edit news item") - (content-language-chooser req) + (content-language-chooser) ((:script :type "text/javascript") "tinyMCE.init({ mode : 'textareas', theme : 'advanced' });") ((:form :method "post") @@ -47,15 +47,15 @@ :value (news-item-text news-item language)))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?"))))))))

-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) (let ((language (session-variable :language))) - (with-query-params (req title text) + (with-query-params (title text) (update-news-item news-item language :title title :text text) (with-bos-cms-page (req :title "News item updated") (:h2 "Your changes have been saved") "You may " (cmslink (edit-object-url news-item) "continue editing the news item")))))

-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item) (delete-object news-item) (with-bos-cms-page (req :title "News item has been deleted") (:h2 "The news item has been deleted"))) \ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp Tue Jan 29 07:19:19 2008 @@ -8,12 +8,11 @@ :cl-user :cl-interpol :cl-ppcre - :net.aserve - :net.aserve.client + :hunchentoot :xhtml-generator :cxml :puri - #+(or) :mime + :cl-mime :acl-compat.socket :bknr.web :bknr.datastore @@ -27,5 +26,4 @@ :bos.m2.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,8 +6,8 @@ (defclass make-poi-handler (page-handler) ())

-(defmethod handle ((handler make-poi-handler) req) - (with-query-params (req name) +(defmethod handle ((handler make-poi-handler)) + (with-query-params (name) (cond ((find-store-object name :class 'poi) (with-bos-cms-page (req :title "Duplicate POI name") @@ -18,13 +18,13 @@ (html (:h2 "Bad technical name") "Please use only alphanumerical characters, - and _ for technical POI names"))) (t - (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) + (redirect (edit-object-url (make-poi (session-variable :language) name)))))))

(defclass edit-poi-handler (admin-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi))

-(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)) req) +(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil))) (with-bos-cms-page (req :title "Choose POI") (if (store-objects-with-class 'poi) (html @@ -50,8 +50,8 @@ (html ((:img :src #?"/images/$(icon).gif")))))

(defmethod handle-object-form ((handler edit-poi-handler) - action (poi poi) req) - (with-query-params (req language shift shift-by) + action (poi poi)) + (with-query-params (language shift shift-by) (unless language (setq language (session-variable :language))) (when shift ;; change image order @@ -67,7 +67,7 @@ (change-slot-values poi 'bos.m2::images new-images))) (setf (session-variable :language) language) (with-bos-cms-page (req :title "Edit POI") - (content-language-chooser req) + (content-language-chooser) (unless (poi-complete poi language) (html (:h2 "This POI is not complete in the current language - Please check that " "the location and all text fields are set and that at least one image " @@ -95,11 +95,11 @@ (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri))))) "[relocate]")) (t (cmslink (format nil "map-browser/?chosen-url=~A" - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri))))) "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) @@ -167,8 +167,8 @@ (submit-button "delete" "delete" :confirm "Really delete the POI?"))))))))

(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :save)) (poi poi) req) - (with-query-params (req published title subtitle description language x y icon movie) + (action (eql :save)) (poi poi)) + (with-query-params (published title subtitle description language x y icon movie) (unless language (setq language (session-variable :language))) (let ((args (list :title title :published published @@ -187,8 +187,8 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-airal)) (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + ) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -207,30 +207,30 @@ (change-slot-values poi 'airals (list (import-image uploaded-file :class-name 'store-image)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi))))

(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-airal)) (poi poi) - req) + ) (let ((airals (poi-airals poi))) (change-slot-values poi 'airals nil) (mapc #'delete-object airals)) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi))))

(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-movie)) (poi poi) - req) + ) (change-slot-values poi 'movies nil) - (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) + (redirect (format nil "/edit-poi/~D" (store-object-id poi))))

(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-panorama)) (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + ) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -240,21 +240,21 @@ :class-name 'store-image) (poi-panoramas poi)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi))))

(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-panorama)) (poi poi) - req) - (with-query-params (req panorama-id) + ) + (with-query-params (panorama-id) (let ((panorama (find-store-object (parse-integer panorama-id)))) (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi))) (mapc #'delete-object panorama))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi))))

(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete)) (poi poi) req) + (action (eql :delete)) (poi poi)) (delete-object poi) (with-bos-cms-page (req :title "POI has been deleted") (html (:h2 "POI has been deleted") @@ -266,8 +266,8 @@ () (:default-initargs :object-class 'poi-image))

-(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)) req) - (with-query-params (req poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil))) + (with-query-params (poi) (with-bos-cms-page (req :title "Upload new POI image") (html (:h2 "Upload new image") @@ -276,10 +276,10 @@ (:p "Choose a file: " ((:input :type "file" :name "image-file"))) (:p (submit-button "upload" "upload"))))))

-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image req) - (with-query-params (req poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image) + (with-query-params (poi) (setq poi (find-store-object (parse-integer poi) :class 'poi)) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -302,15 +302,15 @@ :initargs `(:poi ,poi)))) (redirect (format nil "/edit-poi-image/~D?poi=~D" (store-object-id poi-image) - (store-object-id poi)) req)))) + (store-object-id poi))))))

-(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image req) - (with-query-params (req language poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) + (with-query-params (language poi) (unless language (setq language (session-variable :language))) (with-bos-cms-page (req :title "Edit POI Image") (html (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI") - (content-language-chooser req) + (content-language-chooser) ((:form :method "post" :enctype "multipart/form-data") ((:input :type "hidden" :name "poi" :value poi)) (:table (:tr (:td "thumbnail") @@ -334,8 +334,8 @@ :cols 40))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the image?")))))))))

-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image req) - (with-query-params (req title subtitle description language) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) + (with-query-params (title subtitle description language) (unless language (setq language (session-variable :language))) (update-poi-image poi-image language :title title @@ -345,7 +345,7 @@ (:h2 "The POI image information has been updated") "You may " (cmslink (edit-object-url poi-image) "continue editing the POI image"))))

-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image req) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image) (let ((poi (poi-image-poi poi-image))) (delete-object poi-image) (with-bos-cms-page (req :title "POI image has been deleted") @@ -363,28 +363,26 @@ (sponsor-country (contract-sponsor contract)) (length (contract-m2s contract))))

-(defmethod handle ((handler poi-javascript-handler) req) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) - (let ((*standard-output* *html-stream*)) - (princ "<script language="JavaScript">") (terpri) - (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) - (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) - (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) - (princ "</script>") (terpri))))) +(defmethod handle ((handler poi-javascript-handler)) + (with-http-response (:content-type "text/html; charset=UTF-8") + (no-cache) + (with-http-body () + (let ((*standard-output* *html-stream*)) + (princ "<script language="JavaScript">") (terpri) + (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) + (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) + (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) + (princ "</script>") (terpri)))))

(defclass poi-image-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi))

-(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)) req) +(defmethod handle-object ((handler poi-image-handler) (poi (eql nil))) (error "poi not found"))

-(defmethod handle-object ((handler poi-image-handler) poi req) - (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler req)) +(defmethod handle-object ((handler poi-image-handler) poi) + (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler)) (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index)) @@ -392,6 +390,6 @@ (redirect (format nil "/image/~D~@[~{/~a~}~]" (store-object-id (nth image-index (poi-images poi))) imageproc-arguments) - req) + ) (error "image index ~a out of bounds for poi ~a" image-index poi)))))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp Tue Jan 29 07:19:19 2008 @@ -19,9 +19,9 @@ (declare (ignore second minute hour date month day-of-week is-dst tz)) year))

-(defmethod handle ((handler reports-xml-handler) req) +(defmethod handle ((handler reports-xml-handler)) (with-xml-response req - (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req) + (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler) (setf *year* (and *year* (parse-integer *year*))) (let ((*contracts-to-process* (sort (remove-if (lambda (contract) (or (not (contract-paidp contract))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,23 +6,23 @@ (defclass search-sponsors-handler (admin-only-handler form-handler) ())

-(defmethod handle-form ((handler search-sponsors-handler) action req) +(defmethod handle-form ((handler search-sponsors-handler) action) (with-bos-cms-page (req :title "Search for sponsor")))

(defclass edit-sponsor-handler (admin-only-handler edit-object-handler) ())

-(defmethod object-handler-get-object ((handler edit-sponsor-handler) req) - (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler req))))))) +(defmethod object-handler-get-object ((handler edit-sponsor-handler)) + (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler))))))) (typecase object (sponsor object) (contract (contract-sponsor object)) (otherwise nil))))

-(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)) req) - (with-query-params (req id key count) +(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil))) + (with-query-params (id key count) (when id - (redirect #?"/edit-sponsor/$(id)" req) + (redirect #?"/edit-sponsor/$(id)") (return-from handle-object-form)) (when (or key count) (let ((regex (format nil "(?i)~A" key)) @@ -90,22 +90,22 @@ (defun date-to-universal (date-string) (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"." date-string))))

-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req) - (with-query-params (req numsqm country email name address date language) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil))) + (with-query-params (numsqm country email name address date language) (let* ((sponsor (make-sponsor :email email :country country)) (contract (make-contract sponsor (parse-integer numsqm) :paidp (format nil "~A: manually created by ~A" (format-date-time (get-universal-time)) - (user-login (bknr-request-user req))) + (user-login (bknr-request-user))) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) - (mail-backoffice-sponsor-data contract req) - (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req)))) + (mail-backoffice-sponsor-data contract) + (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor))))))

(defun contract-checkbox-name (contract) (format nil "contract-~D-paid" (store-object-id contract)))

-(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor) (with-bos-cms-page (req :title "Edit Sponsor") (html ((:form :method "post") @@ -154,28 +154,28 @@ (:p (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete this sponsor?"))))))

-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor) (let (changed) (with-bos-cms-page (req :title "Saving sponsor data") (dolist (field-name '(full-name email password country info-text)) - (let ((field-value (query-param req (string-downcase (symbol-name field-name))))) + (let ((field-value (query-param (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) (change-slot-values sponsor field-name field-value) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor)) - (when (and (query-param req (contract-checkbox-name contract)) + (when (and (query-param (contract-checkbox-name contract)) (not (contract-paidp contract))) (change-slot-values contract 'paidp t) (setf changed t) (html (:p "Changed contract status to "paid"")))) (unless changed (html (:p "No changes have been made"))) - (html (cmslink (uri-path (request-uri req)) + (html (cmslink (uri-path (request-uri)) "Return to sponsor profile")))))

-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor) (with-bos-cms-page (req :title "Sponsor deleted") (delete-object sponsor) (html (:p "The sponsor has been deleted")))) @@ -184,16 +184,16 @@ () (:default-initargs :object-class 'contract))

-(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)) req) +(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil))) (with-bos-cms-page (req :title "Invalid contract ID") (html "Invalid contract ID, maybe the sponsor or the contract has been deleted")))

-(defmethod handle-object-form ((handler complete-transfer-handler) action contract req) +(defmethod handle-object-form ((handler complete-transfer-handler) action contract) (if (contract-paidp contract) (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))) req) (let ((numsqm (length (contract-m2s contract)))) - (with-query-params (req email) + (with-query-params (email) (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment") (html ((:form :name "form") @@ -214,8 +214,8 @@ (:td (text-field "email" :size 20 :value email))) (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()")))))))))))

-(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req) - (with-query-params (req email country language) +(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract) + (with-query-params (email country language) (with-bos-cms-page (req :title "Square meter sale completion") (if (contract-paidp contract) (html (:h2 "This sale has already been completed")) @@ -223,7 +223,7 @@ (html (:h2 "Completing square meter sale")) (sponsor-set-country (contract-sponsor contract) country) (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A" - (format-date-time) (user-login (bknr-request-user req)))) + (format-date-time) (user-login (bknr-request-user)))) (when email (html (:p "Sending instruction email to " (:princ-safe email))) (mail-instructions-to-sponsor contract email)))) @@ -233,8 +233,8 @@ (defclass m2-javascript-handler (prefix-handler) ())

-(defmethod handle ((handler m2-javascript-handler) req) - (multiple-value-bind (sponsor-id-or-x y) (parse-url req) +(defmethod handle ((handler m2-javascript-handler)) + (multiple-value-bind (sponsor-id-or-x y) (parse-url) (let ((sponsor (cond (y (let ((m2 (get-m2 (parse-integer sponsor-id-or-x) (parse-integer y)))) @@ -243,10 +243,10 @@ (sponsor-id-or-x (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor)) (t - (when (eq (find-class 'sponsor) (class-of (bknr-request-user req))) - (bknr-request-user req)))))) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (with-http-body (req *ent*) + (when (eq (find-class 'sponsor) (class-of (bknr-request-user))) + (bknr-request-user)))))) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () (let ((*standard-output* *html-stream*)) (princ "<script language="JavaScript">") (terpri) (princ "var profil;") (terpri) @@ -258,16 +258,14 @@ (defclass sponsor-login-handler (page-handler) ())

-(defmethod handle ((handler sponsor-login-handler) req) - (with-query-params (req __sponsorid) - (with-bknr-http-response (req :content-type "text/html") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) +(defmethod handle ((handler sponsor-login-handler)) + (with-query-params (__sponsorid) + (with-http-response (:content-type "text/html") + (no-cache) + (with-http-body () (format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%" (cond - ((eq (find-class 'sponsor) (class-of (bknr-request-user req))) + ((eq (find-class 'sponsor) (class-of (bknr-request-user))) "logged-in") (__sponsorid "login-failed") @@ -278,8 +276,8 @@ () (:default-initargs :class 'contract))

-(defmethod object-handler-get-object ((handler cert-regen-handler) req) - (let* ((object-id-string (first (decoded-handler-path handler req))) +(defmethod object-handler-get-object ((handler cert-regen-handler)) + (let* ((object-id-string (first (decoded-handler-path handler))) (object (store-object-with-id (parse-integer object-id-string)))) (cond ((contract-p object) @@ -288,7 +286,7 @@ (first (sponsor-contracts object))) (t (error "invalid sponsor or contract id ~A" object-id-string)))))

-(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract) req) +(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract)) (with-bos-cms-page (req :title "Re-generate Certificate") (html ((:form :name "form") @@ -307,12 +305,12 @@ (html (:tr (:td (submit-button "regenerate" "regenerate")))))))))

-(defun confirm-cert-regen (req) +(defun confirm-cert-regen () (with-bos-cms-page (req :title "Certificate generation request has been created") (html "Your certificate generation request has been created, please wait a few seconds before checking the PDF file")))

-(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req) - (with-query-params (req name address language) +(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract)) + (with-query-params (name address language) (bos.m2::make-certificate contract name :address address :language language)) - (confirm-cert-regen req)) \ No newline at end of file + (confirm-cert-regen)) \ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp Tue Jan 29 07:19:19 2008 @@ -27,9 +27,8 @@ ((:p :class "footer") "local time is " (:princ-safe (format-date-time)) " - " - (if (and (equal 'bknr-request (type-of *req*)) - (bknr-request-user *req*)) - (html "logged in as " (html-link (bknr-request-user *req*))) + (if (bknr-request-user) + (html "logged in as " (html-link (bknr-request-user))) (html "not logged in")) " - current content language is " (cmslink "change-language" @@ -46,21 +45,21 @@ (setf (session-variable :language) *default-language*)) (session-variable :language))

-(defun content-language-chooser (req) +(defun content-language-chooser () (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (uri-path (request-uri req)) language-symbol) + (html (cmslink (format nil "~A?language=~A" (uri-path (request-uri)) language-symbol) (:princ-safe language-name))))) (if (equal (session-variable :language) language-symbol) (html "[" (show-language-link) "]") (html (show-language-link))) (html " "))))))

-(defun decode-ismap-query-string (req) - (let ((coord-string (caar (request-query req)))) +(defun decode-ismap-query-string () + (let ((coord-string (caar (request-query)))) (when (and coord-string (scan #?r"^\d*,\d*$" coord-string)) (mapcar #'parse-integer (split "," coord-string)))))

Modified: branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp Tue Jan 29 07:19:19 2008 @@ -44,7 +44,7 @@ (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) (call-next-method handler template-name))

-(defmethod initial-template-environment ((expander worldpay-template-handler) req) +(defmethod initial-template-environment ((expander worldpay-template-handler)) (append (list (cons :website-url *website-url*)) (call-next-method)))

@@ -65,11 +65,11 @@ (when (website-supports-language language) language)))

-(defun find-browser-prefered-language (req) +(defun find-browser-prefered-language () "Determine the language prefered by the user, as determined by the Accept-Language header present in the HTTP request. Header decoding is done according to RFC2616, considering individual language preference weights." - (let ((accept-language (header-slot-value req :accept-language))) + (let ((accept-language (header-slot-value :accept-language))) (dolist (language (mapcar #'car (sort (mapcar #'(lambda (language-spec-string) (if (find #; language-spec-string) @@ -90,39 +90,39 @@ (defclass index-handler (page-handler) ())

-(defmethod handle ((handler index-handler) req) - (redirect (format nil "/~A/index" (or (find-browser-prefered-language req) +(defmethod handle ((handler index-handler)) + (redirect (format nil "/~A/index" (or (find-browser-prefered-language) *default-language*)) - req)) + ))

(defclass infosystem-handler (page-handler) ())

-(defmethod handle ((handler infosystem-handler) req) +(defmethod handle ((handler infosystem-handler)) ;; XXX hier logout-parameter implementieren - (with-query-params (req logout) + (with-query-params (logout) (when logout - (bknr.web::drop-session (bknr-request-session req)))) + (bknr.web::drop-session (bknr-request-session)))) (let ((language (session-variable :language))) - (redirect #?"/infosystem/$(language)/satellitenkarte.htm" req))) + (redirect #?"/infosystem/$(language)/satellitenkarte.htm")))

(defclass certificate-handler (object-handler) () (:default-initargs :class 'contract))

-(defmethod handle-object ((handler certificate-handler) contract req) +(defmethod handle-object ((handler certificate-handler) contract) (unless contract - (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req))))) - (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req)) + (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user))))) + (redirect (format nil "/certificates/~D.pdf" (store-object-id contract))))

(defclass statistics-handler (admin-only-handler prefix-handler) ())

-(defmethod handle ((handler statistics-handler) req) - (let ((stats-name (parse-url req))) +(defmethod handle ((handler statistics-handler)) + (let ((stats-name (parse-url))) (cond (stats-name - (redirect (format nil "~A.svg" stats-name) req)) + (redirect (format nil "~A.svg" stats-name))) (t (with-bos-cms-page (req :title "Statistics browser") (:p @@ -136,15 +136,15 @@ (defclass admin-handler (admin-only-handler page-handler) ())

-(defmethod handle ((handler admin-handler) req) +(defmethod handle ((handler admin-handler)) (with-bos-cms-page (req :title "BOS CMS and Administration") "Please choose an administration activity from the menu above"))

(defclass bos-authorizer (bknr-authorizer) ())

-(defmethod find-user-from-request-parameters ((authorizer bos-authorizer) req) - (with-query-params (req __sponsorid __password) +(defmethod find-user-from-request-parameters ((authorizer bos-authorizer)) + (with-query-params (__sponsorid __password) (if (and __sponsorid __password) (handler-case (let ((sponsor (find-store-object (parse-integer __sponsorid) :class 'sponsor))) @@ -159,18 +159,16 @@ (call-next-method))) (call-next-method))))

-(defmethod authorize :after ((authorizer bos-authorizer) - (req http-request) - (ent net.aserve::entity)) - (let ((new-language (or (language-from-url (uri-path (request-uri req))) - (query-param req "language"))) - (current-language (gethash :language (bknr-session-variables (bknr-request-session req))))) +(defmethod authorize :after ((authorizer bos-authorizer)) + (let ((new-language (or (language-from-url (uri-path (request-uri))) + (query-param "language"))) + (current-language (gethash :language (bknr-session-variables (bknr-request-session))))) (when (or (not current-language) (and new-language (not (equal new-language current-language)))) - (setf (gethash :language (bknr-session-variables (bknr-request-session req))) + (setf (gethash :language (bknr-session-variables (bknr-request-session))) (or new-language - (find-browser-prefered-language req) + (find-browser-prefered-language) *default-language*)))))

(defun publish-worldpay-test (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))

Modified: branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp Tue Jan 29 07:19:19 2008 @@ -14,14 +14,14 @@ (defclass breadcrumb-handler (prefix-handler) ())

-(defmethod handle ((handler breadcrumb-handler) req) - (let* ((id (parse-integer (parse-url req) :junk-allowed t)) +(defmethod handle ((handler breadcrumb-handler)) + (let* ((id (parse-integer (parse-url) :junk-allowed t)) (breadcrumb (when id (find id (session-variable :breadcrumbs) :key #'breadcrumb-id)))) (if breadcrumb (progn (setf (session-variable :current-breadcrumb) breadcrumb) - (redirect (breadcrumb-url breadcrumb) req)) - (redirect "/" req)))) + (redirect (breadcrumb-url breadcrumb))) + (redirect "/"))))

(defun new-breadcrumb-id () (if (session-variable :breadcrumb-id) @@ -31,11 +31,11 @@ (defun add-breadcrumb (req title) (let ((current-crumb (session-variable :current-breadcrumb))) (unless (and current-crumb - (string-equal (uri-path (request-uri req)) + (string-equal (uri-path (request-uri)) (uri-path (breadcrumb-url current-crumb)))) (let ((breadcrumb (make-instance 'breadcrumb :id (new-breadcrumb-id) - :url (redirect-uri (request-uri req)) + :url (redirect-uri (request-uri)) :title title))) (setf (session-variable :breadcrumbs) (cons breadcrumb (member current-crumb (session-variable :breadcrumbs)))) @@ -45,4 +45,4 @@

(define-bknr-tag breadcrumb () (html ((:div :class "breadcrumb") - (:princ (caar (form-urlencoded-to-query (uri-path (request-uri *req*)))))))) \ No newline at end of file + (:princ (caar (form-urlencoded-to-query (uri-path (request-uri)))))))) \ No newline at end of file

Modified: branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp Tue Jan 29 07:19:19 2008 @@ -5,7 +5,7 @@ (define-bknr-tag dynasite-blog (&key name) "Display a dynasite blog" (let ((blog (find-store-object name :class 'blog :query-function #'blog-with-name)) - (page (query-param *req* "page"))) + (page (query-param "page"))) (when page (setf page (parse-integer page :junk-allowed t))) (unless page @@ -26,7 +26,7 @@ (html "Please enter a feedback message." :br (text-field "feedback" :size 85) (submit-button "feedback" "post"))))))) - (with-query-params (*req* feedback action) + (with-query-params (feedback action) (if (equal action "feedback") (if feedback (let ((mailinglist (mailinglist-with-name ml))) @@ -34,7 +34,7 @@ (progn (mailinglist-send-mail mailinglist - (let ((host (http-session-host *session*))) + (let ((host (bknr-session-host *session*))) (make-object 'mail :subject (format nil "feedback from ~A (~A)" (bknr.user:user-login *user*)

Modified: branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp Tue Jan 29 07:19:19 2008 @@ -14,7 +14,7 @@ (defclass eboy-template-handler (template-handler) nil)

-(defmethod initial-template-environment ((handler eboy-template-handler) req) +(defmethod initial-template-environment ((handler eboy-template-handler)) (unless (session-variable :chosen-color-theme) (setf (session-variable :chosen-color-theme) (random-elt *color-themes*))) @@ -22,6 +22,6 @@ (first (session-variable :chosen-color-theme))) (call-next-method)))

-(defmethod handle :before ((handler eboy-template-handler) req) - (add-breadcrumb req (uri-path (request-uri req)))) +(defmethod handle :before ((handler eboy-template-handler)) + (add-breadcrumb (uri-path (request-uri))))

Modified: branches/trunk-reorg/projects/eboy/src/item-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/item-handlers.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/item-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -76,18 +76,18 @@ (when item (submit-button "delete" "delete" :confirm "Really delete item?")))))))

-(defmethod authorized-p ((handler edit-item-handler) req) - (admin-p (bknr-request-user req))) +(defmethod authorized-p ((handler edit-item-handler)) + (admin-p (bknr-request-user)))

(defmethod handle-object-form ((handler edit-item-handler) - action item req) - (with-bknr-page (req :title (if item #?"edit item $((article-subject item))" "edit new item")) + action item) + (with-bknr-page (:title (if item #?"edit item $((article-subject item))" "edit new item")) (item-form :id (and item (store-object-id item)))))

(defmethod handle-object-form ((handler edit-item-handler) - (action (eql :save)) item req) - (with-query-params (req name subject text item-keyword) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (action (eql :save)) item) + (with-query-params (name subject text item-keyword) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (setf item-keyword (when item-keyword (list (make-keyword-from-string item-keyword)))) (if item (progn @@ -102,10 +102,10 @@ :text text :image-keywords keywords :keywords item-keyword))))) - (redirect (edit-object-url item) req)) + (redirect (edit-object-url item)))

(defmethod handle-object-form ((handler edit-item-handler) - (action (eql :delete)) item req) + (action (eql :delete)) item) (delete-object item) - (with-bknr-page (req :title "item has been deleted") + (with-bknr-page (:title "item has been deleted") (html "item has been deleted"))) \ No newline at end of file

Modified: branches/trunk-reorg/projects/eboy/src/jerks.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/jerks.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/jerks.lisp Tue Jan 29 07:19:19 2008 @@ -3,8 +3,8 @@ (defclass autojerk-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler autojerk-handler) req) - (let* ((jerks (parse-handler-url handler req)) +(defmethod object-handler-get-object ((handler autojerk-handler)) + (let* ((jerks (parse-handler-url handler)) (jerk-ids (when jerks (split "," jerks))) (jerk-images (mapcar #'(lambda (id) @@ -19,13 +19,13 @@ jerk-images)) jerk-images)))

-(defmethod handle-object ((handler autojerk-handler) (images (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((handler autojerk-handler) (images (eql nil))) + (error-404))

(defmethod handle-object ((handler autojerk-handler) - images req) + images) (format t ";; in handle-object for autojerk-handler~%") - (let ((operations (cdr (decoded-handler-path handler req)))) + (let ((operations (cdr (decoded-handler-path handler)))) (with-image (jerk-image (store-image-width (first images)) (store-image-height (first images)) t) @@ -61,13 +61,13 @@ proc))

(define-bknr-tag autojerk-thumbnail-page (&key (detail "/autojerk-detail")) - (unless (and (not (member "remix" (request-query *req*) + (unless (and (not (member "remix" (request-query) :test #'string-equal :key #'car)) (session-variable :current-autojerk-page)) (setf (session-variable :current-autojerk-page) (generate-autojerk-page))) (setf (session-variable :autojerk-page-uri) - (uri-path (request-uri *req*))) + (uri-path (request-uri))) (html ((:div :class "results") (let ((i 0)) (dolist (row (group-by (session-variable :current-autojerk-page) 8)) @@ -83,7 +83,7 @@ (unless (session-variable :current-autojerk-page) (setf (session-variable :current-autojerk-page) (generate-autojerk-page))) - (with-query-params (*req* image) + (with-query-params (image) (setf image (or (parse-integer image :junk-allowed t) 0)) (let* ((page (session-variable :current-autojerk-page)) (autojerk (nth image page))) @@ -94,19 +94,19 @@ ((:div :class "resultsnav") (if (equal autojerk (car page)) (html "&lt;&lt;&lt; | previous") - (html ((:a :href (format nil "~a?image=0" (uri-path (request-uri *req*)))) + (html ((:a :href (format nil "~a?image=0" (uri-path (request-uri)))) "&lt;&lt;&lt;") " | " - ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1- image))) "previous"))) " | " (if (cdr (member autojerk page :test #'equal)) - (html ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + (html ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1+ image))) "next") " | " - ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1- (length page)))) "&gt;&gt;&gt;")) (html "next | &gt;&gt;&gt;")))

Modified: branches/trunk-reorg/projects/eboy/src/layout.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/layout.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/layout.lisp Tue Jan 29 07:19:19 2008 @@ -546,11 +546,11 @@ ;; xxx ugly: make sure that at least (length new-path-components) path elements are processed (append (request-variable :template-args) (make-list (- (length new-path-components) (length (request-variable :template-args))))))) - (uri-path (request-uri *req*)))) + (uri-path (request-uri)))

(defun make-page-url (&optional page-number) "Make a url pointing to the given page number of the same url as the current request" - (format nil "~a~@[/~a~]" (regex-replace #?r"/\d*$" (uri-path (request-uri *req*)) "") page-number)) + (format nil "~a~@[/~a~]" (regex-replace #?r"/\d*$" (uri-path (request-uri)) "") page-number))

(define-bknr-tag details-resultsbar (&key image) (let ((current-query-result (session-variable :current-query-result))

Modified: branches/trunk-reorg/projects/eboy/src/navi.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/navi.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/navi.lisp Tue Jan 29 07:19:19 2008 @@ -31,7 +31,7 @@ Argumente: active-color - Vordergrundfarbe (Schwarz wird ersetzt)" (destructuring-bind (empty first-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (uri-path (request-uri))) (declare (ignore empty rest)) (dolist (button '(:eboy :browse :shop :about)) (if (string-equal (symbol-name button) first-level) @@ -42,7 +42,7 @@ "Erzeugt das Second-Level-Men�" (destructuring-bind (empty first-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (uri-path (request-uri))) (declare (ignore empty rest)) (dolist (choice (website-menu *current-website*)) (when (and (string-equal (choice-link choice) first-level)

Modified: branches/trunk-reorg/projects/eboy/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/packages.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -7,8 +7,8 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve - :net.html.generator + :hunchentoot + :xhtml-generator :bknr.datastore :bknr.utils :bknr.rss @@ -33,8 +33,8 @@ :eboy :cl-interpol :cl-ppcre - :net.html.generator - :net.aserve + :xhtml-generator + :hunchentoot :puri :bknr.web :bknr.datastore

Modified: branches/trunk-reorg/projects/eboy/src/peecol.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/peecol.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/peecol.lisp Tue Jan 29 07:19:19 2008 @@ -187,14 +187,14 @@

(define-bknr-tag peecol-page (&key (detail "/peecol-detail")) (if (or (not (session-variable :current-peecol-result)) - (member "remix" (request-query *req*) :test #'string-equal :key #'car)) + (member "remix" (request-query) :test #'string-equal :key #'car)) (setf (session-variable :current-peecol-result) (search-peecol-page)))

- (setf (session-variable :query-result-page-uri) (uri-path (request-uri *req*))) + (setf (session-variable :query-result-page-uri) (uri-path (request-uri))) (let* ((results (session-variable :current-peecol-result)) (num-pages (length results)) - (page-num (parse-integer (or (query-param *req* "page") + (page-num (parse-integer (or (query-param "page") "0"))) (page (nth page-num results)) (peecolnr (* 6 (apply #'+ (mapcar #'length (subseq results 0 page-num))))) @@ -209,7 +209,7 @@ (if (zerop page-num) (html "previous ") (html ((:a :href - (format nil "~a?page=~a" (uri-path (request-uri *req*)) + (format nil "~a?page=~a" (uri-path (request-uri)) (1- page-num))) "previous "))) (loop for i from (max 0 (min (- page-num 2) (- num-pages 5))) @@ -219,13 +219,13 @@ (html (:princ-safe (1+ i))) (html ((:a :href (format nil "~a?page=~a" - (uri-path (request-uri *req*)) i)) + (uri-path (request-uri)) i)) (:princ-safe (1+ i))))))) (html " | ") (if (= page-num (1- num-pages)) (html "next ") (html ((:a :href (format nil "~a?page=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1+ page-num))) "next "))))))))) (html (resultsbar) @@ -256,7 +256,7 @@ (unless (session-variable :current-peecol-result) (setf (session-variable :current-peecol-result) (search-peecol-page))) - (with-query-params (*req* peecolnr) + (with-query-params (peecolnr) (setf peecolnr (if peecolnr (if (parse-integer peecolnr :junk-allowed t) (parse-integer peecolnr :junk-allowed t) @@ -274,14 +274,14 @@ (if (equal peecol-triple (first peecols)) (html "previous") (html ((:a :href (format nil "~a?peecolnr=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1- peecolnr))) "previous"))) " | " (if (eq peecolnr (1- peecols-count)) (html "next") (html ((:a :href (format nil "~a?peecolnr=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1+ peecolnr))) "next")))) ((:div :class "resultsinfo")

Modified: branches/trunk-reorg/projects/gpn/add-user-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/add-user-handler.lisp (original) +++ branches/trunk-reorg/projects/gpn/add-user-handler.lisp Tue Jan 29 07:19:19 2008 @@ -21,22 +21,22 @@ (submit-button "create" "create")))))))

-(defmethod handle-form ((handler add-gpn-user-handler) (action (eql nil)) req) - (with-bknr-page (req :Title "Add gpn user") +(defmethod handle-form ((handler add-gpn-user-handler) (action (eql nil))) + (with-bknr-page (:Title "Add gpn user") (add-gpn-user-form)))

(defmethod handle-form ((handler add-gpn-user-handler) (action (eql :create)) req) - (with-query-params (req login full-name email password password2 vortragender) + (with-query-params (login full-name email password password2 vortragender) (unless login - (with-bknr-page (req :title "add gpn user") + (with-bknr-page (:title "add gpn user") (:h2 "Error") "please give a login" (add-gpn-user-form :login login :full-name full-name :email email)) (return-from handle-form)) (unless (or (not password) (string-equal password password2)) - (with-bknr-page (req :title "add gpn user") + (with-bknr-page (:title "add gpn user") (:h2 "Error") "passwords did not match" (add-gpn-user-form :login login :full-name full-name :email email)) @@ -44,7 +44,7 @@ (let ((user (make-gpn-user login :full-name full-name :email email :flags (when vortragender (list :vortragender)) :password password))) - (with-bknr-page (req :title "added gpn user") + (with-bknr-page (:title "added gpn user") (:h2 "User " (:princ-safe (user-login user)) " added") ((:a :href (format nil "/gpn-user/~a" (user-login user))) (:princ-safe (user-login user)))

Modified: branches/trunk-reorg/projects/gpn/gpn-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/gpn-tags.lisp (original) +++ branches/trunk-reorg/projects/gpn/gpn-tags.lisp Tue Jan 29 07:19:19 2008 @@ -15,7 +15,7 @@ text) ; xxx for now

(define-bknr-tag gpn-menu (&key (title "GULASCH PROGRAMMIER NACHT 3")) - (let ((first-level (second (split "/" (puri:uri-path (request-uri *req*)))))) + (let ((first-level (second (split "/" (puri:uri-path (request-uri)))))) (html ((:table :width 700 :cellpadding 0 :cellspacing 5) (:colgroup (dolist (b *gpn-buttons*) (html ((:col :width (third b))))) @@ -32,14 +32,14 @@ ((:a :class "headlink" :href (second button)) (:princ-safe (first button)))))) (html (:td)))) - (if (eql (find-user "anonymous") (bknr-request-user *req*)) + (if (eql (find-user "anonymous") (bknr-request-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/login") "LOGIN"))) (html ((:td :class "headbar") ((:a :class "headlogin" :href (format nil "/gpn-user/~a" - (user-login (bknr-request-user *req*)))) + (user-login (bknr-request-user)))) "HOME")) - (when (admin-p (bknr-request-user *req*)) + (when (admin-p (bknr-request-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/admin") "ADMIN")))) ((:td :class "headbar") @@ -71,7 +71,7 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time item) :show-weekday t)) - (when (equal (article-author item) (bknr-request-user *req*)) + (when (equal (article-author item) (bknr-request-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id item))) " (edit)"))) )))) (html ((:a :class "rss" :href (format nil "~a/~a" (handler-url :blog-rss) @@ -86,7 +86,7 @@ (player (dj-player eboy::*dj*)) (status (when player (player-state player))) (mp3 (when status (ps-mp3 status))) - (action (query-param *req* "action"))) + (action (query-param "action"))) (when action (case (make-keyword-from-string action) (:feed (tamagotchi-feed tamagotchi :time (get-universal-time))) @@ -154,7 +154,7 @@ (when email (html ((:div :class "email") "EMAIL: " (:princ-safe (string-upcase (user-email user)))))))) - (when (string-equal (user-login user) (user-login (bknr-request-user *req*))) + (when (string-equal (user-login user) (user-login (bknr-request-user))) (html ((:div :class "user-edit") ((:p :class "news") "Zum Importieren von Bildern zuerst die Bilder auf ftp://fiep/ hochladen, @@ -278,11 +278,11 @@

(define-bknr-tag logged-in () (html ((:div :class "logged-in") "logged in as " - (if (string-equal (user-login (bknr-request-user *req*)) "anonymous") + (if (string-equal (user-login (bknr-request-user)) "anonymous") (html "anonymous") (html ((:a :style "color:#cc3333;" - :href (format nil "/gpn-user/~a" (user-login (bknr-request-user *req*)))) - (:princ-safe (user-login (bknr-request-user *req*))))))))) + :href (format nil "/gpn-user/~a" (user-login (bknr-request-user)))) + (:princ-safe (user-login (bknr-request-user)))))))))

(define-bknr-tag gpn-fahrplan (&key location) (let ((events (sort (remove-if #'(lambda (event) (< (zeitplan-event-end-time event) (get-universal-time))) @@ -414,5 +414,5 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time article) :show-weekday t)) - (when (equal (article-author article) (bknr-request-user *req*)) + (when (equal (article-author article) (bknr-request-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id article))) " (edit)"))))))))))

Modified: branches/trunk-reorg/projects/gpn/import-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/import-handler.lisp (original) +++ branches/trunk-reorg/projects/gpn/import-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass gpn-import-handler (image-import-handler) ())

-(defmethod import-handler-import-pathname ((handler gpn-import-handler) req) - (let* ((user (bknr-request-user req)) +(defmethod import-handler-import-pathname ((handler gpn-import-handler)) + (let* ((user (bknr-request-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user) "images")) @@ -14,8 +14,8 @@ (ensure-directories-exist spool-dir) spool-dir))

-(defmethod handle-form ((handler image-import-handler) action req) - (with-bknr-page (req :title #?"image import directory") +(defmethod handle-form ((handler image-import-handler) action) + (with-bknr-page (:title #?"image import directory") ((:form :method "post") (when (admin-p *user*) (html ((:div :class "keyword-choose" :align "center") @@ -27,29 +27,29 @@

((:div :class "import-list") (:h2 "Images present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br))))))

-(defmethod import-handler-import-files ((handler image-import-handler) req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (spool-dir (import-handler-import-pathname handler req))) +(defmethod import-handler-import-files ((handler image-import-handler)) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (spool-dir (import-handler-import-pathname handler))) (import-directory spool-dir - :user (bknr-request-user req) + :user (bknr-request-user) :keywords (when (admin-p *user*) keywords) :spool (import-handler-spool-dir handler) :keywords-from-dir (if (admin-p *user*) - (query-param req "keyfromdir") + (query-param "keyfromdir") t))))

-(defmethod handle-form ((handler image-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler image-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-images (remove-if-not #'(lambda (element) (typep element 'store-image)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"gpn import log") + (with-bknr-page (:title #?"gpn import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error

Modified: branches/trunk-reorg/projects/gpn/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/packages.lisp (original) +++ branches/trunk-reorg/projects/gpn/packages.lisp Tue Jan 29 07:19:19 2008 @@ -7,7 +7,7 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :xhtml-generator :bknr.indices :bknr.datastore @@ -25,7 +25,7 @@ (:use :cl :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :xhtml-generator :bknr.utils :bknr.datastore

Modified: branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp (original) +++ branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@ ())

#+(or) -(defmethod create-rss-feed ((handler zeitplan-rss-handler) req) +(defmethod create-rss-feed ((handler zeitplan-rss-handler)) (let* ((events (sort (all-zeitplan-events) #'< :key #'zeitplan-event-start-time)) (url (website-url (page-handler-site handler))) (items (mapcar #'zeitplan-event-to-rss-item events))) @@ -21,13 +21,13 @@ () (:default-initargs :object-class 'zeitplan-event))

-(defmethod authorized-p ((handler edit-zeitplan-handler) req) +(defmethod authorized-p ((handler edit-zeitplan-handler)) (or (admin-p *user*) (user-has-flag *user* :vortragender)))

(defmethod handle-object-form ((handler edit-zeitplan-handler) - action event req) - (with-bknr-page (req :title "edit zeitplan event") + action event) + (with-bknr-page (:title "edit zeitplan event") (if event (html (:h2 "Edit event " (:princ-safe (zeitplan-event-name event)) ":") (gpn-commands:zeitplan-event-form @@ -46,10 +46,10 @@ (html (:li (edit-html-link event))))) ))))

(defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :create)) event req) - (with-query-params (req name description vortragender location) - (let ((start (parse-date-field "start" req)) - (end (parse-date-field "end" req)) + (action (eql :create)) event) + (with-query-params (name description vortragender location) + (let ((start (parse-date-field "start")) + (end (parse-date-field "end")) (vortragender (find-user (string-downcase vortragender)))) (handler-case (progn (ensure-form-field name) @@ -66,9 +66,9 @@ :location (make-keyword-from-string location) :start-time start :end-time end))) - (redirect (edit-object-url event) req))) + (redirect (edit-object-url event)))) (form-field-missing-condition (e) - (with-bknr-page (req :title "edit zeitplan event") + (with-bknr-page (:title "edit zeitplan event") ((:h2 :class "error") "Please fill field " (:princ-safe (form-field-missing-condition-field e)) "!") (gpn-commands:zeitplan-event-form :name name @@ -83,14 +83,14 @@

(defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :save)) event req) + (action (eql :save)) event) (unless event - (redirect (handler-url :edit-zeitplan) req) + (redirect (handler-url :edit-zeitplan)) (return-from handle-object-form))

- (with-query-params (req name description vortragender location) - (let ((start (parse-date-field "start" req)) - (end (parse-date-field "end" req)) + (with-query-params (name description vortragender location) + (let ((start (parse-date-field "start")) + (end (parse-date-field "end")) (vortragender (find-user (string-downcase vortragender)))) (when name (change-slot-values event 'name name)) @@ -104,10 +104,10 @@ (zeitplan-event-set-vortragender event vortragender)) (when location (zeitplan-event-set-location event (make-keyword-from-string location))) - (redirect (edit-object-url event) req)))) + (redirect (edit-object-url event)))))

(defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :delete)) event req) + (action (eql :delete)) event) (when event (delete-object event)) - (redirect (handler-url :edit-zeitplan) req)) + (redirect (handler-url :edit-zeitplan)))

Modified: branches/trunk-reorg/projects/hello-web/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,13 +6,13 @@ () (:default-initargs :query-function #'find-user))

-(defmethod handle-object ((handler hello-object-handler) (object (eql nil)) req) - (with-bknr-page (req :title "object not found") - (html (:p "user " (:b (:princ-safe (first (decoded-handler-path handler req)))) " not found")))) +(defmethod handle-object ((handler hello-object-handler) (object (eql nil))) + (with-bknr-page (:title "object not found") + (html (:p "user " (:b (:princ-safe (first (decoded-handler-path handler)))) " not found"))))

-(defmethod handle-object ((handler hello-object-handler) object req) - (with-bknr-page (req :title "demo handler") +(defmethod handle-object ((handler hello-object-handler) object) + (with-bknr-page (:title "demo handler") (html (:p "This is the demo handler, the object id of user " - (:b (:princ-safe (first (decoded-handler-path handler req)))) " is " + (:b (:princ-safe (first (decoded-handler-path handler)))) " is " (:b (:princ-safe (store-object-id object)))))))

Modified: branches/trunk-reorg/projects/hello-web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/packages.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -17,7 +17,6 @@ :hello-web.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export #:hello))

(defpackage :hello-web.imageproc @@ -43,8 +42,7 @@ :bknr.indices :bknr.rss :hello-web.config - :net.aserve + :hunchentoot :xhtml-generator) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -13,7 +13,7 @@ () (:default-initargs :class 'participant :query-function #'find-user))

-(defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant) req) +(defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant)) (with-lisp-ecoop-page (req #?"Edit participant $((user-login participant))") ((:form :method "post" :enctype "multipart/form-data") ((:table :border "1") @@ -27,7 +27,7 @@ (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Delete this participant?"))))

-(defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant) req) +(defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant)) (participant-reset-password participant) (with-lisp-ecoop-page (req "Password reset") "The participant's password has been reset and sent by mail")) @@ -36,18 +36,18 @@ () (:default-initargs :class 'document))

-(defmethod handle-object ((handler pdf-handler) (document document) req) +(defmethod handle-object ((handler pdf-handler) (document document)) (let ((pdf (file-contents (blob-pathname document)))) - (with-http-response (req *ent* :content-type "application/pdf") - (setf (request-reply-content-length req) (length pdf)) - (with-http-body (req *ent* :external-format '(unsigned-byte 8)) - (write-sequence pdf net.aserve::*html-stream*))))) + (with-http-response (:content-type "application/pdf") + (setf (request-reply-content-length) (length pdf)) + (with-http-body (:external-format '(unsigned-byte 8)) + (write-sequence pdf *html-stream*)))))

(defclass make-submission-handler (admin-only-handler page-handler) ())

-(defmethod handle ((handler make-submission-handler) req) - (with-query-params (req type title abstract) +(defmethod handle ((handler make-submission-handler)) + (with-query-params (type title abstract) (let ((submission (make-object (if (string-equal type "paper") 'paper 'breakout-group-proposal) :title title :abstract abstract))) (with-lisp-ecoop-page (req #?"Submission created") (html ((:script :type "text/javascript") @@ -63,32 +63,32 @@ () (:default-initargs :class 'submission))

-(defmethod handle-object ((handler upload-document-handler) object req) +(defmethod handle-object ((handler upload-document-handler) object) (error "Missing object ID"))

-(defmethod handle-object ((handler upload-document-handler) (submission submission) req) +(defmethod handle-object ((handler upload-document-handler) (submission submission)) (unless (submission-edit-permitted-p submission) (error "can't edit this submission")) - (ecase (request-method req) + (ecase (request-method) (:post - (when (request-uploaded-file req "document") - (with-query-params (req info) + (when (request-uploaded-file "document") + (with-query-params (info) (format t "; new document - info ~S~%" info) - (let ((file-name (request-uploaded-file req "document"))) + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) (let ((document (make-object 'document :info info :submission submission))) (blob-from-file document file-name) - (redirect (format-object-id "/upload/~A?success=1" submission) req)) - (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file")) req))))))) + (redirect (format-object-id "/upload/~A?success=1" submission))) + (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file"))))))))) (:get - (redirect (format-object-id "/upload/~A" submission) req)))) + (redirect (format-object-id "/upload/~A" submission)))))

(defclass delete-document-handler (object-handler) () (:default-initargs :class 'document))

-(defmethod handle-object ((handler delete-document-handler) (document document) req) +(defmethod handle-object ((handler delete-document-handler) (document document)) (unless (submission-edit-permitted-p (document-submission document)) (error "can't edit this submission")) (delete-object document)) @@ -96,7 +96,7 @@ (defclass admin-handler (admin-only-handler page-handler) ())

-(defmethod handle ((handler page-handler) req) +(defmethod handle ((handler page-handler)) (with-lisp-ecoop-page (req "LISP-ECOOP Administration") "Please choose an administrative task from the menu"))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp Tue Jan 29 07:19:19 2008 @@ -38,8 +38,8 @@ "Generic submission")

(defun submission-edit-permitted-p (submission) - (or (admin-p (bknr-request-user *req*)) - (find (bknr-request-user *req*) (submission-submitters submission)))) + (or (admin-p (bknr-request-user)) + (find (bknr-request-user) (submission-submitters submission))))

(defmethod submission-add-submitter ((submission submission) submitter) (pushnew submitter (submission-submitters submission))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp Tue Jan 29 07:19:19 2008 @@ -39,8 +39,8 @@ (or (ignore-errors (parse-integer string)) (ext:parse-time string :default-zone -2))) ; XXX deal with time zone correctly!

-(defmethod handle ((handler schedule-handler) req) - (destructuring-bind (&optional begin end) (mapcar #'parse-time-spec (multiple-value-list (parse-url req))) +(defmethod handle ((handler schedule-handler)) + (destructuring-bind (&optional begin end) (mapcar #'parse-time-spec (multiple-value-list (parse-url))) (unless begin (setf begin (get-universal-time))) (unless end @@ -48,7 +48,7 @@ (labels ((timeslot-wanted (timeslot) (and (>= (timeslot-begin-time timeslot) begin) (<= (timeslot-begin-time timeslot) end)))) - (with-bknr-page (req :title "Schedule") + (with-bknr-page (:title "Schedule") (html (:table (:tr (:th "Time") (:th "Content")) (dolist (timeslot (sort (remove-if-not #'timeslot-wanted (class-instances 'timeslot)) @@ -60,8 +60,8 @@ () (:default-initargs :object-class 'timeslot))

-(defmethod handle-object-form ((handler edit-timeslot-handler) action timeslot req) - (with-bknr-page (req :title "Edit Timeslot") +(defmethod handle-object-form ((handler edit-timeslot-handler) action timeslot) + (with-bknr-page (:title "Edit Timeslot") ((:form :method "POST") ((:label :for "date") "Time:") ((:input :type "text" :size "5" :name "date" :value (format-date-time (timeslot-begin-time timeslot) :show-date nil :show-seconds nil))) @@ -74,8 +74,8 @@ :br (submit-button "delete" "delete"))))

-(defmethod handle-object-form ((handler edit-timeslot-handler) (action (eql :delete)) timeslot req) - (with-bknr-page (req :title "Delete Timeslot") +(defmethod handle-object-form ((handler edit-timeslot-handler) (action (eql :delete)) timeslot) + (with-bknr-page (:title "Delete Timeslot") (delete-object timeslot) (html (:h2 "Timeslot has been deleted"))))

@@ -93,7 +93,7 @@ #'< :key #'timeslot-begin-time)) (with-tag-expanders ((time () - (if (admin-p (bknr-request-user *req*)) + (if (admin-p (bknr-request-user)) (html ((:a :href #?"/edit-timeslot/$((store-object-id timeslot))") (:princ-safe (timeslot-time-string timeslot)))) (html (:princ-safe (timeslot-time-string timeslot)))))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp Tue Jan 29 07:19:19 2008 @@ -20,20 +20,20 @@ (if (parse-integer key :junk-allowed t) (find-store-object (parse-integer key :junk-allowed t)) (find-user key)) - (bknr-request-user *req*)))) + (bknr-request-user))))

(define-bknr-tag profile-editor (&key children) - (when (anonymous-p (bknr-request-user *req*)) + (when (anonymous-p (bknr-request-user)) (warn "User not logged in") (html (:h2 "Please log in to edit the profile")) (return-from profile-editor)) (let ((participant (participant-from-request))) - (unless (or (admin-p (bknr-request-user *req*)) - (eq participant (bknr-request-user *req*))) + (unless (or (admin-p (bknr-request-user)) + (eq participant (bknr-request-user))) (html (:h2 "can't edit this profile")) (return-from profile-editor)) - (when (eq :post (request-method *req*)) - (with-query-params (*req* action) + (when (eq :post (request-method)) + (with-query-params (action) (format t ";; ACTION ~A~%" action) (case (make-keyword-from-string action) (:delete-submission @@ -54,10 +54,10 @@ (delete-object participant) (html (:h2 "Participant has been deleted")) (return-from profile-editor)))) - (when (request-uploaded-file *req* "document") - (with-query-params (*req* type title abstract info) + (when (request-uploaded-file "document") + (with-query-params (type title abstract info) (format t "; new submission - title ~S abstract ~S~%" title abstract) - (let ((file-name (request-uploaded-file *req* "document"))) + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) (let* ((submission (make-object (if (equal type "breakout-group-proposal") @@ -69,8 +69,8 @@ (with-transaction ("adding participant submission") (push submission (participant-submissions participant)))) (html ((:script :language "JavaScript") "alert('Invalid file format of uploaded, only PDF files are accepted')"))))))) - (when (request-uploaded-file *req* "picture") - (let ((picture (import-image (request-uploaded-file *req* "picture")))) + (when (request-uploaded-file "picture") + (let ((picture (import-image (request-uploaded-file "picture")))) (with-transaction ("updating participant picture") (when (participant-picture participant) (delete-object (participant-picture participant))) @@ -112,25 +112,25 @@ (unless (submission-edit-permitted-p submission) (html (:h2 "can't edit this submission")) (return-from submission-editor)) - (when (eq :post (request-method *req*)) - (with-query-params (*req* action) + (when (eq :post (request-method)) + (with-query-params (action) (case (make-keyword-from-string action) (:delete (delete-object submission) (html (:h2 "The submission has been deleted")) (return-from submission-editor)))) - (when (request-uploaded-file *req* "document") - (let ((file-name (request-uploaded-file *req* "document"))) + (when (request-uploaded-file "document") + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (cond ((cl-ppcre:scan "^%PDF-" (read-line pdf)) (html (:h2 "New document has been saved")) - (with-query-params (*req* info) + (with-query-params (info) (let ((document (make-object 'document :info info :submission submission))) (blob-from-file document file-name)))) (t (html ((:script :language "JavaScript") "alert('Invalid file format of uploaded, only PDF files are accepted')"))))))) - (with-query-params (*req* title abstract remove-submitter-id add-submitter-id) + (with-query-params (title abstract remove-submitter-id add-submitter-id) (html (:h2 "Submission updated")) (with-transaction ("updating submission") (when add-submitter-id @@ -146,12 +146,12 @@ (mapc #'emit-template-node children))))

(define-bknr-tag add-participant (&key children) - (unless (admin-p (bknr-request-user *req*)) + (unless (admin-p (bknr-request-user)) (html "You must be logged in as adminstrator to create new participants") (return-from add-participant)) - (with-query-params (*req* action) + (with-query-params (action) (when (eq :create (make-keyword-from-string action)) - (with-query-params (*req* login full-name email text submission) + (with-query-params (login full-name email text submission) (when (find-user login) (error "user ~A already exists" login)) (when submission @@ -175,7 +175,7 @@ (unless (submission-edit-permitted-p submission) (html (:h2 "can't edit this submission")) (return-from submission-submitter-editor)) - (with-query-params (*req* add-submitter-id remove-submitter-id add-submitter remove-submitter) + (with-query-params (add-submitter-id remove-submitter-id add-submitter remove-submitter) (let ((submitters (submission-submitters submission))) (cond (add-submitter-id @@ -192,13 +192,15 @@ (html (:strong "Add submitter") (:ul (dolist (participant (set-difference (class-instances 'participant) submitters)) - (html (:li ((:a :href (format nil "~A?add-submitter-id=~A" (puri:uri-path (request-uri *req*)) (store-object-id participant))) + (html (:li ((:a :href (format nil "~A?add-submitter-id=~A" + (puri:uri-path (request-uri)) + (store-object-id participant))) (:princ-safe (user-full-name participant))))))))) (remove-submitter (html (:strong "Remove Submitter") (:ul (dolist (participant submitters) - (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri *req*)) (store-object-id participant))) + (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri)) (store-object-id participant))) (:princ-safe (user-full-name participant))))))))))))))

(define-bknr-tag submission-uploader () @@ -250,18 +252,18 @@ (html ((:img :src (format-object-id "/image/~A/cell" image))))) (:span ((:a :href (format-object-id "/profile/~A" participant)) (:princ-safe (user-full-name participant))) - (when (or (eq participant (bknr-request-user *req*)) - (admin-p (bknr-request-user *req*))) + (when (or (eq participant (bknr-request-user)) + (admin-p (bknr-request-user))) (html " " ((:a :href (format-object-id "/edit-profile/~A" participant)) "[Edit]")))))))))

(define-bknr-tag participants-only (&key children error) - (if (participant-p (bknr-request-user *req*)) + (if (participant-p (bknr-request-user)) (mapc #'emit-template-node children) (when error (html (:princ-safe error)))))

(define-bknr-tag admin-only (&key children error) - (if (admin-p (bknr-request-user *req*)) + (if (admin-p (bknr-request-user)) (mapc #'emit-template-node children) (when error (html (:princ-safe error))))) @@ -285,7 +287,7 @@ (html "[no submission]")))

(define-bknr-tag login-widget () - (let ((user (bknr-request-user *req*))) + (let ((user (bknr-request-user))) (cond ((anonymous-p user) (html ((:form :method "post") @@ -293,19 +295,19 @@ ((:input :type "text" :name "__username")) "Password" :br ((:input :type "password" :name "__password")) - (when (query-param *req* "__username") + (when (query-param "__username") (html ((:div :id "logfail") "Login failed"))) ((:button :type "submit" :name "action" :value "login") "login")))) (t (html ((:form :method "post" :action (website-make-path *website* "logout")) - ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri *req*)))) + ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri)))) (:div "Logged in as " :br ((:a :href (format-object-id "/edit-profile/~A" user)) (:princ-safe (user-full-name user)))) (:div ((:button :type "submit" :name "action" :value "logout") "logout"))))))))

(define-bknr-tag admin-only (&key children) - (when (admin-p (bknr-request-user *req*)) + (when (admin-p (bknr-request-user)) (mapc #'emit-template-node children)))

(defun parse-duration (string) @@ -314,8 +316,8 @@ (* 60 (+ (* 60 hours) minute)))))

(define-bknr-tag schedule-submission () - (when (eq :post (request-method *req*)) - (with-query-params (*req* date time duration submission freetext) + (when (eq :post (request-method)) + (with-query-params (date time duration submission freetext) (let ((start (ext:parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone (duration (parse-duration duration)) (submission (ignore-errors (store-object-with-id (parse-integer submission :junk-allowed t)))))

Modified: branches/trunk-reorg/projects/mah-jongg/src/game.lisp ============================================================================== --- branches/trunk-reorg/projects/mah-jongg/src/game.lisp (original) +++ branches/trunk-reorg/projects/mah-jongg/src/game.lisp Tue Jan 29 07:19:19 2008 @@ -108,11 +108,11 @@ (text (princ-to-string (cadr (find player results :key #'car)))))))))))

(defun request-param (req name) - (assoc name (request-query req) :test #'equal)) + (assoc name (request-query) :test #'equal))

-(defun handle-game (req ent) - (when (eq :post (request-method req)) - (with-query-params (req action undo-timestamp east north west south winner) +(defun handle-game () + (when (eq :post (request-method)) + (with-query-params (action undo-timestamp east north west south winner) (ecase (make-keyword-from-string action) (:undo (restore (parse-integer undo-timestamp))) @@ -122,12 +122,12 @@ (make-game (1- (get-universal-time)) (name (wind->player (make-keyword-from-string winner))) (mapcar #'(lambda (wind) (list (name (wind->player wind)) - (parse-integer (query-param req (symbol-name wind))))) + (parse-integer (query-param (symbol-name wind))))) '(:east :north :west :south)))) (:clear-round (clear-round))))) - (with-http-response (req ent :content-type "text/xml") - (with-http-body (req ent) + (with-http-response (:content-type "text/xml") + (with-http-body () (with-xml-output (cxml:make-character-stream-sink *html-stream*) (sax:processing-instruction cxml::*sink* (runes:string-rod "xml-stylesheet") (runes:string-rod "type="text/xsl" href="game.xsl"")) (if *round*

Modified: branches/trunk-reorg/projects/mah-jongg/src/package.lisp ============================================================================== --- branches/trunk-reorg/projects/mah-jongg/src/package.lisp (original) +++ branches/trunk-reorg/projects/mah-jongg/src/package.lisp Tue Jan 29 07:19:19 2008 @@ -7,6 +7,6 @@ :bknr.utils :bknr.web :bknr.datastore - :net.aserve - :net.html.generator) + :hunchentoot + :xhtml-generator) (:export)) \ No newline at end of file

Modified: branches/trunk-reorg/projects/quickhoney/src/config.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/config.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/config.lisp Tue Jan 29 07:19:19 2008 @@ -3,10 +3,10 @@ ;; URL für BASE HREFs (defparameter *website-url* "http://quickhoney.com")

-(defparameter *root-directory* #p"home:bknr-svn/projects/quickhoney/") +(defparameter *root-directory* (merge-pathnames #p"../" (make-pathname :name nil :type nil :version nil :defaults *load-pathname*)))

(defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*))

-(defparameter *website-directory* (merge-pathnames #p"website/" *root-directory*)) +(defparameter *website-directory* (probe-file (merge-pathnames #p"website/" *root-directory*)))

(defparameter *webserver-port* 8080)

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 Tue Jan 29 07:19:19 2008 @@ -5,40 +5,38 @@ (defclass javascript-handler () ())

-(defmethod handle :around ((handler javascript-handler) req) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) - (format *html-stream* "<script language="JavaScript">~%") - (call-next-method) - (format *html-stream* "~%</script>~%")))) +(defmethod handle :around ((handler javascript-handler)) + (with-http-response (:content-type "text/html; charset=UTF-8") + (no-cache) + (with-http-body () + (format *html-stream* "<script language="JavaScript">~%") + (call-next-method) + (format *html-stream* "~%</script>~%"))))

(defclass random-image-handler (object-handler) ())

-(defmethod object-handler-get-object ((handler random-image-handler) req) - (random-elt (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler req))))) +(defmethod object-handler-get-object ((handler random-image-handler)) + (random-elt (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler)))))

-(defmethod handle-object ((handler random-image-handler) store-image req) - (redirect (format nil "/image/~A" (store-object-id store-image)) req)) +(defmethod handle-object ((handler random-image-handler) store-image) + (redirect (format nil "/image/~A" (store-object-id store-image))))

(defclass animation-handler (object-handler) ())

-(defmethod handle-object ((handler animation-handler) animation req) +(defmethod handle-object ((handler animation-handler) animation) (let ((content-type (blob-type (quickhoney-animation-image-animation animation)))) - (with-bknr-http-response (req :content-type content-type) - (with-http-body (req *ent*) + (with-http-response (:content-type content-type) + (with-http-body () (blob-to-stream (quickhoney-animation-image-animation animation) *html-stream*)))))

(defclass image-query-js-handler (javascript-handler object-handler) ())

-(defmethod object-handler-get-object ((handler image-query-js-handler) req) +(defmethod object-handler-get-object ((handler image-query-js-handler)) (sort (remove-if-not #'(lambda (object) (subtypep (type-of object) 'quickhoney-image)) - (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler req)))) + (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) #'< :key #'blob-timestamp))

(defmethod image-to-javascript ((image quickhoney-image) &optional stream) @@ -63,9 +61,9 @@ (format t " ]~@[,~]~%" (cdr page-rest))) (format t "]~%")))

-(defmethod handle-object ((handler image-query-js-handler) images req) +(defmethod handle-object ((handler image-query-js-handler) images) (format *html-stream* "parent.process_query_result(~%") - (with-query-params (req layout) + (with-query-params (layout) (princ (layout-to-javascript (make-instance (case (make-keyword-from-string layout) (:smallworld 'quickhoney-name-layout) (t 'quickhoney-standard-layout)) @@ -75,15 +73,15 @@ (defclass login-js-handler (javascript-handler page-handler) ())

-(defmethod handle ((handler login-js-handler) req) +(defmethod handle ((handler login-js-handler)) (format *html-stream* "parent.login_complete(~A, ~S);~%" - (if (admin-p (bknr-request-user req)) "true" "false") - (user-login (bknr-request-user req)))) + (if (admin-p (bknr-request-user)) "true" "false") + (user-login (bknr-request-user))))

(defclass clients-js-handler (javascript-handler page-handler) ())

-(defmethod handle ((handler clients-js-handler) req) +(defmethod handle ((handler clients-js-handler)) (let ((clients (sort (remove "" (all-clients) :test #'equal) #'string-lessp))) (format *html-stream* "parent.set_clients([~S~{, ~S~}]);~%" @@ -93,15 +91,15 @@ () (:default-initargs :object-class 'quickhoney-image))

-(defmethod handle-object-form ((handler edit-image-js-handler) action image req) +(defmethod handle-object-form ((handler edit-image-js-handler) action image) (format t "; invalid action ~A or invalid object ~A~%" action image))

-(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :edit)) image req) - (with-query-params (req client) +(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :edit)) image) + (with-query-params (client) (change-slot-values image 'client client) (format *html-stream* "parent.image_edited()~%")))

-(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image) req) +(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image)) (delete-object image) (format *html-stream* "parent.image_deleted();~%"))

@@ -134,9 +132,9 @@ for subcategory = (make-keyword-from-string subcategory-string) collect (list category subcategory (button-for-category category subcategory background-color))))))

-(defmethod handle ((handler buttons-js-handler) req) +(defmethod handle ((handler buttons-js-handler)) (format *html-stream* "var buttons = [];~%") - (loop for (category subcategory image-url) in (find-button-images (decoded-handler-path handler req)) + (loop for (category subcategory image-url) in (find-button-images (decoded-handler-path handler)) when image-url do (format *html-stream* "buttons['~(~A/~A~)'] = ~S;~%" category subcategory image-url)) (format *html-stream* "parent.set_button_images(buttons);~%")) @@ -144,10 +142,10 @@ (defclass upload-image-handler (admin-only-handler prefix-handler) ())

-(defmethod handle ((handler upload-image-handler) req) - (with-query-params (req client) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car))) - (keywords (mapcar #'make-keyword-from-string (decoded-handler-path handler req)))) +(defmethod handle ((handler upload-image-handler)) + (with-query-params (client) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))) + (keywords (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) (handler-case (progn (unless uploaded-file @@ -166,8 +164,8 @@ :class-name 'quickhoney-image :keywords (cons :upload keywords) :initargs `(:client ,client)))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -179,8 +177,8 @@ :width (round (* ratio width)) :height (round (* ratio height))))) (:p ((:a :href "javascript:done()") "ok"))))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload")) @@ -193,9 +191,9 @@ (defclass upload-animation-handler (admin-only-handler page-handler) ())

-(defmethod handle ((handler upload-animation-handler) req) - (with-query-params (req client) - (let* ((uploaded-files (request-uploaded-files req :all-info t)) +(defmethod handle ((handler upload-animation-handler)) + (with-query-params (client) + (let* ((uploaded-files (request-uploaded-files :all-info t)) (uploaded-image (find "image-file" uploaded-files :test #'equal :key #'upload-name)) (uploaded-animation (find "animation-file" uploaded-files :test #'equal :key #'upload-name))) (handler-case @@ -211,8 +209,8 @@ :class-name 'quickhoney-animation-image :keywords (list :upload :pixel :animation) :initargs `(:client ,client :animation ,animation-blob)))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -223,8 +221,8 @@ (:p ((:img :src (format nil "/image/~D" (store-object-id image))))) (:p ((:a :href "javascript:done()") "ok")))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload")) @@ -237,9 +235,9 @@ (defclass upload-button-handler (admin-only-handler page-handler) ())

-(defmethod handle ((handler upload-button-handler) req) - (with-query-params (req directory subdirectory) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) +(defmethod handle ((handler upload-button-handler)) + (with-query-params (directory subdirectory) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (handler-case (progn (unless (and directory @@ -257,8 +255,8 @@ (let* ((image (make-store-image :name (pathname-name uploaded-file) :class-name 'store-image :keywords (list :button (make-keyword-from-string directory) (make-keyword-from-string subdirectory))))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -270,8 +268,8 @@ :width 208 :height 208))) (:p ((:a :href "javascript:done()") "ok")))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload"))

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 Tue Jan 29 07:19:19 2008 @@ -13,8 +13,6 @@ (unless (class-instances 'bknr.cron::cron-job) (bknr.cron:make-cron-job "daily statistics" 'make-yesterdays-statistics 1 0 :every :every) (bknr.cron:make-cron-job "snapshot" 'snapshot-store 0 5 :every :every)) + #+cmu (actor-start (make-instance 'cron-actor)) (publish-quickhoney)) - -(eval-when (load) - (startup))

Modified: branches/trunk-reorg/projects/quickhoney/src/layout.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/layout.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/layout.lisp Tue Jan 29 07:19:19 2008 @@ -90,15 +90,18 @@ (defclass item-cell (image-cell) ((item :initarg :item :reader cell-item)))

+#+(or) (defmethod cell-image ((cell item-cell)) (item-poster-image (cell-item cell)))

+#+(or) (defmethod cell-keywords ((cell item-cell)) (item-image-keywords (cell-item cell)))

(defmethod cell-name ((cell item-cell)) (string-downcase (symbol-name (object-name (cell-item cell)))))

+#+(or) (defmethod cell-caption ((cell item-cell)) (article-subject (cell-item cell)))

@@ -472,7 +475,7 @@ (make-instance 'item-cell :layout layout :item item))

(defun make-item-url (index) - (format nil "~a/~(~a~)" (request-variable :template-path) (object-name (nth index (session-variable :current-query-result))))) + (format nil "~a/~(~a~)" (request-variable :template-path) (object-name (nth index (session-value :current-query-result)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -481,8 +484,8 @@

(defun reorder-query-result () "reorder the query result in the session so that it reflects the order in the layout." - (setf (session-variable :current-query-result) - (loop for page in (layout-pages (session-variable :current-thumbnail-layout)) + (setf (session-value :current-query-result) + (loop for page in (layout-pages (session-value :current-thumbnail-layout)) append (loop for row in (page-rows page) append (row-objects row)))))

@@ -498,8 +501,3 @@ (list :affinity 'keyword-affinity-layout) (list :shop 'shop-layout) (list :no 'no-layout))) - -(defun show-session-variables (function-name) - (format t ";; in ~a~%" function-name) - (loop for key being the hash-keys of (bknr-session-variables *session*) - do (format t ";; ~a => ~a~%" key (session-variable key))))

Modified: branches/trunk-reorg/projects/quickhoney/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/packages.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -20,9 +20,10 @@ (defpackage :quickhoney (:use :cl :cl-user - :ext + :alexandria :cl-interpol :cl-ppcre + :hunchentoot :bknr.utils :bknr.web :bknr.user @@ -31,22 +32,18 @@ :bknr.images :bknr.rss :quickhoney.config - :net.aserve :xhtml-generator) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) + (:shadowing-import-from :alexandria #:array-index) (:export #:last-image-upload-timestamp))

(defpackage :quickhoney.tags (:use :cl :cl-user - :ext :bknr.web :xhtml-generator :bknr.utils :quickhoney :quickhoney.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export #:client-selectbox))

Modified: branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd (original) +++ branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd Tue Jan 29 07:19:19 2008 @@ -16,7 +16,14 @@ :description "worldpay test web server" :long-description ""

- :depends-on (:cl-interpol :cl-ppcre :aserve :cxml :mime :bknr :bknr-modules :cl-gd) + :depends-on (:cl-interpol + :cl-ppcre + :cxml + :cl-mime + :bknr-web + :bknr-datastore + :bknr-modules + :cl-gd)

:components ((:file "packages") (:file "config" :depends-on ("packages"))

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 Tue Jan 29 07:19:19 2008 @@ -6,11 +6,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-(defun publish-quickhoney (&key (port *webserver-port*) (listeners 20)) - - (unpublish :all t) +(defun publish-quickhoney (&key (port *webserver-port*))

(setf bknr.web::*upload-file-size-limit* (* 30 1024 1024)) + (unpublish) (make-instance 'website :name "Quickhoney CMS" :handler-definitions `(("/random-image" random-image-handler) @@ -31,9 +30,9 @@ :command-packages ((:quickhoney . :quickhoney.tags) (:bknr . :bknr.web))) ("/static" directory-handler - :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*))) + :destination ,(merge-pathnames #p"static/" *website-directory*)) ("/favicon.ico" file-handler - :destination ,(unix-namestring (merge-pathnames #p"static/favicon.ico" *website-directory*)) + :destination ,(merge-pathnames #p"static/favicon.ico" *website-directory*) :content-type "application/x-icon")) :modules '(user images) :admin-navigation '(("user" . "/user/") @@ -46,4 +45,4 @@ :style-sheet-urls '("/static/styles.css") :javascript-urls '("/static/javascript.js"))

- (start :port port :listeners listeners)) + (hunchentoot:start-server :port port))

Modified: branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp (original) +++ branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -18,8 +18,8 @@ (defclass sensor-status-handler (page-handler) ())

-(defmethod handle ((handler sensor-status-handler) req) - (with-bknr-page (req :title "RAW DATA Sensor Status") +(defmethod handle ((handler sensor-status-handler)) + (with-bknr-page (:title "RAW DATA Sensor Status") ((:table :border "1") ((:tr :style "background-color: #cccccc;") (:td "Name") (:td "Current") (:td "Age"))

Modified: branches/trunk-reorg/projects/raw-data/mcp/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/raw-data/mcp/packages.lisp (original) +++ branches/trunk-reorg/projects/raw-data/mcp/packages.lisp Tue Jan 29 07:19:19 2008 @@ -315,7 +315,6 @@ :cl-interpol :cl-ppcre :bknr.web - :net.aserve :xhtml-generator :mcp.config :mcp.sensors

Modified: branches/trunk-reorg/projects/saugnapf/src/package.lisp ============================================================================== --- branches/trunk-reorg/projects/saugnapf/src/package.lisp (original) +++ branches/trunk-reorg/projects/saugnapf/src/package.lisp Tue Jan 29 07:19:19 2008 @@ -44,7 +44,7 @@ :bknr.images :saugnapf.config

- :net.aserve + :hunchentoot :xhtml-generator

:saugnapf.tags

Modified: branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp ============================================================================== --- branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp (original) +++ branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp Tue Jan 29 07:19:19 2008 @@ -27,16 +27,16 @@ (defclass saugnapf-track-handler (edit-object-handler) ())

-(defmethod object-handler-get-object ((handler saugnapf-track-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler saugnapf-track-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'saugnapf-track :query-function #'s-track-with-name))))

-(defmethod authorized-p ((handler saugnapf-track-handler) req) - (let* ((track (object-handler-get-object handler req)) - (user (bknr-request-user req)) - (action (query-param req "action")) +(defmethod authorized-p ((handler saugnapf-track-handler)) + (let* ((track (object-handler-get-object handler)) + (user (bknr-request-user)) + (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p user) nil) ((admin-p user) t) @@ -47,8 +47,8 @@ ((eql action-keyword :create) t) (t nil))))

-(defmethod handle-object-form ((handler saugnapf-track-handler) action (track (eql nil)) req) - (with-bknr-page (req :title "Manage tracks") +(defmethod handle-object-form ((handler saugnapf-track-handler) action (track (eql nil))) + (with-bknr-page (:title "Manage tracks") ((:form :method "POST") (:h2 "Search for track") "Name: " ((:input :type "text" :name "name" :size "30")) :br @@ -57,34 +57,34 @@ (:h2 "Create new track") (track-form)))

-(defmethod handle-object-form ((handler saugnapf-track-handler) action (track saugnapf-track) req) - (with-bknr-page (req :title #?"track $((saugnapf-track-name track))") +(defmethod handle-object-form ((handler saugnapf-track-handler) action (track saugnapf-track)) + (with-bknr-page (:title #?"track $((saugnapf-track-name track))") (track-form :track-id (store-object-id track))))

-(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :save)) track req) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :save)) track) (when track - (with-query-params (req name artist url description) + (with-query-params (name artist url description) (change-slot-values track 'artist artist 'name name 'description description 'url url))) (call-next-method))

-(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :delete)) track req) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :delete)) track) (when track (delete-object track)) - (redirect "/track" req)) + (redirect "/track"))

-(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :create)) track req) - (with-query-params (req name artist url description) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :create)) track) + (with-query-params (name artist url description) (let ((track (make-object 'saugnapf-track :name name :artist artist :description description :url url - :submitter (bknr-request-user req) + :submitter (bknr-request-user) :date (get-universal-time)))) - (redirect (edit-object-url track) req)))) + (redirect (edit-object-url track)))))

(define-bknr-webserver-module saugnapf-track ("/track" saugnapf-track-handler))