July 2004 - lisppaste-cvs@common-lisp.net

[Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/lisppaste.asd lisppaste2/lisppaste.lisp lisppaste2/persistent-pastes.lisp lisppaste2/web-server.lisp
by Brian Mastenbrook 27 Jul '04

27 Jul '04

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)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/system-server.lisp
by Brian Mastenbrook 15 Jul '04

15 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: system-server.lisp Log Message: Da system server Date: Thu Jul 15 05:37:35 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.asd
by Brian Mastenbrook 08 Jul '04

08 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.asd Log Message: fix the depends so that web-server knows about the specialness of some CSS variable Date: Thu Jul 8 11:01:12 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.14 lisppaste2/lisppaste.asd:1.15 --- lisppaste2/lisppaste.asd:1.14 Thu Jul 8 10:42:26 2004 +++ lisppaste2/lisppaste.asd Thu Jul 8 11:01:11 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.14 2004/07/08 17:42:26 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.15 2004/07/08 18:01:11 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -40,6 +40,7 @@ (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server" - :depends-on ("encode-for-pre" "lisppaste" "colorize-package")) + :depends-on ("encode-for-pre" "lisppaste" "colorize-package" + "coloring-css")) (:file "persistent-pastes" :depends-on ("web-server"))))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/variable.lisp
by Brian Mastenbrook 08 Jul '04

08 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/test/lisppaste2 Modified Files: variable.lisp Log Message: recent paste list Date: Thu Jul 8 10:43:37 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.26 lisppaste2/variable.lisp:1.27 --- lisppaste2/variable.lisp:1.26 Tue Jul 6 09:59:59 2004 +++ lisppaste2/variable.lisp Thu Jul 8 10:43:37 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.26 2004/07/06 16:59:59 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.27 2004/07/08 17:43:37 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -105,6 +105,9 @@ (defparameter *css-url* (araneida:merge-url *paste-external-url* "lisppaste.css")) + +(defparameter *recent-url* + (araneida:merge-url *paste-external-url* "recent")) (defvar *paste-listener* (let ((fwd-url (araneida:copy-url *paste-external-url*)))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by Brian Mastenbrook 08 Jul '04

08 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: recent paste list Date: Thu Jul 8 10:42:40 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.61 lisppaste2/web-server.lisp:1.62 --- lisppaste2/web-server.lisp:1.61 Tue Jul 6 09:58:13 2004 +++ lisppaste2/web-server.lisp Thu Jul 8 10:42:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.61 2004/07/06 16:58:13 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.62 2004/07/08 17:42:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -31,6 +31,8 @@ (defclass main-handler (lisppaste-basic-handler) ()) +(defclass recent-handler (lisppaste-basic-handler) ()) + (defclass css-handler (lisppaste-basic-handler) ()) (defclass new-paste-handler (lisppaste-basic-handler) ()) @@ -118,6 +120,31 @@ ,@forms ,@(bottom-links)))) +(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) + (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 @@ -129,21 +156,7 @@ ((td :align right) ((div :class "small-header") "Make a new paste"))) (tr ((td :valign top :width "40%") - ((div :class "simple-paste-list") - (table - ,@(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))))) - (tr - ((td :colspan 3) - (center - (b - ((a :href ,(araneida:urlstring *list-paste-url*)) - "More recent pastes..."))))))) + ,(recent-paste-list-div) (p) ((div :class "small-header") "About lisppaste") ((div :class "info-text") @@ -168,7 +181,7 @@ " - 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")) + (b ((a :href "https://www.paypal.com/xclick/business=chandler%40iddqd.org&item_name=S…") "supporting Lisppaste development")) " with your contributions. Thanks!" )) ((td :valign top :align right) @@ -257,7 +270,7 @@ ((a :href ,(araneida:urlstring *paste-external-url*)) "Main page") " | " - ((a :href "https://www.paypal.com/xclick/business=bmastenb%40indiana.edu&item_name…") + ((a :href "https://www.paypal.com/xclick/business=chandler%40iddqd.org&item_name=S…") "Support Lisppaste")) ((td :id "other-links") ((a :href ,(araneida:urlstring *new-paste-url*)) "New paste") @@ -381,7 +394,7 @@ (last (sort (loop for count being the hash-values of *referer-hash* using (hash-key host) - collect (cons host count)) #'< :key #'cdr) 10)))) + collect (cons host count)) #'< :key #'cdr) 20)))) (p) ((span :class "small-header") "Most popular channels:") (p) @@ -782,7 +795,7 @@ ((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")) + (b ((a :href "https://www.paypal.com/xclick/business=chandler%40iddqd.org&item_name=S…") "making a donation")) " to support further development of the service. Thanks!")))) )))))))) @@ -1020,3 +1033,8 @@ (araneida:http-listener-handler *paste-listener*) (make-instance 'css-handler) (araneida:urlstring *css-url*) t) + +(araneida:install-handler + (araneida:http-listener-handler *paste-listener*) + (make-instance 'recent-handler) + (araneida:urlstring *recent-url*) t)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/abbrev.lisp lisppaste2/lisppaste.asd lisppaste2/clhs-lookup.lisp
by Brian Mastenbrook 08 Jul '04

08 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.asd clhs-lookup.lisp Added Files: abbrev.lisp Log Message: Abbreviations for CLHS lookup Date: Thu Jul 8 10:42:27 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.13 lisppaste2/lisppaste.asd:1.14 --- lisppaste2/lisppaste.asd:1.13 Thu Jun 17 06:10:04 2004 +++ lisppaste2/lisppaste.asd Thu Jul 8 10:42:26 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.13 2004/06/17 13:10:04 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.14 2004/07/08 17:42:26 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -29,7 +29,8 @@ (:file "colorize-package") (:file "coloring-css" :depends-on ("colorize-package")) (:file "colorize" :depends-on ("colorize-package" "coloring-css")) - (:file "clhs-lookup" :depends-on ("encode-for-pre")) + (:file "abbrev") + (:file "clhs-lookup" :depends-on ("encode-for-pre" "abbrev")) (:file "r5rs-lookup" :depends-on ("encode-for-pre")) (:file "elisp-lookup" :depends-on ("encode-for-pre")) (:file "lisppaste" Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.6 lisppaste2/clhs-lookup.lisp:1.7 --- lisppaste2/clhs-lookup.lisp:1.6 Thu Jun 17 05:59:17 2004 +++ lisppaste2/clhs-lookup.lisp Thu Jul 8 10:42:26 2004 @@ -3,7 +3,7 @@ :spec-lookup)) (in-package :clhs-lookup) -(defparameter *hyperspec-pathname* #p"/home/chandler/public_html/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -16,6 +16,8 @@ (defvar *symbol-table* (make-hash-table :test 'equalp)) +(defvar *abbrev-table* (make-hash-table :test 'equalp)) + (defvar *section-table* (make-hash-table :test 'equalp)) (defvar *format-table* (make-hash-table :test 'equalp)) @@ -43,10 +45,16 @@ (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%") (setf *last-warn-time* (get-universal-time))) (return-from populate-table nil)) - (do ((symbol-name (read-line s nil s) (read-line s nil s)) - (url (read-line s nil s) (read-line s nil s))) - ((eq url s) 'done) - (setf (gethash symbol-name *symbol-table*) (concatenate 'string *hyperspec-root* (subseq url 3)))) + (flet ((set-symbol (sym url) + (setf (gethash sym *symbol-table*) url) + (let ((abbrev (abbrev:abbrev sym))) + (and abbrev + (pushnew sym (gethash abbrev *abbrev-table* nil) + :test #'string-equal))))) + (do ((symbol-name (read-line s nil s) (read-line s nil s)) + (url (read-line s nil s) (read-line s nil s))) + ((eq url s) 'done) + (set-symbol symbol-name (concatenate 'string *hyperspec-root* (subseq url 3))))) ;; add in section references. (let ((*default-pathname-defaults* *hyperspec-pathname*)) ;; Yuk. I know. Fixes welcome. @@ -126,6 +134,17 @@ (setf (gethash (concatenate 'string "MOP:" symbol-name) *symbol-table*) (concatenate 'string *mop-root* url)))) (setf *populated-p* t))) +(defun abbrev-lookup (term) + (let ((abbrevs (gethash term *abbrev-table* nil))) + (if (eql (length abbrevs) 0) + nil + (if (eql (length abbrevs) 1) + (format nil "~A: ~A" + (car abbrevs) + (gethash (car abbrevs) *symbol-table*)) + (format nil "Matches: ~{~A~^ ~}" + abbrevs))))) + (defun spec-lookup (term &key (type :all)) (unless *populated-p* (populate-table)) @@ -133,7 +152,10 @@ (:all (or (gethash term *symbol-table*) (gethash term *section-table*) - (gethash term *format-table*))) + (gethash term *format-table*) + (abbrev-lookup term))) + (:abbrev + (abbrev-lookup term)) (:symbol (gethash term *symbol-table*)) (:section

1 0

[Lisppaste-cvs] CVS update: lisppaste2/variable.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/test/lisppaste2 Modified Files: variable.lisp Log Message: New variable.lisp Date: Tue Jul 6 09:59:59 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.25 lisppaste2/variable.lisp:1.26 --- lisppaste2/variable.lisp:1.25 Tue Jul 6 09:57:56 2004 +++ lisppaste2/variable.lisp Tue Jul 6 09:59:59 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.25 2004/07/06 16:57:56 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.26 2004/07/06 16:59:59 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,12 +23,12 @@ (in-package :lisppaste) -(defparameter *internal-http-port* 8081 +(defparameter *internal-http-port* 8000 "Port lisppaste's araneida will listen on for requests from Apache.") -(defparameter *external-http-port* 80 +(defparameter *external-http-port* 8000 "Port lisppaste's araneida will listen on for requests from remote clients.") -(defparameter *paste-site-name* "paste.lisp.org" +(defparameter *paste-site-name* "localhost" "Website we are running on (used for creating links).") (defparameter *paste-external-url* @@ -37,13 +37,8 @@ :host *paste-site-name* ;;; comment out this next line when running ;;; behind a proxying apache - #| :port *external-http-port* |# - ) "/")) - -(defparameter *old-url* (araneida:merge-url - (araneida:make-url :scheme "http" - :host "www.common-lisp.net") - "/paste/")) + :port *external-http-port* + ) "/paste/")) (defvar *meme-links* t) ; whether to link to meme IRC logs, probably ; only useful for freenode's lisppaste @@ -112,17 +107,13 @@ (araneida:merge-url *paste-external-url* "lisppaste.css")) (defvar *paste-listener* - (let ((fwd-url (araneida:copy-url *paste-external-url*)) - (fwd-old-url (araneida:copy-url *old-url*))) + (let ((fwd-url (araneida:copy-url *paste-external-url*))) (setf (araneida:url-port fwd-url) *internal-http-port*) - (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 :translations `((,(araneida:urlstring *paste-external-url*) - ,(araneida:urlstring fwd-url)) - (,(araneida:urlstring *old-url*) - ,(araneida:urlstring fwd-old-url))) + ,(araneida:urlstring fwd-url))) :address #(0 0 0 0) :port (araneida:url-port fwd-url))))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Make the timing go to the same dir as lisppaste Date: Tue Jul 6 09:58:13 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.60 lisppaste2/web-server.lisp:1.61 --- lisppaste2/web-server.lisp:1.60 Tue Jul 6 09:33:46 2004 +++ lisppaste2/web-server.lisp Tue Jul 6 09:58:13 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.60 2004/07/06 16:33:46 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.61 2004/07/06 16:58:13 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -56,11 +56,7 @@ (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*))))) + *times-file-root*)) (defmethod araneida:handle-request-response :around ((handler lisppaste-basic-handler) method request) (with-open-file (*trace-output* (times-file-for-class handler)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/variable.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: variable.lisp Log Message: Bring it up to date with the running lisppaste, then edit out what I don't need Date: Tue Jul 6 09:57:56 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.24 lisppaste2/variable.lisp:1.25 --- lisppaste2/variable.lisp:1.24 Thu Jun 24 12:52:25 2004 +++ lisppaste2/variable.lisp Tue Jul 6 09:57:56 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.24 2004/06/24 19:52:25 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.25 2004/07/06 16:57:56 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,12 +23,12 @@ (in-package :lisppaste) -(defparameter *internal-http-port* 8000 +(defparameter *internal-http-port* 8081 "Port lisppaste's araneida will listen on for requests from Apache.") -(defparameter *external-http-port* 8000 +(defparameter *external-http-port* 80 "Port lisppaste's araneida will listen on for requests from remote clients.") -(defparameter *paste-site-name* "localhost" +(defparameter *paste-site-name* "paste.lisp.org" "Website we are running on (used for creating links).") (defparameter *paste-external-url* @@ -37,10 +37,15 @@ :host *paste-site-name* ;;; comment out this next line when running ;;; behind a proxying apache - :port *external-http-port* - ) "/paste/")) + #| :port *external-http-port* |# + ) "/")) -(defvar *meme-links* nil) ; whether to link to meme IRC logs, probably +(defparameter *old-url* (araneida:merge-url + (araneida:make-url :scheme "http" + :host "www.common-lisp.net") + "/paste/")) + +(defvar *meme-links* t) ; whether to link to meme IRC logs, probably ; only useful for freenode's lisppaste (defvar *paste-maximum-size* 51200) ; in bytes @@ -53,12 +58,26 @@ ; freenode's lisppaste (defparameter *ban-log-file* - "ban-log") ; where logs of attempts by banned users to paste go + (merge-pathnames "ban-log" + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*))))) + ; where logs of attempts by + ; banned users to paste go (defparameter *event-log-file* - "event-log") ; where normal events are logged + (merge-pathnames "event-log" + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*))))) + ; where normal events are + ; logged -(defparameter *no-channel-pastes* nil) ; whether to allow pastes that +(defparameter *no-channel-pastes* t) ; whether to allow pastes that ; don't get announced on a ; channel @@ -93,22 +112,20 @@ (araneida:merge-url *paste-external-url* "lisppaste.css")) (defvar *paste-listener* - (let ((fwd-url (araneida:copy-url *paste-external-url*))) + (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*) - (make-instance 'araneida:serve-event-reverse-proxy-listener + (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 :translations `((,(araneida:urlstring *paste-external-url*) - ,(araneida:urlstring fwd-url))) + ,(araneida:urlstring fwd-url)) + (,(araneida:urlstring *old-url*) + ,(araneida:urlstring fwd-old-url))) :address #(0 0 0 0) :port (araneida:url-port fwd-url)))) -(defvar *paste-listener* - (make-instance #+sbcl #+sb-thread 'threaded-http-listener - #+sbcl #-sb-thread 'araneida:serve-event-http-listener - #-sbcl 'threaded-http-listener - :address #(127 0 0 1) - :port *internal-http-port*)) - (defvar *default-nickname* "devpaste") (defvar *default-irc-server* "irc.freenode.net") (defvar *default-irc-server-port* 6667) @@ -117,8 +134,21 @@ (defvar *pastes* nil) (defvar *paste-counter* 0) (defvar *connection* nil) -(defvar *channels* nil) +(defvar *channels* '("None")) -(defvar *paste-file* "pastes.lisp-expr") +(defvar *paste-file* + (merge-pathnames "pastes.lisp-expr" + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*))))) + +(defparameter *times-file-root* + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*)))) (defvar *boot-time* 0)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/package.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: package.lisp Log Message: MORE EXPORTS Date: Tue Jul 6 09:34:24 2004 Author: bmastenbrook Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.7 lisppaste2/package.lisp:1.8 --- lisppaste2/package.lisp:1.7 Tue Jun 8 08:23:04 2004 +++ lisppaste2/package.lisp Tue Jul 6 09:34:24 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.7 2004/06/08 15:23:04 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.8 2004/07/06 16:34:24 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -9,6 +9,7 @@ (defpackage :lisppaste (:use :cl #+sbcl :sb-bsd-sockets :html-encode) (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help - :kill-paste :kill-paste-annotations :kill-paste-annotation))) + :kill-paste :kill-paste-annotations :kill-paste-annotation + :display-paste-url :find-paste)))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/colorize.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: colorize.lisp Log Message: use *trace-output* for logging Date: Tue Jul 6 09:34:17 2004 Author: bmastenbrook Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.3 lisppaste2/colorize.lisp:1.4 --- lisppaste2/colorize.lisp:1.3 Fri Jun 11 07:34:34 2004 +++ lisppaste2/colorize.lisp Tue Jul 6 09:34:17 2004 @@ -228,7 +228,7 @@ (if (> current-position (length string)) (return-from scan-string (progn - (format t "Scan was called ~S times.~%" + (format *trace-output* "Scan was called ~S times.~%" *scan-calls*) (finish-current (length string) nil (constantly nil)) result))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

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)

1 0