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 ,@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 @@ ,@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=...") "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")) ((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=~..." + (- 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=...") "making a donation")) + " to support further development of the service. Thanks!")))) ))))))))

(defun ends-with (str end)