allow pages without frames (sessions) again

vii · May 31, 2009 · 98e0c92 · 98e0c92
1 parent 0f2667b
commit 98e0c92
Show file tree

Hide file tree

Showing 13 changed files with 208 additions and 135 deletions.
diff --git a/src/blog/blog.lisp b/src/blog/blog.lisp
@@ -1,10 +1,13 @@
 (in-package #:tpd2.blog)
 
+(defconstant +max-comment-length+ 8000)
+
 (defstruct blog
   name
   admin-password-file
   dir
   entries
+  entries-table
   (site (current-site))
   (link-base "/")
   comment-index-prefix
@@ -17,14 +20,18 @@
 
 (my-defun blog read-in ()
   (with-site ((my site)) 
-    (setf (my entries) 
-	  (sort
-	   (iter:iter (iter:for path in (cl-fad:list-directory (my dir)))
-		      (let ((filename (force-string path)))
-			(unless (or (find #\# filename) (find #\~ filename))
+    (setf 
+     (my entries-table) (make-hash-table :test 'equalp)
+     (my entries) 
+     (sort
+      (iter:iter (iter:for path in (cl-fad:list-directory (my dir)))
+		 (let ((filename (force-string path)))
+		   (unless (or (find #\# filename) (find #\~ filename))
 			  (let ((entry (read-in-entry me (file-namestring filename))))
 			    (iter:collect entry)))))
-		      #'> :key #'entry-time))
+      #'> :key #'entry-time))
+    (loop for entry in (my entries)
+	  do (setf (gethash (entry-index-name entry) (my entries-table)) entry))
     (my set-page))
   me)
 
@@ -36,19 +43,25 @@
 (my-defun blog rss-feed-url ()
 	  (byte-vector-cat (my link-base) "feed.rss"))
 
+(my-defun blog post-comment-url ()
+	  (byte-vector-cat (my link-base) "comment.form"))
+
 (my-defun blog admin-url ()
 	  (byte-vector-cat (my link-base) "blog-admin"))
 
+(defmacro defpage-lambda-blog (path function &rest args)
+  `(defpage-lambda ,path ,function :create-frame nil ,@args))
+
 (my-defun blog set-page ()
   (with-site ((my site))
-    (defpage-lambda (my atom-feed-url)
+    (defpage-lambda-blog (my atom-feed-url)
 	(lambda ()
 	  (my atom-feed)))
-    (defpage-lambda (my rss-feed-url)
+    (defpage-lambda-blog (my rss-feed-url)
 	(lambda ()
 	  (my rss-feed)))
 
-    (defpage-lambda (my admin-url) 
+    (defpage-lambda-blog (my admin-url) 
 	(lambda (password entry-name)
 	  (webapp "Blog administration"
 		  (<form :method :post
@@ -81,9 +94,40 @@
 								  (output-object-to-ml c)
 								  (datastore-delete c)))))))))))
 
-    (defpage-lambda (my link-base) 
+    (defpage-lambda-blog (my post-comment-url)
+	(lambda (text author entry-name keep-this-empty .javascript. http-peer-info! all-http-params!)
+	  (let ((entry-name (force-string entry-name)))
+	   (let ((success 
+	     (when (and 
+		    (zerop (length keep-this-empty))
+		    text
+		    (< (length text) +max-comment-length+)
+		    (not (equalp 
+			  text 
+			  (ignore-errors (comment-text (first (datastore-retrieve-indexed 'comment 'entry-index-name entry-name)))))))
+		   (let ((entry (gethash entry-name (my entries-table))))
+		     (when entry
+		       (make-comment 
+			:author author
+			:text text
+			:trace-details http-peer-info!
+			:entry-index-name entry-name)
+		       (channel-notify entry))
+		     t))))
+	     (cond 
+	       (.javascript.
+		(webapp-respond-ajax-body all-http-params!))
+	       (success
+		(webapp "Comment accepted" (<p "Thank you.")))
+	       (t
+		(webapp "Comment rejected by spam protection"
+			(<p "Sorry for the inconvenience. Please contact the blog owner with a description of the problem."))))))))
+
+
+    (defpage-lambda-blog (my link-base) 
 	(lambda ((n (force-byte-vector 0)))
-	  (webapp ((my name) :head-contents 
+	  (webapp ((my name) 
+		   :head-contents 
 		   (with-ml-output
 		       (<link :rel "alternate" :type "application/atom+xml" :href (my atom-feed-url))
 

diff --git a/src/blog/entry.lisp b/src/blog/entry.lisp
@@ -61,39 +61,23 @@
 (my-defun entry story-ml ()
   (<div :class "blog-entry-story"
 	(loop for p in (my paragraphs)
-	      do (<p (output-raw-ml p)))
-	(<p :class "time" "Posted " (time-string (my time)))))
+	      do (<p (output-raw-ml p)))))
 
 (my-defun entry comments ()
   (datastore-retrieve-indexed 'comment 'entry-index-name (my index-name)))
 
 (my-defun entry comment-ml ()
   (<div :class "blog-entry-post-comment"
-	(let ((hidden-value (force-byte-vector (time-string))))
-	  (html-action-form-collapsed "Post a comment"
-	      ((text nil :type <textarea)
-	       (author "Anonymous")
-	       (keep-this-empty nil :type :hidden) 
-	       (time hidden-value :type :hidden))
-
-	    (cond ((and (zerop (length keep-this-empty)) (equalp hidden-value time))
-		   (unless (or 
-			    (not text)
-			    (equalp text 
-				    (ignore-errors (comment-text (first (datastore-retrieve-indexed 'comment 'entry-index-name (my index-name)))))))
-		     (make-comment 
-		      :author author
-		      :text text
-		      :trace-details (frame-trace-info (webapp-frame))
-		      :entry-index-name (my index-name))
-		     (my 'channel-notify)))
-		  (t
-		   (webapp "Comment rejected by spam protection"
-		     (<p "Sorry for the inconvenience. Please contact the blog owner with a description of the problem."))))))))
+	(html-action-form-collapsed ("Post a comment" :action-link (blog-post-comment-url (my blog)))
+				    ((text nil :type <textarea :reset "")
+				     (author "Anonymous")
+				     (entry-name (my index-name) :type :hidden)
+				     (keep-this-empty nil :type :hidden)))))
 
 (my-defun entry 'object-to-ml ()
   (<div :class "blog-entry"
 	(my story-ml)
+	(<p :class "time" "Posted " (time-string (my time)))
 	(call-next-method)
 	(my comment-ml)))
 

diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -231,11 +231,6 @@
 	     (when (my waiting-for-input)
 	       (<span :class "turn" "'s turn")))))
 
-(defmethod player-controller-message ((controller web-state) sender message)
-  (web-state-add-announcement controller
-			      (<p :class "message" (<span :class "sender" (frame-username sender))
-				  " " message)))
-
 (defun css ()
   (css-html-style 
     ((".inherit" <input <a)

diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -55,15 +55,18 @@
 
 (defvar *dispatchers* nil)
 
-(defun do-find-dispatcher (host)
+(defun find-dispatcher-go (host)
   (alist-get *dispatchers* host :test 'equalp))
 
 (defun find-dispatcher (host)
-  (or (do-find-dispatcher host) *default-dispatcher*))
+  (or (find-dispatcher-go host) *default-dispatcher*))
 
 (defun find-or-make-dispatcher (host)
   (let ((host (force-byte-vector host)))
-    (or (do-find-dispatcher host)
+    (or (find-dispatcher-go host)
 	(let ((it (make-dispatcher :canonical-name host)))
 	  (push (cons host it) *dispatchers*)
-	  it))))
+	  it))))
+
+(defun dispatcher-add-alias (dispatcher alias)
+  (setf (alist-get *dispatchers* (force-byte-vector alias)) dispatcher))
diff --git a/src/packages.lisp b/src/packages.lisp
@@ -214,6 +214,7 @@
    #:build-http-response
    #:respond-http
    #:*default-dispatcher*
+   #:dispatcher-add-alias
    #:find-or-make-dispatcher
    #:http-parse-and-generate-response))
 
@@ -293,6 +294,11 @@
    #:channel-update
    #:find-channel
 
+   #:webapp-respond-ajax-body
+
+   #:http-peer-info! 
+   #:all-http-params!
+
    #:message-channel
    #:simple-channel
    #:simple-channel-body-ml

diff --git a/src/webapp/actions.lisp b/src/webapp/actions.lisp
@@ -11,8 +11,8 @@
     (action-id action)))
 
 (defmacro page-action-lambda (&body body)
-  `(lambda(all-http-params)
-     (declare (ignorable all-http-params))
+  `(lambda(all-http-params!)
+     (declare (ignorable all-http-params!))
      ,@body))
 
 (defmacro page-action-link (&body body)
@@ -34,49 +34,63 @@
 	     ,@body)))
 
 (defmacro html-action-form-collapsed (title lambda-list &body body)
-  `(html-collapser (<p ,title)
-		   (html-action-form nil ,lambda-list ,@body)))
+  `(html-collapser (<p ,(force-first title))
+		   (html-action-form (nil ,@(force-rest title) :after-submit-js ((toggle-hiding this.parent-node))) ,lambda-list ,@body)))
 
-(defmacro html-action-form (title lambda-list &body body)
-  `(<form 
-     :onsubmit (js-attrib (return (async-submit-form this))) 
-     :method :post 
-     :action 
-     (page-action-link 
-      (let ,(loop for p in lambda-list collect
-		  `(,(force-first p) (or (alist-get all-http-params ,(force-byte-vector (force-first p)) 
-						    :test 'byte-vector=-fold-ascii-case)
-					 ,(second (force-list p)))))
-	  ,@body))
-     (<p
-       ,title
-       ,@(loop for nv in lambda-list collect
-	       (destructuring-bind (name &optional value &key (type '<input))
-		   (force-list nv)
-		 (let ((name (force-byte-vector name)))
-		   (ecase type
-		     (<input
-		       `(<input :type :text :name ,name
-				,@(when value `(:value ,value))))
-		     (<textarea
-		       `(<textarea :name ,name ,value))
-		     (:hidden
-		      `(<input :type :text :name ,name :value ,value :style (css-attrib :display "none")))))))
-       (<input :class "plain-submit" :type :submit :value "↵"))))
+(defmacro html-action-form (title-and-options lambda-list &body body)
+  (destructuring-bind (title 
+		       &key (action-link      
+			     `(page-action-link 
+			       (let ,(loop for p in lambda-list collect
+					   `(,(force-first p) (or (alist-get all-http-params! ,(force-byte-vector (force-first p)) 
+									     :test 'byte-vector=-fold-ascii-case)
+								  ,(second (force-list p)))))
+				 ,@body)))
+		       (after-submit-js))
+      (force-list title-and-options)
+    (let ((body-ml
+	   (loop for nv in lambda-list collect
+		 (destructuring-bind (name &optional value &key (type '<input) reset)
+		     (force-list nv)
+		    (let ((name (force-byte-vector name)))
+		      (when reset
+			(appendf after-submit-js `((setf (slot-value (this.elements.named-item ,(force-string name)) 'value) ,(if (eq reset t) nil reset)))))
+		      (ecase type
+			(<input
+			 `(<input :type :text :name ,name
+				  ,@(when value `(:value ,value))))
+			(<textarea
+			 `(<textarea :name ,name ,value))
+			(:hidden
+			 `(<input :type :text :name ,name :value ,value :style (css-attrib :display "none")))))))))
+       `(<form 
+	 :onsubmit (js-attrib (return (let ((async-submit-success (async-submit-form this))) ,@after-submit-js async-submit-success)))
+	 :method :post 
+	 :action ,action-link     
+	 (<p
+	  ,title
+	  ,@body-ml
+	  (<input :class "plain-submit" :type :submit :value "↵"))))))
 
 (defun find-action (id)
   (and id (find id (webapp-frame-var 'actions) :key 'action-id :test 'equalp)))
 
-(defun action-respond-body (&key .id. .channels. .javascript. all-http-params)
+(defun action-respond-body (&key .id. .javascript. all-http-params!)
   (with-frame-site 
     (awhen (find-action .id.)
-      (funcall (action-func it) all-http-params))
+	   (funcall (action-func it) all-http-params!))
     (if .javascript.
-	(channel-respond-body (channel-string-to-states .channels.))
+	(webapp-respond-ajax all-http-params!)
 	(funcall (frame-current-page (webapp-frame))))))
+
+(defun webapp-respond-ajax-body (all-http-params!)
+  (let ((channels (channel-string-to-states 
+		   (alist-get all-http-params! (force-byte-vector '.channels.) 
+			      :test 'byte-vector=-fold-ascii-case))))
+   (channel-respond-body channels :always-body t)))
 
 (defun register-action-page ()
-  (defpage-lambda +action-page-name+ #'action-respond-body :defaulting-lambda-list (.id. .channels. .javascript. all-http-params)))
+  (defpage-lambda +action-page-name+ #'action-respond-body :defaulting-lambda-list (.id. .javascript. all-http-params!)))
 
 
 (my-defun frame 'simple-channel-body-ml ()

diff --git a/src/webapp/channel.lisp b/src/webapp/channel.lisp
@@ -27,9 +27,9 @@
 
 (defgeneric channel-update (channel subscriber-state))
 
-(defun channel-respond-page (dispatcher con done path all-http-params)
+(defun channel-respond-page (dispatcher con done path all-http-params!)
   (declare (ignore dispatcher path))
-  (apply-page-call con 'channel-respond con done (.channels.)))
+  (apply-page-call (:con con :function 'channel-respond :create-frame nil) con done (.channels.)))
 
 (defun channel-string-to-states (channels)
   (let ((channel-states))
@@ -38,7 +38,7 @@
 	channels)
     channel-states))
 
-(defun channel-respond-body (channel-states)
+(defun channel-respond-body (channel-states &key always-body)
   (let (at-least-one)
     (let ((sendbuf
 	   (with-ml-output
@@ -50,7 +50,7 @@
 						   (unquote (channel-state channel)))))
 		     (output-raw-ml (channel-update channel state))))
 	     (output-raw-ml (js-to-string (trigger-fetch-channels))))))
-      (when at-least-one
+      (when (or at-least-one always-body)
 	sendbuf))))
 
 (defun channel-respond (con done &key .channels.)

diff --git a/src/webapp/frame.lisp b/src/webapp/frame.lisp
@@ -25,6 +25,9 @@
 (defun find-frame (id)
   (gethash id *frames*))
 
+(defun-speedy webapp-frame-available-p ()
+  (and (boundp '*webapp-frame*) *webapp-frame*))
+
 (defun webapp-frame (&rest args-for-make-frame)
   (unless *webapp-frame*
     (setf *webapp-frame* (apply 'make-frame args-for-make-frame)))

diff --git a/src/webapp/js-library.lisp b/src/webapp/js-library.lisp
@@ -137,6 +137,6 @@
    (defun trigger-fetch-channels ()
      (ps:do-set-timeout (50) 
        (fetch-channels)))
-   #- (and)
-    (trigger-fetch-channels)))
+
+   (trigger-fetch-channels)))