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

[bknr-cvs] r1890 - in trunk: modules projects/quickhoney projects/quickhoney/src thirdparty/cl-gd
by bknr＠bknr.net 06 Mar '06

06 Mar '06

Author: hhubner Date: 2006-03-06 15:01:56 -0500 (Mon, 06 Mar 2006) New Revision: 1890 Added: trunk/projects/quickhoney/src/screenrc trunk/projects/quickhoney/src/start-quickhoney-screen.sh Modified: trunk/modules/bknr-modules.asd trunk/modules/packages.lisp trunk/projects/quickhoney/ trunk/thirdparty/cl-gd/Makefile Log: deployment changes for quickhoney Modified: trunk/modules/bknr-modules.asd =================================================================== --- trunk/modules/bknr-modules.asd 2006-03-05 14:04:26 UTC (rev 1889) +++ trunk/modules/bknr-modules.asd 2006-03-06 20:01:56 UTC (rev 1890) @@ -30,7 +30,7 @@ :klammerscript #+(not allegro) :acl-compat - :bknr-id3) + #+nil :bknr-id3) :components ((:file "packages") Modified: trunk/modules/packages.lisp =================================================================== --- trunk/modules/packages.lisp 2006-03-05 14:04:26 UTC (rev 1889) +++ trunk/modules/packages.lisp 2006-03-06 20:01:56 UTC (rev 1890) @@ -6,7 +6,7 @@ :cl-interpol :net.aserve :puri - :bknr.id3 + #+(or) :bknr.id3 :bknr.rss :bknr.utils :bknr.web Property changes on: trunk/projects/quickhoney ___________________________________________________________________ Name: svn:ignore + datastore Added: trunk/projects/quickhoney/src/screenrc =================================================================== --- trunk/projects/quickhoney/src/screenrc 2006-03-05 14:04:26 UTC (rev 1889) +++ trunk/projects/quickhoney/src/screenrc 2006-03-06 20:01:56 UTC (rev 1890) @@ -0,0 +1 @@ +screen -t lisp lisp -core cmucl.core -load load.lisp Added: trunk/projects/quickhoney/src/start-quickhoney-screen.sh =================================================================== --- trunk/projects/quickhoney/src/start-quickhoney-screen.sh 2006-03-05 14:04:26 UTC (rev 1889) +++ trunk/projects/quickhoney/src/start-quickhoney-screen.sh 2006-03-06 20:01:56 UTC (rev 1890) @@ -0,0 +1,13 @@ +#!/bin/sh + + +TERM=xterm +SHELL=/bin/tcsh +HOME=/home/hans +PATH=/home/hans/bin:/usr/local/bin:/bin:/usr/bin:/usr/X11R6/bin + +export TERM SHELL HOME PATH +dir=$HOME/bknr-svn/projects/quickhoney/src + +cd $dir +sudo -u hans screen -m -d -c $dir/screenrc Property changes on: trunk/projects/quickhoney/src/start-quickhoney-screen.sh ___________________________________________________________________ Name: svn:executable + * Modified: trunk/thirdparty/cl-gd/Makefile =================================================================== --- trunk/thirdparty/cl-gd/Makefile 2006-03-05 14:04:26 UTC (rev 1889) +++ trunk/thirdparty/cl-gd/Makefile 2006-03-06 20:01:56 UTC (rev 1890) @@ -1,8 +1,8 @@ # this should work for FreeBSD and most Linux distros cl-gd-glue.so: - gcc -I/usr/local/include -fPIC -c cl-gd-glue.c - ld -shared -lgd -lz -lpng -ljpeg -lfreetype -liconv -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib + gcc -fPIC -c cl-gd-glue.c + ld -shared -lgd -lz -lpng -ljpeg -lfreetype -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib rm cl-gd-glue.o # this should work for Mac OS X

1 0

[bknr-cvs] r1889 - in branches/xml-class-rework/bknr/src: data utils web
by bknr＠bknr.net 05 Mar '06

05 Mar '06

