[bknr-cvs] r1912 - in branches/xml-class-rework/projects/lisp-ecoop: src website/static website/templates
bknr at bknr.net
bknr at bknr.net
Fri Mar 10 15:22:39 UTC 2006
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)
, at 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 at 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 at huebner.org.
-
-Have fun and see you in Glasgow!"
+be reached by email as hans at 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+@\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>
More information about the Bknr-cvs
mailing list