[Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/lisppaste.asd lisppaste2/lisppaste.lisp lisppaste2/persistent-pastes.lisp lisppaste2/web-server.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Jul 27 18:47:11 UTC 2004
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)
More information about the Lisppaste-cvs
mailing list