Author: hhubner Date: 2006-03-05 09:04:26 -0500 (Sun, 05 Mar 2006) New Revision: 1889 Modified: branches/xml-class-rework/bknr/src/data/object.lisp branches/xml-class-rework/bknr/src/utils/package.lisp branches/xml-class-rework/bknr/src/utils/utils.lisp branches/xml-class-rework/bknr/src/web/authorizer.lisp Log: Attempt to handle uploads which are over the size limit better (not finished) Add scale-bytes function to pretty-print a file's size. Change delete-object so that it can be called within transaction code. Modified: branches/xml-class-rework/bknr/src/data/object.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/object.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/data/object.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -560,17 +560,21 @@ (destroy-object (store-object-with-id id))) (defun delete-object (object) - (execute (make-instance 'transaction :function-symbol 'tx-delete-object - :timestamp (get-universal-time) - :args (list (store-object-id object))))) + (if (in-transaction-p) + (destroy-object object) + (execute (make-instance 'transaction :function-symbol 'tx-delete-object + :timestamp (get-universal-time) + :args (list (store-object-id object)))))) (defun tx-delete-objects (&rest object-ids) (mapc #'(lambda (id) (destroy-object (store-object-with-id id))) object-ids)) (defun delete-objects (&rest objects) - (execute (make-instance 'transaction :function-symbol 'tx-delete-objects - :timestamp (get-universal-time) - :args (mapcar #'store-object-id objects)))) + (if (in-transaction-p) + (mapc #'destroy-object objects) + (execute (make-instance 'transaction :function-symbol 'tx-delete-objects + :timestamp (get-universal-time) + :args (mapcar #'store-object-id objects))))) (deftransaction change-slot-values (object &rest slots-and-values) (when object Modified: branches/xml-class-rework/bknr/src/utils/package.lisp =================================================================== --- branches/xml-class-rework/bknr/src/utils/package.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/utils/package.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -14,6 +14,9 @@ #+(not allegro) (:shadowing-import-from :acl-compat.mp process-kill process-wait) (:export #:define-bknr-class + + ;; byte size formatting + #:scale-bytes ;; date format #:format-date-time Modified: branches/xml-class-rework/bknr/src/utils/utils.lisp =================================================================== --- branches/xml-class-rework/bknr/src/utils/utils.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/utils/utils.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -536,3 +536,17 @@ (apply #'append subclasses (mapcar #'collect-subclasses subclasses))))) (mapcar #'class-name (remove-duplicates (collect-subclasses (if (symbolp class) (find-class class) class)))))) + +(defun scale-bytes (byte-count) + (cond + ((> byte-count (* 1024 1024 1024 1024)) + (format nil "~3,1F TB" (/ byte-count (* 1024 1024 1024 1024)))) + ((> byte-count (* 1024 1024 1024)) + (format nil "~3,1F GB" (/ byte-count (* 1024 1024 1024)))) + ((> byte-count (* 1024 1024)) + (format nil "~3,1F MB" (/ byte-count (* 1024 1024)))) + ((> byte-count 1024) + (format nil "~3,1F KB" (/ byte-count 1024))) + (t + (format nil "~A" byte-count)))) + \ No newline at end of file Modified: branches/xml-class-rework/bknr/src/web/authorizer.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -71,17 +71,26 @@ (defmethod authorize ((authorizer bknr-authorizer) (req http-request) ent) - ;; 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))) + (format t "; trying to authorize request~%") + ;; Catch any errors that occur during request body processing + (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) + (format t "; request authorized~%") + (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)))) + + (format t "; request NOT authorized~%") ;; unauthorized, come up with 401 response to the web browser (redirect "/login" req) :deny)

1 0

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

05 Mar '06

Author: hhubner Date: 2006-03-05 09:02:00 -0500 (Sun, 05 Mar 2006) New Revision: 1888 Added: branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.css branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.js branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml Modified: branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp branches/xml-class-rework/projects/lisp-ecoop/src/lisp-ecoop.asd 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/edit-profile.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml Log: Numerous changes to support the new data model with multiple documents per submission. Modified: branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/handlers.lisp 2006-03-05 14:02:00 UTC (rev 1888) @@ -2,6 +2,9 @@ (enable-interpol-syntax) +(defun format-object-id (format object &rest args) + (apply #'format nil format (store-object-id object) args)) + (defmacro with-lisp-ecoop-page ((req title) &body body) `(with-bknr-page (,req :title ,title) ,@body)) @@ -25,7 +28,7 @@ (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 :submission-pathname (request-uploaded-file req "submission")) + (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."))) @@ -54,15 +57,50 @@ (defclass pdf-handler (object-handler) () - (:default-initargs :class 'submission)) + (:default-initargs :class 'document)) -(defmethod handle-object ((handler pdf-handler) (submission submission) req) - (let ((pdf (file-contents (blob-pathname submission)))) +(defmethod handle-object ((handler pdf-handler) (document document) req) + (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*))))) + +(defclass upload-document-handler (object-handler) + () + (:default-initargs :class 'submission)) + +(defmethod handle-object ((handler upload-document-handler) object req) + (error "Missing object ID")) + +(defmethod handle-object ((handler upload-document-handler) (submission submission) req) + (unless (submission-edit-permitted-p submission) + (error "can't edit this submission")) + (ecase (request-method req) + (:post + (when (request-uploaded-file req "document") + (with-query-params (req info) + (format t "; new document - info ~S~%" info) + (let ((file-name (request-uploaded-file req "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))))))) + (:get + (redirect (format-object-id "/upload/~A" submission) req)))) + +(defclass delete-document-handler (object-handler) + () + (:default-initargs :class 'document)) + +(defmethod handle-object ((handler delete-document-handler) (document document) req) + (unless (submission-edit-permitted-p (document-submission document)) + (error "can't edit this submission")) + (delete-object document)) + (defclass admin-handler (admin-only-handler page-handler) ()) @@ -74,5 +112,7 @@ ("/add-participant" add-participant-handler) ("/edit-participant" edit-participant-handler) ("/pdf" pdf-handler) + ("/upload-document" upload-document-handler) + ("/delete-document" delete-document-handler) ("/admin" admin-handler)) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/lisp-ecoop.asd =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/lisp-ecoop.asd 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/lisp-ecoop.asd 2006-03-05 14:02:00 UTC (rev 1888) @@ -8,12 +8,12 @@ (in-package :lisp-ecoop.system) (defsystem :lisp-ecoop - :name "worldpay test" + :name "LISP ECOOP Website" :author "Hans Huebner <hans(a)huebner.org>" :version "0" :maintainer "Hans Huebner <hans(a)huebner.org>" :licence "BSD" - :description "BKNR Test Web Server" + :description "Website for the LISP ECOOP Workshops" :long-description "" :depends-on (:bknr-modules :cxml :klammerscript) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/packages.lisp 2006-03-05 14:02:00 UTC (rev 1888) @@ -58,6 +58,10 @@ #:submission-remove-submitter #:submission-timeslot #:submission-documents + #:submission-edit-permitted-p + + #:document + #:document-info #:timeslot)) (defpackage :lisp-ecoop.tags Modified: branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/participant.lisp 2006-03-05 14:02:00 UTC (rev 1888) @@ -3,9 +3,19 @@ (enable-interpol-syntax) (define-lisp-ecoop-class document (blob) - ((info :update :documentation "Short information for the document (e.g. 'Slides' or 'Draft Paper')")) - (:default-initargs :type "application/pdf")) + ((info :update :documentation "Short information for the document (e.g. 'Slides' or 'Draft Paper')") + (submission :read :documentation "Submission that this document belongs to")) + (:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document"))) +(defmethod initialize-persistent-instance :after ((document document)) + (with-slots (submission) document + (push document (submission-documents submission)))) + +(defmethod destroy-object :before ((document document)) + (with-slots (submission) document + (with-slots (documents) submission + (setf documents (remove document documents))))) + (define-lisp-ecoop-class submission () ((title :update :documentation "Title of the submission" :initform nil :attribute t) (abstract :update :documentation "Abstract or short description" :initform nil :element t) @@ -13,6 +23,13 @@ (timeslot :update :documentation "Timeslot scheduled for this submission" :initform nil :attribute t) (documents :update :documentation "List of documents attached to this submission" :initform nil :element t))) +(defmethod destroy-object :before ((submission submission)) + (dolist (participant (submission-submitters submission)) + (with-slots (submissions) participant + (setf submissions (remove submission submissions)))) + (mapc #'destroy-object (submission-documents submission)) + (setf (submission-documents submission) nil)) + (defmethod destroy-object :before ((timeslot timeslot)) (when (subtypep (type-of (timeslot-content timeslot)) 'submission) (setf (submission-timeslot (timeslot-content timeslot)) nil))) @@ -20,6 +37,10 @@ (defmethod submission-type ((submission submission)) "Generic submission") +(defun submission-edit-permitted-p (submission) + (or (admin-p (bknr-request-user *req*)) + (find (bknr-request-user *req*) (submission-submitters submission)))) + (defmethod submission-add-submitter ((submission submission) submitter) (pushnew submitter (submission-submitters submission)) (pushnew submission (participant-submissions submitter))) @@ -131,17 +152,19 @@ (user-login participant) password))) -(defun make-participant (login &key full-name email text submission-pathname) +(defun make-participant (login &key full-name email text document-pathname) (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 submission-pathname - (let ((submission (make-object 'submission))) - (blob-from-file submission submission-pathname) + (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))))) (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-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/tags.lisp 2006-03-05 14:02:00 UTC (rev 1888) @@ -53,18 +53,19 @@ (delete-object participant) (html (:h2 "Participant has been deleted")) (return-from profile-editor)))) - (when (request-uploaded-file *req* "submission") - (with-query-params (*req* type title abstract) + (when (request-uploaded-file *req* "document") + (with-query-params (*req* type title abstract info) (format t "; new submission - title ~S abstract ~S~%" title abstract) - (let ((file-name (request-uploaded-file *req* "submission"))) + (let ((file-name (request-uploaded-file *req* "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") - 'breakout-group-proposal - 'paper) - :submitters (list participant) :title title :abstract abstract))) - (blob-from-file submission file-name) - (with-transaction ("adding pariticipant submission") + (let* ((submission (make-object (if (equal type "breakout-group-proposal") + 'breakout-group-proposal + 'paper) + :submitters (list participant) :title title :abstract abstract)) + (document (make-object 'document :info info :submission submission))) + (blob-from-file document file-name) + (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") @@ -91,24 +92,17 @@ (let ((*participant* participant)) (mapc #'emit-template-node children)))) -(defun submission-info (submission) - (if submission - (dolist (document (submission-documents submission)) - (with-open-file (submission-file (blob-pathname document)) - (format nil "(~D bytes, uploaded ~A)" - (file-length submission-file) - (format-date-time (file-write-date submission-file))))) - "[no submission uploaded]")) +(defun document-file-info (document) + (with-open-file (document-file (blob-pathname document)) + (format nil "(~A, uploaded ~A)" + (scale-bytes (file-length document-file)) + (format-date-time (file-write-date document-file))))) (defvar *submission*) (defun submission-from-request () (find-store-object (parse-integer (get-template-var :*path-arg*)))) -(defun submission-edit-permitted-p (submission) - (or (admin-p (bknr-request-user *req*)) - (find (bknr-request-user *req*) (submission-submitters submission)))) - (define-bknr-tag submission-editor (&key children) (let ((submission (submission-from-request))) (unless submission @@ -123,13 +117,15 @@ (delete-object submission) (html (:h2 "The submission has been deleted")) (return-from submission-editor)))) - (when (request-uploaded-file *req* "file") - (let ((file-name (request-uploaded-file *req* "file"))) + (when (request-uploaded-file *req* "document") + (let ((file-name (request-uploaded-file *req* "document"))) (with-open-file (pdf file-name) (cond ((cl-ppcre:scan "^%PDF-" (read-line pdf)) (html (:h2 "New document has been saved")) - (blob-from-file submission file-name)) + (with-query-params (*req* 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) @@ -181,12 +177,18 @@ (:princ-safe (user-full-name participant)))))))))))))) (define-bknr-tag submission-uploader () - (html (:princ-safe (submission-info *submission*)) :br - ((:button :type "button" :value "show" :onclick (format-object-id "document.location.href = '/submission/~A';" *submission*)) - "show") - :br - "Choose PDF file and press 'upload'" :br - ((:input :type "file" :name "file")) ((:button :type "submit" :name "action" :value "upload") "upload"))) + (html + (:table + (:tbody + (dolist (document (submission-documents *submission*)) + (html + (:tr + (:td (:princ-safe (document-info document))) + (:td (:princ-safe (document-file-info document))) + (:td ((:button :type "button" :value "show" :onclick (format-object-id "document.location.href = '/pdf/~A';" document)) "show") + ((:button :type "button" :value "delete" + :onclick (format-object-id "return delete_document(~A, \"~A\");" document (document-info document))) "delete")))))))) + (html ((:button :type "button" :value "show" :onclick "return open_document_upload_window()") "upload"))) (define-bknr-tag submission-submitters-chooser () (let ((submitters (submission-submitters *submission*))) @@ -254,7 +256,6 @@ (dolist (submission (participant-submissions *participant*)) (html ((:a :href (format-object-id "/submission/~A" submission)) (:princ-safe (submission-title submission))) " (" (:princ-safe (submission-type submission)) ")" - :br (:princ-safe (submission-info submission)) :br)) (html "[no submission]"))) @@ -340,6 +341,14 @@ (html " " ((:a :href (format-object-id "/edit-submission/~A" submission)) "[Edit]"))))))) +(define-bknr-tag submission-document-links (&key (submission (object-from-request))) + (html + (:h2 "Documents") + (:ul + (dolist (document (submission-documents submission)) + (html (:li ((:a :href (format-object-id "/pdf/~A" document) :target "_new") + (:princ-safe (document-info document)) " " (:princ-safe (document-file-info document))))))))) + (define-bknr-tag load-argument-object (&key children) (let* ((object (object-from-request))) (object-to-template-vars object) Modified: branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/src/webserver.lisp 2006-03-05 14:02:00 UTC (rev 1888) @@ -28,7 +28,8 @@ :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*)))) :modules '(user images stats mailinglist mailinglist-registration participants schedule) - :admin-navigation '(("user" . "/user/") + :admin-navigation '(("add participant" . "/add-participant") + ("user" . "/user/") ("stats" . "/stats") ("post mailinglists" . "/post-mailinglist") ("logout" . "/logout")) Added: branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.css =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.css 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.css 2006-03-05 14:02:00 UTC (rev 1888) @@ -0,0 +1,21 @@ +body { + font-family: Verdana, Geneva, Arial, Helvetica, sans-serif; + background-color: #ffffff; +} + +h1 { + font-size: 14pt; + font-weight: bold; +} + +div.page { + position: absolute; + visibility: hidden; + top: 20px; + left: 20px; +} + +label { + width: 200px; + float: left; +} \ No newline at end of file Added: branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.js =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.js 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/document-utils.js 2006-03-05 14:02:00 UTC (rev 1888) @@ -0,0 +1,47 @@ +// -*- Java -*- Script + +function $(name) +{ + return document.getElementById(name); +} + +function init() +{ + var url = document.location.href; + + // alert('init: ' + url); + + if (url.match("failure=")) { + var message = url.replace(/.*failure=(.*)/, "$1"); + $('error-message').innerHTML = decodeURI(message); + $('failed').style.visibility = 'visible'; + } else if (url.match("success=1")) { + $('success').style.visibility = 'visible'; + window.opener.location.reload(); + setTimeout("window.close()", 1000); + } else { + $('form').style.visibility = 'visible'; + } +} + +function begin_upload() +{ + if ($('info_input').value.match(/^\s*$/)) { + $('info_input').style.backgroundColor = '#f33'; + $('info_input').focus(); + return false; + } + + $('form').style.visibility = 'hidden'; + $('progress').style.visibility = 'visible'; + + var action = document.location.href; + action = action.replace(/upload/, "upload-document"); + + // alert(action); + + $('upload_document_form').action = action; + + return true; +} + 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-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/javascript.js 2006-03-05 14:02:00 UTC (rev 1888) @@ -1,5 +1,33 @@ // -*- Java -*- +var POPUP_WINDOW_PARAMS = 'width=500,height=300,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes'; + +function http_request(url) +{ + var client; + + if (window.XMLHttpRequest) { + client = new XMLHttpRequest(); + } else { + client = new ActiveXObject("Microsoft.XMLHTTP"); + } + + client.open("GET", url, false); + + try { + if (window.XMLHttpRequest) { + client.send(null); + } else { + client.send(); + } + } + catch (e) { + debug('error sending request: ', e); + } + + return client.responseXML; +} + /* cms support */ function check(button, checkboxname, b) { @@ -24,7 +52,44 @@ /* adding/removing submitters */ function submitters_window(url) { - var submitters_window = open(url, "changesubmitters", "width=200,height=400,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes"); + var submitters_window = open(url, "changesubmitters", POPUP_WINDOW_PARAMS); submitters_window.focus(); return false; } + +/* Check upload parameters */ + +function check_document_upload() +{ + var info_input = document.getElementById('document-info-input'); + if (info_input.value == "") { + alert("Missing document info"); + info_input.focus(); + return false; + } + + return true; +} + +// Open document upload window + +function open_document_upload_window() { + var object_id = parseInt(window.location.href.replace(/.*\/(\d+)/, "$1")); + open('/upload-document/' + object_id, 'upload', POPUP_WINDOW_PARAMS); + return false; +} + +// Delete a document + +function delete_document(id, info) { + if (!confirm('Delete document "' + info + '" ?')) { + return false; + } + + http_request('/delete-document/' + id); + + window.location.reload(); + + return true; +} + 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-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/static/styles.css 2006-03-05 14:02:00 UTC (rev 1888) @@ -165,8 +165,8 @@ } div#body div#content { - position: absolute; - left: 180px; + position: absolute; + left: 180px; } body h1 { @@ -242,4 +242,5 @@ pre { font-family: Times, serif; -} \ No newline at end of file +} + Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-profile.xml 2006-03-05 14:02:00 UTC (rev 1888) @@ -62,28 +62,6 @@ <tr> <td colspan="2"><lisp-ecoop:submission-list participant-only="1" /></td> </tr> - <tr><th colspan="2">New Submission</th></tr> - <tr> - <td>Type:</td> - <td> - <select name="type"> - <option value="paper">Paper</option> - <option value="breakout-group-proposal">Breakout Group Proposal</option> - </select> - </td> - </tr> - <tr> - <td>Title:</td> - <td><input type="text" name="title" size="80" /></td> - </tr> - <tr> - <td>Abstract:</td> - <td><textarea name="abstract" cols="76" rows="10"> </textarea></td> - </tr> - <tr> - <td>PDF:</td> - <td><input type="file" name="submission" /><input type="submit" name="action" value="upload" /></td> - </tr> <tr><th colspan="2">Action</th></tr> <tr> <td colspan="2"> @@ -96,11 +74,6 @@ </lisp-ecoop:profile-editor> <p> Please contact <a href="mailto:hans@bknr.net">Hans Hübner</a> for -inquiries relating to the workshop web site. We are interested in -developing the website into a LISP-based system to coordinate -distributed development activities and related real-life meetings -using an incremental development process. See <a -href="/bknr-technology">the Website technology blurb</a> for a -description of the technology used by this web site. +inquiries relating to the workshop web site. </p> </lisp-ecoop:page> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/edit-submission.xml 2006-03-05 14:02:00 UTC (rev 1888) @@ -26,7 +26,7 @@ <td><textarea name="abstract" cols="76" rows="15">$(abstract)</textarea></td> </tr> <tr> - <td>Document (PDF)</td> + <td>Documents (PDF)</td> <td><lisp-ecoop:submission-uploader /></td> </tr> <tr><th colspan="2">Action</th></tr> Modified: branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/submission.xml 2006-03-05 14:02:00 UTC (rev 1888) @@ -8,6 +8,6 @@ <h1>$(title)</h1> <h2><lisp-ecoop:submission-submitter-links /></h2> <blockquote><pre>$(abstract)</pre></blockquote> - <a href="/pdf/$(object-id)">[Show PDF]</a> + <lisp-ecoop:submission-document-links /> </lisp-ecoop:load-argument-object> </lisp-ecoop:page> 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-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/toplevel.xml 2006-03-05 14:02:00 UTC (rev 1888) @@ -36,6 +36,7 @@ </div> <div id="content"> <bknr:tag-body /> + <hr class="content-rule"/> </div> </div> </body> Added: branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml =================================================================== --- branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml 2006-03-03 22:31:33 UTC (rev 1887) +++ branches/xml-class-rework/projects/lisp-ecoop/website/templates/upload.xml 2006-03-05 14:02:00 UTC (rev 1888) @@ -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>Upload document</title> + <link rel="stylesheet" type="text/css" href="/static/document-utils.css" /> + <script src="/static/document-utils.js" language="javascript" type="text/javascript"> </script> + </head> + <body class="utility-window" onload="init()"> + <div id="form" class="page"> + <h1>Upload a document</h1> + <p> + Your document needs to be in PDF format. Every document has an attached short + information text which describes the nature of the content. Suggested texts + include "Draft Paper", "Final Paper", "Slides". + </p> + <form method="post" name="upload_document_form" id="upload_document_form" enctype="multipart/form-data" onsubmit="return begin_upload();" action="/upload-document"> + <label for="info">Info text</label><br/> + <input type="text" size="40" maxlength="40" name="info" id="info_input"/><br/> + <label for="document">Document</label><br/> + <input type="file" name="document" value="*.pdf"/><br/> + <button type="submit" name="submit">Upload</button> + </form> + <p> + <a href="#" onclick="window.close();">Cancel</a> + </p> + </div> + <div id="progress" class="page"> + Upload in progress, please wait + </div> + <div id="success" class="page"> + Done uploading + </div> + <div id="failed" class="page"> + <p> + Upload failed: <span id="error-message"> </span> + </p> + <a href="#" onclick="window.close();">Dang!</a> + </div> + </body> +</html>

1 0

[bknr-cvs] r1887 - branches/xml-class-rework/projects/mah-jongg/website
by bknr＠bknr.net 03 Mar '06

03 Mar '06

Author: hhubner Date: 2006-03-03 17:31:33 -0500 (Fri, 03 Mar 2006) New Revision: 1887 Modified: branches/xml-class-rework/projects/mah-jongg/website/game.js branches/xml-class-rework/projects/mah-jongg/website/game.xsl Log: Small UI enhancements. Modified: branches/xml-class-rework/projects/mah-jongg/website/game.js =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 20:56:27 UTC (rev 1886) +++ branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 22:31:33 UTC (rev 1887) @@ -7,24 +7,29 @@ return document.getElementById(name); } +var interval; + function init_new_round_form() { + interval = setInterval("check_new_round_form()", 300); $('east').focus(); } function check_new_round_form() { + var is_valid = true; + for (i in winds) { if ($(winds[i]).value.match(/^\s*$/)) { - $(winds[i]).focus(); - return false; + is_valid = false; } } - return true; + $('make_round_button').disabled = is_valid ? undefined : 'disabled'; + + return is_valid; } -var check_new_game_inputs_interval; var winner_clicked = false; function set_winner_clicked() @@ -35,8 +40,8 @@ function check_new_game_inputs() { - if (!check_new_game_inputs_interval) { - check_new_game_inputs_interval = setInterval("check_new_game_inputs()", 300); + if (!interval) { + interval = setInterval("check_new_game_inputs()", 300); } var is_valid = winner_clicked; Modified: branches/xml-class-rework/projects/mah-jongg/website/game.xsl =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 20:56:27 UTC (rev 1886) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 22:31:33 UTC (rev 1887) @@ -26,7 +26,7 @@ <img src="east.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="east" name="east"/> + <input type="text" id="east" name="east" autocomplete="off"/> </td> </tr> <tr> @@ -34,7 +34,7 @@ <img src="north.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="north" name="north"/> + <input type="text" id="north" name="north" autocomplete="off"/> </td> </tr> <tr> @@ -42,7 +42,7 @@ <img src="west.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="west" name="west"/> + <input type="text" id="west" name="west" autocomplete="off"/> </td> </tr> <tr> @@ -50,12 +50,12 @@ <img src="south.jpg" width="100" height="140"/> </td> <td> - <input type="text" id="south" name="south"/> + <input type="text" id="south" name="south" autocomplete="off"/> </td> </tr> <tr> <td colspan="2"> - <button type="submit" name="action" value="make-round">Start Round</button> + <button type="submit" name="action" id="make_round_button" value="make-round" disabled="disabled">Start Round</button> </td> </tr> </tbody>

1 0

[bknr-cvs] r1886 - branches/xml-class-rework/projects/mah-jongg/website
by bknr＠bknr.net 03 Mar '06

03 Mar '06

Author: hhubner Date: 2006-03-03 15:56:27 -0500 (Fri, 03 Mar 2006) New Revision: 1886 Modified: branches/xml-class-rework/projects/mah-jongg/website/game.css branches/xml-class-rework/projects/mah-jongg/website/game.js branches/xml-class-rework/projects/mah-jongg/website/game.xsl Log: User interface now basically works. Modified: branches/xml-class-rework/projects/mah-jongg/website/game.css =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 17:50:47 UTC (rev 1885) +++ branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 20:56:27 UTC (rev 1886) @@ -56,7 +56,7 @@ } .score-input { - width: 40px; + width: 70px; text-align: right; } Modified: branches/xml-class-rework/projects/mah-jongg/website/game.js =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 17:50:47 UTC (rev 1885) +++ branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 20:56:27 UTC (rev 1886) @@ -25,21 +25,39 @@ } var check_new_game_inputs_interval; +var winner_clicked = false; +function set_winner_clicked() +{ + winner_clicked = true; + check_new_game_inputs(); +} + function check_new_game_inputs() { if (!check_new_game_inputs_interval) { check_new_game_inputs_interval = setInterval("check_new_game_inputs()", 300); } + var is_valid = winner_clicked; + for (i in winds) { - if ($(winds[i]).value.match(/^\s*$/)) { - $('make_game_button').disabled = 'disabled'; - return false; + try { + var value = parseInt($(winds[i] + '-score').value) * (1 << parseInt($(winds[i] + '-doubles').value)); + $(winds[i]).value = isNaN(value) ? '' : Math.min(value, 3000); } + catch (e) { + // Ignore errors + } } - $('make_game_button').disabled = undefined; + for (i in winds) { + if (!$(winds[i]).value.match(/^[1-9]/)) { + is_valid = false; + } + } + + $('make_game_button').disabled = is_valid ? undefined : 'disabled'; return true; } Modified: branches/xml-class-rework/projects/mah-jongg/website/game.xsl =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 17:50:47 UTC (rev 1885) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 20:56:27 UTC (rev 1886) @@ -125,19 +125,19 @@ <img width="50" height="70" src="{(a)wind}.jpg"/> </td> <td> - <input type="radio" name="winner" value="{@wind}" onclick="check_new_game_inputs()"/> + <input type="radio" name="winner" value="{@wind}" onclick="return set_winner_clicked()"/> </td> <th> <xsl:value-of select="@name"/> </th> <td> - <input autocomplete="off" id="{@wind}-score" class="score-input" onchange="input_change('{@wind}');"/> + <input autocomplete="off" id="{@wind}-score" tabindex="1" class="score-input" onchange="return check_new_game_inputs();" value=""/> </td> <td> - <input autocomplete="off" id="{@wind}-doubles" class="score-input" onchange="input_change('{@wind}');" value="0"/> + <input autocomplete="off" id="{@wind}-doubles" tabindex="1" class="score-input" onchange="return check_new_game_inputs();" value="0"/> </td> <td> - <input autocomplete="off" id="{@wind}" name="{@wind}" class="score-input" readonly="readonly"/> + <input autocomplete="off" id="{@wind}" name="{@wind}" class="score-input" readonly="readonly" value=""/> </td> </tr> </xsl:template>

1 0

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

03 Mar '06

Author: hhubner Date: 2006-03-03 12:50:47 -0500 (Fri, 03 Mar 2006) New Revision: 1885 Added: branches/xml-class-rework/projects/mah-jongg/ branches/xml-class-rework/projects/mah-jongg/src/ branches/xml-class-rework/projects/mah-jongg/src/game.lisp branches/xml-class-rework/projects/mah-jongg/src/load.lisp branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd branches/xml-class-rework/projects/mah-jongg/src/package.lisp branches/xml-class-rework/projects/mah-jongg/src/test.lisp branches/xml-class-rework/projects/mah-jongg/website/ branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg branches/xml-class-rework/projects/mah-jongg/website/east.jpg branches/xml-class-rework/projects/mah-jongg/website/game.css branches/xml-class-rework/projects/mah-jongg/website/game.js branches/xml-class-rework/projects/mah-jongg/website/game.xml branches/xml-class-rework/projects/mah-jongg/website/game.xsl branches/xml-class-rework/projects/mah-jongg/website/north.jpg branches/xml-class-rework/projects/mah-jongg/website/south.jpg branches/xml-class-rework/projects/mah-jongg/website/undohtml.css branches/xml-class-rework/projects/mah-jongg/website/west.jpg Log: First version of the Mah-Jongg calculation server. Property changes on: branches/xml-class-rework/projects/mah-jongg ___________________________________________________________________ Name: svn:ignore + datastore Added: branches/xml-class-rework/projects/mah-jongg/src/game.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,139 @@ +(in-package :mah-jongg) + +(defvar *round* nil) + +(deftransaction clear-round () + (setf *round* nil)) + +(defclass player () + ((name :reader name :initarg :name) + (wind :accessor wind :initarg :wind) + (score :accessor score :initarg :score :initform 0))) + +(defmethod print-object ((player player) stream) + (print-unreadable-object (player stream :type t) + (format stream "~S (~A) SCORE: ~A" (name player) (wind player) (score player)))) + +(defun make-player (name wind) + (make-instance 'player :name name :wind wind)) + +(defun wind->player (wind) + (find wind (players *round*) :key #'wind)) + +(defun next-wind (player) + (cadr (member (wind player) '(:east :south :west :north :east)))) + +(defun east-p (player) + (eq :east (wind player))) + +(defun balance (player-1 score-1 player-2 &optional (score-2 0)) + (let ((sum (* (if (east-p player-1) 2 1) (- score-1 score-2)))) + (incf (score player-1) sum) + (decf (score player-2) sum))) + +(defclass round () + ((players :reader players :initarg :players :documentation "List of players") + (games :accessor games :initform nil) + (east-win-count :accessor east-win-count :initform 0))) + +(defun find-player (name) + (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) + (setf *round* (make-instance 'round + :players (list (make-player east :east) + (make-player north :north) + (make-player west :west) + (make-player south :south))))) + +(defun rotate-winds () + (dolist (player (players *round*)) + (setf (wind player) (next-wind player)))) + +(defclass game () + ((winner :reader winner :initarg :winner) + (east :reader east :initarg :east) + (results :reader results :initarg :results :documentation "List ((<player> <score>) (...))"))) + +(defmethod print-object ((game game) stream) + (print-unreadable-object (game stream :type t) + (format stream "WINNER: ~S" (name (winner game))))) + +(deftransaction make-game (winner results) + (let* ((all-results (mapcar #'(lambda (name-score) (list (find-player (car name-score)) (cadr name-score))) results)) + (winner (find-player winner)) + (east (find-if #'east-p (players *round*))) + (winner-result (find winner all-results :key #'car)) + (other-results (remove winner all-results :key #'car))) + (dolist (loser (mapcar #'car other-results)) + (balance winner (cadr winner-result) loser)) + (apply #'balance (append (nth 0 other-results) (nth 1 other-results))) + (apply #'balance (append (nth 1 other-results) (nth 2 other-results))) + (apply #'balance (append (nth 0 other-results) (nth 2 other-results))) + (when (east-p winner) + (incf (east-win-count *round*))) + (when (or (not (east-p winner)) + (eql 4 (east-win-count *round*))) + (rotate-winds) + (setf (east-win-count *round*) 0)) + (car (push (make-instance 'game + :winner winner + :east east + :results all-results) + (games *round*))))) + +(defun round-as-xml () + (with-element "round" + (dolist (player (players *round*)) + (with-slots (name wind score) player + (with-element "player" + (attribute "name" name) + (attribute "wind" (string-downcase wind)) + (attribute "score" score)))) + (dolist (game (reverse (games *round*))) + (with-slots (winner east results) game + (with-element "game" + (dolist (player (players *round*)) + (with-element "score" + (attribute "name" (name player)) + (when (eq player winner) + (attribute "winner" "1")) + (when (eq player east) + (attribute "east" "1")) + (text (princ-to-string (cadr (find player results :key #'car))))))))))) + +(defun request-param (req name) + (assoc name (request-query req) :test #'equal)) + +(defun handle-game (req ent) + (when (eq :post (request-method req)) + (with-query-params (req action east north west south winner) + (ecase (make-keyword-from-string action) + (:make-round + (make-round east north west south)) + (:make-game + (make-game (name (wind->player (make-keyword-from-string winner))) + (mapcar #'(lambda (wind) (list (name (wind->player wind)) + (parse-integer (query-param req (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-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* + (round-as-xml) + (with-element "no-round")))))) + +(defun start-server (&key (port 8080)) + + (unpublish :all t) + (close-store) + + (make-instance 'store + :directory "../datastore/") + (publish :path "/game" :function 'handle-game) + (publish-directory :prefix "/" :destination "../website/") + (start :port port)) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/src/load.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/load.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/load.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,10 @@ +(push :cl-gd-gif *features*) + +(asdf:oos 'asdf:load-op :mah-jongg) +(asdf:oos 'asdf:load-op :swank) + +(swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t) + +(mah-jongg::start-server) + +(mp::startup-idle-and-top-level-loops) Added: branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,22 @@ +;;;; -*- Mode: LISP -*- + +(in-package :cl-user) + +(defpackage :mah-jongg.system + (:use :cl :asdf)) + +(in-package :mah-jongg.system) + +(defsystem :mah-jongg + :name "Mah Jongg" + :author "Hans Huebner <hans(a)huebner.org>" + :version "0" + :maintainer "Hans Huebner <hans(a)huebner.org>" + :licence "BSD" + :description "Mah Jongg game calculator" + :long-description "" + + :depends-on (:cxml :bknr :bknr-datastore :aserve) + + :components ((:file "package") + (:file "game" :depends-on ("package")))) Added: branches/xml-class-rework/projects/mah-jongg/src/package.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/package.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/package.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,12 @@ +(in-package :cl-user) + +(defpackage :mah-jongg + (:use :cl + :cl-user + :cxml + :bknr.utils + :bknr.web + :bknr.datastore + :net.aserve + :net.html.generator) + (:export)) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/src/test.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/test.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/test.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,11 @@ +(in-package :mah-jongg) + +(clear-round) + +(make-round "hans" "julia" "starbug" "lisa") + +(make-game "hans" '((hans 1000) (julia 10) (starbug 20) (lisa 200))) + +(make-game "starbug" '((hans 10) (julia 100) (starbug 200) (lisa 200))) + +(players *round*) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/east.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/east.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/game.css =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,67 @@ +body { + font-family: sans-serif; + background-image: url(bamboo.jpg); + height: 1200px; +} + +* { + font-size: 30px; +} + +th { + width: 120px; +} + +td, th { + background-color: #fff; +} + +td.winner { + background-color: #ccc; +} + +td { + text-align: right; +} + +tr.sum { + padding-top: 4px; +} + +td.sum { + border-style: dashed; + border-width: 4px; +} + +td img { + float: left; + margin-left: 4px; + margin-top: 4px; +} + +table { + margin: 20px; +} + +table#game-list { + position: absolute; + right: 0px; + top: 0px; +} + +table#current-game { + position: fixed; + left: 0px; + bottom: 0px; +} + +.score-input { + width: 40px; + text-align: right; +} + +#end-round-button { + position: fixed; + right: 20px; + bottom: 20px; +} \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/game.js =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,45 @@ +// -*- Java -*- + +var winds = [ 'east', 'north', 'west', 'south' ]; + +function $(name) +{ + return document.getElementById(name); +} + +function init_new_round_form() +{ + $('east').focus(); +} + +function check_new_round_form() +{ + for (i in winds) { + if ($(winds[i]).value.match(/^\s*$/)) { + $(winds[i]).focus(); + return false; + } + } + + return true; +} + +var check_new_game_inputs_interval; + +function check_new_game_inputs() +{ + if (!check_new_game_inputs_interval) { + check_new_game_inputs_interval = setInterval("check_new_game_inputs()", 300); + } + + for (i in winds) { + if ($(winds[i]).value.match(/^\s*$/)) { + $('make_game_button').disabled = 'disabled'; + return false; + } + } + + $('make_game_button').disabled = undefined; + + return true; +} Added: branches/xml-class-rework/projects/mah-jongg/website/game.xml =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xml 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xml 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,2 @@ +<?xml-stylesheet type="text/xsl" href="game.xsl"?> +<round><player name="hans" score="0" wind="EAST"></player><player name="julia" score="0" wind="NORTH"></player><player name="starbug" score="0" wind="WEST"></player><player name="lisa" score="0" wind="SOUTH"></player></round> \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/game.xsl =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,151 @@ +<?xml version="1.0" ?> + +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns="http://www.w3.org/1999/xhtml" + version="1.0"> + + <xsl:template match="/"> + <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>Mah-Jongg</title> + <link href="undohtml.css" rel="stylesheet" type="text/css"/> + <link href="game.css" rel="stylesheet" type="text/css"/> + <script type="text/javascript" src="game.js"> </script> + </head> + <xsl:apply-templates/> + </html> + </xsl:template> + + <xsl:template match="/no-round"> + <body onload="init_new_round_form();"> + <form name="new_round_form" id="new_round_form" action="#" method="post" onsubmit="return check_new_round_form();"> + <table> + <tbody> + <tr> + <td> + <img src="east.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="east" name="east"/> + </td> + </tr> + <tr> + <td> + <img src="north.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="north" name="north"/> + </td> + </tr> + <tr> + <td> + <img src="west.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="west" name="west"/> + </td> + </tr> + <tr> + <td> + <img src="south.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="south" name="south"/> + </td> + </tr> + <tr> + <td colspan="2"> + <button type="submit" name="action" value="make-round">Start Round</button> + </td> + </tr> + </tbody> + </table> + </form> + </body> + </xsl:template> + + <xsl:template match="/round"> + <body> + <table id="game-list"> + <thead> + <tr> + <xsl:apply-templates select="player"/> + </tr> + </thead> + <tbody> + <xsl:apply-templates select="game"/> + <tr class="sum"> + <xsl:apply-templates select="player" mode="score"/> + </tr> + </tbody> + </table> + <form method="post" action="#"> + <table id="current-game"> + <tbody> + <xsl:apply-templates select="player" mode="form"/> + <tr> + <td colspan="6"> + <button type="submit" name="action" value="make-game" disabled="disabled" id="make_game_button">Add Result</button> + </td> + </tr> + </tbody> + </table> + <button type="submit" name="action" id="end-round-button" value="clear-round">End Round</button> + </form> + </body> + </xsl:template> + + <xsl:template match="player"> + <th> + <xsl:value-of select="@name"/> + </th> + </xsl:template> + + <xsl:template match="game"> + <tr> + <xsl:apply-templates select="score"/> + </tr> + </xsl:template> + + <xsl:template match="score"> + <td> + <xsl:if test="@winner != ''"> + <xsl:attribute name="class">winner</xsl:attribute> + </xsl:if> + <xsl:if test="@east != ''"> + <img width="20" height="28" src="east.jpg"/> + </xsl:if> + <xsl:value-of select="text()"/> + </td> + </xsl:template> + + <xsl:template match="player" mode="form"> + <tr> + <td> + <img width="50" height="70" src="{(a)wind}.jpg"/> + </td> + <td> + <input type="radio" name="winner" value="{@wind}" onclick="check_new_game_inputs()"/> + </td> + <th> + <xsl:value-of select="@name"/> + </th> + <td> + <input autocomplete="off" id="{@wind}-score" class="score-input" onchange="input_change('{@wind}');"/> + </td> + <td> + <input autocomplete="off" id="{@wind}-doubles" class="score-input" onchange="input_change('{@wind}');" value="0"/> + </td> + <td> + <input autocomplete="off" id="{@wind}" name="{@wind}" class="score-input" readonly="readonly"/> + </td> + </tr> + </xsl:template> + + <xsl:template match="player" mode="score"> + <td class="sum"> + <xsl:value-of select="@score"/> + </td> + </xsl:template> + +</xsl:stylesheet> \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/north.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/north.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/south.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/south.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/undohtml.css =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/undohtml.css 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/undohtml.css 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,30 @@ +/* undohtml.css */ + +/* (CC) 2004 Tantek Celik. Some Rights Reserved. */ + +/* http://creativecommons.org/ licenses/by/2.0 */ +/* This style sheet is licensed under a Creative Commons License. */ +/* Purpose: undo some of the default styling of common (X)HTML browsers */ +/* link underlines tend to make hypertext less readable, + because underlines obscure the shapes of the lower + halves of words */ +:link,:visited { text-decoration:none } + +/* no list-markers by default, since lists are used more + often for semantics */ +ul,ol { list-style:none } + +/* avoid browser default inconsistent heading font-sizes */ +h1,h2,h3,h4,h5,h6 { font-size:1em; } + +/* remove the inconsistent (among browsers) default ul,ol + padding or margin */ +/* the default spacing on headings does not match nor align + with normal interline spacing at all, so let's get rid of it. */ +/* zero out the spacing around pre, form, body, html, p, + blockquote as well */ +/* form elements are oddly inconsistent, + and not quite CSS emulatable. */ +/* nonetheless strip their margin and padding as well */ +ul,ol,li,h1,h2,h3,h4,h5,h6,pre,form,body,html,p, blockquote,fieldset,input { margin:0; padding:0 } + Added: branches/xml-class-rework/projects/mah-jongg/website/west.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/west.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

1 0