[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Jul 6 16:33:46 UTC 2004
Update of /project/lisppaste/cvsroot/lisppaste2
In directory common-lisp.net:/home/bmastenbrook/lisppaste2
Modified Files:
web-server.lisp
Log Message:
Bringing CVS up to date, step 1 of 2354235235
Date: Tue Jul 6 09:33:46 2004
Author: bmastenbrook
Index: lisppaste2/web-server.lisp
diff -u lisppaste2/web-server.lisp:1.59 lisppaste2/web-server.lisp:1.60
--- lisppaste2/web-server.lisp:1.59 Thu Jun 24 12:47:39 2004
+++ lisppaste2/web-server.lisp Tue Jul 6 09:33:46 2004
@@ -1,4 +1,4 @@
-;;;; $Id: web-server.lisp,v 1.59 2004/06/24 19:47:39 bmastenbrook Exp $
+;;;; $Id: web-server.lisp,v 1.60 2004/07/06 16:33:46 bmastenbrook Exp $
;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -17,29 +17,65 @@
(channel :initarg :channel :initform "" :accessor paste-channel)
(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)))))
+
+(defun find-paste (number)
+ (find number *pastes* :key #'paste-number))
+
(defmacro make-paste (&rest arguments)
`(progn
(funcall 'make-instance 'paste , at arguments)))
-(defclass main-handler (araneida:handler) ())
+(defclass lisppaste-basic-handler (araneida:handler) ())
+
+(defclass main-handler (lisppaste-basic-handler) ())
+
+(defclass css-handler (lisppaste-basic-handler) ())
-(defclass css-handler (araneida:handler) ())
+(defclass new-paste-handler (lisppaste-basic-handler) ())
-(defclass new-paste-handler (araneida:handler) ())
+(defclass list-paste-handler (lisppaste-basic-handler) ())
-(defclass list-paste-handler (araneida:handler) ())
+(defclass submit-paste-handler (lisppaste-basic-handler) ())
-(defclass submit-paste-handler (araneida:handler) ())
+(defclass display-paste-handler (lisppaste-basic-handler) ())
-(defclass display-paste-handler (araneida:handler) ())
+(defclass rss-handler (lisppaste-basic-handler) ())
-(defclass rss-handler (araneida:handler) ())
+(defclass rss-full-handler (lisppaste-basic-handler) ())
-(defclass rss-full-handler (araneida:handler) ())
+(defclass syndication-handler (lisppaste-basic-handler) ())
-(defclass syndication-handler (araneida:handler) ())
+(defclass stats-handler (lisppaste-basic-handler) ())
-(defclass stats-handler (araneida:handler) ())
+(defvar *referer-hash* (make-hash-table :test #'equalp))
+
+(defvar *referer-example-hash* (make-hash-table :test #'equalp))
+
+(defun times-file-for-class (class)
+ (merge-pathnames (format nil "times-~(~A~)"
+ (symbol-name (class-name (class-of class))))
+ (make-pathname
+ :directory
+ (pathname-directory
+ (or *load-truename*
+ *default-pathname-defaults*)))))
+
+(defmethod araneida: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)
+ (time
+ (progn
+ (let ((referer (car (araneida:request-header request :referer)))
+ (araneida::*default-url-defaults* (araneida:request-url request)))
+ (when (stringp referer)
+ (let ((url (araneida:parse-urlstring referer nil)))
+ (when url
+ (incf (gethash (araneida:url-host url) *referer-hash* 0))
+ (setf (gethash (araneida:url-host url) *referer-example-hash*) url)))))
+ (call-next-method)))))
(defmethod araneida:handle-request-response ((handler css-handler) method request)
(let ((colorize:*css-background-class* "paste"))
@@ -86,9 +122,6 @@
, at forms
,@(bottom-links))))
-(defun paste-display-url (paste)
- (araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))
-
(defmethod araneida:handle-request-response ((handler main-handler) method request)
(araneida:request-send-headers request :expires 0)
(araneida:html-stream
@@ -102,13 +135,19 @@
((td :valign top :width "40%")
((div :class "simple-paste-list")
(table
- ,@(loop for i from 1 to 10
+ ,@(loop for i from 1 to 10
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)))))))
+ ((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...")))))))
(p)
((div :class "small-header") "About lisppaste")
((div :class "info-text")
@@ -130,8 +169,12 @@
(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)."))
+ " - a hosting service for projects written in Common Lisp (like this one)."
+ (p)
+ "Please consider "
+ (b ((a :href "https://www.paypal.com/xclick/business=bmastenb%40indiana.edu&item_name=Support+Lisppaste%2C+SBCL/Darwin%2C+etc.&no_shipping=1&no_note=1&tax=0¤cy_code=USD") "supporting Lisppaste development"))
+ " with your contributions. Thanks!"
+ ))
((td :valign top :align right)
((form :method post :action ,(araneida:urlstring *submit-paste-url*))
,(generate-new-paste-form :width 60))))
@@ -216,7 +259,10 @@
(tr
((td :id "main-link")
((a :href ,(araneida:urlstring *paste-external-url*))
- "Main page"))
+ "Main page")
+ " | "
+ ((a :href "https://www.paypal.com/xclick/business=bmastenb%40indiana.edu&item_name=Support+Lisppaste%2C+SBCL/Darwin%2C+etc.&no_shipping=1&no_note=1&tax=0¤cy_code=USD")
+ "Support Lisppaste"))
((td :id "other-links")
((a :href ,(araneida:urlstring *new-paste-url*)) "New paste")
" | "
@@ -239,9 +285,12 @@
(t (format nil "~A~A" (time-delta-primitive delta level) (if ago-p " ago" ""))))))
(defun irc-log-link (utime channel)
- (format nil "http://meme.b9.com/now.html?utime=~A&channel=~A"
- utime
- (string-left-trim "#" channel)))
+ (format nil "http://meme.b9.com/cview.html?utime=~A&channel=~A&start=~A&end=~A#utime_requested"
+ (- utime 5)
+ (string-left-trim "#" channel)
+ #+nil (* 60 60)
+ (- utime (* 60 60))
+ (+ utime (* 60 60))))
(defun first-<-mod (n &rest nums)
(some #'(lambda (n2)
@@ -319,6 +368,25 @@
((span :class "small-header") "Uptime: ")
,(time-delta *boot-time* :ago-p nil :level 3)
(p)
+ ((span :class "small-header") "Most common HTTP referrers:")
+ (p)
+ ((table :class "info-table")
+ ,@(mapcar #'(lambda (pair)
+ `(tr
+ ((th :valign top)
+ ,(car pair))
+ ((td :valign top)
+ ,(cdr pair)
+ ,@(when (gethash (car pair) *referer-example-hash*)
+ `(" " ((a :href ,(araneida:urlstring (gethash (car pair)
+ *referer-example-hash*)))
+ "(Example)"))))))
+ (nreverse
+ (last
+ (sort
+ (loop for count being the hash-values of *referer-hash* using (hash-key host)
+ collect (cons host count)) #'< :key #'cdr) 10))))
+ (p)
((span :class "small-header") "Most popular channels:")
(p)
((table :border 0 :class "info-table")
@@ -534,10 +602,7 @@
(if discriminate-channel (format nil " on channel ~A" discriminate-channel) "")
(mapcar #'(lambda (paste)
(format nil "<item><link>~A</link><pubDate>~A</pubDate><title>\"~A\" by ~A</title><description>~A</description></item>~C~C"
- (concatenate 'string
- (araneida:urlstring
- (araneida:merge-url *display-paste-url*
- (prin1-to-string (paste-number paste)))))
+ (paste-display-url paste)
(date:universal-time-to-rfc-date
(apply #'max
(paste-universal-time paste)
@@ -628,7 +693,8 @@
`("The paste will be announced on the selected channel on " ,(irc:server-name *connection*) ". "))
,@(if annotate
`("This paste will be used to annotate "
- ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number annotate))))) ,(concatenate 'string (paste-title annotate) "."))
+ (b
+ ((a :href ,(paste-display-url annotate)) ,(concatenate 'string (paste-title annotate) ".")))
((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number annotate))))
((input :type hidden :name "channel" :value ,(paste-channel annotate))))))
(p)
@@ -703,11 +769,25 @@
,@(unless (and *no-channel-pastes*
(string-equal channel "none"))
`(", and was also sent to " ,channel " at " ,(irc:server-name *connection*))) ".")
- `((span :class "small-header") "Don't paste more junk; annotate!")
`((form :method post :action ,(araneida:urlstring *new-paste-url*))
((input :type hidden :name "annotate" :value ,(prin1-to-string paste-number)))
- (center ((span :class "controls")
- ((input :type submit :value "Annotate this paste")))))
+ (table
+ (tr
+ (td
+ ((div :class "controls")
+ ((span :class "small-header") "Don't make more pastes; annotate this one!")
+ (br)
+ ((input :type submit :value "Annotate this paste")))))))
+ `(p)
+ `(table
+ (tr
+ (td
+ ((div :class "info-text")
+ ((span :class "small-header") "Donations accepted")
+ (br)
+ "If you appreciate Lisppaste, please consider "
+ (b ((a :href "https://www.paypal.com/xclick/business=bmastenb%40indiana.edu&item_name=Support+Lisppaste%2C+SBCL/Darwin%2C+etc.&no_shipping=1&no_note=1&tax=0¤cy_code=USD") "making a donation"))
+ " to support further development of the service. Thanks!"))))
))))))))
(defun ends-with (str end)
More information about the Lisppaste-cvs
mailing list