Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2

Modified Files: README.lisp lisppaste.asd lisppaste.lisp persistent-pastes.lisp web-server.lisp Log Message: Don't remember

Date: Tue Jul 27 11:47:11 2004 Author: bmastenbrook

Index: lisppaste2/README.lisp diff -u lisppaste2/README.lisp:1.9 lisppaste2/README.lisp:1.10 --- lisppaste2/README.lisp:1.9 Thu Jul 15 05:36:49 2004 +++ lisppaste2/README.lisp Tue Jul 27 11:47:10 2004 @@ -1,4 +1,4 @@ -;;;; $Id: README.lisp,v 1.9 2004/07/15 12:36:49 bmastenbrook Exp $ +;;;; $Id: README.lisp,v 1.10 2004/07/27 18:47:10 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/README.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -24,10 +24,8 @@

(require :asdf) (asdf:operate 'asdf:load-op :lisppaste) -(asdf:operate 'asdf:load-op :xml-rpc)

-(load "xml-paste") -(s-xml-rpc:start-xml-rpc-server :port 8185) +(ignore-errors (s-xml-rpc:start-xml-rpc-server :port 8185))

(lisppaste:start-lisppaste :channels '("#lisp" "#scheme" "#clhs" "#opendarwin" "#macdev" "#fink" "#jedit" "#dylan" "#emacs" "#xemacs" "#colloquy" "#adium" "#growl") :nickname "lisppaste"

Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.16 lisppaste2/lisppaste.asd:1.17 --- lisppaste2/lisppaste.asd:1.16 Thu Jul 15 05:36:49 2004 +++ lisppaste2/lisppaste.asd Tue Jul 27 11:47:10 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.16 2004/07/15 12:36:49 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.17 2004/07/27 18:47:10 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $

;;;; See the LICENSE file for licensing information. @@ -42,6 +42,7 @@ (:file "web-server" :depends-on ("encode-for-pre" "lisppaste" "colorize-package" + "colorize" "coloring-css")) (:file "system-server" :depends-on ("variable" "encode-for-pre"

Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.23 lisppaste2/lisppaste.lisp:1.24 --- lisppaste2/lisppaste.lisp:1.23 Thu Jul 15 05:36:49 2004 +++ lisppaste2/lisppaste.lisp Tue Jul 27 11:47:10 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.23 2004/07/15 12:36:49 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.24 2004/07/27 18:47:10 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -55,7 +55,7 @@ (setf *channels* channels) (if *no-channel-pastes* (pushnew "None" *channels* :test #'string-equal)) - (read-pastes-from-file *paste-file*) + (read-xml-pastes) (format t "Populating lookup table...~%") (clhs-lookup:populate-table) (r5rs-lookup:populate-table)

Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.12 lisppaste2/persistent-pastes.lisp:1.13 --- lisppaste2/persistent-pastes.lisp:1.12 Thu Jul 15 05:36:49 2004 +++ lisppaste2/persistent-pastes.lisp Tue Jul 27 11:47:10 2004 @@ -94,7 +94,7 @@ :type "xml" :defaults *paste-path*)) #'< :key #'(lambda (e) - (parse-integer (pathname-name e) :Junk-allowed t))))) + (parse-integer (pathname-name e) :junk-allowed t)))))

(defun write-all-xml-pastes ()

Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.63 lisppaste2/web-server.lisp:1.64 --- lisppaste2/web-server.lisp:1.63 Thu Jul 15 05:36:49 2004 +++ lisppaste2/web-server.lisp Tue Jul 27 11:47:11 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.63 2004/07/15 12:36:49 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.64 2004/07/27 18:47:11 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -88,6 +88,9 @@ table.info-table { border-collapse: collapse; border : 1px solid #AAA ; background-color: #F9E9F9; empty-cells: hide; } table.info-table td { border : 1px dotted #AAA; background-color: transparent; padding-left: 2em; padding-right: 2em; } table.info-table th { border : 1px dotted #AAA; background-color: transparent; text-align: left; padding-right: 1em; } +table.rate-table { border-collapse: collapse; border : 1px solid #AAA ; background-color: #F9E9F9; empty-cells: hide; } +table.rate-table td { border : 1px dotted #AAA; background-color: transparent; padding: 2pt; } +table.rate-table th { border : 1px dotted #AAA; background-color: transparent; text-align: left; padding: 1pt; } .new-paste-form { background-color : #FFE9E9 ; border: 2px solid #D99; padding : 4px; } .paste-header { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-bottom : 4px; } .info-text { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-top : 4px; text-align: justify; } @@ -378,6 +381,41 @@ append)) "Full"))))) *channels*)))))

+(defun encode-beginning-of-month (month year &key next-month) + (if next-month + (encode-beginning-of-month (if (eql month 12) 1 (1+ month)) + (if (eql month 12) (1+ year) year)) + (encode-universal-time 0 0 0 1 month year))) + +(defun mix-red-green (n) + (format nil "#~2,'0X~2,'0X00" + (truncate (* (- 1 n) #xAA)) + (truncate (* n #xAA)))) + +(defun paste-rate-divs () + (let* ((rates (loop for i in (reverse *pastes*) + for count from 1 + with j = (paste-universal-time (car (last *pastes*))) + with time = 0 + appending (when (>= (- (paste-universal-time i) + (* 60 60 24 7)) + j) + (setf j (paste-universal-time i)) + (incf time (* 60 60 24 7)) + `( + ,(/ count time))))) + (min-rate (loop for i in rates minimizing i)) + (max-rate (loop for i in rates maximizing i))) + (when (> max-rate min-rate) + (loop for i in rates + for rate = (/ (- i min-rate) (- max-rate min-rate)) + appending `(((div :style + ,(format nil "height: 1ex; padding: 0pt; margin: 2pt; background-color: ~A; width: ~A%;" + (mix-red-green rate) + (truncate (+ 10 (* 90 rate)))) + ))))))) + + (defmethod araneida:handle-request-response ((handler stats-handler) method request) (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") @@ -425,7 +463,7 @@ #'> :key #'cdr))) (p) ((span :class "small-header") "Average rates of pasting:") (p) - ((table :border 0 :class "info-table") + ((table :class "info-table") ,@(mapcar #'(lambda (pair) `(tr #+(or) (td ,(length (second pair))) @@ -438,42 +476,117 @@ (third pair) (length (second pair)))) :ago-p nil) " between pastes"))) - (list* - (list "Overall" *pastes* (- (paste-universal-time (first *pastes*)) - (paste-universal-time (car (last *pastes*))))) - (list "Last 30 days" - (remove-if #'(lambda (e) - (< (paste-universal-time e) - (- (get-universal-time) - (* 60 60 24 30)))) - *pastes*) - (* 60 60 24 30)) - (list "Last week" - (remove-if #'(lambda (e) - (< (paste-universal-time e) - (- (get-universal-time) - (* 60 60 24 7)))) - *pastes*) - (* 60 60 24 7)) - (list "Last day" - (remove-if #'(lambda (e) - (< (paste-universal-time e) - (- (get-universal-time) - (* 60 60 24)))) - *pastes*) - (* 60 60 24)) - (sort - (loop for i in *channels* - if (find i *pastes* :key #'paste-channel - :test #'string=) - collect (let ((p (remove i *pastes* - :key #'paste-channel - :test-not #'string=))) - (list (format nil "In ~A" i) - p - (- (paste-universal-time (first p)) - (paste-universal-time (car (last p))))))) - #'> :key #'(lambda (e) (length (second e))))))) + (list* + (list "Overall" *pastes* (- (get-universal-time) + (paste-universal-time (car (last *pastes*))))) + (list "Last 30 days" + (remove-if #'(lambda (e) + (< (paste-universal-time e) + (- (get-universal-time) + (* 60 60 24 30)))) + *pastes*) + (* 60 60 24 30)) + (list "Last week" + (remove-if #'(lambda (e) + (< (paste-universal-time e) + (- (get-universal-time) + (* 60 60 24 7)))) + *pastes*) + (* 60 60 24 7)) + (list "Last day" + (remove-if #'(lambda (e) + (< (paste-universal-time e) + (- (get-universal-time) + (* 60 60 24)))) + *pastes*) + (* 60 60 24)) + (sort + (loop for i in *channels* + if (find i *pastes* :key #'paste-channel + :test #'string=) + collect (let ((p (remove i *pastes* + :key #'paste-channel + :test-not #'string=))) + (list (format nil "In ~A" i) + p + (- (get-universal-time) + (paste-universal-time (car (last p))))))) + #'< :key #'(lambda (pair) + (truncate (/ + (third pair) + (length (second pair))))))) + )) + (p) + ((span :class "small-header") "Trends in paste rates:") (p) + ((table :class "rate-table") + ,@(let ((first-paste (car (last *pastes*))) + (this-year (date:with-date (get-universal-time) nil date:year)) + (this-month (date:with-date (get-universal-time) nil date:month))) + `((tr + (th) + ,@(date:with-date + (paste-universal-time first-paste) nil + (loop for year from date:year to this-year + appending + (loop for month from (if (eql year date:year) + date:month + 1) + to (if (eql year this-year) + this-month + 12) + collecting + `((td :nowrap "NOWRAP") + (b + ,(format nil "~/date:monthname/ ~A" month year))))))) + (tr + (th "Count:") + ,@(date:with-date + (paste-universal-time first-paste) nil + (loop for year from date:year to this-year + appending + (loop for month from (if (eql year date:year) + date:month + 1) + to (if (eql year this-year) + this-month + 12) + collecting + `(td + ,(format nil "~A" + (count-if #'(lambda (e) + (<= (encode-beginning-of-month month year) + (paste-universal-time e) + (encode-beginning-of-month month year :next-month t))) *pastes*))))))) + (tr + ((th :nowrap "NOWRAP") "Total avg. rate per month:") + ,@(date:with-date + (paste-universal-time first-paste) nil + (loop for year from date:year to this-year + appending + (loop for month from (if (eql year date:year) + date:month + 1) + for count from 1 + to (if (eql year this-year) + this-month + 12) + collecting + `(td + ,(let ((ml (count-if #'(lambda (e) + (<= + (paste-universal-time e) + (encode-beginning-of-month month year :next-month t))) *pastes*))) + (format nil "~,2F" + (/ ml (if (eql month this-month) + (+ (1- count) + (/ (- (get-universal-time) + (encode-beginning-of-month this-month this-year)) + (- (encode-beginning-of-month this-month this-year :next-month t) + (encode-beginning-of-month this-month this-year)))) + count)))))))))))) + (p) + ((span :class "small-header") "Rise in overall pasting rate by week:") (p) + ,@(paste-rate-divs) ))))

(defmethod araneida:handle-request-response ((handler list-paste-handler) method request)