added atom feeds (still rather weird)

vii · May 12, 2009 · bf7ab7f · bf7ab7f
1 parent 6ea6156
commit bf7ab7f
Show file tree

Hide file tree

Showing 21 changed files with 141 additions and 73 deletions.
diff --git a/src/blog/blog.lisp b/src/blog/blog.lisp
@@ -22,13 +22,23 @@
     (my set-page))
   me)
 
+(my-defun blog ready-entries (&key (start 0))
+	  (subseq (remove-if-not 'entry-ready (my entries)) start))
+
+(my-defun blog feed-url ()
+	  (byte-vector-cat (my link-base) "feed.atom"))
+
 (my-defun blog set-page ()
   (with-site ((my site))
+    (defpage-lambda (my feed-url)
+	(lambda ()
+	  (my feed)))
+
     (defpage-lambda (my link-base) 
 	(lambda(&key n)
-	  (webapp (my name)
+	  (webapp ((my name) :head-contents (<link :rel "alternate" :type "application/atom+xml" :href (my feed-url)))
 	    (let ((n (byte-vector-parse-integer n)))
-	      (let ((entries (subseq (remove-if-not 'entry-ready (my entries)) n)) (count 10))
+	      (let ((entries (my ready-entries :start n)) (count 10))
 		(<div :class "blog"
 		      (loop while entries
 			    repeat count
@@ -40,3 +50,7 @@
 			(<p :class "next-entries" (<a :href (page-link (my link-base) :n (force-byte-vector (+ n count))) "More entries"))))))))
       ((n (force-byte-vector 0))))))
 
+(my-defun blog last-updated ()
+	  (loop for e in (my entries)
+		when (entry-ready e)
+		maximizing (entry-time e)))
diff --git a/src/blog/entry.lisp b/src/blog/entry.lisp
@@ -37,9 +37,8 @@
 
 (defun time-string (&optional (ut (get-universal-time)))
   (multiple-value-bind
-	(second minute hour date month year day daylight-p zone)
+	(second minute hour date month year)
       (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 GMT" year month date hour minute second)))
 
 (my-defun entry filename ()
@@ -104,7 +103,7 @@
   (with-site ((its site (my blog)))
     (defpage-lambda (my url-path)
 	(lambda()
-	  (webapp (my combined-title)
+	  (webapp ((my combined-title))
 	    (output-object-to-ml me))))))
 
 (my-defun entry read-paragraphs-from-buffer (buffer)

diff --git a/src/blog/feed.lisp b/src/blog/feed.lisp
@@ -0,0 +1,24 @@
+(in-package #:tpd2.blog)
+
+(my-defun blog feed (&key (count 10))
+	  (values
+	   (with-ml-output-start 
+	       (output-raw-ml "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
+	     (tpd2.ml.atom:<feed 
+	      (tpd2.ml.atom:<title
+	       (my name))
+	      (tpd2.ml.atom:<link
+	       :href (my link-base))
+	      (tpd2.ml.atom:<updated 
+	       (w3c-timestring (my last-updated)))
+	      (loop repeat count
+		    for entry in (my ready-entries) do
+		    (tpd2.ml.atom:<entry 
+		     (tpd2.ml.atom:<title (entry-title entry))
+		     (tpd2.ml.atom:<updated (w3c-timestring (entry-time entry)))
+		     (tpd2.ml.atom:<id (entry-url-path entry))
+		     (tpd2.ml.atom:<link (entry-url-path entry))
+		     (tpd2.ml.atom:<content :type "text/html" 
+					    (loop for p in (entry-paragraphs entry) do
+						  (<p p ))))))) ; if there are any XML errors the whole feed won't display
+	   (byte-vector-cat "Content-Type: application/atom+xml" tpd2.io:+newline+)))
diff --git a/src/game/card.lisp b/src/game/card.lisp
@@ -1,7 +1,7 @@
 (in-package #:tpd2.game)
 
 (eval-always
-  (defconstant +suits+ '(:clubs :hearts :spades :diamonds))
+  (define-constant +suits+ '(:clubs :hearts :spades :diamonds) :test 'equal)
   (defconstant +cards-per-suit+ 13))
 
 (defstruct card 

diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -14,7 +14,6 @@
   (with-sendbuf (response)
     "HTTP/1.1 " code " " banner +newline+
     "Content-Length: " (sendbuf-len body) +newline+
-    "Content-Type: text/html;charset=utf-8" +newline+
     headers
     +newline+
     body))

diff --git a/src/io/con.lisp b/src/io/con.lisp
@@ -54,7 +54,8 @@
   (timeout-set (my timeout) delay)
   (values))
 
-(defconstant +newline+ (force-byte-vector #(13 10)))
+(define-constant +newline+ (force-byte-vector #(13 10))
+  :test 'equalp)
 
 (my-defun con set-callback (func)
   (setf (my ready-callback) func))

diff --git a/src/io/syscalls.lisp b/src/io/syscalls.lisp
@@ -146,8 +146,8 @@
 (def-simple-syscall close
     (fd :int))
 
-(defconstant +SIG_IGN+ (cffi:make-pointer 1))
-(defconstant +SIG_DFL+ (cffi:make-pointer 0))
+(define-constant +SIG_IGN+ (cffi:make-pointer 1) :test 'cffi:pointer-eq)
+(define-constant +SIG_DFL+ (cffi:make-pointer 0)  :test 'cffi:pointer-eq)
 (defconstant +SIGPIPE+ 13)
 
 (cffi:defcfun ("signal" syscall-signal)

diff --git a/src/lib/byte-vector.lisp b/src/lib/byte-vector.lisp
@@ -37,7 +37,7 @@
 	  do (setf (aref ret i) arg))
     ret))
 
-(defconstant +byte-to-digit-table+
+(define-constant +byte-to-digit-table+
   (make-array 256 :element-type '(integer -1 36) 
 	      :initial-contents (loop for i from 0 below 256 
 				      collect 
@@ -52,7 +52,8 @@
 					(or (in-range #\a #\z i 10)
 					    (in-range #\A #\Z i 10)
 					    (in-range #\0 #\9 i 0)
-					    -1)))))
+					    -1))))
+  :test 'equalp)
 
 (declaim-defun-consistent-ftype byte-to-digit ((unsigned-byte 8)) (integer -1 36))
 (defun-consistent byte-to-digit (byte)

diff --git a/src/lib/one-liners.lisp b/src/lib/one-liners.lisp
@@ -63,3 +63,7 @@
   `(debug-assert (not 'reached-here)))
 
 
+(defmacro defconstant-string (name value &optional documentation)
+  `(define-constant ,name ,value
+     :test 'string=
+     ,@(when documentation `((:documentation ,documentation)))))
diff --git a/src/lib/utils.lisp b/src/lib/utils.lisp
@@ -50,4 +50,4 @@
 
 (defun backtrace-description (err)
   (format nil "ERROR ~A:~&~A" (with-output-to-string (*standard-output*) (describe err)) 
-	  (trivial-backtrace:get-backtrace err)))
+	  (trivial-backtrace:backtrace-string)))
diff --git a/src/ml/css.lisp b/src/ml/css.lisp
@@ -2,7 +2,7 @@
 
 ; From http://www.w3.org/TR/REC-CSS2/propidx.html
 ; if you want more just use "strings"
-(defconstant +css-properties+ '(
+(define-constant +css-properties+ '(
 				:azimuth
 				:background
 				:background-color 
@@ -147,7 +147,8 @@
 				:x-opacity
 				:x-column-width
 				:x-column-gap
-				))
+				)
+  :test 'equalp)
 
 ;; Write CSS like this: (("p.asdfsaf" "p + p") :property "value" :property "value")
 

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -5,7 +5,7 @@
 (defpackage #:teepeedee2.lib
   (:nicknames #:tpd2.lib)
   (:use #:common-lisp #:iter #:cl-irregsexp.bytestrings)
-  (:import-from #:cl-utilities #:with-unique-names)
+  (:import-from #:alexandria #:with-unique-names #:define-constant)
   (:import-from #:trivial-garbage #:finalize #:cancel-finalization)
   (:import-from #:cl-cont #:call/cc #:with-call/cc)
   (:import-from #:cl-irregsexp 
@@ -48,7 +48,8 @@
 
    #:with-unique-names
    #:once-only
-
+   #:define-constant
+   #:defconstant-string
 
    #:copy-byte-vector
    #:make-byte-vector
@@ -236,6 +237,8 @@
    #:js-html-script
    #:js-attrib
    #:js-to-string
+
+   #:w3c-timestring
 ))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

diff --git a/src/truc/robots.lisp b/src/truc/robots.lisp
@@ -26,7 +26,7 @@
 	      (t my-best-card))))))
 
 
-(defconstant +best-starts+ #(0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 0 2 2 0 2 2 2 2 0 2 2 2
+(define-constant +best-starts+ #(0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 0 2 2 0 2 2 2 2 0 2 2 2
   0 0 2 2 0 2 2 2 0 0 0 2 0 2 2 2 2 0 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 2 2
   2 0 1 1 1 1 1 1 2 1 2 1 1 2 2 2 2 1 1 0 1 1 2 2 2 1 1 1 0 1 1 2 2 1 2 1
   1 0 1 2 2 1 2 2 1 1 0 1 2 1 2 2 2 2 1 0 0 2 2 2 2 2 2 2 2 1 2 1 1 2 2 2
@@ -41,10 +41,11 @@
   0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 2 2 2 2 2 0 0 2 1 2 2 2 2 1 0 2 2 1 2
   2 1 1 0 2 2 2 1 2 1 1 0 2 2 2 2 1 1 1 0 2 2 1 1 1 1 1 0 0 1 1 1 1 1 0 0
   0 0 0 0 0 0 0 0)
-  "Given the hand described by the index, 0 means play the highest card, 1 the middle card and 2 the lowest card first")
+  :documentation "Given the hand described by the index, 0 means play the highest card, 1 the middle card and 2 the lowest card first"
+  :test 'equalp)
 
 
-(defconstant +three-card-win-probabilities+ 
+(define-constant +three-card-win-probabilities+ 
   #(0 1/1218 1/522 11/3654 5/1218 19/3654 23/3654 3/406 1/1218 79/3654 44/1827
     71/1827 122/1827 197/1827 296/1827 419/1827 1/522 44/1827 101/3654 82/1827
     5/63 8/63 49/261 478/1827 11/3654 71/1827 82/1827 143/1827 64/609 323/1827
@@ -100,7 +101,8 @@
     298/609 55/87 179/261 1375/1827 1457/1827 1651/1827 1 892/1827 49/87
     170/261 1375/1827 1468/1827 1574/1827 1720/1827 1 373/609 132/203 428/609
     1457/1827 1574/1827 545/609 1765/1827 1 2609/3654 1441/1827 1558/1827
-    1651/1827 1720/1827 1765/1827 3575/3654 1 1 1 1 1 1 1 1 1))
+    1651/1827 1720/1827 1765/1827 3575/3654 1 1 1 1 1 1 1 1 1)
+  :test 'equalp)
 
 (my-defun truc-player win-probability ()
   "Rough and ready win probability not taking into account who starts or anything much"

diff --git a/src/truc/truc.lisp b/src/truc/truc.lisp
@@ -1,9 +1,10 @@
 (in-package #:tpd2.game.truc)
 
-(defconstant +truc-ranking+ '(6 7 0 12 11 10 9 8))
-(defconstant +truc-deck+ 
-  (mapcar 'card-number 
-	  (loop for s in +suits+ append (loop for i in +truc-ranking+ collect (make-card :suit s :value i)))))
+(define-constant +truc-ranking+ '(6 7 0 12 11 10 9 8) :test 'equal)
+(define-constant +truc-deck+ 
+  (map 'vector 'card-number 
+	  (loop for s in +suits+ append (loop for i in +truc-ranking+ collect (make-card :suit s :value i))))
+  :test 'equalp)
 (defconstant +truc-winning-stack+ 12)
 
 (defgame truc ()

diff --git a/src/webapp/html-constants.lisp b/src/webapp/html-constants.lisp
@@ -1,14 +1,14 @@
 (in-package #:tpd2.webapp)
 
-(defconstant +channel-page-name+ "/*channel*")
+(defconstant-string +channel-page-name+ "/*channel*")
 
-(defconstant +action-page-name+ "/*action*")
+(defconstant-string +action-page-name+ "/*action*")
 
-(defconstant +action-form-class+ "-action-form-")
-(defconstant +action-link-class+ "-action-link-")
-(defconstant +replace-link-class+ "-replace-link-")
+(defconstant-string +action-form-class+ "-action-form-")
+(defconstant-string +action-link-class+ "-action-link-")
+(defconstant-string +replace-link-class+ "-replace-link-")
 
-(defconstant +html-id-async-status+ "-async-status-")
-(defconstant +html-class-scroll-to-bottom+ "-scroll-to-bottom-")
-(defconstant +html-class-collapsed+ "-collapsed-")
+(defconstant-string +html-id-async-status+ "-async-status-")
+(defconstant-string +html-class-scroll-to-bottom+ "-scroll-to-bottom-")
+(defconstant-string +html-class-collapsed+ "-collapsed-")
 
diff --git a/src/webapp/names.lisp b/src/webapp/names.lisp
@@ -1,6 +1,6 @@
 (in-package #:tpd2.webapp)
 
-(defconstant +names+ '("Mildred"
+(define-constant +names+ #("Mildred"
 		       "Henry"
 		       "Alice"
 		       "Walter"
@@ -1980,7 +1980,8 @@
 		       "Lenord"
 		       "Macy"
 		       "Arden"
-		       "Paralee"))
+		       "Paralee")
+  :test 'equalp)
 
 (defun-speedy random-letter ()
   (code-char (+ (char-code #\A) (random 26))))

diff --git a/src/webapp/page.lisp b/src/webapp/page.lisp
@@ -1,14 +1,16 @@
 (in-package #:tpd2.webapp)
 
 (defvar *webapp-frame*)
-(defconstant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame."))
+(define-constant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame.")
+  :test 'equalp)
 
-(defconstant +web-safe-chars+ 
+(define-constant +web-safe-chars+ 
   (force-byte-vector 
    (append (loop for c from (char-code #\A) to (char-code #\Z) collect c)
 	   (loop for c from (char-code #\a) to (char-code #\z) collect c)
 	   (loop for c from (char-code #\0) to (char-code #\9) collect c)
-	   (mapcar 'char-code '(#\- #\_)))))
+	   (mapcar 'char-code '(#\- #\_))))
+  :test 'equalp)
 
 (defun generate-args-for-defpage-from-params (params-var defaulting-lambda-list)
   (let ((arg-names (mapcar 'force-first defaulting-lambda-list))

diff --git a/src/webapp/site.lisp b/src/webapp/site.lisp
@@ -1,8 +1,8 @@
 (in-package #:tpd2.webapp)
 
 (eval-always
-  (defconstant +site-customization-funcs+ '(page-head page-body-start page-body-footer))
-  (defconstant +site-customization-func-args+ '(title)))
+  (define-constant +site-customization-funcs+ '(page-head page-body-start page-body-footer) :test 'equalp)
+  (define-constant +site-customization-func-args+ '(title) :test 'equalp))
 
 (defparameter *current-site* nil)
 
@@ -14,9 +14,9 @@
   (runtime-name '*current-site*)
   (dispatcher *default-dispatcher*)
   (page-head (lambda(title)
-	       `(<head
-		  (<title ,title)
-		  (webapp-default-page-head-contents))))
+	       `(with-ml-output
+		  (<title ,title))
+		  (webapp-default-page-head-contents)))
   (page-body-start 
    (lambda(title)
      `(<h1 ,title)))

diff --git a/src/webapp/webapp.lisp b/src/webapp/webapp.lisp
@@ -13,32 +13,38 @@
 (defmacro ml-to-byte-vector (ml)
   `(sendbuf-to-byte-vector (with-ml-output-start ,ml)))
 
-(defmacro webapp-ml (title &body body)
+(defmacro webapp-ml (title-and-options &body body)
   (with-unique-names (title-ml)
-    `(let ((,title-ml
-	    (ml-to-byte-vector ,title)))
-       (setf (webapp-frame-var 'actions) nil)
-       (with-frame-site
-	   (with-ml-output-start 
+    (destructuring-bind (title &key head-contents)
+	(force-list title-and-options)
+      `(let ((,title-ml
+	      (ml-to-byte-vector ,title)))
+	 (setf (webapp-frame-var 'actions) nil)
+	 (values
+	  (with-frame-site
+	      (with-ml-output-start 
 	     (output-raw-ml "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"" 
-			  " \"http://www.w3.org/TR/html4/loose.dtd\">")
-	     (<html
-	       (current-site-call page-head  ,title-ml)
-	       (<body
-		 (current-site-call page-body-start ,title-ml)
-		 ,@body
-		 (current-site-call page-body-footer ,title-ml))))))))
-
-(defmacro webapp-lambda (title &body body)
+			    " \"http://www.w3.org/TR/html4/loose.dtd\">")
+		(<html
+		 (<head
+		  (current-site-call page-head ,title-ml)
+		  ,head-contents)
+		 (<body
+		  (current-site-call page-body-start ,title-ml)
+		  ,@body
+		  (current-site-call page-body-footer ,title-ml)))))
+	  (byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+))))))
+
+(defmacro webapp-lambda (title-and-options &body body)
   (with-unique-names (l)
   `(labels ((,l ()
 	      (setf (frame-current-page (webapp-frame)) 
 		    #',l)
-	      (webapp-ml ,title ,@body)))
+	      (webapp-ml ,title-and-options ,@body)))
      #',l)))
 
-(defmacro webapp (title &body body)
-  `(funcall (webapp-lambda ,title ,@body)))
+(defmacro webapp (title-and-options &body body)
+  `(funcall (webapp-lambda ,title-and-options ,@body)))
 
 (defmacro link-to-webapp (title &body body)
   (with-unique-names (title-ml)