From bmastenbrook at common-lisp.net Fri May 21 16:42:40 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 21 May 2004 12:42:40 -0400 Subject: [Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp Message-ID: Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Stats page Date: Fri May 21 12:42:39 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.45 lisppaste2/web-server.lisp:1.46 --- lisppaste2/web-server.lisp:1.45 Mon Apr 26 12:45:02 2004 +++ lisppaste2/web-server.lisp Fri May 21 12:42:38 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.45 2004/04/26 16:45:02 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.46 2004/05/21 16:42:38 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -30,6 +30,8 @@ (defclass syndication-handler (araneida:handler) ()) +(defclass stats-handler (araneida:handler) ()) + (defmethod araneida:handle-request-response ((handler new-paste-handler) method request) (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request))) (annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t))) @@ -75,12 +77,12 @@ " | " ((a :href "http://common-lisp.net/project/lisppaste/xml-rpc.html") "XML-RPC") " | " - ((a :href "http://common-lisp.net/project/lisppaste") "lisppaste home page") + ((a :href ,(araneida:urlstring *stats-url*)) "Stats") " | " - "Uptime: " ,(time-delta *boot-time* :ago-p nil))) + ((a :href "http://common-lisp.net/project/lisppaste") "lisppaste home page"))) -(defun time-delta (time &key (level 2) (ago-p t)) - (let ((delta (- (get-universal-time) time))) +(defun time-delta (time &key (level 2) (ago-p t) (origin (get-universal-time))) + (let ((delta (- origin time))) (cond ((< delta 1) "<Doc Brown>From the future...</Doc Brown>") ((< delta (* 60 60)) (format nil "~A~A" (time-delta-primitive delta 1) (if ago-p " ago" ""))) @@ -160,6 +162,85 @@ *channels*)) ,@(bottom-links))))) +(defmethod araneida:handle-request-response ((handler stats-handler) method request) + (araneida:request-send-headers request :expires 0) + (format (araneida:request-stream request) "") + (araneida:html-stream + (araneida:request-stream request) + `(html + (head (title "Statistics") + ,(rss-link-header)) + (body + (h2 "Statistics") + (b "Uptime: ") ,(time-delta *boot-time* :ago-p nil :level 3) + (p) + (b "Most popular channels:") (br) + ((table :border 2) + ,@(mapcar #'(lambda (pair) + `(tr + ((td :valign top) + (tt ,(car pair))) + ((td :valign top) + (tt ,(cdr pair))))) + (sort + (loop for i in *channels* + collect (cons i (count i *pastes* + :key #'paste-channel + :test #'string=))) + #'> :key #'cdr))) + (p) + (b "Average rates of pasting:") (br) + ((table :border 2) + ,@(mapcar #'(lambda (pair) + `(tr + #+(or) (td ,(length (second pair))) + ((td :valign top) + (tt ,(first pair))) + ((td :valign top) + (tt ,(time-delta + 0 :origin + (truncate (/ + (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))))))) + ,@(bottom-links))))) + (defmethod araneida:handle-request-response ((handler list-paste-handler) method request) (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "") @@ -512,3 +593,8 @@ (araneida:http-listener-handler *paste-listener*) (make-instance 'syndication-handler) (araneida:urlstring *syndication-url*) nil) + +(araneida:install-handler + (araneida:http-listener-handler *paste-listener*) + (make-instance 'stats-handler) + (araneida:urlstring *stats-url*) nil) From bmastenbrook at common-lisp.net Fri May 21 19:30:46 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 21 May 2004 15:30:46 -0400 Subject: [Lisppaste-cvs] CVS update: lisppaste2/README.lisp lisppaste2/package.lisp lisppaste2/persistent-pastes.lisp lisppaste2/variable.lisp Message-ID: Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv28257 Modified Files: README.lisp package.lisp persistent-pastes.lisp variable.lisp Log Message: Small bugfixes for non-SBCL Date: Fri May 21 15:30:46 2004 Author: bmastenbrook Index: lisppaste2/README.lisp diff -u lisppaste2/README.lisp:1.4 lisppaste2/README.lisp:1.5 --- lisppaste2/README.lisp:1.4 Tue Feb 3 22:03:09 2004 +++ lisppaste2/README.lisp Fri May 21 15:30:45 2004 @@ -1,4 +1,4 @@ -;;;; $Id: README.lisp,v 1.4 2004/02/04 03:03:09 bmastenbrook Exp $ +;;;; $Id: README.lisp,v 1.5 2004/05/21 19:30:45 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/README.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,7 +23,7 @@ ;;; follows, or simply (load "README"). (require :asdf) -(require :lisppaste) +(asdf:operate 'asdf:load-op :lisppaste) (lisppaste:start-lisppaste :channels '("#lisppaste") :nickname (format nil Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.3 lisppaste2/package.lisp:1.4 --- lisppaste2/package.lisp:1.3 Tue Apr 27 17:03:21 2004 +++ lisppaste2/package.lisp Fri May 21 15:30:45 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.3 2004/04/27 21:03:21 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.4 2004/05/21 19:30:45 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -7,7 +7,7 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste - (:use :cl :sb-bsd-sockets) + (:use :cl #+sbcl :sb-bsd-sockets) (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.8 lisppaste2/persistent-pastes.lisp:1.9 --- lisppaste2/persistent-pastes.lisp:1.8 Tue Apr 27 17:47:32 2004 +++ lisppaste2/persistent-pastes.lisp Fri May 21 15:30:45 2004 @@ -24,13 +24,15 @@ (defun save-pastes-to-file (file-name) (let ((*package* (find-package :lisppaste))) - (with-open-file (file file-name :direction :output :if-exists :supersede) + (with-open-file (file file-name :direction :output :if-exists :supersede + :if-does-not-exist :create) (let ((*print-readably* t)) (format file "~{~S~%~}" (mapcan #'paste-list-alist (reverse *pastes*))))))) (defun serialize-transaction (file-name paste &optional annotate-number) (let ((*package* (find-package :lisppaste))) - (with-open-file (file file-name :direction :output :if-exists :append) + (with-open-file (file file-name :direction :output :if-exists :append + :if-does-not-exist :create) (let ((*print-readably* t)) (if annotate-number (format file "~S~%" (serialized-annotation annotate-number paste)) Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.13 lisppaste2/variable.lisp:1.14 --- lisppaste2/variable.lisp:1.13 Thu Mar 11 09:21:34 2004 +++ lisppaste2/variable.lisp Fri May 21 15:30:45 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.13 2004/03/11 14:21:34 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.14 2004/05/21 19:30:45 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -51,10 +51,14 @@ (defparameter *syndication-url* (araneida:merge-url *paste-external-url* "syndication")) +(defparameter *stats-url* + (araneida:merge-url *paste-external-url* "stats")) + (defvar *paste-listener* (let ((fwd-url (araneida:copy-url *paste-url*))) (setf (araneida:url-port fwd-url) *internal-http-port*) - (make-instance 'araneida:serve-event-reverse-proxy-listener + (make-instance #+sbcl 'araneida:serve-event-reverse-proxy-listener + #-sbcl 'araneida:threaded-reverse-proxy-listener :translations `((,(araneida:urlstring *paste-url*) ,(araneida:urlstring fwd-url))) From bmastenbrook at common-lisp.net Fri May 21 21:29:11 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 21 May 2004 17:29:11 -0400 Subject: [Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp Message-ID: Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: pagination (woot!) Date: Fri May 21 17:29:11 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.46 lisppaste2/web-server.lisp:1.47 --- lisppaste2/web-server.lisp:1.46 Fri May 21 12:42:38 2004 +++ lisppaste2/web-server.lisp Fri May 21 17:29:11 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.46 2004/05/21 16:42:38 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.47 2004/05/21 21:29:11 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -36,16 +36,18 @@ (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request))) (annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t))) (annotate (if annotate-number (find annotate-number *pastes* :key #'paste-number))) - (default-channel (find-if #'(lambda (e) (> (length e) 1)) - (list - (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) - (concatenate 'string "#" - (araneida:request-cookie request "CHANNEL")) - (and (eql method :post) - (araneida:body-param "channel" - (araneida:request-body request))))))) + (default-channel + (or (and annotate (paste-channel annotate)) + (find-if #'(lambda (e) (> (length e) 1)) + (list + (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) + (concatenate 'string "#" + (araneida:request-cookie request "CHANNEL")) + (and (eql method :post) + (araneida:body-param "channel" + (araneida:request-body request)))))))) (cond - ((and default-channel (find default-channel *channels* :test #'string=)) + ((and default-channel (find default-channel *channels* :test #'string=)) (araneida:request-send-headers request :expires 0 :set-cookie (format nil "CHANNEL=~A; path=/" (subseq default-channel 1))) (new-paste-form request :annotate annotate :default-channel default-channel)) (t (araneida:request-send-headers request :expires 0) @@ -58,6 +60,7 @@ (body (h2 "Select a channel") ((form :method post :action ,(araneida:urlstring *new-paste-url*)) + ((input :type "hidden" :name "annotate" :value ,annotate-string)) "Please select a channel to lisppaste to: " ((select :name "channel") ((option :value "")) @@ -244,69 +247,120 @@ (defmethod araneida:handle-request-response ((handler list-paste-handler) method request) (araneida:request-send-headers request :expires 0) (format (araneida:request-stream request) "") - (let ((discriminate-channel (or - (araneida:body-param "channel" (araneida:request-body request)) - (if (not (string= (araneida::request-unhandled-part request) "")) - (substitute #\# #\/ (araneida::request-unhandled-part request) - :test #'char=))))) - (if (string-equal discriminate-channel "allchannels") - (setf discriminate-channel nil)) - (araneida:html-stream - (araneida:request-stream request) - `(html - (head (title "All pastes") - ,(rss-link-header)) - (body - (center (h2 ,(if discriminate-channel - (format nil "All pastes in channel ~A" discriminate-channel) - "All pastes in system"))) - ,@(if discriminate-channel - (if (not (member discriminate-channel *channels* :test #'string-equal)) - `(((h2) ((font :color "red") ,(format nil "Warning: no channel named ~A found!" - discriminate-channel)))))) - (center - ((form :method post :action ,(araneida:urlstring *list-paste-url*)) - (table - (tr ((td :align left) "View only: ") - ((td :valign top) - ((select :name "channel") - ((option :value "allchannels") "All channels") - ,@(mapcar #'(lambda (e) - `((option :value ,e ,@(if (and discriminate-channel - (string-equal e discriminate-channel)) - '(:selected))) - ,(encode-for-pre e))) *channels*))) - ((td :valign top) - ((input :type submit :value "Submit")))) - (tr ((td :align left) - ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: ")) - ((td :align center) - ((a :href ,(concatenate 'string - (araneida:urlstring *rss-url*) - (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Basic") - " | " - ((a :href ,(concatenate 'string - (araneida:urlstring *rss-full-url*) - (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Full")) - (td))))) - (p) - ((table :width "100%" :cellpadding 2) - (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann.")) - ,@(mapcar #'(lambda (paste) - `(tr ((td :nowrap "nowrap") ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) - ,(concatenate 'string "#" (prin1-to-string (paste-number paste))))) - ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12))) - ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste))) - ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil)) - ((td :width "100%" :bgcolor "#F4F4F4" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50))) - ((td :nowrap "nowrap") ,(length (paste-annotations paste))))) - (if discriminate-channel - (remove discriminate-channel *pastes* :test-not #'string-equal - :key #'paste-channel) - *pastes*))) - ,@(bottom-links)))))) + (flet ((page-url (discriminate-channel i) + (araneida:urlstring + (let ((url (araneida:copy-url *list-paste-url*))) + (if discriminate-channel + (setf (araneida:url-path url) + (concatenate 'string + (araneida:url-path url) + "/"))) + (araneida:merge-url + url + (format nil "~A?~A" + (if discriminate-channel + (subseq discriminate-channel 1) "") + i)))))) + (destructuring-bind + (channel &rest others) (split-sequence:split-sequence + #\? + (araneida::request-unhandled-part request)) + (let* ((discriminate-channel (or + (araneida:body-param "channel" (araneida:request-body request)) + (if (not (string= channel "")) + (substitute #\# #\/ channel + :test #'char=)))) + (discriminate-channel + (if (string-equal discriminate-channel "allchannels") + nil discriminate-channel)) + (page (if others + (parse-integer (car others) :junk-allowed t) 0)) + (discriminated-pastes + (if discriminate-channel + (remove discriminate-channel *pastes* :test-not #'string-equal + :key #'paste-channel) + *pastes*)) + (highest-page (floor (/ (- (length discriminated-pastes) 1) + *pastes-per-page*))) + (page-links + `(,@(if (> page 0) + `(((a :href ,(page-url discriminate-channel (1- page))) + "Newer <") " ")) + ,@(loop for i from 0 to highest-page + appending + `(,(if (not (eql i page)) + `((a :href ,(page-url discriminate-channel i)) + ,(1+ i)) + (1+ i)) ,@(if (eql i highest-page) + nil + '(" ")))) + ,@(if (< page highest-page) + `(((a :href ,(page-url discriminate-channel (1+ page))) + "> Older")))))) + (araneida:html-stream + (araneida:request-stream request) + `(html + (head (title "All pastes") + ,(rss-link-header)) + (body + (center (h2 ,(if discriminate-channel + (format nil "All pastes in channel ~A" discriminate-channel) + "All pastes in system"))) + ,@(if discriminate-channel + (if (not (member discriminate-channel *channels* :test #'string-equal)) + `(((h2) ((font :color "red") ,(format nil "Warning: no channel named ~A found!" + discriminate-channel)))))) + (center + ((form :method post :action ,(araneida:urlstring *list-paste-url*)) + (table + (tr ((td :align left) "View only: ") + ((td :valign top) + ((select :name "channel") + ((option :value "allchannels") "All channels") + ,@(mapcar #'(lambda (e) + `((option :value ,e ,@(if (and discriminate-channel + (string-equal e discriminate-channel)) + '(:selected))) + ,(encode-for-pre e))) *channels*))) + ((td :valign top) + ((input :type submit :value "Submit")))) + (tr ((td :align left) + ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: ")) + ((td :align center) + ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + (if discriminate-channel + (substitute #\? #\# discriminate-channel) ""))) "Basic") + " | " + ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + (if discriminate-channel + (substitute #\? #\# discriminate-channel) ""))) "Full")) + (td)) + (tr ((td :align left) + "Page: ") + ((td :align center) + , at page-links)) + ))) + (p) + ((table :width "100%" :cellpadding 2) + (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann.")) + ,@(mapcar #'(lambda (paste) + `(tr ((td :nowrap "nowrap") ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) + ,(concatenate 'string "#" (prin1-to-string (paste-number paste))))) + ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12))) + ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste))) + ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil)) + ((td :width "100%" :bgcolor "#F4F4F4" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50))) + ((td :nowrap "nowrap") ,(length (paste-annotations paste))))) + (loop for i from 0 + to (- (* (1+ page) *pastes-per-page*) 1) + for j in discriminated-pastes + if (>= i (* page *pastes-per-page*)) + collect j))) + (center + "Page: " , at page-links) + ,@(bottom-links)))))))) (defun handle-rss-request (request &key full) (araneida:request-send-headers request :expires 0 :content-type "application/rss+xml") @@ -361,7 +415,7 @@ (defmethod araneida:handle-request-response ((handler rss-full-handler) method request) (handle-rss-request request :full t)) -(defun new-paste-form (request &key (message "") (annotate nil) (default-channel "")) +(defun new-paste-form (request &key (message "") (annotate nil) (default-channel "") (default-user "") (default-title "") (default-contents "")) (format (araneida:request-stream request) "") (araneida:html-stream (araneida:request-stream request) @@ -392,41 +446,48 @@ ,(encode-for-pre e))) *channels*)))))) (tr (th "Enter your username:") - (td ((input :type text :name "username")))) + (td ((input :type text :name "username" + :value ,(encode-for-pre default-user))))) (tr (th "Enter a title:") - (td ((input :type text :name "title")))) + (td ((input :type text :name "title" + :value ,(encode-for-pre default-title))))) (tr ((th :valign top) "Enter your paste:") - (td ((textarea :rows 24 :cols 80 :name "text")))) + (td ((textarea :rows 24 :cols 80 :name "text") + ,(encode-for-pre default-contents)))) (tr ((th) "Submit your paste:") ((td) ((input :type submit :value "Submit paste")) " " ((input :type reset :value "Clear paste")))))) ,@(bottom-links))))) (defmethod araneida:handle-request-response ((handler submit-paste-handler) method request) - (let ((username (araneida:body-param "username" (araneida:request-body request))) - (title (araneida:body-param "title" (araneida:request-body request))) - (text (araneida:body-param "text" (araneida:request-body request))) - (annotate (araneida:body-param "annotate" (araneida:request-body request))) - (channel (araneida:body-param "channel" (araneida:request-body request)))) + (let* ((username (araneida:body-param "username" (araneida:request-body request))) + (title (araneida:body-param "title" (araneida:request-body request))) + (text (araneida:body-param "text" (araneida:request-body request))) + (annotate (araneida:body-param "annotate" (araneida:request-body request))) + (annotate-number (if annotate (parse-integer annotate :junk-allowed t))) + (annotate-paste (if annotate-number (find annotate-number *pastes* :key #'paste-number))) + (channel (araneida:body-param "channel" (araneida:request-body request)))) (if (> (length channel) 1) (araneida:request-send-headers request :expires 0 :set-cookie (format nil "CHANNEL=~A; path=/" (subseq channel 1))) - (araneida:request-send-headers request :expires 0)) + (araneida:request-send-headers request :expires 0)) (cond + ((> (length text) *paste-maximum-size*) + (new-paste-form request :message "Paste too large." :default-channel channel :annotate annotate-paste :default-user username :default-title title)) ((zerop (length channel)) - (new-paste-form request :message "Please select a channel." :default-channel channel)) + (new-paste-form request :message "Please select a channel." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) ((zerop (length username)) - (new-paste-form request :message "Please enter your username." :default-channel channel)) + (new-paste-form request :message "Please enter your username." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) ((zerop (length title)) - (new-paste-form request :message "Please enter a title." :default-channel channel)) + (new-paste-form request :message "Please enter a title." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) ((zerop (length text)) - (new-paste-form request :message "Please enter your paste." :default-channel channel)) - ((and annotate (not (parse-integer annotate :junk-allowed t))) - (new-paste-form request :message "Malformed annotation request." :default-channel channel)) + (new-paste-form request :message "Please enter your paste." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) + ((and annotate (not annotate-paste)) + (new-paste-form request :message "Malformed annotation request." :default-channel channel :default-user username :default-title title :default-contents text)) ((not (member channel *channels* :test #'string-equal)) - (new-paste-form request :message "Whatever channel that is, I don't know about it." :default-channel channel)) + (new-paste-form request :message "Whatever channel that is, I don't know about it." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) (t (let* ((paste-number (if annotate (parse-integer annotate :junk-allowed t) (incf *paste-counter*))) (paste-to-annotate (if annotate (find paste-number *pastes* :key #'paste-number))) From bmastenbrook at common-lisp.net Fri May 21 21:29:22 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 21 May 2004 17:29:22 -0400 Subject: [Lisppaste-cvs] CVS update: lisppaste2/xml-paste.lisp Message-ID: Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: xml-paste.lisp Log Message: paste maximum size Date: Fri May 21 17:29:22 2004 Author: bmastenbrook Index: lisppaste2/xml-paste.lisp diff -u lisppaste2/xml-paste.lisp:1.4 lisppaste2/xml-paste.lisp:1.5 --- lisppaste2/xml-paste.lisp:1.4 Tue Apr 27 17:47:32 2004 +++ lisppaste2/xml-paste.lisp Fri May 21 17:29:22 2004 @@ -25,34 +25,37 @@ "Error: all arguments must be strings." (if (not (every (lambda (s) (> (length s) 0)) (list paste-channel paste-user paste-title paste-contents))) "Error: all arguments must be non-empty strings." - (let ((annotate-this (if annotate (find annotate *pastes* :key #'paste-number))) - (paste-contents (remove #\return paste-contents))) - (if (if annotate - (not (string-equal paste-channel (paste-channel annotate-this))) - (not (member paste-channel *channels* :test #'string-equal))) - (format nil "Error: invalid channel ~S." paste-channel) - (let* ((number (if annotate - (incf (paste-annotation-counter annotate-this)) - (incf *paste-counter*))) - (url (araneida:urlstring - (araneida:merge-url *display-paste-url* - (if annotate - (format nil "~A#~A" - (paste-number annotate-this) - number) - (prin1-to-string number)))))) - (make-new-paste *pastes* (annotate - (paste-number annotate-this) - (paste-annotations annotate-this)) - url - :number number - :user paste-user - :title paste-title - :contents paste-contents - :universal-time (get-universal-time) - :channel paste-channel) - (format nil "Your paste has been announced to ~A and is available at ~A ." - paste-channel url)))))))) + (if (> (length paste-contents) + *paste-maximum-size*) + "Error: paste too large." + (let ((annotate-this (if annotate (find annotate *pastes* :key #'paste-number))) + (paste-contents (remove #\return paste-contents))) + (if (if annotate + (not (string-equal paste-channel (paste-channel annotate-this))) + (not (member paste-channel *channels* :test #'string-equal))) + (format nil "Error: invalid channel ~S." paste-channel) + (let* ((number (if annotate + (incf (paste-annotation-counter annotate-this)) + (incf *paste-counter*))) + (url (araneida:urlstring + (araneida:merge-url *display-paste-url* + (if annotate + (format nil "~A#~A" + (paste-number annotate-this) + number) + (prin1-to-string number)))))) + (make-new-paste *pastes* (annotate + (paste-number annotate-this) + (paste-annotations annotate-this)) + url + :number number + :user paste-user + :title paste-title + :contents paste-contents + :universal-time (get-universal-time) + :channel paste-channel) + (format nil "Your paste has been announced to ~A and is available at ~A ." + paste-channel url))))))))) ((string-equal method-name "pasteheaders") (destructuring-bind (length &optional supplied-start) args From bmastenbrook at common-lisp.net Fri May 21 22:11:09 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 21 May 2004 18:11:09 -0400 Subject: [Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.lisp Message-ID: Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: encode-for-pre.lisp Log Message: Thanks much to Xach for a rewrite Date: Fri May 21 18:11:09 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.13 lisppaste2/encode-for-pre.lisp:1.14 --- lisppaste2/encode-for-pre.lisp:1.13 Wed Mar 31 16:33:07 2004 +++ lisppaste2/encode-for-pre.lisp Fri May 21 18:11:09 2004 @@ -1,53 +1,70 @@ -;;;; $Id: encode-for-pre.lisp,v 1.13 2004/03/31 21:33:07 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.14 2004/05/21 22:11:09 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) -(defun replace-in-string-1 (str char repstr &optional only-in-dup) - (let* ((new-length (loop for i from 0 to (1- (length str)) - summing (if (not only-in-dup) - (if (char= (elt str i) char) - (length repstr) 1) - (if (> i 0) - (if (and (member (elt str (1- i)) only-in-dup :test #'char=) - (char= (elt str i) char)) - (length repstr) 1) 1)))) - (new-array (make-array `(,new-length) :element-type 'character))) - (loop for i from 0 to (1- (length str)) - with j = 0 - do (if (if only-in-dup - (and (> i 0) (char= (elt str i) char) - (member (elt str (1- i)) - only-in-dup :test #'char=)) - (char= (elt str i) char)) - (progn - (loop for k from 0 to (1- (length repstr)) - do (setf (elt new-array (+ j k)) (elt repstr k))) - (incf j (length repstr))) - (progn - (setf (elt new-array j) (elt str i)) - (incf j)))) - new-array)) - -(defun replace-in-string (str chars repstrs) - (declare (type string str)) - (let ((stri str)) - (loop for char in chars for repstr in repstrs do - (setf stri (replace-in-string-1 stri char repstr))) - stri)) - -(defun encode-for-pre (str) - (replace-in-string str '(#\& #\< #\>) '("&" "<" ">"))) - -(defun replace-first-space (str) - (if (char= (elt str 0) #\space) - (concatenate 'string " " (subseq str 1)) - str)) - -(defun encode-for-tt (str) - (replace-first-space (replace-in-string-1 (replace-in-string str '(#\& #\< #\> #\newline #\return #\linefeed #\tab) '("&" "<" ">" "
" "" "" " ")) #\space " " '(#\space #\>)))) - -(defun encode-for-http (str) - (replace-in-string-1 str #\> (format nil ">~%") nil)) +(defun encode-for-tt (string) + (let ((pos 0) (end (length string)) + (char nil)) + (flet ((next-char () + (setf char (when (> end pos) + (prog1 + (schar string pos) + (incf pos)))))) + (with-output-to-string (out) + (block nil + (tagbody + escape-spaces + (next-char) + (when (eql char #\Space) + (write-string " " out) + (go escape-spaces)) + process-char + (case char + ((nil) (return)) + ((#\Newline) + (write-string "
" out) + (go escape-spaces)) + ((#\&) + (write-string "&" out)) + ((#\<) + (write-string "<" out)) + ((#\>) + (write-string ">" out)) + ((#\Tab) + (write-string " " out)) + ((#\Space) + (write-char #\Space out) + (go escape-spaces)) + ((#\Linefeed #\Return)) + (t + (write-char char out))) + (next-char) + (go process-char))))))) + + +(defun encode-for-pre (string) + (declare (simple-string string)) + (let ((output (make-array (truncate (length string) 2/3) + :element-type 'character + :adjustable t + :fill-pointer 0))) + (with-output-to-string (out output) + (loop for char across string + do (case char + ((#\&) (write-string "&" out)) + ((#\<) (write-string "<" out)) + ((#\>) (write-string ">" out)) + (t (write-char char out))))) + (coerce output 'simple-string))) + + +(defun encode-for-http (string) + (declare (simple-string string)) + (with-output-to-string (out) + (loop for char across string + do (write-char char out) + when (char= char #\>) + do (write-char #\Newline out))))