part way to figuring out how to have multiple sites in the same lisp

vii · Feb 7, 2009 · 601a53b · 601a53b
1 parent 458dca0
commit 601a53b
Show file tree

Hide file tree

Showing 14 changed files with 154 additions and 183 deletions.
diff --git a/src/blog/blog.lisp b/src/blog/blog.lisp
@@ -4,9 +4,27 @@
   name
   dir
   entries
-  site
-  link-base-url
+  (site *default-site*)
   static-base-url)
 
 (my-defun blog read-in ()
-
+  (let ((*default-site* (my site))) 
+    (setf (my entries) 
+	  (sort
+	   (iter:iter (iter:for filename in (cl-fad:list-directory (my dir)))
+		 (unless (or (find #\# filename) (find #\~ filename))
+		   (let ((entry (read-in-blog-entry me (file-namestring filename))))
+		     (when (and entry (blog-entry-ready entry)) 
+		       (iter:collect entry)))))
+	    #'> :key #'blog-entry-time))
+    (defpage-lambda "/"
+	(lambda()
+	  (webapp (my filename)
+	    (output-object-to-ml me))))))
+
+(my-defun blog 'object-to-ml ()
+  (<div :class "blog"
+	(loop for entry in (my entries)
+	      for n below 20
+	      do (output-object-to-ml entry))))
+
diff --git a/src/blog/entry.lisp b/src/blog/entry.lisp
@@ -24,7 +24,7 @@
 	(second minute hour date month year day daylight-p zone)
       (decode-universal-time ut 0)
     (declare (ignore day daylight-p zone))
-    (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D UTC" year month date hour minute second)))
+    (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D GMT" year month date hour minute second)))
 
 (my-defun entry filename ()
   (strcat (its dir (my blog)) (my name)))
@@ -55,14 +55,15 @@
 	(let ((hidden-value (force-byte-vector (time-string))))
 	  (html-action-form "Post a comment"
 	      ((author "Anonymous")
-	       (text nil :type '<textarea)
-	       (keep-this-empty nil :type :hidden) (time hidden-value :type :hidden))
+	       (text nil :type <textarea)
+	       (keep-this-empty nil :type :hidden) 
+	       (time hidden-value :type :hidden))
 
 	    (cond ((and (zerop (length keep-this-empty)) (equalp hidden-value time))
 		   (make-comment 
 		    :author author
 		    :text text
-		    :trace-details ...
+		    :trace-details (frame-trace-info (webapp-frame))
 		    :entry-index-name (my index-name))
 		   (my 'channel-notify))
 		  (t
@@ -76,21 +77,17 @@
 	(my comment-ml)))
 
 (my-defun entry set-page ()
-  (defpage-lambda (my url-path)
-      (lambda()
-	(webapp (my name)
-	  (output-object-to-ml me)))))
+  (let ((*default-site* (its site (my blog))))
+    (defpage-lambda (my url-path)
+	(lambda()
+	  (webapp (my name)
+	    (output-object-to-ml me))))))
 
-
-
-(my-defun entry read-paragraphs-from-stream (stream)
+(my-defun entry read-paragraphs-from-buffer (buffer)
   (setf (my paragraphs)
-	(loop for paragraph = (loop for line = (read-line stream nil "")
-				    until (if-match-bind ((*(space)) (last)) line)
-				    collect line collect (string #\Newline))
-	      until (not paragraph)
-	      collect (match-replace-all (apply 'strcat paragraph) 
-					 ("${static-base}"  (blog-static-base-url (my blog)))))))
+	(match-split (progn #\Newline (* (space)) #\Newline)
+		     (match-replace-all buffer
+					("${static-base}"  (blog-static-base-url (my blog)))))))
 
 (defun parse-time (str)
   (match-bind 
@@ -106,24 +103,34 @@
       str
     (encode-universal-time second minute hour day month year)))
 
-(defun read-in-blog-entry (name)
-  (let ((blog-entry (make-blog-entry :name name)))
-    (with-shorthand-accessor (my blog-entry)
-      (with-open-file (stream (my filename))
-	(setf (my time) (or (file-write-date stream) (get-universal-time)))
-
-	(loop for line = (read-line stream nil "")
+(defun slurp-file (filename)
+  (with-open-file (s filename :element-type 'byte-vector)
+    (let ((buf (make-byte-vector (file-length s))))
+      (read-sequence buf s)
+      buf)))
+
+
+(defun read-in-entry (blog name)
+  (let ((entry (make-entry :blog blog :name name)))
+    (with-shorthand-accessor (my entry)
+      (let ((remaining (slurp-file (my filename))))
+	(loop for line = 
+	      (match-bind (line #\Newline after)
+		  remaining
+		(setf remaining after)
+		line)
 	      until (if-match-bind ( (* (space)) (last)) line)
 	      do (when (if-match-bind "XXX" line)
 		   (format *debug-io* "Entry not ready (XXX): ~A~&" name)
-		   (return-from read-in-blog-entry))
+		   (return-from read-in-entry))
 	      do (match-bind ((* (space)) header ":" value)
 			     line
 			     (when (equalp header "time")
 			       (setf value (parse-time value)))
 
-			  (setf (slot-value blog-entry (normally-capitalized-string-to-symbol header))
+			  (setf (slot-value entry (normally-capitalized-string-to-symbol header))
 				value)))
-	(my read-paragraphs-from-stream stream))
-      (my publish))))
+	(my read-paragraphs-from-buffer remaining)))
+    (my set-page)
+    entry))
 
diff --git a/src/blog/main.lisp b/src/blog/main.lisp
@@ -1,19 +1,11 @@
 (in-package #:tpd2.blog)
 
-(defrecord message
-  (entry-name :index t)
-  text
-  (author :index t)
-  (time :initform (get-universal-time))
-  trace-details)
-
-
 (defvar *root-dir* "/home/john/Junk/mopoko/")
 (defvar *blog-dir* (strcat *root-dir* "/Blog/"))
 
 (datastore-use-file (strcat *root-dir* "tpd2-datastore.log.lisp"))
 
-
+(make-blog 
 
 (defun css ()
   (let ((unimportant-color "#888888"))
@@ -123,79 +115,3 @@
       (loop for l in (datastore-retrieve-all 'phone-contact 1) do
 	    (<h2 "What telephone number to call to talk to me")
 	    (output-object-to-ml l)))))
-
-(defun time-string (ut)
-  (multiple-value-bind
-	(second minute hour date month year day daylight-p zone)
-      (decode-universal-time ut 0)
-    (declare (ignore day daylight-p zone))
-    (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D UTC" year month date hour minute second)))
-
-(defun empty-line (line)
-  (if-match ((:progn :whitespace? :$) line)))
-
-(my-defun blog-entry read-paragraphs-from-stream (stream)
-  (setf (my paragraphs)
-	(loop for paragraph = (loop for line = (read-line stream nil "")
-				 until (empty-line line)
-				 collect line collect " ")
-	   until (not paragraph)
-	   collect (match-replace-all (apply 'strcat paragraph) ("\\$\\{static-base\\}"  (strcat "../static-blog/" (my name)))))))
-
-(defvar *check-blogs-timeout* (make-timeout :func 'check-blogs))
-
-
-(defun check-blogs ()
-  (setf *blog-entries* nil)
-  (loop for filename in (directory (strcat *blog-dir* "/*"))
-     for name = (file-namestring filename)
-     unless (or (find #\# name) (find #\~ name))
-     do (read-in-blog-entry (file-namestring name)))
-  (timeout-set *check-blogs-timeout* 500))
-
-(defun parse-time (str)
-  0)
-
-(defun read-in-blog-entry (name)
-  (let ((blog-entry (make-blog-entry :name name)))
-    (with-shorthand-accessor (my blog-entry)
-      (with-open-file (stream (my filename))
-	(setf (my time) (or (file-write-date stream) (get-universal-time)))
-
-	(loop for line = (read-line stream nil "")
-	   until (empty-line line)
-	   do (when (if-match (("XXX") line))
-		(format *debug-io* "Entry not ready (XXX): ~A~&" name)
-		(return-from read-in-blog-entry))
-	   do (match-bind ( (* (space)) header (progn (* (space)) ":")  (* (space)) value (progn (* (space)) (last)))
-		  line
-		(when (equalp (force-string header) "time")
-		  (setf value (parse-time value)))
-
-		(setf (slot-value blog-entry (intern (string-upcase (force-string header)) (find-package #.(package-name *package*))))
-		      value)))
-	(my read-paragraphs-from-stream stream))
-      (my publish))))
-
-
-(defvar *blog-entries* nil)
-
-(my-defun blog-entry publish ()
-  (setf *blog-entries*
-	(merge 'list (list me)
-	       (delete-if (lambda(other) (equalp (my name) (blog-entry-name other))) 
-			  *blog-entries*) #'> :key #'blog-entry-time))
-
-  (setf (my raw-ml)
-	(tpd2.io:sendbuf-to-byte-vector
-	  (<div :class "blog-entry"
-		(loop for paragraph in (my paragraphs)
-		   do (<p (output-raw-ml paragraph)))
-		(<p :class "time" "Posted " (time-string (my time)))))))
-
-(check-blogs)
-
-(my-defun blog-entry 'object-to-ml ()
-  (<div :class "blog-entry-wrapper"
-	(<h2 (my title))
-	(output-raw-ml (my raw-ml))))
diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -348,8 +348,3 @@
 	   (tpd2.io:event-loop)))
      :name "MOPOKO-EVENT-LOOP")))
 
-(defpage "/test" (name)
-  (<h1 "Hello " name))
-
-(defpage "/test-plain" ()
-  (<p "hello dude" ))
diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -57,7 +57,7 @@
 (defvar *dispatchers* nil)
 
 (defun do-find-dispatcher (host)
-  (cdr-assoc *dispatchers* host :test 'equalp))
+  (alist-get *dispatchers* host :test 'equalp))
 
 (defun find-dispatcher (host)
   (or (do-find-dispatcher host) *default-dispatcher*))

diff --git a/src/ml/define-dtd.lisp b/src/ml/define-dtd.lisp
@@ -23,6 +23,7 @@
     (loop for form in body
 	  do (when
 		 (typecase form
+		   (null nil)
 		   (list
 		    (when (and (symbolp (first form)) (eq #\< (char (force-string (first form)) 0))
 			       (not (eq (symbol-package (first form)) (find-package :cl))))

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -9,11 +9,11 @@
   (:import-from #:trivial-garbage #:finalize #:cancel-finalization)
   (:import-from #:cl-cont #:call/cc #:with-call/cc)
   (:import-from #:cl-irregsexp 
-		#:match-replace-all #:match-replace-one 
+		#:match-replace-all #:match-replace-one #:match-split
 		#:match-bind #:if-match-bind
 		#:match-failed )
   (:import-from #:cl-irregsexp.utils
-		#:cdr-assoc
+		#:alist-get
 		#:defun-consistent
 		#:declaim-defun-consistent-ftype
 		#:defun-speedy
@@ -35,7 +35,7 @@
 
    #:match-replace-all #:match-replace-one 
    #:match-bind #:if-match-bind
-   #:match-failed
+   #:match-failed #:match-split
 
    #:superquote
    #:superquote-function
@@ -117,7 +117,7 @@
    #:random-shuffle
    #:random-elt
 
-   #:cdr-assoc
+   #:alist-get
 
    #:case-match-fold-ascii-case
 
@@ -188,6 +188,7 @@
    #:con-clear-failure-callbacks
    #:con-when-ready-to-read
    #:con-peek
+   #:con-peer-info
 
    #:+newline+
    #:+SOCK_DGRAM+
@@ -258,6 +259,7 @@
    #:link-to-webapp
 
    #:defpage
+   #:defpage-lambda
 
    #:webapp-default-page-head-contents
    #:webapp-default-page-footer
@@ -271,6 +273,7 @@
    #:frame-var
    #:frame-username
    #:frame-messages
+   #:frame-trace-info
    #:list-all-frames
    #:find-frame
    #:frame-id

diff --git a/src/webapp/actions.lisp b/src/webapp/actions.lisp
@@ -33,7 +33,7 @@
      :action 
      (page-action-link 
       (let ,(loop for p in lambda-list collect
-		  `(,(force-first p) (or (cdr-assoc all-http-params ,(force-byte-vector (force-first p)) 
+		  `(,(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))

diff --git a/src/webapp/channel.lisp b/src/webapp/channel.lisp
@@ -29,7 +29,7 @@
 
 (defun channel-respond-page (dispatcher con done path all-http-params)
   (declare (ignore dispatcher path))
-  (apply-page-call 'channel-respond con done (.channels.)))
+  (apply-page-call con 'channel-respond con done (.channels.)))
 
 (defun channel-string-to-states (channels)
   (let ((channel-states))
@@ -55,19 +55,21 @@
 
 (defun channel-respond (con done &key .channels.)
   (let ((channel-states (channel-string-to-states .channels.)))
-    (flet ((finished () 
-	     (when (con-dead? con)
-	       (return-from finished t))
-	     (awhen (channel-respond-body channel-states)
-	       (respond-http con done :body it)
-	       t)))
+    (with-preserve-specials (*webapp-frame*) 
+      (flet ((finished () 
+	       (when (con-dead? con)
+		 (return-from finished t))
+	       (with-specials-restored
+		   (awhen (channel-respond-body channel-states)
+		     (respond-http con done :body it)
+		     t))))
       (unless (finished)
 	(let (func)
 	  (flet ((unsubscribe ()
 		   (loop for (channel ) in channel-states do (channel-unsubscribe channel func))))
 	    (setf func
 		  (lambda() (when (finished) (unsubscribe))))
-	    (loop for (channel ) in channel-states do (channel-subscribe channel func))))))))
+	    (loop for (channel ) in channel-states do (channel-subscribe channel func)))))))))
 
 (defun register-channel-page ()
   (dispatcher-register-path *default-dispatcher*  +channel-page-name+ #'channel-respond-page))

diff --git a/src/webapp/frame.lisp b/src/webapp/frame.lisp
@@ -2,10 +2,12 @@
 
 (defmyclass (frame (:include simple-channel))
   current-page
+  (site *default-site*)
   variables
   (username (random-name))
   (messages (make-list-channel))
-  timeout)
+  timeout
+  trace-info)
 
 (defvar *frames* (make-hash-table :test #'equalp))
 
@@ -21,12 +23,11 @@
   (my reset-timeout))
 
 (defun find-frame (id)
-  (awhen (gethash id *frames*)
-    it))
+  (gethash id *frames*))
 
-(defun webapp-frame ()
+(defun webapp-frame (&rest args-for-make-frame)
   (unless *webapp-frame*
-    (setf *webapp-frame* (make-frame)))
+    (setf *webapp-frame* (apply 'make-frame args-for-make-frame)))
   *webapp-frame*)
 
 (my-defun frame var (id)