From bmastenbrook at common-lisp.net  Tue Jan 16 00:56:31 2007
From: bmastenbrook at common-lisp.net (bmastenbrook)
Date: Mon, 15 Jan 2007 19:56:31 -0500 (EST)
Subject: [Lisppaste-cvs] CVS lisppaste2
Message-ID: <20070116005631.6CC6730B0@common-lisp.net>

Update of /project/lisppaste/cvsroot/lisppaste2
In directory clnet:/tmp/cvs-serv4784

Modified Files:
	lisppaste.asd package.lisp system-server.lisp variable.lisp 
	web-server.lisp 
Log Message:
Major change: use webutils and XML mixed mode. Add captchas.


--- /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd	2006/06/29 13:50:23	1.21
+++ /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd	2007/01/16 00:56:30	1.22
@@ -1,5 +1,5 @@
 ;;;; Silly emacs, this is -*- Lisp -*-
-;;;; $Id: lisppaste.asd,v 1.21 2006/06/29 13:50:23 lisppaste Exp $
+;;;; $Id: lisppaste.asd,v 1.22 2007/01/16 00:56:30 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -22,19 +22,19 @@
 pre-configured IRC channel about the paste and where it can be
 located."
     :depends-on (:araneida #-lisppaste-no-irc :cl-irc
-                           :split-sequence :s-xml :s-xml-rpc :cl-ppcre)
-    :components ((:file "encode-for-pre")
-                 (:file "package" :depends-on ("encode-for-pre"))
+                           :split-sequence :s-xml :s-xml-rpc :cl-ppcre
+                           :html-encode :webutils)
+    :components ((:file "package")
                  (:file "variable"
                         :depends-on ("package"))
                  (:file "colorize-package")
                  (:file "coloring-css" :depends-on ("colorize-package"))
-                 (:file "colorize" :depends-on ("colorize-package" "coloring-css" "encode-for-pre"))
+                 (:file "colorize" :depends-on ("colorize-package" "coloring-css"))
                  (:file "abbrev")
-                 (:file "clhs-lookup" :depends-on ("encode-for-pre" "abbrev"))
-                 (:file "r5rs-lookup" :depends-on ("encode-for-pre"))
-		 (:file "cocoa-lookup" :depends-on ("encode-for-pre"))
-                 (:file "elisp-lookup" :depends-on ("encode-for-pre"))
+                 (:file "clhs-lookup" :depends-on ("abbrev"))
+                 (:file "r5rs-lookup")
+		 (:file "cocoa-lookup")
+                 (:file "elisp-lookup")
                  #-lisppaste-no-irc (:file "irc-notification" :depends-on ("variable" "package"))
                  (:file "lisppaste"
                         :depends-on ("variable" "clhs-lookup"
@@ -46,13 +46,12 @@
                  (:file "coloring-types"
                         :depends-on ("colorize" "clhs-lookup"))
                  (:file "web-server"
-                        :depends-on ("encode-for-pre" "lisppaste"
-                                                      "colorize-package"
-                                                      "colorize"
-                                                      "coloring-css"))
+                        :depends-on ("lisppaste"
+                                     "colorize-package"
+                                     "colorize"
+                                     "coloring-css"))
                  (:file "system-server"
-                        :depends-on ("variable" "encode-for-pre"
-                                                "colorize-package"
+                        :depends-on ("variable" "colorize-package"
                                                 "coloring-css"))
                  (:file "xml-paste"
                         :depends-on ("variable" "lisppaste"))
--- /project/lisppaste/cvsroot/lisppaste2/package.lisp	2004/11/07 21:01:43	1.10
+++ /project/lisppaste/cvsroot/lisppaste2/package.lisp	2007/01/16 00:56:30	1.11
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.10 2004/11/07 21:01:43 bmastenbrook Exp $
+;;;; $Id: package.lisp,v 1.11 2007/01/16 00:56:30 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -7,7 +7,7 @@
 
 (eval-when (:execute :load-toplevel :compile-toplevel)
   (defpackage :lisppaste
-      (:use :cl #+sbcl :sb-bsd-sockets :html-encode)
+      (:use :cl #+sbcl :sb-bsd-sockets :html-encode :araneida :webutils)
     (:export :start-lisppaste :join-new-irc-channel
              :start-irc-notification :hup-irc-connection
              :quit-all-connections :hup-all-connections
--- /project/lisppaste/cvsroot/lisppaste2/system-server.lisp	2004/07/15 12:37:35	1.1
+++ /project/lisppaste/cvsroot/lisppaste2/system-server.lisp	2007/01/16 00:56:30	1.2
@@ -14,25 +14,28 @@
               (find-component-from-string (subseq string start-of-rest) :root new-root)
               new-root)))))
 
-(defclass main-system-server-handler (araneida:handler) ())
+(defclass main-system-server-handler (handler) ())
 
-(defclass show-component-handler (araneida:handler) ())
+(defclass show-component-handler (handler) ())
 
-(defmethod araneida:handle-request-response ((handler main-system-server-handler) method request)
-  (araneida:request-send-headers request :expires 0)
-  (araneida:html-stream
-   (araneida:request-stream request)
+(defmethod handle-request-response ((handler main-system-server-handler) method request)
+  (request-send-headers request :expires 0)
+  (xml-output-to-stream
+   (request-stream request)
    (lisppaste-wrap-page
     "Select a System"
-    `((div :class "controls")
-      (ul
-       ,@(loop for i in (all-system-names)
-               for system = (asdf:find-system i)
-               collect `(li ((a :href ,(araneida:urlstring (araneida:merge-url *show-component-url*
-                                                             i)))
-                             ,i) " - " ,(or (ignore-errors (asdf:system-description system))
-                                            (ignore-errors (asdf:system-long-description system))
-                                          "No Description"))))))))
+    (<div class="controls">
+          (<ul>
+           (loop for i in (all-system-names)
+              for system = (asdf:find-system i)
+              collect (<li>
+                       (<a href=?(urlstring (merge-url *show-component-url*
+                                                       i))>
+                           i)
+                       " - "
+                       (or (ignore-errors (asdf:system-description system))
+                           (ignore-errors (asdf:system-long-description system))
+                           "No Description"))))))))
 
 (defun memoize-colorize-file (component type)
   (let ((ent (list (asdf:component-pathname component)
@@ -56,97 +59,98 @@
           (string< (asdf:component-name c1) (asdf:component-name c2)))))
 
 (defun module-div (component url)
-  `(div
-    ,@(if (typep component 'asdf:system)
-          `(((div :class "info-text")
-             ((span :class "small-header") ,(format nil "About system \"~A\"" (asdf:component-name component)))
-             (p)
-             (table
-              (tr
-               (td (b "Name"))
-               (td ,(asdf:component-name component)))
-              (tr
-               (td (b "Version"))
-               (td ,(or (ignore-errors (asdf:component-version component)) "None")))
-              (tr
-               (td (b "Author"))
-               (td ,(or (ignore-errors (asdf:system-author component)) "None")))
-              (tr
-               (td (b "License"))
-               (td ,(or (ignore-errors (asdf::system-licence component)) "None")))
-              (tr
-               (td (b "Description"))
-               (td ,(or (ignore-errors (asdf:system-description component)) "None")))
-              (tr
-               (td (b "Long Description"))
-               (td ,(or (ignore-errors (asdf:system-long-description component)) "None")))))
-            (p)))
-    ((div :class "controls")
-     ((span :class "small-header") "Select a component:")
-     (ul
-      ,@(loop for i in (sort (copy-list (asdf:module-components component)) #'component-sorter)
-              for link = `((a :href ,(concatenate 'string
+  (<div>
+   (when (typep component 'asdf:system)
+     (<div class="info-text">
+           (<span class="small-header">
+                  (format nil "About system \"~A\""
+                          (asdf:component-name component)))
+           <p/>
+           (<table>
+            (<tr>
+             (<td> (<b> "Name"))
+             (<td> (asdf:component-name component)))
+            (<tr>
+             (<td> (<b> "Version"))
+             (<td> (or (ignore-errors (asdf:component-version component)) "None")))
+            (<tr>
+             (<td> (<b> "Author"))
+             (<td> (or (ignore-errors (asdf:system-author component)) "None")))
+            (<tr>
+             (<td> (<b> "License"))
+             (<td> (or (ignore-errors (asdf:system-license component)) "None")))
+            (<tr>
+             (<td> (<b> "Description"))
+             (<td> (or (ignore-errors (asdf:system-description component)) "None")))
+            (<tr>
+             (<td> (<b> "Long Description"))
+             (<td> (or (ignore-errors (asdf:system-long-description component)) "None"))))))
+   (<div class="controls">
+         (<span class="small-header"> "Select a component:")
+         (<ul>
+          (loop for i in (sort (copy-list (asdf:module-components component)) #'component-sorter)
+              for link = (<a href=?(concatenate 'string
                                                   url
                                                   "/"
-                                                  (asdf:component-name i)))
-                           ,(asdf:component-name i))
-              if (typep i 'asdf:module) collect `(li (b ,link))
-              else collect `(li ,link))))))
+                                                  (asdf:component-name i))>
+                             (asdf:component-name i))
+              if (typep i 'asdf:module) collect (<li> (<b> link))
+              else collect (<li> link))))))
 
 (defun file-div (component type)
-  `((table :width "100%" :class "paste-area")
-    (tr
-     ((td :bgcolor "#F4F4F4")
-      (tt
-       ,(if (eql type :none)
-            (html-encode:encode-for-tt
-             (with-output-to-string (s)
-              (with-open-file (f (asdf:component-pathname component) :direction :input)
-                (loop for line = (read-line f nil nil)
-                      while line
-                      do (progn (write-string line s)
-                                (terpri s))))))
-            (memoize-colorize-file component type)))))))
+  (<table width="100%" class="paste-area">
+          (<tr>
+           (<td bgcolor="#F4F4F4">
+                (if (eql type :none)
+                    (<pre>
+                     (with-output-to-string (s)
+                       (with-open-file (f (asdf:component-pathname component) :direction :input)
+                         (loop for line = (read-line f nil nil)
+                            while line
+                            do (progn (write-string line s)
+                                      (terpri s))))))
+                    (<tt>
+                     (make-unescaped-string
+                      (memoize-colorize-file component type))))))))
 
-(defmethod araneida:handle-request-response ((handler show-component-handler) method request)
-  (let ((component (find-component-from-string (araneida:request-unhandled-part request))))
+(defmethod handle-request-response ((handler show-component-handler) method request)
+  (let ((component (find-component-from-string (request-unhandled-part request))))
     (and component
          (progn
-           (araneida:request-send-headers request :expires 0)
-           (araneida:html-stream
-            (araneida:request-stream request)
+           (request-send-headers request :expires 0)
+           (xml-output-to-stream
+            (request-stream request)
             (lisppaste-wrap-page
              (format nil "Component ~A" (asdf:component-name component))
-             `(div
-               ((div :class "controls")
-                "You are here: "
-                ((a :href ,(araneida:urlstring *main-system-server-url*))
-                 "All Systems")
-                ,@(loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (araneida:request-unhandled-part request)))))
-                        appending `(" / "
-                                    ((a :href ,(araneida:urlstring
-                                                (araneida:merge-url *show-component-url*
+             (<div>
+              (<div class="controls">
+                    "You are here: "
+                    (<a href=?(urlstring *main-system-server-url*)>
+                        "All Systems")
+                    (loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (request-unhandled-part request)))))
+                       collect " / "
+                         collect (<a href=?(urlstring (merge-url *show-component-url*
                                                            (format nil "~{~A~^/~}"
-                                                                   i))))
-                                     ,(car (last i))))))
-               (p)
-               ,(typecase component
-                          (asdf:module (module-div component (araneida:urlstring (araneida:request-url request))))
-                          (asdf:cl-source-file (file-div component :common-lisp-file))
-                          (asdf:static-file
-                           (file-div component (if (equalp (pathname-type (asdf:component-pathname component)) "lisp")
-                                                   :common-lisp-file
-                                                   :none)))
-                          (t `((div :class "paste-area")
-                               "I don't know what to do with this component."))))))))))
+                                                                   i)))>
+                                     (car (last i)))))
+              <p/>
+              (typecase component
+                (asdf:module (module-div component (urlstring (request-url request))))
+                (asdf:cl-source-file (file-div component :common-lisp-file))
+                (asdf:static-file
+                 (file-div component (if (equalp (pathname-type (asdf:component-pathname component)) "lisp")
+                                         :common-lisp-file
+                                         :none)))
+                (t (<div class="paste-area">
+                         "I'm afraid I don't quite know what to do with this file.")))))))))))))
 
 (when *serve-source*
-  (araneida:install-handler
-   (araneida:http-listener-handler *paste-listener*)
+  (install-handler
+   (http-listener-handler *paste-listener*)
    (make-instance 'main-system-server-handler)
-   (araneida:urlstring *main-system-server-url*) t)
+   (urlstring *main-system-server-url*) t)
   
-  (araneida:install-handler
-   (araneida:http-listener-handler *paste-listener*)
+  (install-handler
+   (http-listener-handler *paste-listener*)
    (make-instance 'show-component-handler)
-   (araneida:urlstring *show-component-url*) nil))
+   (urlstring *show-component-url*) nil))
--- /project/lisppaste/cvsroot/lisppaste2/variable.lisp	2006/12/02 00:06:04	1.46
+++ /project/lisppaste/cvsroot/lisppaste2/variable.lisp	2007/01/16 00:56:30	1.47
@@ -1,4 +1,4 @@
-;;;; $Id: variable.lisp,v 1.46 2006/12/02 00:06:04 lisppaste Exp $
+;;;; $Id: variable.lisp,v 1.47 2007/01/16 00:56:30 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -25,23 +25,24 @@
 
 (defparameter *internal-http-port* 8080
   "Port lisppaste's araneida will listen on for requests from Apache.")
-(defparameter *external-http-port* 80
+(defparameter *external-http-port* 8080
   "Port lisppaste's araneida will listen on for requests from remote clients.")
 
-(defparameter *paste-site-name* "paste.lisp.org"
+(defparameter *paste-site-name* "distral.local"
   "Website we are running on (used for creating links).")
 
 (defparameter *paste-external-url*
-  (araneida:merge-url
-   (araneida:make-url :scheme "http"
+  (merge-url
+   (make-url :scheme "http"
                       :host *paste-site-name*
                       ;;; comment out this next line when running
                       ;;; behind a proxying apache
+                      :port *external-http-port*
 		      #| :port *external-http-port* |#
                       ) "/"))
 
-(defparameter *old-url* (araneida:merge-url
-                         (araneida:make-url :scheme "http"
+(defparameter *old-url* (merge-url
+                         (make-url :scheme "http"
                                             :host "www.common-lisp.net")
                          "/paste/"))
 
@@ -56,11 +57,9 @@
 (defparameter *owner-email* "lisppaste-requests at common-lisp.net") ; the owner of this lisppaste
 
 (defparameter *ads*
-  '(ul
-(li ((a :href "http://planet.lisp.org")
-	 "Planet Lisp"))
-    (li ((a :href "http://www.gigamonkeys.com/book/")
-	 "Practical Common Lisp - learn Lisp!")))) ; gratuitous promotions
+  (<ul> (<li> (<a href="http://planet.lisp.org/"> "Planet Lisp"))
+        (<li> (<a href="http://www.gigamonkeys.com/book/">
+                  "Practical Common Lisp - learn Lisp!")))) ; gratuitous promotions
 
 (defvar *paste-maximum-size* 51200) ; in bytes
 
@@ -111,71 +110,74 @@
 
 (defparameter *serve-source* t)
 
+;; once every this often, clear out the "used" captchas
+(defparameter *used-captcha-release-time* (* 60 60 24))
+
 ;; You shouldn't need to edit below this line.
 ;; LINE
 
 (defparameter *display-paste-url*
-  (araneida:merge-url *paste-external-url* "display/"))
+  (merge-url *paste-external-url* "display/"))
 
 (defparameter *new-paste-url*
-  (araneida:merge-url *paste-external-url* "new"))
+  (merge-url *paste-external-url* "new"))
 
 (defparameter *list-paste-url*
-  (araneida:merge-url *paste-external-url* "list"))
+  (merge-url *paste-external-url* "list"))
 
 (defparameter *submit-paste-url*
-  (araneida:merge-url *paste-external-url* "submit"))
+  (merge-url *paste-external-url* "submit"))
 
 (defparameter *rss-url*
-  (araneida:merge-url *paste-external-url* "list.rss"))
+  (merge-url *paste-external-url* "list.rss"))
 
 (defparameter *rss-full-url*
-  (araneida:merge-url *paste-external-url* "list-full.rss"))
+  (merge-url *paste-external-url* "list-full.rss"))
 
 (defparameter *syndication-url*
-  (araneida:merge-url *paste-external-url* "syndication"))
+  (merge-url *paste-external-url* "syndication"))
 
 (defparameter *stats-url*
-  (araneida:merge-url *paste-external-url* "stats"))
+  (merge-url *paste-external-url* "stats"))
 
 (defparameter *css-url*
-  (araneida:merge-url *paste-external-url* "lisppaste.css"))
+  (merge-url *paste-external-url* "lisppaste.css"))
 
 (defparameter *recent-url*
-  (araneida:merge-url *paste-external-url* "recent"))
+  (merge-url *paste-external-url* "recent"))
 
 (defparameter *email-redirect-url*
-  (araneida:merge-url *paste-external-url* "email"))
+  (merge-url *paste-external-url* "email"))
 
 (defparameter *channel-select-url*
-  (araneida:merge-url *paste-external-url* "channels"))
+  (merge-url *paste-external-url* "channels"))
 
 (defparameter *404-urls*
-  (list (araneida:merge-url *paste-external-url* "favicon.ico")
-	(araneida:merge-url *paste-external-url* "robots.txt")))
+  (list (merge-url *paste-external-url* "favicon.ico")
+	(merge-url *paste-external-url* "robots.txt")))
 
-(defparameter *main-system-server-url* (araneida:merge-url *paste-external-url*
+(defparameter *main-system-server-url* (merge-url *paste-external-url*
                                                            "system-server/"))
 
-(defparameter *show-component-url* (araneida:merge-url *paste-external-url*
+(defparameter *show-component-url* (merge-url *paste-external-url*
                                                        "system-server/show/"))
 
 (defvar *paste-listener*
-  (let ((fwd-url (araneida:copy-url *paste-external-url*))
-        (fwd-old-url (araneida:copy-url *old-url*)))
-    (setf (araneida:url-port fwd-url) *internal-http-port*)
+  (let ((fwd-url (copy-url *paste-external-url*))
+        (fwd-old-url (copy-url *old-url*)))
+    (setf (url-port fwd-url) *internal-http-port*)
     ;; temporary fix!
-    (setf (araneida:url-host fwd-url) "127.0.0.1")
-    (setf (araneida:url-port fwd-old-url) *internal-http-port*)
-    (make-instance #+sbcl 'araneida:serve-event-reverse-proxy-listener
-                   #-sbcl 'araneida:threaded-reverse-proxy-listener
+    (setf (url-host fwd-url) "127.0.0.1")
+    (setf (url-port fwd-old-url) *internal-http-port*)
+    (make-instance #+sbcl 'serve-event-reverse-proxy-listener
+                   #-sbcl 'threaded-reverse-proxy-listener
                    :translations
-                   `((,(araneida:urlstring *paste-external-url*)
-                      ,(araneida:urlstring fwd-url))
-                     (,(araneida:urlstring *old-url*)
-                      ,(araneida:urlstring fwd-old-url)))
-                   :address #(127 0 0 1)
-                   :port (araneida:url-port fwd-url))))
+                   `((,(urlstring *paste-external-url*)
+                      ,(urlstring fwd-url))
+                     (,(urlstring *old-url*)
+                      ,(urlstring fwd-old-url)))
+                   :address #(0 0 0 0)
+                   :port (url-port fwd-url))))
 
 (defvar *default-nickname* "devpaste")
 (defvar *default-irc-server* "irc.freenode.net")
--- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 00:36:32	1.87
+++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 00:56:31	1.88
@@ -1,4 +1,4 @@
-;;;; $Id: web-server.lisp,v 1.87 2007/01/16 00:36:32 lisppaste Exp $
+;;;; $Id: web-server.lisp,v 1.88 2007/01/16 00:56:31 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -17,7 +17,7 @@
    (colorization-mode :initarg :colorization-mode :initform "" :accessor paste-colorization-mode)))
 
 (defun paste-display-url (paste)
-  (araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))
+  (urlstring (merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))
 
 (defun find-paste (number)
   (find number *pastes* :key #'paste-number))
@@ -26,7 +26,7 @@
   `(progn
     (funcall 'make-instance 'paste , at arguments)))
 
-(defclass lisppaste-basic-handler (araneida:handler) ())
+(defclass lisppaste-basic-handler (handler) ())
 
 (defclass main-handler (lisppaste-basic-handler) ())
 
@@ -54,7 +54,7 @@
 
 (defclass channel-select-handler (lisppaste-basic-handler) ())
 
-(defclass 404-handler (araneida:handler) ())
+(defclass 404-handler (handler) ())
 
 (defvar *referer-hash* (make-hash-table :test #'equalp))
 
@@ -86,39 +86,12 @@
                (remhash host *referer-hash*)
                (incf (gethash "Google" *referer-hash* 0) count)))))
 
-(defmethod araneida:handle-request-response :around ((handler lisppaste-basic-handler) method request)
+(defmethod handle-request-response :around ((handler lisppaste-basic-handler) method request)
   (with-open-file (*trace-output* (times-file-for-class handler)
                                   :direction :output
                                   :if-exists :append :if-does-not-exist :create)
     (unwind-protect
-	 (progn
-	   (let ((referer (car (araneida:request-header request :referer)))
-		 (araneida::*default-url-defaults* (araneida:request-url request)))
-	     (when (stringp referer)
-	       (when (string= referer ": " :end1 2)
-		 ;; Some maniac is sending ": http://paste.lisp.org/"
-		 ;; as a referer.  We need to strip that leading colon.
-		 (format t "bogus referer ~S~%" referer)
-		 (setf referer (subseq referer 2)))
-	       (let ((url (ignore-errors (araneida:parse-urlstring referer nil))))
-		 (when url
-		   (let ((real-host (araneida:url-host url))
-			 (split-host (split-sequence:split-sequence #\. (araneida:url-host url))))
-		     (if (or
-			  (and (eql (length split-host) 3)
-			       (string-equal (first split-host) "www")
-			       (string-equal (second split-host) "google"))
-			  (and (eql (length split-host) 4)
-			       (string-equal (first split-host) "www")
-			       (string-equal (second split-host) "google")
-			       (or
-				(string-equal (third split-host) "co")
-				(string-equal (third split-host) "com"))
-			       (eql (length (fourth split-host)) 2)))
-			 (setf real-host "Google"))
-		     (incf (gethash real-host *referer-hash* 0))
-		     (setf (gethash real-host *referer-example-hash*) url))))))
-	   (call-next-method))
+         (call-next-method)
       (force-output *trace-output*))))
 
 (defun make-css ()
@@ -157,131 +130,149 @@
             (colorize:make-background-css "#F4F4F4")
             colorize:*coloring-css*)))
 
-(defmethod araneida:handle-request-response ((handler css-handler) method request)
-  (araneida:request-send-headers request :expires 0 :content-type "text/css")
-  (araneida:html-stream
-   (araneida:request-stream request)
+(defmethod handle-request-response ((handler css-handler) method request)
+  (request-send-headers request :expires 0 :content-type "text/css")
+  (html-stream
+   (request-stream request)
    (make-css)))
 
+(defun rss-link-header ()
+  <link rel="alternate" type="application/rss+xml" title="Lisppaste RSS" href=?(urlstring *rss-url*)/>)
+
 (defun lisppaste-wrap-page (title &rest forms)
-  `(html
-    (head (title ,title)
-     #-nil
-     ((link :type "text/css" :rel "stylesheet" :href ,(araneida:url-path *css-url*)))
-     #+nil
-     ((style :type "text/css")
-      ,(make-css))
-     ,(rss-link-header))
-    (body
-     ((div :class "top-header")
-      ,title)
-     (p)
-     , at forms
-     ,@(bottom-links))))
+  (<html>
+   (<head> (<title> title)
+           <link type="text/css" rel="stylesheet" href=?(url-path *css-url*)/>
+           (rss-link-header))
+   (<body>
+    (<div class="top-header"> title)
+    <p/>
+    forms
+    (bottom-links))))
+
+(defun bottom-links ()
+  (list
+   <p/>
+   (<div class="bottom-links">
+         (<table width="100%">
+                 (<tr>
+                  (<td id="main-link">
+                       (<a href=?(urlstring *paste-external-url*)> "Main page"))
+                  (<td id="other-links">
+                       (<a href=?(urlstring *new-paste-url*)> "New paste")
+                       " | "
+                       (<a href=?(urlstring *list-paste-url*)> "List all pastes")
+                       " | "
+                       (<a href=?(urlstring *syndication-url*)> "Syndication")
+                       " | "
+                       (<a href="http://common-lisp.net/project/lisppaste/xml-rpc.html"> "XML-RPC")
+                       (when *serve-source*
+                         (list " | "
+                               (<a href=?(urlstring (merge-url *show-component-url* "lisppaste"))>
+                                   "Source")))
+                       " | "
+                       (<a href=?(urlstring *email-redirect-url*)> "Requests Email")
+                       " | "
+                       (<a href="http://www.common-lisp.net/project/lisppaste"> "Project home"))))) 
+   (<i> "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.")))
 
 (defun recent-paste-list-div (&key (count 10))
-  `((div :class "simple-paste-list")
-    (table
-     ,@(loop for i from 1 to count
-             for j in *pastes*
-             collect `(tr
-                       ((td :valign center) ((a :href ,(paste-display-url j))
-                                             ,(encode-for-pre (paste-title j))))
-                       ((td :valign bottom) " by " ,(encode-for-pre (paste-user j)))
-                       ((td :valign bottom) ,(encode-for-pre (paste-channel j)))))
-     (tr
-      ((td :colspan 3)
-       (center
-        (b
-         ((a :href ,(araneida:urlstring *list-paste-url*))
-          "More recent pastes..."))))))))
-
-(defmethod araneida:handle-request-response ((handler recent-handler) method request)
-  (araneida:request-send-headers request :expires 0)
-  (araneida:html-stream
-   (araneida:request-stream request)
+  (<div class="simple-paste-list">
+        (<table>
+         (loop for i from 1 to count
+              for j in *pastes*
+              collect (<tr>
+                       (<td valign="center"> (<a href=?(paste-display-url j)>
+                                                 (paste-title j)))
+                       (<td valign="bottom"> " by " (paste-user j))
+                       (<td valign="bottom"> (paste-channel j))))
+         (<tr> (<td colspan="3">
+                    (<center> (<b> (<a href=?(urlstring *list-paste-url*)>
+                                       "More recent pastes..."))))))))
+
+(defmethod handle-request-response ((handler recent-handler) method request)
+  (request-send-headers request :expires 0)
+  (xml-output-to-stream
+   (request-stream request)
    (lisppaste-wrap-page
     "Recent Pastes"
     (recent-paste-list-div :count 20))))
 
-(defmethod araneida:handle-request-response ((handler main-handler) method request)
-  (araneida:request-send-headers request :expires 0)
-  (araneida:html-stream
-   (araneida:request-stream request)
+(defmethod handle-request-response ((handler main-handler) method request)
+  (request-send-headers request :expires 0)
+  (xml-output-to-stream
+   (request-stream request)
    (lisppaste-wrap-page
     (format nil "~A pastebin" *paste-site-name*)
-    `((table :width "100%" :border 0 :cellpadding 2)
-      (tr (td ((div :class "small-header") "Recent pastes"))
-       ((td :align right) ((div :class "small-header") "Make a new paste")))
-      (tr
-       ((td :valign top :width "40%")
-        ,(recent-paste-list-div)
-        (p)
-        ((div :class "small-header") "About lisppaste")
-        ((div :class "info-text")
-         "Lisppaste is a pastebot / pastebin / nopaste service with syntax highlighting, XML-RPC support, annotations, and more."
-         (p)
-         "Many times when working via IRC, people want to share a
+    (<table width="100%" border="0" cellpadding="2">
+            (<tr> (<td> (<div class="small-header"> "Recent Pastes"))
+                  (<td align="right"> (<div class="small-header"> "Make a new paste")))
+            (<tr> (<td valign="top" width="40%">
+                       (recent-paste-list-div)
+                       <p/>
+                       (<div class="small-header"> "About lisppaste")
+                       (<div class="info-text">
+                             "Lisppaste is a pastebot / pastebin / nopaste service with syntax highlighting, XML-RPC support, annotations, and more.")
+                       <p/>
+                       "Many times when working via IRC, people want to share a
 snippet of code with somebody else. However, just pasting the code
 into IRC creates a flood of text which is hard to read and scrolls by
 as discussion progresses."
-         (p)
-         "Thus, the pastebot was invented, which has a web form where
+                       <p/>
+                       "Thus, the pastebot was invented, which has a web form where
 users can paste code, and the URL of the paste is announced on the
 desired channel. Lisppaste is an advanced pastebot running on the IRC
 server "
-         ,(encode-for-pre *irc-network-name*)
-         " which has many unique features."
-         ,@(if *no-channel-pastes*
-               '((p) " It also allows pastes which are not announced on any channel, which
+                       *irc-network-name*
+                       " which has many unique features."
+                       (when *no-channel-pastes*
+                         (list
+                          <p/>
+                          "It also allows pastes which are not announced on any channel, which
 is useful for sections of code which need to be sent to a mailing list
 or are discussed in ways other than IRC."))
-         (p)
-         "Lisppaste is graciously hosted by "
-         (b ((a :href "http://www.common-lisp.net/") "common-lisp.net"))
-         " - a hosting service for projects written in Common Lisp (like this one)."
-         (p)
-         "Questions? Comments? Want lisppaste in your channel? " ((a :href ,(araneida:urlstring *email-redirect-url*)) "Email me") "."
-         ))
-       ((td :valign top :align right)
-        ((form :method post :action ,(araneida:urlstring *submit-paste-url*))
-         ,(generate-new-paste-form :width 60))
-	(p)
-	((div :class "small-header") "Ads absolutely not by Google")
-        ((div :class "ads-text")
-	 ,*ads*)))
-      
-      ))))
+                       <p/>
+                       "Lisppaste is graciously hosted by "
+                       (<b> (<a href="http://www.common-lisp.net/"> "common-lisp.net"))
+                       " - a hosting service for projects written in Common Lisp (like this one)."
+                       <p/>
+                       "Questions? Comments? Want lisppaste in your channel? "
+                       (<a href=?(urlstring *email-redirect-url*)> "Email me")
+                       ".")
+                  (<td valign="top" align="right">
+                       (<form method="post" action=?(urlstring *submit-paste-url*)>
+                              (generate-new-paste-form :width 60))
+                       <p/>
+                       (<div class="small-header"> "Ads absolutely not by Google")
+                       (<div class="ads-text"> *ads*)))))))
 
 (defun ban-log (user request)
   (log-event
    (format nil "Blocked attempt by ~S, IP ~S, (referred by ~S) to submit a paste.~%Request headers are: ~S.~%Request body is: ~S.~%"
 	   user
-	   (car (araneida:request-header request :x-forwarded-for))
-	   (car (araneida:request-header request :referer))
-	   (araneida:request-headers request)
-	   (araneida:request-body request))
+	   (car (request-header request :x-forwarded-for))
+	   (car (request-header request :referer))
+	   (request-headers request)
+	   (request-body request))
    :log-file *ban-log-file*))
 
-(defmethod araneida:handle-request-response :around
+(defmethod handle-request-response :around
     ((handler submit-paste-handler) method request)
-  (let ((forwarded-for (car (araneida:request-header request :x-forwarded-for))))
+  (let ((forwarded-for (car (request-header request :x-forwarded-for))))
     (if (and forwarded-for
                  (member forwarded-for
                          *banned-ips* :test #'string-equal))
         (progn
 	  (ban-log forwarded-for request) 
-          (araneida:request-send-headers request :expires 0)
-          (araneida:html-stream
-           (araneida:request-stream request)
-           `(html
-             (head
-              (title "No cookie for you!"))
-             (body (h1 ((font :color "red") "Naughty boy!"))))))
+          (request-send-headers request :expires 0)
+          (xml-output-to-stream
+           (request-stream request)
+           (<html> (<head> <title> "No cookie for you!")
+                   (<body> (<h1> (<font color="red"> "Naughty boy!"))))))
         (call-next-method))))
 
-(defmethod araneida:handle-request-response ((handler new-paste-handler) method request)
-  (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request)))
+(defmethod handle-request-response ((handler new-paste-handler) method request)
+  (let* ((annotate-string (body-param "annotate" (request-body request)))
          (annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t)))
          (annotate (if annotate-number (find annotate-number *pastes* :key #'paste-number)))
          (default-channel
@@ -289,10 +280,10 @@
                  (find-if #'(lambda (e) (> (length e) 1))
                           (list
                            (and (eql method :post)
-                                (araneida:body-param "channel"
-                                                     (araneida:request-body request)))
-                           (substitute #\# #\/ (araneida:urlstring-unescape (araneida::request-unhandled-part request)) :test #'char=)
-                           (concatenate 'string "#" (araneida:request-cookie request "CHANNEL"))
+                                (body-param "channel"
+                                                     (request-body request)))
+                           (substitute #\# #\/ (urlstring-unescape (request-unhandled-part request)) :test #'char=)
+                           (concatenate 'string "#" (request-cookie request "CHANNEL"))
                            (and *no-channel-pastes*
                                 "None")
                            )))))
@@ -300,55 +291,28 @@
       ((and default-channel (or (and *no-channel-pastes*
                                      (string-equal default-channel "None"))
                                 (find default-channel *channels* :test #'string-equal)))
-       (araneida:request-send-headers request :expires 0 :set-cookie
+       (request-send-headers request :expires 0 :set-cookie
                                       (format nil "CHANNEL=~A; path=/"
                                               (or (and *no-channel-pastes*
                                                        (string-equal default-channel "none")
                                                        "None")
                                                   (subseq default-channel 1))))
        (new-paste-form request :annotate annotate :default-channel default-channel))
-     (t (araneida:request-send-headers request :expires 0)
-	(araneida:html-stream
-	 (araneida:request-stream request)
+     (t (request-send-headers request :expires 0)
+	(xml-output-to-stream
+	 (request-stream request)
          (lisppaste-wrap-page
           "Select a channel"
-          `((form :method post :action ,(araneida:urlstring *new-paste-url*))
-            ((div :class "controls")
-             ((input :type "hidden" :name "annotate" :value ,annotate-string))
-             "Please select a channel to lisppaste to: "
-             ((select :name "channel")
-              ((option :value ""))
-              ,@(mapcar #'(lambda (e)
-                            `((option :value ,e)
-                              ,(encode-for-pre e))) *channels*))
-             ((input :type submit :value "Submit"))))))))))
-  
-(defun bottom-links ()
-  `((p)
-    ((div :class "bottom-links")
-     ((table :width "100%")
-      (tr
-       ((td :id "main-link")
-        ((a :href ,(araneida:urlstring *paste-external-url*))
-         "Main page")
-        )
-       ((td :id "other-links")
-        ((a :href ,(araneida:urlstring *new-paste-url*)) "New paste")
-        " | "
-        ((a :href ,(araneida:urlstring *list-paste-url*)) "List all pastes")
-        " | "
-        ((a :href ,(araneida:urlstring *syndication-url*)) "Syndication")
-        " | "
-        ((a :href "http://common-lisp.net/project/lisppaste/xml-rpc.html") "XML-RPC")
-        ,@(if *serve-source*
-              `(" | "
-                ((a :href ,(araneida:urlstring (araneida:merge-url
-                                                *show-component-url* "lisppaste"))) "Source")))
-        " | "
-	((a :href ,(araneida:urlstring *email-redirect-url*)) "Requests Email")
-	" | "
-        ((a :href "http://common-lisp.net/project/lisppaste") "Project home")))))
-    (i "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.")))
+          (<form method="post" action=?(urlstring *new-paste-url*)>
+                 (<div class="controls">
+                       <input type="hidden" name="annotate" value=?annotate-string />
+                       "Please select a channel to lisppaste to: "
+                               (<select name="channel">
+                                        (<option value=""> "")
+                                        (mapcar (lambda (e)
+                                                  (<option value=?e> e))
+                                                *channels*))
+                       <input type="submit" value="Submit"/>))))))))

[1497 lines skipped]



From bmastenbrook at common-lisp.net  Tue Jan 16 01:10:44 2007
From: bmastenbrook at common-lisp.net (bmastenbrook)
Date: Mon, 15 Jan 2007 20:10:44 -0500 (EST)
Subject: [Lisppaste-cvs] CVS lisppaste2
Message-ID: <20070116011044.8C4BF19007@common-lisp.net>

Update of /project/lisppaste/cvsroot/lisppaste2
In directory clnet:/tmp/cvs-serv9580

Modified Files:
	web-server.lisp 
Log Message:
Captchas should only be entered once an hour


--- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 00:56:31	1.88
+++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 01:10:44	1.89
@@ -1,4 +1,4 @@
-;;;; $Id: web-server.lisp,v 1.88 2007/01/16 00:56:31 bmastenbrook Exp $
+;;;; $Id: web-server.lisp,v 1.89 2007/01/16 01:10:44 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -86,12 +86,16 @@
                (remhash host *referer-hash*)
                (incf (gethash "Google" *referer-hash* 0) count)))))
 
+(defvar *show-captcha* t)
+
 (defmethod handle-request-response :around ((handler lisppaste-basic-handler) method request)
   (with-open-file (*trace-output* (times-file-for-class handler)
                                   :direction :output
                                   :if-exists :append :if-does-not-exist :create)
+    (expire-authorization-tokens)
     (unwind-protect
-         (call-next-method)
+         (let ((*show-captcha* (not (is-authorized request))))
+           (call-next-method))
       (force-output *trace-output*))))
 
 (defun make-css ()
@@ -677,15 +681,16 @@
           (<tr>
            (<th align="left" width="0%" nowrap="nowrap"> "Enter a title:")
            (<td> <input type="text" name="title" value=?default-title />))
-          (<tr>
-           (<th align="left" width="0%" nowrap="nowrap"> "Captcha:")
-           (<td>
-            (multiple-value-bind (captcha captchaid)
-                (make-captcha 8)
-              (list
-               captcha
-               <input type="text" name="captcha" />
-               <input type="hidden" name="captchaid" value=?captchaid />))))
+          (when *show-captcha*
+            (<tr>
+             (<th align="left" width="0%" nowrap="nowrap"> "Captcha:")
+             (<td>
+              (multiple-value-bind (captcha captchaid)
+                  (make-captcha 8)
+                (list
+                 captcha
+                 <input type="text" name="captcha" />
+                 <input type="hidden" name="captchaid" value=?captchaid />)))))
           (unless annotate
             (<tr>
              (<th align="left" width="0%" nowrap="nowrap">
@@ -765,20 +770,26 @@
          (annotate-paste (if annotate-number (find annotate-number *pastes* :key #'paste-number)))
          (channel (body-param "channel" (request-body request)))
          (captcha (body-param "captcha" (request-body request)))
-         (captchaid (body-param "captchaid" (request-body request))))
-    (if (> (length channel) 1)
-	(request-send-headers request :expires 0
-				       :set-cookie (format nil "CHANNEL=~A; path=/"
-                                                           (or (and *no-channel-pastes*
-                                                                    (string-equal channel "none")
-                                                                    "None")
-                                                               (subseq channel 1))))
-        (request-send-headers request :expires 0))
+         (captchaid (body-param "captchaid" (request-body request)))
+         (correct (and captcha captchaid (captcha-entered-correctly-p captcha 8 captchaid))))
+    (let ((cookies nil))
+      (when (> (length channel) 1)
+        (push (format nil "CHANNEL=~A; path=/"
+                      (or (and *no-channel-pastes*
+                               (string-equal channel "none")
+                               "None")
+                          (subseq channel 1))) cookies))
+      (when correct
+        (push (make-authorization-token) cookies))
+      (if cookies
+          (request-send-headers request :expires 0
+                                :set-cookie cookies)
+          (request-send-headers request :expires 0))) 
     (expire-used-captchas)
     (cond
-      ((captcha-used captchaid)
+      ((and (> (length captchaid) 0) (captcha-used captchaid))
        (new-paste-form request :message "This captcha has been used already. Did you use the back button?" :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
-      ((not (captcha-entered-correctly-p captcha 8 captchaid))
+      ((and *show-captcha* (not correct))
        (new-paste-form request :message "You entered the captcha incorrectly." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
       ((> (length text) *paste-maximum-size*)
        (new-paste-form request :message "Paste too large." :default-channel channel :annotate annotate-paste :default-user username :default-title title))



From bmastenbrook at common-lisp.net  Tue Jan 16 01:17:32 2007
From: bmastenbrook at common-lisp.net (bmastenbrook)
Date: Mon, 15 Jan 2007 20:17:32 -0500 (EST)
Subject: [Lisppaste-cvs] CVS lisppaste2
Message-ID: <20070116011732.C74A51E010@common-lisp.net>

Update of /project/lisppaste/cvsroot/lisppaste2
In directory clnet:/tmp/cvs-serv10195

Modified Files:
	system-server.lisp 
Log Message:
paredit failed me! (trailing parens?)))


--- /project/lisppaste/cvsroot/lisppaste2/system-server.lisp	2007/01/16 00:56:30	1.2
+++ /project/lisppaste/cvsroot/lisppaste2/system-server.lisp	2007/01/16 01:17:32	1.3
@@ -129,10 +129,10 @@
                         "All Systems")
                     (loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (request-unhandled-part request)))))
                        collect " / "
-                         collect (<a href=?(urlstring (merge-url *show-component-url*
-                                                           (format nil "~{~A~^/~}"
-                                                                   i)))>
-                                     (car (last i)))))
+                       collect (<a href=?(urlstring (merge-url *show-component-url*
+                                                               (format nil "~{~A~^/~}"
+                                                                       i)))>
+                                   (car (last i)))))
               <p/>
               (typecase component
                 (asdf:module (module-div component (urlstring (request-url request))))
@@ -142,7 +142,7 @@
                                          :common-lisp-file
                                          :none)))
                 (t (<div class="paste-area">
-                         "I'm afraid I don't quite know what to do with this file.")))))))))))))
+                         "I'm afraid I don't quite know what to do with this file."))))))))))
 
 (when *serve-source*
   (install-handler



From bmastenbrook at common-lisp.net  Tue Jan 16 02:37:39 2007
From: bmastenbrook at common-lisp.net (bmastenbrook)
Date: Mon, 15 Jan 2007 21:37:39 -0500 (EST)
Subject: [Lisppaste-cvs] CVS lisppaste2
Message-ID: <20070116023739.648D9281E5@common-lisp.net>

Update of /project/lisppaste/cvsroot/lisppaste2
In directory clnet:/tmp/cvs-serv23816

Modified Files:
	web-server.lisp 
Log Message:
Oops. Monospace.


--- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 01:10:44	1.89
+++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp	2007/01/16 02:37:39	1.90
@@ -1,4 +1,4 @@
-;;;; $Id: web-server.lisp,v 1.89 2007/01/16 01:10:44 bmastenbrook Exp $
+;;;; $Id: web-server.lisp,v 1.90 2007/01/16 02:37:39 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -945,21 +945,22 @@
        (<table width="100%" class="paste-area">
                (<tr>
                 (<td bgcolor="#F4F4F4" colspan="2" width="100%">
-                     (when line-numbers (make-unescaped-string (line-number)))
-                     ;; FIXME!!! This all needs to be converted to use
-                     ;; XML objects natively.
-                     (make-unescaped-string
-                      (if colorize-as
-                          (memoize-format (list (paste-contents paste)
-                                                colorize-as
-                                                line-numbers)
-                                          (lambda ()
-                                      (colorize:format-scan colorize-as
-                                                            (mapcar #'(lambda (e)
-                                                                        (cons (car e)
-                                                                              (encode (cdr e))))
-                                                                    (colorize:scan-string colorize-as (paste-contents paste))))))
-                          (encode (paste-contents paste)))))))))))
+                     (<tt>
+                      (when line-numbers (make-unescaped-string (line-number)))
+                      ;; FIXME!!! This all needs to be converted to use
+                      ;; XML objects natively.
+                      (make-unescaped-string
+                       (if colorize-as
+                           (memoize-format (list (paste-contents paste)
+                                                 colorize-as
+                                                 line-numbers)
+                                           (lambda ()
+                                             (colorize:format-scan colorize-as
+                                                                   (mapcar #'(lambda (e)
+                                                                               (cons (car e)
+                                                                                     (encode (cdr e))))
+                                                                           (colorize:scan-string colorize-as (paste-contents paste))))))
+                           (encode (paste-contents paste))))))))))))
 
 (defmethod handle-request-response ((handler display-paste-handler) method request)
   (let* ((paste-number (parse-integer