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

[Lisppaste-cvs] CVS update: lisppaste2/xml-paste.lisp lisppaste2/persistent-pastes.lisp
by Brian Mastenbrook 27 Apr '04

27 Apr '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: xml-paste.lisp persistent-pastes.lisp Log Message: Remove evil ^Ms Date: Tue Apr 27 17:47:33 2004 Author: bmastenbrook Index: lisppaste2/xml-paste.lisp diff -u lisppaste2/xml-paste.lisp:1.3 lisppaste2/xml-paste.lisp:1.4 --- lisppaste2/xml-paste.lisp:1.3 Tue Apr 27 17:03:21 2004 +++ lisppaste2/xml-paste.lisp Tue Apr 27 17:47:32 2004 @@ -1,7 +1,7 @@ (in-package :lisppaste) (defun paste-xml-list (paste &optional contents) - (format t "collecting paste number ~A~%" (paste-number paste)) +; (format t "collecting paste number ~A~%" (paste-number paste)) (list* (paste-number paste) (xml-rpc:xml-rpc-time (paste-universal-time paste)) (paste-user paste) @@ -9,10 +9,11 @@ (paste-title paste) (length (paste-annotations paste)) (if contents - (list (paste-contents paste))))) + (list (remove #\return (paste-contents paste)))))) (setf xml-rpc:*xml-rpc-call-hook* (lambda (method-name &rest args) + (format t "Handling XML-RPC request for ~S ~{~S~^ ~}~%" method-name args) (block hook (handler-bind ((condition #'(lambda (c) (return-from hook @@ -24,7 +25,8 @@ "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)))) + (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))) @@ -53,36 +55,34 @@ paste-channel url)))))))) ((string-equal method-name "pasteheaders") (destructuring-bind - (length &optional (start (paste-number (car *pastes*)))) args - (format t "args is ~A~%" args) - (mapcar #'paste-xml-list - (loop for i from 1 to length - for j in (member start *pastes* :key #'paste-number) - collect j)))) + (length &optional supplied-start) args + (let ((start (or supplied-start (paste-number (car *pastes*))))) + (mapcar #'paste-xml-list + (loop for i from 1 to length + for j in (member start *pastes* :key #'paste-number) + collect j))))) ((string-equal method-name "pasteheadersbychannel") (destructuring-bind (channel length &optional supplied-start) args (let* ((*pastes* (remove channel *pastes* :test-not #'string-equal :key #'paste-channel)) (start (or supplied-start (paste-number (car *pastes*))))) - (format t "args is ~A~%" args) (mapcar #'paste-xml-list (loop for i from 1 to length for j in (member start *pastes* :key #'paste-number) collect j))))) ((string-equal method-name "pasteannotationheaders") - (format t "args is ~A~%" args) (nreverse (mapcar #'paste-xml-list - (if args - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - *pastes*)))) + (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql))))) ((string-equal method-name "pastedetails") - (if (eql (length args) 1) - (paste-xml-list (find (car args) *pastes* :key #'paste-number :test #'eql) t) - (if (eql (length args) 2) - (paste-xml-list - (find (second args) - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - :key #'paste-number :test #'eql) t) - "Error: Invalid number of arguments."))) + (destructuring-bind + (paste &optional annotation) args + (if (not annotation) + (paste-xml-list (find paste *pastes* :key #'paste-number :test #'eql) t) + (paste-xml-list + (find annotation + (paste-annotations (find paste *pastes* :key #'paste-number :test #'eql)) + :key #'paste-number :test #'eql) t)))) + ((string-equal method-name "listchannels") + *channels*) (t (format nil "Error: unimplemented method ~S." method-name))))))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.7 lisppaste2/persistent-pastes.lisp:1.8 --- lisppaste2/persistent-pastes.lisp:1.7 Sun Mar 7 13:16:27 2004 +++ lisppaste2/persistent-pastes.lisp Tue Apr 27 17:47:32 2004 @@ -48,7 +48,7 @@ (make-paste :number number :user user :title title - :contents contents + :contents (remove #\return contents) :universal-time universal-time :channel channel :annotations nil)))

1 0

[Lisppaste-cvs] CVS update: public_html/xml-rpc.html
by Brian Mastenbrook 27 Apr '04

27 Apr '04

Update of /project/lisppaste/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv20788 Modified Files: xml-rpc.html Log Message: New method Date: Tue Apr 27 17:46:57 2004 Author: bmastenbrook Index: public_html/xml-rpc.html diff -u public_html/xml-rpc.html:1.4 public_html/xml-rpc.html:1.5 --- public_html/xml-rpc.html:1.4 Tue Apr 27 17:08:25 2004 +++ public_html/xml-rpc.html Tue Apr 27 17:46:57 2004 @@ -47,6 +47,9 @@ the username, channel, title, number of annotations, and lastly the paste or annotation contents. + <tt>listchannels</tt> - returns a list of channels that the + lisppaste bot is visible on. + If you are planning on running a lisppaste with XML-RPC support, you will need Sven Van Caekenberghe's <a href="http://homepage.mac.com/svc/xml-rpc/readme.html">XML-RPC</a>

1 0

[Lisppaste-cvs] CVS update: public_html/xml-rpc.html
by Brian Mastenbrook 27 Apr '04

27 Apr '04

Update of /project/lisppaste/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv27178 Modified Files: xml-rpc.html Log Message: New XML-RPC interface Date: Tue Apr 27 17:08:26 2004 Author: bmastenbrook Index: public_html/xml-rpc.html diff -u public_html/xml-rpc.html:1.3 public_html/xml-rpc.html:1.4 --- public_html/xml-rpc.html:1.3 Tue Mar 9 01:50:36 2004 +++ public_html/xml-rpc.html Tue Apr 27 17:08:25 2004 @@ -22,16 +22,30 @@ number of a paste to annotate, in which case the channel must be equal to the original channel. - <tt>pasteheaders [annotate]</tt> - returns a list of lists - describing all pastes on the system, or if <tt>annotate</tt> is - supplied, a list of lists describing the annotations of the paste - with that number. Each list has (in order) the number of the - paste, the time of the paste, the username, channel, and title of - the paste, and the number of annotations for the paste. + <tt>pasteheaders number [start]</tt> - returns a list of lists + describing the most recent <tt>number</tt> pastes on the system. + Each list has (in order) the number of the paste, the time of the + paste, the username, channel, and title of the paste, and the + number of annotations for the paste. - <tt>pastecontents number [annotation]</tt> - returns the paste - contents of the paste with number number, or of the annotation - with supplied number of that paste. + <tt>pasteheadersbychannel channel number [start]</tt> - returns + a list of lists describing the most recent <tt>number</tt> pastes + in the supplied channel. The return type is the same as + <tt>pasteheaders</tt>. + + <tt>pasteannotationheaders number</tt> - returns a list of + lists describing the annotations of the paste numbered + <tt>number</tt>. Each list has (in order) the number of the + annotation, the time of the annotation, the username, channel, and + title of the annotation, and the number of annotations for the + annotation (currently always 0). + + <tt>pastedetails number [annotation]</tt> - returns a list + describing the paste numbered <tt>number</tt>, or of the + annotation of it numbered <tt>annotation</tt>. This list has (in + order) the number of the past or annotation, the time it occured, + the username, channel, title, number of annotations, and lastly + the paste or annotation contents. If you are planning on running a lisppaste with XML-RPC support, you will need Sven Van Caekenberghe's <a @@ -47,7 +61,7 @@ <address><a href="http://www.cs.indiana.edu/~bmastenb/">Brian Mastenbrook</a></address>   -Last modified: Tue Mar 9 01:49:48 2004 EST +Last modified: Tue Apr 27 16:08:14 2004 EST  </body> </html>

1 0

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.lisp lisppaste2/package.lisp lisppaste2/xml-paste.lisp
by Brian Mastenbrook 27 Apr '04

27 Apr '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.lisp package.lisp xml-paste.lisp Log Message: restructure xml-rpc interface Date: Tue Apr 27 17:03:21 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.14 lisppaste2/lisppaste.lisp:1.15 --- lisppaste2/lisppaste.lisp:1.14 Mon Apr 26 12:46:55 2004 +++ lisppaste2/lisppaste.lisp Tue Apr 27 17:03:21 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.14 2004/04/26 16:46:55 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.15 2004/04/27 21:03:21 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -63,3 +63,9 @@ (push ,paste-name ,paste-list)) `(push ,paste-name ,paste-list)) (serialize-transaction "pastes.lisp-expr" ,paste-name (if ,annotate ,real-number))))) + +(defun shut-up () + (setf (irc:client-stream *connection*) (make-broadcast-stream))) + +(defun un-shut-up () + (setf (irc:client-stream *connection*) *trace-output*)) \ No newline at end of file Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.2 lisppaste2/package.lisp:1.3 --- lisppaste2/package.lisp:1.2 Tue Feb 3 21:41:12 2004 +++ lisppaste2/package.lisp Tue Apr 27 17:03:21 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.2 2004/02/04 02:41:12 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.3 2004/04/27 21:03:21 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,6 +8,6 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste (:use :cl :sb-bsd-sockets) - (:export :start-lisppaste))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up))) Index: lisppaste2/xml-paste.lisp diff -u lisppaste2/xml-paste.lisp:1.2 lisppaste2/xml-paste.lisp:1.3 --- lisppaste2/xml-paste.lisp:1.2 Sun Mar 7 01:39:56 2004 +++ lisppaste2/xml-paste.lisp Tue Apr 27 17:03:21 2004 @@ -1,5 +1,16 @@ (in-package :lisppaste) +(defun paste-xml-list (paste &optional contents) + (format t "collecting paste number ~A~%" (paste-number paste)) + (list* (paste-number paste) + (xml-rpc:xml-rpc-time (paste-universal-time paste)) + (paste-user paste) + (paste-channel paste) + (paste-title paste) + (length (paste-annotations paste)) + (if contents + (list (paste-contents paste))))) + (setf xml-rpc:*xml-rpc-call-hook* (lambda (method-name &rest args) (block hook @@ -40,24 +51,38 @@ :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") + ((string-equal method-name "pasteheaders") + (destructuring-bind + (length &optional (start (paste-number (car *pastes*)))) args + (format t "args is ~A~%" args) + (mapcar #'paste-xml-list + (loop for i from 1 to length + for j in (member start *pastes* :key #'paste-number) + collect j)))) + ((string-equal method-name "pasteheadersbychannel") + (destructuring-bind + (channel length &optional supplied-start) args + (let* ((*pastes* (remove channel *pastes* :test-not #'string-equal :key #'paste-channel)) + (start (or supplied-start (paste-number (car *pastes*))))) + (format t "args is ~A~%" args) + (mapcar #'paste-xml-list + (loop for i from 1 to length + for j in (member start *pastes* :key #'paste-number) + collect j))))) + ((string-equal method-name "pasteannotationheaders") + (format t "args is ~A~%" args) (nreverse - (mapcar #'(lambda (paste) - (list (paste-number paste) - (xml-rpc:xml-rpc-time (paste-universal-time paste)) - (paste-user paste) - (paste-channel paste) - (paste-title paste) - (length (paste-annotations paste)))) - (if args (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - *pastes*)))) - ((string-equal method-name "pastecontents") + (mapcar #'paste-xml-list + (if args + (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) + *pastes*)))) + ((string-equal method-name "pastedetails") (if (eql (length args) 1) - (paste-contents (find (car args) *pastes* :key #'paste-number :test #'eql)) - (if (eql (length args) 2) - (paste-contents - (find (second args) - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - :key #'paste-number :test #'eql)) - "Error: Invalid number of arguments."))) + (paste-xml-list (find (car args) *pastes* :key #'paste-number :test #'eql) t) + (if (eql (length args) 2) + (paste-xml-list + (find (second args) + (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) + :key #'paste-number :test #'eql) t) + "Error: Invalid number of arguments."))) (t (format nil "Error: unimplemented method ~S." method-name)))))))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.lisp
by Brian Mastenbrook 26 Apr '04

26 Apr '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.lisp Log Message: Use s-b-m-h instead of r-m-l Date: Mon Apr 26 12:46:56 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.13 lisppaste2/lisppaste.lisp:1.14 --- lisppaste2/lisppaste.lisp:1.13 Thu Mar 11 09:21:33 2004 +++ lisppaste2/lisppaste.lisp Mon Apr 26 12:46:55 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.13 2004/03/11 14:21:33 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.14 2004/04/26 16:46:55 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -47,7 +47,7 @@ :port *default-irc-server-port*)) (mapcar #'(lambda (channel) (irc:join *connection* channel)) *channels*) (add-hook nickname) - (irc:read-message-loop *connection*)) + (irc:start-background-message-handler *connection*)) (defmacro make-new-paste (paste-list (&optional annotate real-number annotate-list) url &rest keys &key channel user title &allow-other-keys)

1 0

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

26 Apr '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Commit whatever's lying around on disk Date: Mon Apr 26 12:45:08 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.44 lisppaste2/web-server.lisp:1.45 --- lisppaste2/web-server.lisp:1.44 Wed Mar 31 16:33:07 2004 +++ lisppaste2/web-server.lisp Mon Apr 26 12:45:02 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.44 2004/03/31 21:33:07 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.45 2004/04/26 16:45:02 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -31,7 +31,6 @@ (defclass syndication-handler (araneida:handler) ()) (defmethod araneida:handle-request-response ((handler new-paste-handler) method request) - (araneida:request-send-headers request :expires 0) (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))) @@ -39,8 +38,32 @@ (list (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=) (concatenate 'string "#" - (araneida:request-cookie request "CHANNEL")))))) - (new-paste-form request :annotate annotate :default-channel default-channel))) + (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=)) + (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) + (araneida:html-stream + (araneida:request-stream request) + `(html + (head + (title "Select a channel") + ,(rss-link-header)) + (body + (h2 "Select a channel") + ((form :method post :action ,(araneida:urlstring *new-paste-url*)) + "Please select a channel to lisppaste to: " + ((select :name "channel") + ((option :value "")) + ,@(mapcar #'(lambda (e) + `((option :value ,e) + ,(encode-for-pre e))) *channels*)) + ((input :type submit :value "Submit"))) + ,@(bottom-links)))))))) (defun bottom-links () `((hr) @@ -205,7 +228,7 @@ ,@(bottom-links)))))) (defun handle-rss-request (request &key full) - (araneida:request-send-headers request :expires 0) + (araneida:request-send-headers request :expires 0 :content-type "application/rss+xml") (format (araneida:request-stream request) "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>~C~C" #\Return #\Linefeed) (let ((discriminate-channel (if (not (string= (araneida::request-unhandled-part request) "")) (substitute #\# #\? (araneida::request-unhandled-part request) @@ -242,10 +265,13 @@ (paste-annotations paste)))))) (format nil "Paste to channel ~A with ~A annotations." (encode-for-pre (paste-channel paste)) (length (paste-annotations paste)))) #\Return #\Linefeed)) - (if discriminate-channel - (remove discriminate-channel *pastes* :test-not #'string-equal - :key #'paste-channel) - *pastes*)) + (loop + for paste in + (if discriminate-channel + (remove discriminate-channel *pastes* :test-not #'string-equal + :key #'paste-channel) + *pastes*) for j from 1 to 20 + collect paste)) #\Return #\Linefeed))))) (defmethod araneida:handle-request-response ((handler rss-handler) method request) @@ -278,10 +304,11 @@ `((tr (th "Select a channel:") (td ((select :name "channel") - ,@(mapcar #'(lambda (e) - `((option :value ,e ,@(if (string-equal e default-channel) - '(:selected))) - ,(encode-for-pre e))) *channels*)))))) + (option :value "") + ,@(mapcar #'(lambda (e) + `((option :value ,e ,@(if (string-equal e default-channel) + '(:selected))) + ,(encode-for-pre e))) *channels*)))))) (tr (th "Enter your username:") (td ((input :type text :name "username")))) @@ -302,10 +329,13 @@ (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)))) - (araneida:request-send-headers request :expires 0 - :set-cookie (format nil "CHANNEL=~A; path=/" (subseq channel 1))) - + (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)) (cond + ((zerop (length channel)) + (new-paste-form request :message "Please select a channel." :default-channel channel)) ((zerop (length username)) (new-paste-form request :message "Please enter your username." :default-channel channel)) ((zerop (length title)) @@ -315,7 +345,7 @@ ((and annotate (not (parse-integer annotate :junk-allowed t))) (new-paste-form request :message "Malformed annotation request." :default-channel channel)) ((not (member channel *channels* :test #'string-equal)) - (new-paste-form request :message "Whatever channel that is, I don't know about it." :default channel)) + (new-paste-form request :message "Whatever channel that is, I don't know about it." :default-channel channel)) (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)))

1 0