March 2006 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r1912 - in branches/xml-class-rework/projects/lisp-ecoop: src website/static website/templates
by bknr＠bknr.net 10 Mar '06

10 Mar '06

Author: hhubner Date: 2006-03-10 10:22:38 -0500 (Fri, 10 Mar 2006) New Revision: 1912 Modified: branches/xml-class-rework/projects/lisp-ecoop/src/config.lisp branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp branches/xml-class-rework/projects/lisp-ecoop/src/tags.lisp branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js branches/xml-class-rework/projects/lisp-ecoop/website/static/styles.css branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml Log: Integrated administration functions into the template based site. Numerous smaller changes. Modified: branches/xml-class-rework/projects/lisp-ecoop/src/config.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/config.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/config.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -1,8 +1,12 @@ (in-package :lisp-ecoop.config) ;; URL für BASE HREFs -(defparameter *website-url* "http://lisp-ecoop.bknr.net") +(defparameter *base-path* "/") +(eval-when (:load-toplevel :execute) + (when (probe-file "site.lisp") + (load "site.lisp"))) + (defparameter *root-directory* #p"home:bknr-svn/projects/lisp-ecoop/") (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -9,36 +9,6 @@ `(with-bknr-page (,req :title ,title) ,@body)) -(defclass add-participant-handler (admin-only-handler form-handler) - ()) - -(defmethod handle-form ((handler add-participant-handler) (action (eql nil)) req) - (with-lisp-ecoop-page (req "Create new participant") - ((:form :method "post" :enctype "multipart/form-data" :onsubmit "return check_participant_form(this);") - ((:table :border "1") - (:tr (:th "Login") - (:td (text-field "login" :size 15))) - (:tr (:th "Full Name") - (:td (text-field "full-name" :size 25))) - (:tr (:th "Email") - (:td (text-field "email" :size 25))) - (:tr (:th "Submission") - (:td ((:select :name "submission" :id "submission-selector" :size "1") - (dolist (submission (sort (copy-list (class-instances 'submission)) - #'string-lessp :key #'submission-title)) - (html ((:option :value (store-object-id submission)) - (:princ-safe (submission-title submission)))))) - ((:input :type "submit" :onclick "return create_submission_window();" :value "new"))))) - (submit-button "create" "create")))) - -(defmethod handle-form ((handler add-participant-handler) (action (eql :create)) req) - (with-query-params (req login full-name email text) - (when (find-user login) - (error "user ~A already exists" login)) - (make-participant login :full-name full-name :email email :text text :document-pathname (request-uploaded-file req "document")) - (with-lisp-ecoop-page (req "Pariticpant created") - "The participant has been created in the database and a welcome mail has been sent."))) - (defclass edit-participant-handler (edit-object-handler) () (:default-initargs :class 'participant :query-function #'find-user)) @@ -77,8 +47,8 @@ ()) (defmethod handle ((handler make-submission-handler) req) - (with-query-params (req title abstract) - (let ((submission (make-object 'submission :title title :abstract abstract))) + (with-query-params (req 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") (:princ-safe #?" @@ -131,11 +101,8 @@ "Please choose an administrative task from the menu")) (define-bknr-webserver-module participants - ("/add-participant" add-participant-handler) - ("/edit-participant" edit-participant-handler) ("/make-submission" make-submission-handler) ("/pdf" pdf-handler) ("/upload-document" upload-document-handler) - ("/delete-document" delete-document-handler) - ("/admin" admin-handler)) + ("/delete-document" delete-document-handler)) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -3,7 +3,7 @@ (defpackage :lisp-ecoop.config (:use :cl :cl-user) - (:export #:*website-url* + (:export #:*base-path* #:*website-directory* #:*webserver-port* #:*store-directory* @@ -39,6 +39,7 @@ :xhtml-generator) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:participant + #:make-participant #:all-participants #:participant-p #:participant-text Modified: branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -82,6 +82,10 @@ (text :update :documentation "Self descriptionary text" :element t)) (:default-initargs :picture nil :submission nil :interests nil :text "")) +(defun curry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append args more)))) + (defmethod initialize-persistent-instance :after ((participant participant)) (make-email-list)) @@ -127,7 +131,7 @@ Please direct your questions regarding the workshop to Hans Hübner, who can be reached by email as hans(a)huebner.org. -Have fun and see you in Glasgow!" +Have fun and see you on the workshop!" (user-login participant) initial-password))) @@ -145,26 +149,19 @@ Your new password is: ~A Please direct your questions regarding the workshop to Hans Hübner, who can -be reached by email as hans(a)huebner.org. - -Have fun and see you in Glasgow!" +be reached by email as hans(a)huebner.org." (user-login participant) (user-login participant) password))) -(defun make-participant (login &key full-name email text document-pathname) +(defun make-participant (login &key full-name email text submission) (let* ((initial-password (generate-random-password)) - (participant (make-user login :full-name full-name :email email :password initial-password - :class 'participant))) - (when text - (with-transaction ("set participant text") - (setf (participant-text participant) text))) - (when document-pathname - (let* ((submission (make-object 'submission)) - (document (make-object 'document :info "Initial paper"))) - (blob-from-file document document-pathname) - (with-transaction ("set participant submission") - (push document (submission-documents submission)) - (setf (participant-submissions participant) (list submission))))) + (participant (make-user login :full-name full-name :email email :password initial-password + :class 'participant))) + (with-transaction (:initialize-participant) + (when text + (setf (participant-text participant) text)) + (when submission + (submission-add-submitter submission participant))) (send-welcome-mail participant initial-password) participant)) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/tags.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/tags.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/tags.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -30,7 +30,8 @@ (let ((participant (participant-from-request))) (unless (or (admin-p (bknr-request-user *req*)) (eq participant (bknr-request-user *req*))) - (error "can't edit this profile")) + (html (:h2 "can't edit this profile")) + (return-from profile-editor)) (when (eq :post (request-method *req*)) (with-query-params (*req* action) (format t ";; ACTION ~A~%" action) @@ -109,7 +110,8 @@ (html (:h2 "Invalid submission ID")) (return-from submission-editor)) (unless (submission-edit-permitted-p submission) - (error "can't edit this submission")) + (html (:h2 "can't edit this submission")) + (return-from submission-editor)) (when (eq :post (request-method *req*)) (with-query-params (*req* action) (case (make-keyword-from-string action) @@ -143,13 +145,36 @@ (let ((*submission* submission)) (mapc #'emit-template-node children)))) +(define-bknr-tag add-participant (&key children) + (unless (admin-p (bknr-request-user *req*)) + (html "You must be logged in as adminstrator to create new participants") + (return-from add-participant)) + (with-query-params (*req* action) + (when (eq :create (make-keyword-from-string action)) + (with-query-params (*req* login full-name email text submission) + (when (find-user login) + (error "user ~A already exists" login)) + (when submission + (setf submission (find-store-object (parse-integer submission)))) + (make-participant login :full-name full-name :email email :text text :submission submission) + (html + (:princ-safe #?"The participant $(login) has been created in the database and a welcome mail has been sent."))))) + (mapc #'emit-template-node children)) + +(define-bknr-tag submission-option-list () + (dolist (submission (sort (copy-list (class-instances 'submission)) + #'string-lessp :key #'submission-title)) + (html ((:option :value (store-object-id submission)) + (:princ-safe (submission-title submission)))))) + (define-bknr-tag submission-submitter-editor () (let ((submission (submission-from-request))) (unless submission (html (:h2 "Invalid submission ID")) (return-from submission-submitter-editor)) (unless (submission-edit-permitted-p submission) - (error "can't edit this 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) (let ((submitters (submission-submitters submission))) (cond @@ -263,22 +288,26 @@ (let ((user (bknr-request-user *req*))) (cond ((anonymous-p user) - (when (query-param *req* "__username") - (html ((:div :id "logfail") "Login failed"))) (html ((:form :method "post") - "Login" :br - ((:input :type "text" :name "__username")) - "Password" :br - ((:input :type "password" :name "__password")) - ((:button :type "submit" :name "action" :value "login") "login")))) + "Login" :br + ((:input :type "text" :name "__username")) + "Password" :br + ((:input :type "password" :name "__password")) + (when (query-param *req* "__username") + (html ((:div :id "logfail") "Login failed"))) + ((:button :type "submit" :name "action" :value "login") "login")))) (t - (html ((:form :method "post" :action "/logout") - ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri *req*)))) + (html ((:form :method "post" :action (website-make-path *website* "logout")) + ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri *req*)))) (: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*)) + (mapc #'emit-template-node children))) + (defun parse-duration (string) (ignore-errors (destructuring-bind (hours minute) (mapcar #'parse-integer (coerce (nth-value 1 (scan-to-strings #?r"^(\d+):(\d\d)$" string)) 'list)) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-10 15:22:38 UTC (rev 1912) @@ -8,7 +8,7 @@ (defun make-daily-statistics () (bknr.stats::make-yesterdays-stats :delete-events t :remove-referer-hosts '("lisp-ecoop.bknr.net"))) -(defun publish-lisp-ecoop (&key (port *webserver-port*) (listeners 20) (base-href "/")) +(defun publish-lisp-ecoop (&key (port *webserver-port*) (listeners 20) (base-href *base-path*)) (unless (bknr.cron:cron-job-with-name "daily webserver statistics") (bknr.cron:make-cron-job "daily webserver statistics" 'make-daily-statistics @@ -27,11 +27,7 @@ :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*)))) :modules '(user images stats mailinglist mailinglist-registration participants schedule) - :admin-navigation '(("add participant" . "/add-participant") - ("user" . "/user/") - ("stats" . "/stats") - ("post mailinglists" . "/post-mailinglist") - ("logout" . "/logout")) + :admin-navigation nil :authorizer (make-instance 'bknr-authorizer) :style-sheet-urls (list (format nil "~Astatic/styles.css" base-href)) Modified: branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js 2006-03-10 15:22:38 UTC (rev 1912) @@ -101,7 +101,7 @@ var first_missing; for (var i = 1; i < arguments.length; i++) { var field = form[arguments[i]]; - if (field.value.match(/^\S+$/)) { + if (field.value.match(/\S+/)) { field.style.background = '#fff'; } else { input_complete = false; @@ -132,7 +132,7 @@ submission_selector.selectedIndex = 0; } - open('/create-submission', 'createsubmission', POPUP_WINDOW_PARAMS); + open('create-submission', 'createsubmission', POPUP_WINDOW_PARAMS); return false; } @@ -140,3 +140,18 @@ function check_create_submission_form(form) { return check_form_fields(form, 'title'); } + +// Make new participant + +function check_new_participant_form(form) +{ + var retval = check_form_fields(form, 'login', 'full-name', 'email'); + + if (retval && !form['email'].value.match(/^\S+(a)\S+\.\S+$/)) { + alert("invalid email address"); + form['email'].focus(); + return false; + } + + return retval; +} Modified: branches/xml-class-rework/projects/lisp-ecoop/website/static/styles.css =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/static/styles.css 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/styles.css 2006-03-10 15:22:38 UTC (rev 1912) @@ -134,6 +134,12 @@ z-index: 2; } +div.site-menu div.title { + border: 0px; + border-bottom: 1px solid #000000; + background-color: #f0f0f0; +} + div.site-menu a { text-decoration: none; color: #0000ff; Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml 2006-03-10 15:22:38 UTC (rev 1912) @@ -6,8 +6,8 @@ <head> <title>Create submission</title> <link rel="stylesheet" type="text/css" href="/static/document-utils.css" /> - <script src="/static/document-utils.js" language="javascript" type="text/javascript"> </script> - <script src="/static/javascript.js" language="javascript" type="text/javascript"> </script> + <script src="static/document-utils.js" language="javascript" type="text/javascript"> </script> + <script src="static/javascript.js" language="javascript" type="text/javascript"> </script> </head> <body class="utility-window" onload="init()"> <div id="form" class="page"> @@ -16,7 +16,11 @@ Using this form, a new submission may be created. </p> <form method="post" name="create_submission_form" id="create_submission_form" enctype="multipart/form-data" - action="/make-submission" onsubmit="return check_create_submission_form(this);"> + action="make-submission" onsubmit="return check_create_submission_form(this);"> + <p> + <input type="radio" name="type" value="paper" checked="checked"/> Paper + <input type="radio" name="type" value="breakout-group"/> Breakout group proposal + </p> <label for="title">Title</label><br/> <input type="text" size="40" maxlength="40" name="title" id="title_input"/><br/> <label for="abstract">Abstract</label><br/> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml 2006-03-10 15:13:53 UTC (rev 1911) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml 2006-03-10 15:22:38 UTC (rev 1912) @@ -30,6 +30,14 @@ container-class="site-menu" active-class="site-menu-active" inactive-class="site-menu-inactive" /> + <lisp-ecoop:admin-only> + <menu:site-menu config="admin-menu.xml" + menu-name="admin" + title="Admin" + container-class="site-menu" + active-class="site-menu-active" + inactive-class="site-menu-inactive" /> + </lisp-ecoop:admin-only> <div id="login"> <lisp-ecoop:login-widget /> </div>

1 0

[bknr-cvs] r1911 - in branches/xml-class-rework/projects/mah-jongg: src website
by bknr＠bknr.net 10 Mar '06

10 Mar '06

Author: hhubner Date: 2006-03-10 10:13:53 -0500 (Fri, 10 Mar 2006) New Revision: 1911 Modified: branches/xml-class-rework/projects/mah-jongg/src/game.lisp branches/xml-class-rework/projects/mah-jongg/website/game.js branches/xml-class-rework/projects/mah-jongg/website/game.xsl Log: Change order of winds, first real-life test was successful. Modified: branches/xml-class-rework/projects/mah-jongg/src/game.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-10 14:53:13 UTC (rev 1910) +++ branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-10 15:13:53 UTC (rev 1911) @@ -21,7 +21,7 @@ (find wind (players *round*) :key #'wind)) (defun next-wind (player) - (cadr (member (wind player) '(:east :south :west :north :east)))) + (cadr (member (wind player) '(:east :north :west :south :east)))) (defun east-p (player) (eq :east (wind player))) @@ -40,12 +40,12 @@ (or (find name (players *round*) :key #'name :test #'string-equal) (error "can't find player named ~S" name))) -(deftransaction make-round (east north west south) +(deftransaction make-round (east south west north) (setf *round* (make-instance 'round :players (list (make-player east :east) - (make-player north :north) + (make-player south :south) (make-player west :west) - (make-player south :south))))) + (make-player north :north))))) (defun rotate-winds () (dolist (player (players *round*)) @@ -117,7 +117,7 @@ (:undo (restore (parse-integer undo-timestamp))) (:make-round - (make-round east north west south)) + (make-round east south west north)) (:make-game (make-game (1- (get-universal-time)) (name (wind->player (make-keyword-from-string winner))) Modified: branches/xml-class-rework/projects/mah-jongg/website/game.js =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-10 14:53:13 UTC (rev 1910) +++ branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-10 15:13:53 UTC (rev 1911) @@ -1,6 +1,6 @@ // -*- Java -*- -var winds = [ 'east', 'north', 'west', 'south' ]; +var winds = [ 'east', 'south', 'west', 'north' ]; function $(name) { Modified: branches/xml-class-rework/projects/mah-jongg/website/game.xsl =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-10 14:53:13 UTC (rev 1910) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-10 15:13:53 UTC (rev 1911) @@ -31,10 +31,10 @@ </tr> <tr> <td> - <img src="north.jpg" width="100" height="140"/> + <img src="south.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="north" name="north" autocomplete="off"/> + <input type="text" id="south" name="south" autocomplete="off"/> </td> </tr> <tr> @@ -47,10 +47,10 @@ </tr> <tr> <td> - <img src="south.jpg" width="100" height="140"/> + <img src="north.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="south" name="south" autocomplete="off"/> + <input type="text" id="north" name="north" autocomplete="off"/> </td> </tr> <tr>

1 0

[bknr-cvs] r1910 - in branches/xml-class-rework/bknr/src: . sysclasses web
by bknr＠bknr.net 10 Mar '06

10 Mar '06

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

1 0

[bknr-cvs] r1909 - branches/xml-class-rework/bknr/src/web
by bknr＠bknr.net 08 Mar '06

08 Mar '06

Author: hhubner Date: 2006-03-08 01:51:00 -0500 (Wed, 08 Mar 2006) New Revision: 1909 Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp branches/xml-class-rework/bknr/src/web/templates.lisp branches/xml-class-rework/bknr/src/web/web-macros.lisp branches/xml-class-rework/bknr/src/web/web-utils.lisp Log: Improve error message generation. Now the template based error page is used all over. The website class is getting more and more messed up, though. Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -47,6 +47,12 @@ :accessor website-login-logo-url) (import-spool-directory :initarg :import-spool-directory :accessor website-import-spool-directory) + (template-base-directory :initarg :template-base-directory + :reader website-template-base-directory) + (template-command-packages :initarg :template-command-packages + :reader website-template-command-packages) + (template-handler :initform nil + :reader website-template-handler) (show-page-function :initarg :show-page-function :accessor website-show-page-function) (show-error-page-function :initarg :show-error-page-function @@ -63,6 +69,8 @@ :login-logo-url "/image/bknr-logo" :site-logo-url "/image/bknr-logo" :import-spool-directory #p"/home/bknr/spool/" + :template-base-directory nil + :template-command-packages nil :show-page-function #'show-page :show-error-page-function #'show-error-page)) @@ -124,7 +132,14 @@ (mapcar #'(lambda (module-name) (or (gethash (symbol-name module-name) *website-modules*) (warn "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 + :name "/" + :site website + :destination (website-template-base-directory website) + :command-packages (website-template-command-packages website))) + (push (website-template-handler website) + (website-handlers website))) (mapc #'(lambda (handler) (publish-handler website handler)) (website-handlers website))) @@ -209,15 +224,7 @@ (redirect-uri (request-uri req))) (redirect "/login" req)) (handler-bind ((error #'(lambda (e) - (with-bknr-page (req :title "error processing your request" - :response *response-internal-server-error*) - (if (or (admin-p *user*) - *bknr-debug*) - (html (:pre (:princ-safe e) - #+cmu - ((:font :size "-3") - (debug:backtrace 30 *html-stream*)))) - (html "error processing your request"))) + (funcall (website-show-error-page-function *website*) e) (do-error-log-request req e) (error e)))) (handle handler req))) Modified: branches/xml-class-rework/bknr/src/web/templates.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/templates.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/templates.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -310,7 +310,7 @@ (length (page-handler-prefix handler))) :env (initial-template-environment handler req) :request req))) - ;; ... und wenn keine Fehler entdeckt wurden, rauschreiben + ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben (if body (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" Modified: branches/xml-class-rework/bknr/src/web/web-macros.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -94,16 +94,18 @@ (session-info))))) (defun show-error-page (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*) - (:html - (:head - (header :title "Error processing your request")) - ((:body :class "cms") - (:h1 "Error processing your request") - (:p "While processing your request, an error occured:") - (:pre (:princ-safe error)))))) + (if (website-template-handler *website*) + (send-error-response (website-template-handler *website*) *req* (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*) + (:html + (:head + (header :title "Error processing your request")) + ((:body :class "cms") + (:h1 "Error processing your request") + (:p "While processing your request, an error occured:") + (:pre (:princ-safe error))))))) (defun show-page-with-error-handlers (fn req &key response title (show-page (website-show-page-function *website*)) Modified: branches/xml-class-rework/bknr/src/web/web-utils.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -65,17 +65,30 @@ (loop for name-value in (form-urlencoded-to-query (get-request-body request)) do (push name-value (getf (request-reply-plist request) 'bknr-parsed-parameters)))) -(defun get-parameters-from-body (request) +(defun parse-request-body (request &key uploads) + (let ((content-type (header-slot-value request :content-type))) + (cond + ((null content-type) + nil) + ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) + (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-parameters) nil) - (let ((content-type (header-slot-value request :content-type))) - (cond - ((null content-type) - nil) - ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) - (get-urlencoded-form-data request)) - ((scan #?r"^(?i)multipart/form-data" content-type) - (get-multipart-form-data request)))) + (parse-request-body request :uploads t) (setf (getf (request-reply-plist request) 'body-parsed) t))) (defun request-uploaded-files (request)

1 0

[bknr-cvs] r1908 - in branches/xml-class-rework/projects/lisp-ecoop: src website/static website/templates
by bknr＠bknr.net 08 Mar '06

08 Mar '06

Author: hhubner Date: 2006-03-08 01:49:37 -0500 (Wed, 08 Mar 2006) New Revision: 1908 Added: branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml Modified: branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml Log: First version for Pascal to test. Modified: branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-08 06:49:37 UTC (rev 1908) @@ -14,14 +14,21 @@ (defmethod handle-form ((handler add-participant-handler) (action (eql nil)) req) (with-lisp-ecoop-page (req "Create new participant") - ((:form :method "post" :enctype "multipart/form-data") + ((:form :method "post" :enctype "multipart/form-data" :onsubmit "return check_participant_form(this);") ((:table :border "1") (:tr (:th "Login") (:td (text-field "login" :size 15))) (:tr (:th "Full Name") (:td (text-field "full-name" :size 25))) (:tr (:th "Email") - (:td (text-field "email" :size 25)))) + (:td (text-field "email" :size 25))) + (:tr (:th "Submission") + (:td ((:select :name "submission" :id "submission-selector" :size "1") + (dolist (submission (sort (copy-list (class-instances 'submission)) + #'string-lessp :key #'submission-title)) + (html ((:option :value (store-object-id submission)) + (:princ-safe (submission-title submission)))))) + ((:input :type "submit" :onclick "return create_submission_window();" :value "new"))))) (submit-button "create" "create")))) (defmethod handle-form ((handler add-participant-handler) (action (eql :create)) req) @@ -37,7 +44,7 @@ (:default-initargs :class 'participant :query-function #'find-user)) (defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant) req) - (with-lisp-ecoop-page (req #?"Edit participant ((user-login participant))") + (with-lisp-ecoop-page (req #?"Edit participant $((user-login participant))") ((:form :method "post" :enctype "multipart/form-data") ((:table :border "1") (:tr (:th "Login") @@ -66,7 +73,22 @@ (with-http-body (req *ent* :external-format '(unsigned-byte 8)) (write-sequence pdf net.aserve::*html-stream*))))) +(defclass make-submission-handler (admin-only-handler page-handler) + ()) +(defmethod handle ((handler make-submission-handler) req) + (with-query-params (req title abstract) + (let ((submission (make-object 'submission :title title :abstract abstract))) + (with-lisp-ecoop-page (req #?"Submission created") + (html ((:script :type "text/javascript") + (:princ-safe #?" +if (window.opener) { + opener.add_submission($((store-object-id submission)), '$(title)'); + window.close(); +} else { + window.location.href = 'edit-submission/$((store-object-id submission))'; +}"))))))) + (defclass upload-document-handler (object-handler) () (:default-initargs :class 'submission)) @@ -111,6 +133,7 @@ (define-bknr-webserver-module participants ("/add-participant" add-participant-handler) ("/edit-participant" edit-participant-handler) + ("/make-submission" make-submission-handler) ("/pdf" pdf-handler) ("/upload-document" upload-document-handler) ("/delete-document" delete-document-handler) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-08 06:49:37 UTC (rev 1908) @@ -17,13 +17,12 @@ (make-instance 'website :name "LISP ECOOP CMS" :base-href base-href + :template-base-directory (namestring (merge-pathnames #p"templates/" *website-directory*)) + :template-command-packages '((:lisp-ecoop . :lisp-ecoop.tags) + (:bknr . :bknr.web) + (:menu . :bknr.site-menu)) :handler-definitions `(("/" redirect-handler :to "home") - ("/" template-handler - :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*)) - :command-packages ((:lisp-ecoop . :lisp-ecoop.tags) - (:bknr . :bknr.web) - (:menu . :bknr.site-menu))) ("/static" directory-handler :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*)))) :modules '(user images stats mailinglist mailinglist-registration participants schedule) Modified: branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js 2006-03-08 06:49:37 UTC (rev 1908) @@ -1,6 +1,6 @@ // -*- Java -*- -var POPUP_WINDOW_PARAMS = 'width=500,height=300,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes'; +var POPUP_WINDOW_PARAMS = 'width=700,height=450,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes'; function http_request(url) { @@ -93,3 +93,50 @@ return true; } +// Create Participant form check + +function check_form_fields(form) +{ + var input_complete = true; + var first_missing; + for (var i = 1; i < arguments.length; i++) { + var field = form[arguments[i]]; + if (field.value.match(/^\S+$/)) { + field.style.background = '#fff'; + } else { + input_complete = false; + field.style.background = '#faa'; + if (!first_missing) { + first_missing = field; + } + } + } + + if (!input_complete) { + first_missing.focus(); + } + + return input_complete; +} + +function check_participant_form(form) { + return check_form_fields(form, 'login', 'full-name', 'email'); +} + +// Make a new submission + +function create_submission_window() { + window.add_submission = function(id, title) { + var submission_selector = document.getElementById('submission-selector'); + submission_selector.innerHTML = '<option selected="selected" value="' + id + '">' + title + '</option>' + submission_selector.innerHTML; + submission_selector.selectedIndex = 0; + } + + open('/create-submission', 'createsubmission', POPUP_WINDOW_PARAMS); + + return false; +} + +function check_create_submission_form(form) { + return check_form_fields(form, 'title'); +} Added: branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/create-submission.xml 2006-03-08 06:49:37 UTC (rev 1908) @@ -0,0 +1,43 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html + xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net"> + <head> + <title>Create submission</title> + <link rel="stylesheet" type="text/css" href="/static/document-utils.css" /> + <script src="/static/document-utils.js" language="javascript" type="text/javascript"> </script> + <script src="/static/javascript.js" language="javascript" type="text/javascript"> </script> + </head> + <body class="utility-window" onload="init()"> + <div id="form" class="page"> + <h1>Create a Submission</h1> + <p> + Using this form, a new submission may be created. + </p> + <form method="post" name="create_submission_form" id="create_submission_form" enctype="multipart/form-data" + action="/make-submission" onsubmit="return check_create_submission_form(this);"> + <label for="title">Title</label><br/> + <input type="text" size="40" maxlength="40" name="title" id="title_input"/><br/> + <label for="abstract">Abstract</label><br/> + <textarea name="abstract" cols="72" rows="10"> </textarea><br/> + <button type="submit" name="submit">Create</button> + </form> + <p> + <a href="#" onclick="window.close();">Cancel</a> + </p> + </div> + <div id="progress" class="page"> + Creating submission... + </div> + <div id="success" class="page"> + Submission created. + </div> + <div id="failed" class="page"> + <p> + Cannot create submission: <span id="error-message"> </span> + </p> + <a href="#" onclick="window.close();">Dang!</a> + </div> + </body> +</html> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml 2006-03-08 06:49:37 UTC (rev 1908) @@ -28,10 +28,10 @@ </p> </div> <div id="progress" class="page"> - Upload in progress, please wait + Upload in progress, please wait.... </div> <div id="success" class="page"> - Done uploading + Done uploading. </div> <div id="failed" class="page"> <p> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml 2006-03-07 20:03:26 UTC (rev 1907) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/user-error.xml 2006-03-08 06:49:37 UTC (rev 1908) @@ -7,8 +7,16 @@ xmlns:lisp-ecoop="http://lisp-ecoop06.bknr.net" xmlns:menu="http://bknr.net/menu" > -Your request could not be processed because an error occured: + <head> + <title>Error</title> + <link rel="stylesheet" type="text/css" href="$(base)static/styles.css" /> + </head> + <body> + <h2> + Your request could not be processed because an error occured: + </h2> <pre> $(error-message) </pre> + </body> </html> \ No newline at end of file

1 0

[bknr-cvs] r1907 - in trunk/projects/quickhoney/website: static templates
by bknr＠bknr.net 07 Mar '06

07 Mar '06

Author: hhubner Date: 2006-03-07 15:03:26 -0500 (Tue, 07 Mar 2006) New Revision: 1907 Modified: trunk/projects/quickhoney/website/static/styles.css trunk/projects/quickhoney/website/templates/frontpage.bknr Log: More changes that were lost. Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2006-03-07 19:47:58 UTC (rev 1906) +++ trunk/projects/quickhoney/website/static/styles.css 2006-03-07 20:03:26 UTC (rev 1907) @@ -5,6 +5,11 @@ background-color: #ffffff; } +#hidden-vcard { + visibility: hidden; + height: 0px; +} + /* cms styles */ h1 { Modified: trunk/projects/quickhoney/website/templates/frontpage.bknr =================================================================== --- trunk/projects/quickhoney/website/templates/frontpage.bknr 2006-03-07 19:47:58 UTC (rev 1906) +++ trunk/projects/quickhoney/website/templates/frontpage.bknr 2006-03-07 20:03:26 UTC (rev 1907) @@ -10,10 +10,16 @@ <link rel="stylesheet" href="/static/styles.css" /> <script src="/static/javascript.js" type="text/javascript"> </script> - <title>QuickHoney</title> + <title>QuickHoney - Nana Rausch + Peter Stemmler</title> </head> <body id="quickhoney"> + <div id="hidden-vcard"> + <h1>QuickHoney Illustrations</h1><br /> + <h1>Peter Stemmler</h1>Phone: 646.270.5562<br /> + <h1>Nana Rausch</h1>Phone 646.270.5592<br /> + Studio for Illustration, New York, Portfolio, Email<br /> + </div> <table border="0" width="100%"> <tr height="200">

1 0

[bknr-cvs] r1906 - trunk/projects/quickhoney/website/static
by bknr＠bknr.net 07 Mar '06

07 Mar '06

Author: hhubner Date: 2006-03-07 14:47:58 -0500 (Tue, 07 Mar 2006) New Revision: 1906 Modified: trunk/projects/quickhoney/website/static/javascript.js Log: Correct correction Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2006-03-07 19:46:37 UTC (rev 1905) +++ trunk/projects/quickhoney/website/static/javascript.js 2006-03-07 19:47:58 UTC (rev 1906) @@ -743,8 +743,8 @@ var image = row[image_index]; thumbnail_html += '<a href="#" onclick="display_image(' + "'" + image.position + "'" + ');">' - + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + ',8" ' - + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + '" ' + + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" ' + + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + ',8" ' + ' onload="reveal_image(this);" />' + '</a>'; }

1 0

[bknr-cvs] r1905 - trunk/projects/quickhoney/website/static
by bknr＠bknr.net 07 Mar '06

07 Mar '06

Author: hhubner Date: 2006-03-07 14:46:37 -0500 (Tue, 07 Mar 2006) New Revision: 1905 Modified: trunk/projects/quickhoney/website/static/javascript.js Log: Re-add thumbnail borders. Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2006-03-07 19:44:34 UTC (rev 1904) +++ trunk/projects/quickhoney/website/static/javascript.js 2006-03-07 19:46:37 UTC (rev 1905) @@ -743,7 +743,7 @@ var image = row[image_index]; thumbnail_html += '<a href="#" onclick="display_image(' + "'" + image.position + "'" + ');">' - + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" ' + + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + ',8" ' + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + '" ' + ' onload="reveal_image(this);" />' + '</a>';

1 0

[bknr-cvs] r1904 - trunk/projects/quickhoney/src
by bknr＠bknr.net 07 Mar '06

07 Mar '06

Author: hhubner Date: 2006-03-07 14:44:34 -0500 (Tue, 07 Mar 2006) New Revision: 1904 Added: trunk/projects/quickhoney/src/mods.lisp Log: Several manual modifications as ordererd by quickhoney. Added: trunk/projects/quickhoney/src/mods.lisp =================================================================== --- trunk/projects/quickhoney/src/mods.lisp 2006-03-07 19:43:24 UTC (rev 1903) +++ trunk/projects/quickhoney/src/mods.lisp 2006-03-07 19:44:34 UTC (rev 1904) @@ -0,0 +1,17 @@ +(in-package :quickhoney) + +(setq *images* (get-keywords-intersection-store-images '(:city))) + +(with-transaction (:korrektur) + (dolist (image *images*) + (setf (store-image-keywords image) (remove :city (store-image-keywords image))) + (pushnew :landscape (store-image-keywords image)))) + +(import-image "/home/hans/type-t-shirt.png" :keywords '(:type) :keywords-from-dir nil) + +(with-transaction (:korrektur) + (dolist (image (remove-if-not #'(lambda (image) (scan "shirt" (store-image-name image))) (class-instances 'quickhoney-image))) + (setf (store-image-keywords image) (remove :special (store-image-keywords image))) + (push :t-shirt (store-image-keywords image)))) + +(import-image "/home/hans/contact-peter-nana.png" :keywords '(:type) :keywords-from-dir nil) \ No newline at end of file

1 0

[bknr-cvs] r1903 - trunk/projects/quickhoney/src
by bknr＠bknr.net 07 Mar '06

07 Mar '06

Author: hhubner Date: 2006-03-07 14:43:24 -0500 (Tue, 07 Mar 2006) New Revision: 1903 Modified: trunk/projects/quickhoney/src/webserver.lisp Log: Add "stats" module Modified: trunk/projects/quickhoney/src/webserver.lisp =================================================================== --- trunk/projects/quickhoney/src/webserver.lisp 2006-03-07 19:42:39 UTC (rev 1902) +++ trunk/projects/quickhoney/src/webserver.lisp 2006-03-07 19:43:24 UTC (rev 1903) @@ -33,7 +33,7 @@ ("/favicon.ico" file-handler :destination ,(unix-namestring (merge-pathnames #p"static/favicon.ico" *website-directory*)) :content-type "application/x-icon")) - :modules '(user images) + :modules '(user images stats) :admin-navigation '(("user" . "/user/") ("images" . "/edit-images") ("import" . "/import")

1 0