- lisppaste-cvs@common-lisp.net - mailman3.common-lisp.net

[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.lisp lisppaste2/persistent-pastes.lisp
by Brian Mastenbrook 08 Jun '04

08 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.lisp persistent-pastes.lisp Log Message: no-channel pastes; kill-paste command Date: Tue Jun 8 08:21:30 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.18 lisppaste2/lisppaste.lisp:1.19 --- lisppaste2/lisppaste.lisp:1.18 Fri Jun 4 17:14:31 2004 +++ lisppaste2/lisppaste.lisp Tue Jun 8 08:21:30 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.18 2004/06/05 00:14:31 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.19 2004/06/08 15:21:30 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -81,19 +81,36 @@ &key channel user title &allow-other-keys) (let ((paste-name (gensym))) `(let ((,paste-name (make-paste ,@keys))) - (irc:privmsg *connection* ,channel - (if ,annotate - (format nil "~A annotated #~A with \"~A\" at ~A" ,user ,real-number ,title ,url) - (format nil "~A pasted \"~A\" at ~A" ,user ,title ,url))) - ,(if annotate - `(if ,annotate - (push ,paste-name ,annotate-list) - (push ,paste-name ,paste-list)) - `(push ,paste-name ,paste-list)) - (serialize-transaction "pastes.lisp-expr" ,paste-name (if ,annotate ,real-number))))) + (if (not (string-equal channel "None")) + (irc:privmsg *connection* ,channel + (if ,annotate + (format nil "~A annotated #~A with \"~A\" at ~A" ,user ,real-number ,title ,url) + (format nil "~A pasted \"~A\" at ~A" ,user ,title ,url)))) + ,(if annotate + `(if ,annotate + (push ,paste-name ,annotate-list) + (push ,paste-name ,paste-list)) + `(push ,paste-name ,paste-list)) + (serialize-transaction *paste-file* ,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*)) + +(defun kill-paste (number) + (setf *pastes* + (remove number *pastes* :key #'paste-number)) + (serialize-to-file *paste-file* `(kill-paste ,number))) + +(defun kill-paste-annotations (number) + (setf (paste-annotations (find number *pastes* :key #'paste-number)) + nil) + (serialize-to-file *paste-file* `(kill-paste-annotations ,number))) + +(defun kill-paste-annotation (number ann) + (let ((paste (find number *pastes* :key #'paste-number))) + (setf (paste-annotations paste) + (remove ann (paste-annotations paste) :key #'paste-number)) + (serialize-to-file *paste-file* `(kill-paste-annotation ,number ,ann)))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.9 lisppaste2/persistent-pastes.lisp:1.10 --- lisppaste2/persistent-pastes.lisp:1.9 Fri May 21 12:30:45 2004 +++ lisppaste2/persistent-pastes.lisp Tue Jun 8 08:21:30 2004 @@ -1,5 +1,7 @@ (in-package :lisppaste) +(defvar *in-operation* nil) + (defun paste-alist (paste) (list (cons 'number (paste-number paste)) @@ -7,7 +9,8 @@ (cons 'title (paste-title paste)) (cons 'contents (paste-contents paste)) (cons 'universal-time (paste-universal-time paste)) - (cons 'channel (paste-channel paste)))) + (cons 'channel (paste-channel paste)) + (cons 'colorization-mode (paste-colorization-mode paste)))) (defun serialized-initial-paste (paste) (cons 'make-paste (paste-alist paste))) @@ -29,14 +32,19 @@ (let ((*print-readably* t)) (format file "~{~S~%~}" (mapcan #'paste-list-alist (reverse *pastes*))))))) +(defun serialize-to-file (file-name operation) + (unless *in-operation* + (let ((*package* (find-package :lisppaste))) + (with-open-file (file file-name :direction :output :if-exists :append + :if-does-not-exist :create) + (let ((*print-readably* t)) + (format file "~S~%" operation)))))) + (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 - :if-does-not-exist :create) - (let ((*print-readably* t)) - (if annotate-number - (format file "~S~%" (serialized-annotation annotate-number paste)) - (format file "~S~%" (serialized-initial-paste paste))))))) + (serialize-to-file file-name + (if annotate-number + (serialized-annotation annotate-number paste) + (serialized-initial-paste paste)))) (defmacro with-assoc-vals (entry-list alist &body body) `(let ,(mapcar #'(lambda (e) (list e `(cdr (assoc ',e ,alist)))) entry-list) @@ -59,14 +67,18 @@ (ecase (car expr) (make-paste (push (make-paste-from-alist (cdr expr)) *pastes*)) (annotate-paste (let ((paste (find (second expr) *pastes* :key #'paste-number))) - (push (make-paste-from-alist (cddr expr) paste) (paste-annotations paste)))))) + (push (make-paste-from-alist (cddr expr) paste) (paste-annotations paste)))) + (kill-paste (kill-paste (second expr))) + (kill-paste-annotations (kill-paste-annotations (second expr))) + (kill-paste-annotation (kill-paste-annotation (second expr) (third expr))))) (defun read-pastes-from-file (file-name) - (setf *pastes* nil) - (let ((*package* (find-package :lisppaste))) - (with-open-file (file file-name :direction :input :if-does-not-exist nil) - (if file - (loop (let ((paste (read file nil))) - (if paste - (deserialize paste) - (return-from read-pastes-from-file t)))))))) + (let ((*in-operation* t)) + (setf *pastes* nil) + (let ((*package* (find-package :lisppaste))) + (with-open-file (file file-name :direction :input :if-does-not-exist nil) + (if file + (loop (let ((paste (read file nil))) + (if paste + (deserialize paste) + (return-from read-pastes-from-file t)))))))))

1 0

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

08 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp encode-for-pre.lisp Log Message: Fix line numbering, spacing. Add support for pastes with no channel. Date: Tue Jun 8 08:20:40 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.51 lisppaste2/web-server.lisp:1.52 --- lisppaste2/web-server.lisp:1.51 Fri Jun 4 14:23:23 2004 +++ lisppaste2/web-server.lisp Tue Jun 8 08:20:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.51 2004/06/04 21:23:23 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.52 2004/06/08 15:20:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -60,7 +60,6 @@ (body (h1 ((font :color "red") "Naughty boy!")))))) (call-next-method)))) - (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))) @@ -69,15 +68,28 @@ (or (and annotate (paste-channel annotate)) (find-if #'(lambda (e) (> (length e) 1)) (list + (and (eql method :post) + (araneida:body-param "channel" + (araneida:request-body request))) + (and *no-channel-pastes* + (or + (string-equal (araneida::request-unhandled-part request) "/none") + (string-equal (araneida:request-cookie request "CHANNEL") "None")) + "None") (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=)) - (araneida:request-send-headers request :expires 0 :set-cookie (format nil "CHANNEL=~A; path=/" (subseq default-channel 1))) + ((and default-channel (or (and *no-channel-pastes* + (string-equal default-channel "None")) + (find default-channel *channels* :test #'string=))) + (araneida:request-send-headers request :expires 0 :set-cookie + (format nil "CHANNEL=~A; path=/" + (or (and *no-channel-pastes* + (string-equal default-channel "none") + "None") + (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 @@ -180,6 +192,17 @@ (td ((a :href ,(araneida:urlstring *rss-url*)) "Basic")) ((td :width 10)) (td ((a :href ,(araneida:urlstring *rss-full-url*)) "Full"))) + ,@(if *no-channel-pastes* + `((tr + ((th :align left) "None") + ((td :width 30)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-url*) + "?none")) "Basic")) + ((td :width 10)) + (td ((a :href ,(concatenate 'string + (araneida:urlstring *rss-full-url*) + "?none")) "Full"))))) ,@(mapcar #'(lambda (channel) `(tr ((th :align left) ,channel) @@ -300,8 +323,11 @@ (let* ((discriminate-channel (or (araneida:body-param "channel" (araneida:request-body request)) (if (not (string= channel "")) - (substitute #\# #\/ channel - :test #'char=)))) + (or (and *no-channel-pastes* + (string-equal channel "/none") + "None") + (substitute #\# #\/ channel + :test #'char=))))) (discriminate-channel (if (string-equal discriminate-channel "allchannels") nil discriminate-channel)) @@ -362,12 +388,19 @@ ((a :href ,(concatenate 'string (araneida:urlstring *rss-url*) (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Basic") + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) ""))) "Basic") " | " ((a :href ,(concatenate 'string (araneida:urlstring *rss-full-url*) (if discriminate-channel - (substitute #\? #\# discriminate-channel) ""))) "Full")) + (or (and *no-channel-pastes* + (string-equal discriminate-channel "none") + "?none") + (substitute #\? #\# discriminate-channel)) + ""))) "Full")) ) (tr ((td :align left) "Page: ") @@ -398,8 +431,11 @@ (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) - :test #'char=)))) + (or (and *no-channel-pastes* + (string-equal (araneida::request-unhandled-part request) "?none") + "None") + (substitute #\# #\? (araneida::request-unhandled-part request) + :test #'char=))))) (araneida:html-stream (araneida:request-stream request) `((|rss| :|version| "2.0") @@ -458,8 +494,11 @@ (h2 ,(if annotate "Enter your annotation" "Enter your paste")) ((font :color red) (h2 ,message)) ((form :method post :action ,(araneida:urlstring *submit-paste-url*)) - (p "Enter a username, title, and paste contents into the fields below. The -paste will be announced on the selected channel @ " ,(irc:server-name *connection*) ".") + (p "Enter a username, title, and paste contents into the fields below." + ,@(unless (and annotate + *no-channel-pastes* + (string-equal (paste-channel annotate) "None")) + `("The paste will be announced on the selected channel @ " ,(irc:server-name *connection*) "."))) ,@(if annotate `((p "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) "."))) @@ -474,7 +513,7 @@ (option :value "") ,@(mapcar #'(lambda (e) `((option :value ,e ,@(if (string-equal e default-channel) - '(:selected))) + '(:selected "SELECTED"))) ,(encode-for-pre e))) *channels*)))))) (tr (th "Enter your username:") @@ -484,6 +523,16 @@ (th "Enter a title:") (td ((input :type text :name "title" :value ,(encode-for-pre default-title))))) + ,@(if (not annotate) + `((tr + (th (i "(Optional) Colorize as: ")) + (td ((select :name "colorize") + ((option :value "" :selected "SELECTED") "") + ((option :value "None") "None") + ,@(mapcar #'(lambda (pair) + `((option :value ,(cdr pair)) + ,(cdr pair))) + (colorize:coloring-types))))))) (tr ((th :valign top) "Enter your paste:") (td ((textarea :rows 24 :cols 80 :name "text") @@ -497,13 +546,18 @@ (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))) + (colorize-as (araneida:body-param "colorize" (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))) + :set-cookie (format nil "CHANNEL=~A; path=/" + (or (and *no-channel-pastes* + (string-equal channel "none") + "None") + (subseq channel 1)))) (araneida:request-send-headers request :expires 0)) (cond ((> (length text) *paste-maximum-size*) @@ -540,7 +594,8 @@ :title title :contents text :universal-time (get-universal-time) - :channel channel) + :channel channel + :colorization-mode (coerce colorize-as 'string)) (format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") (araneida:html-stream (araneida:request-stream request) @@ -549,7 +604,10 @@ ,(rss-link-header)) (body (h2 "Pasted!") - (p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) ", and was also sent to " ,channel " @ " ,(irc:server-name *connection*)) + (p ,(if annotate "Your annotation should be available at " "Your paste should be available at ") ((a :href ,url) ,url) + ,@(unless (and *no-channel-pastes* + (string-equal channel "none")) + `(", and was also sent to " ,channel " @ " ,(irc:server-name *connection*))) ".") (h3 "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))) @@ -562,38 +620,51 @@ (if (< l1 l2) nil (string= (subseq str (- l1 l2) l1) end)))) -(defun format-paste (paste this-url paste-number &optional annotation colorize-as) - `((table :width "100%" :cellpadding 2) - (tr ((td :align "left" :width "0%" :nowrap "nowrap") - ,(if annotation - `((a :name ,(prin1-to-string paste-number)) "Annotation number ") - "Paste number ") ,paste-number ": ") - ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) - (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") - ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) - (tr (td) - ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) - ,@(if (or (not annotation) *meme-links*) - `((tr (td) - ((td :align "left" :width "100%") - ,@(if (not annotation) - `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* - " | " "")))) - ,@(if *meme-links* - `(((a :href ,(irc-log-link (paste-universal-time paste) (paste-channel paste))) "Context in IRC logs"))))))) - (tr ((td :align "left" :valign "top" :nowrap "nowrap") "Paste contents:") - ,@(if this-url - `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) - (tr (td (p))) - (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") - (tt - ,(if colorize-as - (colorize:format-scan colorize-as - (mapcar #'(lambda (e) - (cons (car e) - (encode-for-tt (cdr e)))) - (colorize:scan-string colorize-as (paste-contents paste)))) - (encode-for-tt (paste-contents paste)))))))) +(defun format-paste (paste this-url paste-number &optional annotation colorize-as line-numbers) + (let ((n 0)) + (labels + ((line-number () + (format nil "<span class=\"paste\">~A</span>" + (encode-for-tt (format nil "~4D: " (incf n)) + :first-char-nbsp t))) + (encode (str) + (encode-for-tt str + :with-line-numbers + (if line-numbers + #'line-number)))) + `((table :width "100%" :cellpadding 2) + (tr ((td :align "left" :width "0%" :nowrap "nowrap") + ,(if annotation + `((a :name ,(prin1-to-string paste-number)) "Annotation number ") + "Paste number ") ,paste-number ": ") + ((td :align "left" :width "100%") (b ,(encode-for-pre (paste-title paste))))) + (tr ((td :align "left" :nowrap "nowrap") "Pasted by: ") + ((td :align "left" :width "100%") ,(encode-for-pre (paste-user paste)))) + (tr (td) + ((td :align "left" :width "100%") ,(time-delta (paste-universal-time paste)))) + ,@(if (or (not annotation) *meme-links*) + `((tr (td) + ((td :align "left" :width "100%") + ,@(if (not annotation) + `((,(encode-for-pre (paste-channel paste)) ,(if *meme-links* + " | " "")))) + ,@(if *meme-links* + `(((a :href ,(irc-log-link (paste-universal-time paste) (paste-channel paste))) "Context in IRC logs"))))))) + (tr ((td :align "left" :valign "top" :nowrap "nowrap") "Paste contents:") + ,@(if this-url + `(((td :width "100%") ((a :href ,(concatenate 'string this-url "/raw")) "(raw source)"))))) + (tr (td (p))) + (tr ((td :bgcolor "#F4F4F4" :colspan 2 :width "100%") + (tt + ,@(if line-numbers + (list (line-number))) + ,(if colorize-as + (colorize:format-scan colorize-as + (mapcar #'(lambda (e) + (cons (car e) + (encode (cdr e)))) + (colorize:scan-string colorize-as (paste-contents paste)))) + (encode (paste-contents paste)))))))))) (defmethod araneida:handle-request-response ((handler display-paste-handler) method request) ; XXX request-unhandled-part will be exported in 0.81 @@ -604,13 +675,22 @@ (paste (some #'(lambda (element) (and (eql paste-number (paste-number element)) element)) *pastes*)) - (colorize-string (araneida:body-param "colorize" (araneida:request-body request))) + (linenumbers (equalp (araneida:body-param "linenumbers" (araneida:request-body request)) + "true")) + (colorize-string (or (and paste + (> (length (paste-colorization-mode paste)) 0) + (paste-colorization-mode paste)) + (araneida:body-param "colorize" (araneida:request-body request)))) (colorize-as (or (car (rassoc colorize-string (colorize:coloring-types) :test #'string-equal)) (if (and paste (not (string-equal colorize-string "None"))) (colorize:autodetect-coloring-type (paste-channel paste))))) (colorize:*css-background-class* "paste")) + (and paste + (format t "Serving paste number ~S to ~S.~%" + (paste-number paste) + (car (araneida:request-header request :x-forwarded-for)))) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -641,7 +721,8 @@ colorize:*coloring-css*)) ,(rss-link-header)) (body - ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as) + ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as + linenumbers) ,@(if (paste-annotations paste) `((p) "Annotations for this paste: " @@ -651,7 +732,7 @@ ,(format-paste a (format nil "~A,~A" (araneida:urlstring (araneida:request-url request)) - (paste-number a)) (paste-number a) t colorize-as))) + (paste-number a)) (paste-number a) t colorize-as linenumbers))) (reverse (paste-annotations paste))))) `((p) "This paste has no annotations.")) (p) @@ -670,7 +751,11 @@ '(:selected "SELECTED"))) ,(cdr pair))) (colorize:coloring-types))) - ((input :type submit :value "Colorize"))) + (br) + ((input :type "checkbox" :name "linenumbers" :value "true" + ,@(if linenumbers '(:checked "checked")))) " Show Line Numbers" + (br) + ((input :type submit :value "Format"))) (p) ((form :method post :action ,(araneida:urlstring *new-paste-url*)) ((input :type hidden :name "annotate" :value ,(prin1-to-string (paste-number paste)))) Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.16 lisppaste2/encode-for-pre.lisp:1.17 --- lisppaste2/encode-for-pre.lisp:1.16 Thu Jun 3 13:19:40 2004 +++ lisppaste2/encode-for-pre.lisp Tue Jun 8 08:20:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.16 2004/06/03 20:19:40 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.17 2004/06/08 15:20:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,7 +8,7 @@ (:export :encode-for-pre :encode-for-tt :encode-for-http)) (in-package :html-encode) -(defun encode-for-tt (string) +(defun encode-for-tt (string &key with-line-numbers first-char-nbsp) (let ((pos 0) (end (length string)) (char nil)) (flet ((next-char () @@ -19,6 +19,9 @@ (with-output-to-string (out) (block nil (tagbody + (unless first-char-nbsp + (next-char) + (go process-char)) escape-spaces (next-char) (when (eql char #\Space) @@ -29,6 +32,8 @@ ((nil) (return)) ((#\Newline) (write-string "<br>" out) + (if with-line-numbers + (write-string (funcall with-line-numbers) out)) (go escape-spaces)) ((#\&) (write-string "&" out))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/coloring-types.lisp
by Brian Mastenbrook 04 Jun '04

04 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp Log Message: Make the scanner treat numbers as symbols; simplify the scanner Date: Fri Jun 4 07:09:51 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.4 lisppaste2/coloring-types.lisp:1.5 --- lisppaste2/coloring-types.lisp:1.4 Thu Jun 3 13:20:46 2004 +++ lisppaste2/coloring-types.lisp Fri Jun 4 07:09:51 2004 @@ -3,7 +3,7 @@ (in-package :colorize) (defparameter *symbol-characters* - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&") + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890") (defparameter *non-constituent* '(#\space #\tab #\newline #\linefeed #\page #\return @@ -30,10 +30,7 @@ (((:normal :in-list) ((or (scan-any *symbol-characters*) - (and (scan "+") (scan-any *symbol-characters*)) - (and (scan "-") (scan-any *symbol-characters*)) - (scan "1+") - (scan "1-") + (and (scan #\.) (scan-any *symbol-characters*)) (and (scan #\\) (advance 1))) (set-mode :symbol :until (scan-any *non-constituent*)

1 0

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

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: IP banning (web-server.lisp part) Date: Thu Jun 3 15:12:14 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.49 lisppaste2/web-server.lisp:1.50 --- lisppaste2/web-server.lisp:1.49 Thu Jun 3 07:16:35 2004 +++ lisppaste2/web-server.lisp Thu Jun 3 15:12:14 2004 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.49 2004/06/03 14:16:35 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.50 2004/06/03 22:12:14 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -35,6 +35,31 @@ (defclass syndication-handler (araneida:handler) ()) (defclass stats-handler (araneida:handler) ()) + +(defmethod araneida:handle-request-response :around + ((handler submit-paste-handler) method request) + (let ((forwarded-for (car (araneida:request-header request :x-forwarded-for)))) + (if (and forwarded-for + (member forwarded-for + *banned-ips* :test #'string-equal)) + (progn + (with-open-file (s "ban-log" :direction :output :if-exists :append + :if-does-not-exist :create) + (format s "Logged attempt by ~S to submit a paste.~%" + forwarded-for) + (format s "Request headers are: ~S.~%" + (araneida:request-headers request)) + (format s "Request body is: ~S.~%" + (araneida:request-body request))) + (araneida:request-send-headers request :expires 0) + (araneida:html-stream + (araneida:request-stream request) + `(html + (head + (title "No cookie for you!")) + (body (h1 ((font :color "red") "Naughty boy!")))))) + (call-next-method)))) + (defmethod araneida:handle-request-response ((handler new-paste-handler) method request) (let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request)))

1 0

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

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/test/lisppaste2 Modified Files: variable.lisp Log Message: IP banning (variable.lisp part) Date: Thu Jun 3 15:12:03 2004 Author: bmastenbrook Index: lisppaste2/variable.lisp diff -u lisppaste2/variable.lisp:1.15 lisppaste2/variable.lisp:1.16 --- lisppaste2/variable.lisp:1.15 Tue Jun 1 06:21:19 2004 +++ lisppaste2/variable.lisp Thu Jun 3 15:12:03 2004 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.15 2004/06/01 13:21:19 bmastenbrook Exp $ +;;;; $Id: variable.lisp,v 1.16 2004/06/03 22:12:03 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -30,6 +30,12 @@ (defvar *paste-maximum-size* 51200) (defvar *pastes-per-page* 50) + +(defparameter *banned-ips* + '("69.11.238.252" "168.143.113.138")) + +(defparameter *ban-log-file* + "ban-log") ;; You shouldn't need to edit below this line. ;; LINE

1 0

[Lisppaste-cvs] CVS update: lisppaste2/elisp-symbols.lisp-expr
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: elisp-symbols.lisp-expr Log Message: Take out "foo" Date: Thu Jun 3 13:29:17 2004 Author: bmastenbrook Index: lisppaste2/elisp-symbols.lisp-expr diff -u lisppaste2/elisp-symbols.lisp-expr:1.1 lisppaste2/elisp-symbols.lisp-expr:1.2 --- lisppaste2/elisp-symbols.lisp-expr:1.1 Thu Jun 3 13:20:19 2004 +++ lisppaste2/elisp-symbols.lisp-expr Thu Jun 3 13:29:17 2004 @@ -766,7 +766,7 @@ ("font-lock-warning-face" . "elisp_370.html#IDX1128") ("fontification-functions" . "elisp_639.html#IDX2424") ("fontified (text property)" . "elisp_527.html#IDX1903") - ("foo" . "elisp_12.html#IDX7") ("for" . "elisp_182.html#IDX511") + ("for" . "elisp_182.html#IDX511") ("force-mode-line-update" . "elisp_358.html#IDX1087") ("format" . "elisp_75.html#IDX176") ("format-alist" . "elisp_404.html#IDX1284") @@ -1909,4 +1909,4 @@ ("y-or-n-p" . "elisp_281.html#IDX778") ("y-or-n-p-with-timeout" . "elisp_281.html#IDX779") ("yank" . "elisp_504.html#IDX1788") ("yank-pop" . "elisp_504.html#IDX1790") - ("yes-or-no-p" . "elisp_281.html#IDX780") ("zerop" . "elisp_60.html#IDX87")) \ No newline at end of file + ("yes-or-no-p" . "elisp_281.html#IDX780") ("zerop" . "elisp_60.html#IDX87"))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/coloring-types.lisp lisppaste2/lisppaste.asd
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp lisppaste.asd Log Message: elisp colorization Date: Thu Jun 3 13:20:46 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.3 lisppaste2/coloring-types.lisp:1.4 --- lisppaste2/coloring-types.lisp:1.3 Thu Jun 3 07:17:04 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 3 13:20:46 2004 @@ -22,10 +22,6 @@ (defparameter *close-parens* '(#\))) (define-coloring-type :lisp "Basic Lisp" - :autodetect (lambda (name) - (member name '("emacs") - :test #'(lambda (name ext) - (search ext name :test #'char-equal)))) :modes (:normal :symbol :escaped-symbol :keyword :string :comment :multiline :character :single-escaped :in-list :syntax-error) @@ -191,6 +187,24 @@ (declare (ignore type)) (let ((result (if (find-package :r5rs-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) + s)))) + (if result + (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" + result (call-parent-formatter)) + (call-parent-formatter))))))) + +(define-coloring-type :elisp "Emacs Lisp" + :autodetect (lambda (name) + (member name '("emacs") + :test #'(lambda (name ext) + (search ext name :test #'char-equal)))) + :parent :lisp + :formatters + (((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :elisp-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) s)))) (if result (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.10 lisppaste2/lisppaste.asd:1.11 --- lisppaste2/lisppaste.asd:1.10 Thu Jun 3 07:17:58 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 13:20:46 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.11 2004/06/03 20:20:46 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -33,6 +33,7 @@ (:file "colorize" :depends-on ("colorize-package" "coloring-css")) (:file "clhs-lookup" :depends-on ("encode-for-pre")) (:file "r5rs-lookup" :depends-on ("encode-for-pre")) + (:file "elisp-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/r5rs-symbols.lisp-expr lisppaste2/elisp-symbols.lisp-expr lisppaste2/elisp-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: r5rs-symbols.lisp-expr elisp-symbols.lisp-expr elisp-lookup.lisp Log Message: Symbols for R5RS and Elisp; lookup for elisp Date: Thu Jun 3 13:20:19 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: encode-for-pre.lisp Log Message: eight spaces instead of four for tabs Date: Thu Jun 3 13:19:40 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.15 lisppaste2/encode-for-pre.lisp:1.16 --- lisppaste2/encode-for-pre.lisp:1.15 Tue Jun 1 06:17:50 2004 +++ lisppaste2/encode-for-pre.lisp Thu Jun 3 13:19:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.15 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.16 2004/06/03 20:19:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -37,7 +37,7 @@ ((#\>) (write-string ">" out)) ((#\Tab) - (write-string "    " out)) + (write-string "        " out)) ((#\Space) (write-char #\Space out) (go escape-spaces))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/package.lisp lisppaste2/lisppaste.lisp lisppaste2/lisppaste.asd
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: package.lisp lisppaste.lisp lisppaste.asd Log Message: package: export shut-up; lisppaste: better response for help; lisppaste.asd: add r5rs-lookup Date: Thu Jun 3 07:17:58 2004 Author: bmastenbrook Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.5 lisppaste2/package.lisp:1.6 --- lisppaste2/package.lisp:1.5 Tue Jun 1 06:18:35 2004 +++ lisppaste2/package.lisp Thu Jun 3 07:17:58 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.5 2004/06/01 13:18:35 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.6 2004/06/03 14:17:58 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 #+sbcl :sb-bsd-sockets :html-encode) - (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help))) Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.16 lisppaste2/lisppaste.lisp:1.17 --- lisppaste2/lisppaste.lisp:1.16 Tue Jun 1 06:17:50 2004 +++ lisppaste2/lisppaste.lisp Thu Jun 3 07:17:58 2004 @@ -1,10 +1,29 @@ -;;;; $Id: lisppaste.lisp,v 1.16 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.17 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) +(defun say-help (channel) + (when (and *connection* + (find channel *channels* :test #'string=)) + (irc:privmsg *connection* + channel + (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq channel 1))) + t)) + +(defun help-request-p (nick help text) + (and (> (length text) + (length nick)) + (search nick text :start2 0 :end2 (length nick) :test #'char-equal) + (let ((url-position (search help text :start2 (length nick) + :test #'char-equal))) + (and + url-position + (notany #'alphanumericp (subseq text (length nick) (1- url-position))) + (notany #'alphanumericp (subseq text (+ url-position (length help)))))))) + (defun make-msg-hook (nick) (lambda (message) (let ((text (irc:trailing-argument message))) @@ -12,18 +31,10 @@ (irc:privmsg *connection* (irc:source message) (format nil "To use the lisppaste bot, visit ~A and enter your paste. Be sure to select the right channel!" (araneida:urlstring *new-paste-url*)))) - ((and (> (length text) - (length nick)) - (search nick text :start2 0 :end2 (length nick) :test #'char-equal)) - (let ((url-position (search "url" text :start2 (length nick) - :test #'char-equal))) - (if (and - url-position - (notany #'alphanumericp (subseq text (length nick) (1- url-position))) - (notany #'alphanumericp (subseq text (+ url-position 3)))) - (irc:privmsg *connection* - (first (irc:arguments message)) - (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq (first (irc:arguments message)) 1)))))))))) + ((some #'(lambda (e) + (help-request-p nick e text)) + '("url" "help" "hello")) + (say-help (first (irc:arguments message)))))))) (defun add-hook (nick) @@ -44,6 +55,7 @@ (setf *channels* channels) (read-pastes-from-file *paste-file*) (mapcar #'(lambda (channel) (irc:join connection channel)) channels) + (clhs-lookup:populate-table) (araneida:start-listening *paste-listener*) (add-hook nickname) (setf *boot-time* (get-universal-time)) Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.9 lisppaste2/lisppaste.asd:1.10 --- lisppaste2/lisppaste.asd:1.9 Tue Jun 1 06:19:22 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 07:17:58 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.9 2004/06/01 13:19:22 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -22,15 +22,17 @@ pre-configured IRC channel about the paste and where it can be located." :depends-on (:araneida :cl-irc) - :components ((:file "package") + :components ((:file "encode-for-pre") + (:file "package" :depends-on ("encode-for-pre")) (:file "variable" :depends-on ("package")) - (:file "encode-for-pre" - :depends-on ("variable")) (:file "lisppaste" :depends-on ("variable")) - (:file "colorize") - (:file "clhs-lookup") + (: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 "r5rs-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0