January 2007 - lisppaste-cvs@common-lisp.net

[Lisppaste-cvs] CVS lisppaste2
by bmastenbrook 16 Jan '07

16 Jan '07

Update of /project/lisppaste/cvsroot/lisppaste2 In directory clnet:/tmp/cvs-serv23816 Modified Files: web-server.lisp Log Message: Oops. Monospace. --- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 01:10:44 1.89 +++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 02:37:39 1.90 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.89 2007/01/16 01:10:44 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.90 2007/01/16 02:37:39 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -945,21 +945,22 @@ (<table width="100%" class="paste-area"> (<tr> (<td bgcolor="#F4F4F4" colspan="2" width="100%"> - (when line-numbers (make-unescaped-string (line-number))) - ;; FIXME!!! This all needs to be converted to use - ;; XML objects natively. - (make-unescaped-string - (if colorize-as - (memoize-format (list (paste-contents paste) - colorize-as - line-numbers) - (lambda () - (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))))))))))) + (<tt> + (when line-numbers (make-unescaped-string (line-number))) + ;; FIXME!!! This all needs to be converted to use + ;; XML objects natively. + (make-unescaped-string + (if colorize-as + (memoize-format (list (paste-contents paste) + colorize-as + line-numbers) + (lambda () + (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 handle-request-response ((handler display-paste-handler) method request) (let* ((paste-number (parse-integer

1 0

[Lisppaste-cvs] CVS lisppaste2
by bmastenbrook 16 Jan '07

16 Jan '07

Update of /project/lisppaste/cvsroot/lisppaste2 In directory clnet:/tmp/cvs-serv10195 Modified Files: system-server.lisp Log Message: paredit failed me! (trailing parens?))) --- /project/lisppaste/cvsroot/lisppaste2/system-server.lisp 2007/01/16 00:56:30 1.2 +++ /project/lisppaste/cvsroot/lisppaste2/system-server.lisp 2007/01/16 01:17:32 1.3 @@ -129,10 +129,10 @@ "All Systems") (loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (request-unhandled-part request))))) collect " / " - collect (<a href=?(urlstring (merge-url *show-component-url* - (format nil "~{~A~^/~}" - i)))> - (car (last i))))) + collect (<a href=?(urlstring (merge-url *show-component-url* + (format nil "~{~A~^/~}" + i)))> + (car (last i))))) <p/> (typecase component (asdf:module (module-div component (urlstring (request-url request)))) @@ -142,7 +142,7 @@ :common-lisp-file :none))) (t (<div class="paste-area"> - "I'm afraid I don't quite know what to do with this file."))))))))))))) + "I'm afraid I don't quite know what to do with this file.")))))))))) (when *serve-source* (install-handler

1 0

[Lisppaste-cvs] CVS lisppaste2
by bmastenbrook 16 Jan '07

16 Jan '07

Update of /project/lisppaste/cvsroot/lisppaste2 In directory clnet:/tmp/cvs-serv9580 Modified Files: web-server.lisp Log Message: Captchas should only be entered once an hour --- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 00:56:31 1.88 +++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 01:10:44 1.89 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.88 2007/01/16 00:56:31 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.89 2007/01/16 01:10:44 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -86,12 +86,16 @@ (remhash host *referer-hash*) (incf (gethash "Google" *referer-hash* 0) count))))) +(defvar *show-captcha* t) + (defmethod 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) + (expire-authorization-tokens) (unwind-protect - (call-next-method) + (let ((*show-captcha* (not (is-authorized request)))) + (call-next-method)) (force-output *trace-output*)))) (defun make-css () @@ -677,15 +681,16 @@ (<tr> (<th align="left" width="0%" nowrap="nowrap"> "Enter a title:") (<td> <input type="text" name="title" value=?default-title />)) - (<tr> - (<th align="left" width="0%" nowrap="nowrap"> "Captcha:") - (<td> - (multiple-value-bind (captcha captchaid) - (make-captcha 8) - (list - captcha - <input type="text" name="captcha" /> - <input type="hidden" name="captchaid" value=?captchaid />)))) + (when *show-captcha* + (<tr> + (<th align="left" width="0%" nowrap="nowrap"> "Captcha:") + (<td> + (multiple-value-bind (captcha captchaid) + (make-captcha 8) + (list + captcha + <input type="text" name="captcha" /> + <input type="hidden" name="captchaid" value=?captchaid />))))) (unless annotate (<tr> (<th align="left" width="0%" nowrap="nowrap"> @@ -765,20 +770,26 @@ (annotate-paste (if annotate-number (find annotate-number *pastes* :key #'paste-number))) (channel (body-param "channel" (request-body request))) (captcha (body-param "captcha" (request-body request))) - (captchaid (body-param "captchaid" (request-body request)))) - (if (> (length channel) 1) - (request-send-headers request :expires 0 - :set-cookie (format nil "CHANNEL=~A; path=/" - (or (and *no-channel-pastes* - (string-equal channel "none") - "None") - (subseq channel 1)))) - (request-send-headers request :expires 0)) + (captchaid (body-param "captchaid" (request-body request))) + (correct (and captcha captchaid (captcha-entered-correctly-p captcha 8 captchaid)))) + (let ((cookies nil)) + (when (> (length channel) 1) + (push (format nil "CHANNEL=~A; path=/" + (or (and *no-channel-pastes* + (string-equal channel "none") + "None") + (subseq channel 1))) cookies)) + (when correct + (push (make-authorization-token) cookies)) + (if cookies + (request-send-headers request :expires 0 + :set-cookie cookies) + (request-send-headers request :expires 0))) (expire-used-captchas) (cond - ((captcha-used captchaid) + ((and (> (length captchaid) 0) (captcha-used captchaid)) (new-paste-form request :message "This captcha has been used already. Did you use the back button?" :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) - ((not (captcha-entered-correctly-p captcha 8 captchaid)) + ((and *show-captcha* (not correct)) (new-paste-form request :message "You entered the captcha incorrectly." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text)) ((> (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))

1 0

[Lisppaste-cvs] CVS lisppaste2
by bmastenbrook 16 Jan '07

16 Jan '07

Update of /project/lisppaste/cvsroot/lisppaste2 In directory clnet:/tmp/cvs-serv4784 Modified Files: lisppaste.asd package.lisp system-server.lisp variable.lisp web-server.lisp Log Message: Major change: use webutils and XML mixed mode. Add captchas. --- /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd 2006/06/29 13:50:23 1.21 +++ /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd 2007/01/16 00:56:30 1.22 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.21 2006/06/29 13:50:23 lisppaste Exp $ +;;;; $Id: lisppaste.asd,v 1.22 2007/01/16 00:56:30 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -22,19 +22,19 @@ pre-configured IRC channel about the paste and where it can be located." :depends-on (:araneida #-lisppaste-no-irc :cl-irc - :split-sequence :s-xml :s-xml-rpc :cl-ppcre) - :components ((:file "encode-for-pre") - (:file "package" :depends-on ("encode-for-pre")) + :split-sequence :s-xml :s-xml-rpc :cl-ppcre + :html-encode :webutils) + :components ((:file "package") (:file "variable" :depends-on ("package")) (:file "colorize-package") (:file "coloring-css" :depends-on ("colorize-package")) - (:file "colorize" :depends-on ("colorize-package" "coloring-css" "encode-for-pre")) + (:file "colorize" :depends-on ("colorize-package" "coloring-css")) (:file "abbrev") - (:file "clhs-lookup" :depends-on ("encode-for-pre" "abbrev")) - (:file "r5rs-lookup" :depends-on ("encode-for-pre")) - (:file "cocoa-lookup" :depends-on ("encode-for-pre")) - (:file "elisp-lookup" :depends-on ("encode-for-pre")) + (:file "clhs-lookup" :depends-on ("abbrev")) + (:file "r5rs-lookup") + (:file "cocoa-lookup") + (:file "elisp-lookup") #-lisppaste-no-irc (:file "irc-notification" :depends-on ("variable" "package")) (:file "lisppaste" :depends-on ("variable" "clhs-lookup" @@ -46,13 +46,12 @@ (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server" - :depends-on ("encode-for-pre" "lisppaste" - "colorize-package" - "colorize" - "coloring-css")) + :depends-on ("lisppaste" + "colorize-package" + "colorize" + "coloring-css")) (:file "system-server" - :depends-on ("variable" "encode-for-pre" - "colorize-package" + :depends-on ("variable" "colorize-package" "coloring-css")) (:file "xml-paste" :depends-on ("variable" "lisppaste")) --- /project/lisppaste/cvsroot/lisppaste2/package.lisp 2004/11/07 21:01:43 1.10 +++ /project/lisppaste/cvsroot/lisppaste2/package.lisp 2007/01/16 00:56:30 1.11 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.10 2004/11/07 21:01:43 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.11 2007/01/16 00:56:30 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 #+sbcl :sb-bsd-sockets :html-encode) + (:use :cl #+sbcl :sb-bsd-sockets :html-encode :araneida :webutils) (:export :start-lisppaste :join-new-irc-channel :start-irc-notification :hup-irc-connection :quit-all-connections :hup-all-connections --- /project/lisppaste/cvsroot/lisppaste2/system-server.lisp 2004/07/15 12:37:35 1.1 +++ /project/lisppaste/cvsroot/lisppaste2/system-server.lisp 2007/01/16 00:56:30 1.2 @@ -14,25 +14,28 @@ (find-component-from-string (subseq string start-of-rest) :root new-root) new-root))))) -(defclass main-system-server-handler (araneida:handler) ()) +(defclass main-system-server-handler (handler) ()) -(defclass show-component-handler (araneida:handler) ()) +(defclass show-component-handler (handler) ()) -(defmethod araneida:handle-request-response ((handler main-system-server-handler) method request) - (araneida:request-send-headers request :expires 0) - (araneida:html-stream - (araneida:request-stream request) +(defmethod handle-request-response ((handler main-system-server-handler) method request) + (request-send-headers request :expires 0) + (xml-output-to-stream + (request-stream request) (lisppaste-wrap-page "Select a System" - `((div :class "controls") - (ul - ,@(loop for i in (all-system-names) - for system = (asdf:find-system i) - collect `(li ((a :href ,(araneida:urlstring (araneida:merge-url *show-component-url* - i))) - ,i) " - " ,(or (ignore-errors (asdf:system-description system)) - (ignore-errors (asdf:system-long-description system)) - "No Description")))))))) + (<div class="controls"> + (<ul> + (loop for i in (all-system-names) + for system = (asdf:find-system i) + collect (<li> + (<a href=?(urlstring (merge-url *show-component-url* + i))> + i) + " - " + (or (ignore-errors (asdf:system-description system)) + (ignore-errors (asdf:system-long-description system)) + "No Description")))))))) (defun memoize-colorize-file (component type) (let ((ent (list (asdf:component-pathname component) @@ -56,97 +59,98 @@ (string< (asdf:component-name c1) (asdf:component-name c2))))) (defun module-div (component url) - `(div - ,@(if (typep component 'asdf:system) - `(((div :class "info-text") - ((span :class "small-header") ,(format nil "About system \"~A\"" (asdf:component-name component))) - (p) - (table - (tr - (td (b "Name")) - (td ,(asdf:component-name component))) - (tr - (td (b "Version")) - (td ,(or (ignore-errors (asdf:component-version component)) "None"))) - (tr - (td (b "Author")) - (td ,(or (ignore-errors (asdf:system-author component)) "None"))) - (tr - (td (b "License")) - (td ,(or (ignore-errors (asdf::system-licence component)) "None"))) - (tr - (td (b "Description")) - (td ,(or (ignore-errors (asdf:system-description component)) "None"))) - (tr - (td (b "Long Description")) - (td ,(or (ignore-errors (asdf:system-long-description component)) "None"))))) - (p))) - ((div :class "controls") - ((span :class "small-header") "Select a component:") - (ul - ,@(loop for i in (sort (copy-list (asdf:module-components component)) #'component-sorter) - for link = `((a :href ,(concatenate 'string + (<div> + (when (typep component 'asdf:system) + (<div class="info-text"> + (<span class="small-header"> + (format nil "About system \"~A\"" + (asdf:component-name component))) + <p/> + (<table> + (<tr> + (<td> (<b> "Name")) + (<td> (asdf:component-name component))) + (<tr> + (<td> (<b> "Version")) + (<td> (or (ignore-errors (asdf:component-version component)) "None"))) + (<tr> + (<td> (<b> "Author")) + (<td> (or (ignore-errors (asdf:system-author component)) "None"))) + (<tr> + (<td> (<b> "License")) + (<td> (or (ignore-errors (asdf:system-license component)) "None"))) + (<tr> + (<td> (<b> "Description")) + (<td> (or (ignore-errors (asdf:system-description component)) "None"))) + (<tr> + (<td> (<b> "Long Description")) + (<td> (or (ignore-errors (asdf:system-long-description component)) "None")))))) + (<div class="controls"> + (<span class="small-header"> "Select a component:") + (<ul> + (loop for i in (sort (copy-list (asdf:module-components component)) #'component-sorter) + for link = (<a href=?(concatenate 'string url "/" - (asdf:component-name i))) - ,(asdf:component-name i)) - if (typep i 'asdf:module) collect `(li (b ,link)) - else collect `(li ,link)))))) + (asdf:component-name i))> + (asdf:component-name i)) + if (typep i 'asdf:module) collect (<li> (<b> link)) + else collect (<li> link)))))) (defun file-div (component type) - `((table :width "100%" :class "paste-area") - (tr - ((td :bgcolor "#F4F4F4") - (tt - ,(if (eql type :none) - (html-encode:encode-for-tt - (with-output-to-string (s) - (with-open-file (f (asdf:component-pathname component) :direction :input) - (loop for line = (read-line f nil nil) - while line - do (progn (write-string line s) - (terpri s)))))) - (memoize-colorize-file component type))))))) + (<table width="100%" class="paste-area"> + (<tr> + (<td bgcolor="#F4F4F4"> + (if (eql type :none) + (<pre> + (with-output-to-string (s) + (with-open-file (f (asdf:component-pathname component) :direction :input) + (loop for line = (read-line f nil nil) + while line + do (progn (write-string line s) + (terpri s)))))) + (<tt> + (make-unescaped-string + (memoize-colorize-file component type)))))))) -(defmethod araneida:handle-request-response ((handler show-component-handler) method request) - (let ((component (find-component-from-string (araneida:request-unhandled-part request)))) +(defmethod handle-request-response ((handler show-component-handler) method request) + (let ((component (find-component-from-string (request-unhandled-part request)))) (and component (progn - (araneida:request-send-headers request :expires 0) - (araneida:html-stream - (araneida:request-stream request) + (request-send-headers request :expires 0) + (xml-output-to-stream + (request-stream request) (lisppaste-wrap-page (format nil "Component ~A" (asdf:component-name component)) - `(div - ((div :class "controls") - "You are here: " - ((a :href ,(araneida:urlstring *main-system-server-url*)) - "All Systems") - ,@(loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (araneida:request-unhandled-part request))))) - appending `(" / " - ((a :href ,(araneida:urlstring - (araneida:merge-url *show-component-url* + (<div> + (<div class="controls"> + "You are here: " + (<a href=?(urlstring *main-system-server-url*)> + "All Systems") + (loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (request-unhandled-part request))))) + collect " / " + collect (<a href=?(urlstring (merge-url *show-component-url* (format nil "~{~A~^/~}" - i)))) - ,(car (last i)))))) - (p) - ,(typecase component - (asdf:module (module-div component (araneida:urlstring (araneida:request-url request)))) - (asdf:cl-source-file (file-div component :common-lisp-file)) - (asdf:static-file - (file-div component (if (equalp (pathname-type (asdf:component-pathname component)) "lisp") - :common-lisp-file - :none))) - (t `((div :class "paste-area") - "I don't know what to do with this component.")))))))))) + i)))> + (car (last i))))) + <p/> + (typecase component + (asdf:module (module-div component (urlstring (request-url request)))) + (asdf:cl-source-file (file-div component :common-lisp-file)) + (asdf:static-file + (file-div component (if (equalp (pathname-type (asdf:component-pathname component)) "lisp") + :common-lisp-file + :none))) + (t (<div class="paste-area"> + "I'm afraid I don't quite know what to do with this file."))))))))))))) (when *serve-source* - (araneida:install-handler - (araneida:http-listener-handler *paste-listener*) + (install-handler + (http-listener-handler *paste-listener*) (make-instance 'main-system-server-handler) - (araneida:urlstring *main-system-server-url*) t) + (urlstring *main-system-server-url*) t) - (araneida:install-handler - (araneida:http-listener-handler *paste-listener*) + (install-handler + (http-listener-handler *paste-listener*) (make-instance 'show-component-handler) - (araneida:urlstring *show-component-url*) nil)) + (urlstring *show-component-url*) nil)) --- /project/lisppaste/cvsroot/lisppaste2/variable.lisp 2006/12/02 00:06:04 1.46 +++ /project/lisppaste/cvsroot/lisppaste2/variable.lisp 2007/01/16 00:56:30 1.47 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.46 2006/12/02 00:06:04 lisppaste Exp $ +;;;; $Id: variable.lisp,v 1.47 2007/01/16 00:56:30 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -25,23 +25,24 @@ (defparameter *internal-http-port* 8080 "Port lisppaste's araneida will listen on for requests from Apache.") -(defparameter *external-http-port* 80 +(defparameter *external-http-port* 8080 "Port lisppaste's araneida will listen on for requests from remote clients.") -(defparameter *paste-site-name* "paste.lisp.org" +(defparameter *paste-site-name* "distral.local" "Website we are running on (used for creating links).") (defparameter *paste-external-url* - (araneida:merge-url - (araneida:make-url :scheme "http" + (merge-url + (make-url :scheme "http" :host *paste-site-name* ;;; comment out this next line when running ;;; behind a proxying apache + :port *external-http-port* #| :port *external-http-port* |# ) "/")) -(defparameter *old-url* (araneida:merge-url - (araneida:make-url :scheme "http" +(defparameter *old-url* (merge-url + (make-url :scheme "http" :host "www.common-lisp.net") "/paste/")) @@ -56,11 +57,9 @@ (defparameter *owner-email* "lisppaste-requests(a)common-lisp.net") ; the owner of this lisppaste (defparameter *ads* - '(ul -(li ((a :href "http://planet.lisp.org") - "Planet Lisp")) - (li ((a :href "http://www.gigamonkeys.com/book/") - "Practical Common Lisp - learn Lisp!")))) ; gratuitous promotions + (<ul> (<li> (<a href="http://planet.lisp.org/"> "Planet Lisp")) + (<li> (<a href="http://www.gigamonkeys.com/book/"> + "Practical Common Lisp - learn Lisp!")))) ; gratuitous promotions (defvar *paste-maximum-size* 51200) ; in bytes @@ -111,71 +110,74 @@ (defparameter *serve-source* t) +;; once every this often, clear out the "used" captchas +(defparameter *used-captcha-release-time* (* 60 60 24)) + ;; You shouldn't need to edit below this line. ;; LINE (defparameter *display-paste-url* - (araneida:merge-url *paste-external-url* "display/")) + (merge-url *paste-external-url* "display/")) (defparameter *new-paste-url* - (araneida:merge-url *paste-external-url* "new")) + (merge-url *paste-external-url* "new")) (defparameter *list-paste-url* - (araneida:merge-url *paste-external-url* "list")) + (merge-url *paste-external-url* "list")) (defparameter *submit-paste-url* - (araneida:merge-url *paste-external-url* "submit")) + (merge-url *paste-external-url* "submit")) (defparameter *rss-url* - (araneida:merge-url *paste-external-url* "list.rss")) + (merge-url *paste-external-url* "list.rss")) (defparameter *rss-full-url* - (araneida:merge-url *paste-external-url* "list-full.rss")) + (merge-url *paste-external-url* "list-full.rss")) (defparameter *syndication-url* - (araneida:merge-url *paste-external-url* "syndication")) + (merge-url *paste-external-url* "syndication")) (defparameter *stats-url* - (araneida:merge-url *paste-external-url* "stats")) + (merge-url *paste-external-url* "stats")) (defparameter *css-url* - (araneida:merge-url *paste-external-url* "lisppaste.css")) + (merge-url *paste-external-url* "lisppaste.css")) (defparameter *recent-url* - (araneida:merge-url *paste-external-url* "recent")) + (merge-url *paste-external-url* "recent")) (defparameter *email-redirect-url* - (araneida:merge-url *paste-external-url* "email")) + (merge-url *paste-external-url* "email")) (defparameter *channel-select-url* - (araneida:merge-url *paste-external-url* "channels")) + (merge-url *paste-external-url* "channels")) (defparameter *404-urls* - (list (araneida:merge-url *paste-external-url* "favicon.ico") - (araneida:merge-url *paste-external-url* "robots.txt"))) + (list (merge-url *paste-external-url* "favicon.ico") + (merge-url *paste-external-url* "robots.txt"))) -(defparameter *main-system-server-url* (araneida:merge-url *paste-external-url* +(defparameter *main-system-server-url* (merge-url *paste-external-url* "system-server/")) -(defparameter *show-component-url* (araneida:merge-url *paste-external-url* +(defparameter *show-component-url* (merge-url *paste-external-url* "system-server/show/")) (defvar *paste-listener* - (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*) + (let ((fwd-url (copy-url *paste-external-url*)) + (fwd-old-url (copy-url *old-url*))) + (setf (url-port fwd-url) *internal-http-port*) ;; temporary fix! - (setf (araneida:url-host fwd-url) "127.0.0.1") - (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 + (setf (url-host fwd-url) "127.0.0.1") + (setf (url-port fwd-old-url) *internal-http-port*) + (make-instance #+sbcl 'serve-event-reverse-proxy-listener + #-sbcl 'threaded-reverse-proxy-listener :translations - `((,(araneida:urlstring *paste-external-url*) - ,(araneida:urlstring fwd-url)) - (,(araneida:urlstring *old-url*) - ,(araneida:urlstring fwd-old-url))) - :address #(127 0 0 1) - :port (araneida:url-port fwd-url)))) + `((,(urlstring *paste-external-url*) + ,(urlstring fwd-url)) + (,(urlstring *old-url*) + ,(urlstring fwd-old-url))) + :address #(0 0 0 0) + :port (url-port fwd-url)))) (defvar *default-nickname* "devpaste") (defvar *default-irc-server* "irc.freenode.net") --- /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 00:36:32 1.87 +++ /project/lisppaste/cvsroot/lisppaste2/web-server.lisp 2007/01/16 00:56:31 1.88 @@ -1,4 +1,4 @@ -;;;; $Id: web-server.lisp,v 1.87 2007/01/16 00:36:32 lisppaste Exp $ +;;;; $Id: web-server.lisp,v 1.88 2007/01/16 00:56:31 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -17,7 +17,7 @@ (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))))) + (urlstring (merge-url *display-paste-url* (prin1-to-string (paste-number paste))))) (defun find-paste (number) (find number *pastes* :key #'paste-number)) @@ -26,7 +26,7 @@ `(progn (funcall 'make-instance 'paste ,@arguments))) -(defclass lisppaste-basic-handler (araneida:handler) ()) +(defclass lisppaste-basic-handler (handler) ()) (defclass main-handler (lisppaste-basic-handler) ()) @@ -54,7 +54,7 @@ (defclass channel-select-handler (lisppaste-basic-handler) ()) -(defclass 404-handler (araneida:handler) ()) +(defclass 404-handler (handler) ()) (defvar *referer-hash* (make-hash-table :test #'equalp)) @@ -86,39 +86,12 @@ (remhash host *referer-hash*) (incf (gethash "Google" *referer-hash* 0) count))))) -(defmethod araneida:handle-request-response :around ((handler lisppaste-basic-handler) method request) +(defmethod 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) (unwind-protect - (progn - (let ((referer (car (araneida:request-header request :referer))) - (araneida::*default-url-defaults* (araneida:request-url request))) - (when (stringp referer) - (when (string= referer ": " :end1 2) - ;; Some maniac is sending ": http://paste.lisp.org/" - ;; as a referer. We need to strip that leading colon. - (format t "bogus referer ~S~%" referer) - (setf referer (subseq referer 2))) - (let ((url (ignore-errors (araneida:parse-urlstring referer nil)))) - (when url - (let ((real-host (araneida:url-host url)) - (split-host (split-sequence:split-sequence #\. (araneida:url-host url)))) - (if (or - (and (eql (length split-host) 3) - (string-equal (first split-host) "www") - (string-equal (second split-host) "google")) - (and (eql (length split-host) 4) - (string-equal (first split-host) "www") - (string-equal (second split-host) "google") - (or - (string-equal (third split-host) "co") - (string-equal (third split-host) "com")) - (eql (length (fourth split-host)) 2))) - (setf real-host "Google")) - (incf (gethash real-host *referer-hash* 0)) - (setf (gethash real-host *referer-example-hash*) url)))))) - (call-next-method)) + (call-next-method) (force-output *trace-output*)))) (defun make-css () @@ -157,131 +130,149 @@ (colorize:make-background-css "#F4F4F4") colorize:*coloring-css*))) -(defmethod araneida:handle-request-response ((handler css-handler) method request) - (araneida:request-send-headers request :expires 0 :content-type "text/css") - (araneida:html-stream - (araneida:request-stream request) +(defmethod handle-request-response ((handler css-handler) method request) + (request-send-headers request :expires 0 :content-type "text/css") + (html-stream + (request-stream request) (make-css))) +(defun rss-link-header () + <link rel="alternate" type="application/rss+xml" title="Lisppaste RSS" href=?(urlstring *rss-url*)/>) + (defun lisppaste-wrap-page (title &rest forms) - `(html - (head (title ,title) - #-nil - ((link :type "text/css" :rel "stylesheet" :href ,(araneida:url-path *css-url*))) - #+nil - ((style :type "text/css") - ,(make-css)) - ,(rss-link-header)) - (body - ((div :class "top-header") - ,title) - (p) - ,@forms - ,@(bottom-links)))) + (<html> + (<head> (<title> title) + <link type="text/css" rel="stylesheet" href=?(url-path *css-url*)/> + (rss-link-header)) + (<body> + (<div class="top-header"> title) + <p/> + forms + (bottom-links)))) + +(defun bottom-links () + (list + <p/> + (<div class="bottom-links"> + (<table width="100%"> + (<tr> + (<td id="main-link"> + (<a href=?(urlstring *paste-external-url*)> "Main page")) + (<td id="other-links"> + (<a href=?(urlstring *new-paste-url*)> "New paste") + " | " + (<a href=?(urlstring *list-paste-url*)> "List all pastes") + " | " + (<a href=?(urlstring *syndication-url*)> "Syndication") + " | " + (<a href="http://common-lisp.net/project/lisppaste/xml-rpc.html"> "XML-RPC") + (when *serve-source* + (list " | " + (<a href=?(urlstring (merge-url *show-component-url* "lisppaste"))> + "Source"))) + " | " + (<a href=?(urlstring *email-redirect-url*)> "Requests Email") + " | " + (<a href="http://www.common-lisp.net/project/lisppaste"> "Project home"))))) + (<i> "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively."))) (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) + (<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)> + (paste-title j))) + (<td valign="bottom"> " by " (paste-user j)) + (<td valign="bottom"> (paste-channel j)))) + (<tr> (<td colspan="3"> + (<center> (<b> (<a href=?(urlstring *list-paste-url*)> + "More recent pastes...")))))))) + +(defmethod handle-request-response ((handler recent-handler) method request) + (request-send-headers request :expires 0) + (xml-output-to-stream + (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 - (araneida:request-stream request) +(defmethod handle-request-response ((handler main-handler) method request) + (request-send-headers request :expires 0) + (xml-output-to-stream + (request-stream request) (lisppaste-wrap-page (format nil "~A pastebin" *paste-site-name*) - `((table :width "100%" :border 0 :cellpadding 2) - (tr (td ((div :class "small-header") "Recent pastes")) - ((td :align right) ((div :class "small-header") "Make a new paste"))) - (tr - ((td :valign top :width "40%") - ,(recent-paste-list-div) - (p) - ((div :class "small-header") "About lisppaste") - ((div :class "info-text") - "Lisppaste is a pastebot / pastebin / nopaste service with syntax highlighting, XML-RPC support, annotations, and more." - (p) - "Many times when working via IRC, people want to share a + (<table width="100%" border="0" cellpadding="2"> + (<tr> (<td> (<div class="small-header"> "Recent Pastes")) + (<td align="right"> (<div class="small-header"> "Make a new paste"))) + (<tr> (<td valign="top" width="40%"> + (recent-paste-list-div) + <p/> + (<div class="small-header"> "About lisppaste") + (<div class="info-text"> + "Lisppaste is a pastebot / pastebin / nopaste service with syntax highlighting, XML-RPC support, annotations, and more.") + <p/> + "Many times when working via IRC, people want to share a snippet of code with somebody else. However, just pasting the code into IRC creates a flood of text which is hard to read and scrolls by as discussion progresses." - (p) - "Thus, the pastebot was invented, which has a web form where + <p/> + "Thus, the pastebot was invented, which has a web form where users can paste code, and the URL of the paste is announced on the desired channel. Lisppaste is an advanced pastebot running on the IRC server " - ,(encode-for-pre *irc-network-name*) - " which has many unique features." - ,@(if *no-channel-pastes* - '((p) " It also allows pastes which are not announced on any channel, which + *irc-network-name* + " which has many unique features." + (when *no-channel-pastes* + (list + <p/> + "It also allows pastes which are not announced on any channel, which is useful for sections of code which need to be sent to a mailing list or are discussed in ways other than IRC.")) - (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)." - (p) - "Questions? Comments? Want lisppaste in your channel? " ((a :href ,(araneida:urlstring *email-redirect-url*)) "Email me") "." - )) - ((td :valign top :align right) - ((form :method post :action ,(araneida:urlstring *submit-paste-url*)) - ,(generate-new-paste-form :width 60)) - (p) - ((div :class "small-header") "Ads absolutely not by Google") - ((div :class "ads-text") - ,*ads*))) - - )))) + <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)." + <p/> + "Questions? Comments? Want lisppaste in your channel? " + (<a href=?(urlstring *email-redirect-url*)> "Email me") + ".") + (<td valign="top" align="right"> + (<form method="post" action=?(urlstring *submit-paste-url*)> + (generate-new-paste-form :width 60)) + <p/> + (<div class="small-header"> "Ads absolutely not by Google") + (<div class="ads-text"> *ads*))))))) (defun ban-log (user request) (log-event (format nil "Blocked attempt by ~S, IP ~S, (referred by ~S) to submit a paste.~%Request headers are: ~S.~%Request body is: ~S.~%" user - (car (araneida:request-header request :x-forwarded-for)) - (car (araneida:request-header request :referer)) - (araneida:request-headers request) - (araneida:request-body request)) + (car (request-header request :x-forwarded-for)) + (car (request-header request :referer)) + (request-headers request) + (request-body request)) :log-file *ban-log-file*)) -(defmethod araneida:handle-request-response :around +(defmethod handle-request-response :around ((handler submit-paste-handler) method request) - (let ((forwarded-for (car (araneida:request-header request :x-forwarded-for)))) + (let ((forwarded-for (car (request-header request :x-forwarded-for)))) (if (and forwarded-for (member forwarded-for *banned-ips* :test #'string-equal)) (progn (ban-log forwarded-for 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!")))))) + (request-send-headers request :expires 0) + (xml-output-to-stream + (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))) +(defmethod handle-request-response ((handler new-paste-handler) method request) + (let* ((annotate-string (body-param "annotate" (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 @@ -289,10 +280,10 @@ (find-if #'(lambda (e) (> (length e) 1)) (list (and (eql method :post) - (araneida:body-param "channel" - (araneida:request-body request))) - (substitute #\# #\/ (araneida:urlstring-unescape (araneida::request-unhandled-part request)) :test #'char=) - (concatenate 'string "#" (araneida:request-cookie request "CHANNEL")) + (body-param "channel" + (request-body request))) + (substitute #\# #\/ (urlstring-unescape (request-unhandled-part request)) :test #'char=) + (concatenate 'string "#" (request-cookie request "CHANNEL")) (and *no-channel-pastes* "None") ))))) @@ -300,55 +291,28 @@ ((and default-channel (or (and *no-channel-pastes* (string-equal default-channel "None")) (find default-channel *channels* :test #'string-equal))) - (araneida:request-send-headers request :expires 0 :set-cookie + (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 - (araneida:request-stream request) + (t (request-send-headers request :expires 0) + (xml-output-to-stream + (request-stream request) (lisppaste-wrap-page "Select a channel" - `((form :method post :action ,(araneida:urlstring *new-paste-url*)) - ((div :class "controls") - ((input :type "hidden" :name "annotate" :value ,annotate-string)) - "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")))))))))) - -(defun bottom-links () - `((p) - ((div :class "bottom-links") - ((table :width "100%") - (tr - ((td :id "main-link") - ((a :href ,(araneida:urlstring *paste-external-url*)) - "Main page") - ) - ((td :id "other-links") - ((a :href ,(araneida:urlstring *new-paste-url*)) "New paste") - " | " - ((a :href ,(araneida:urlstring *list-paste-url*)) "List all pastes") - " | " - ((a :href ,(araneida:urlstring *syndication-url*)) "Syndication") - " | " - ((a :href "http://common-lisp.net/project/lisppaste/xml-rpc.html") "XML-RPC") - ,@(if *serve-source* - `(" | " - ((a :href ,(araneida:urlstring (araneida:merge-url - *show-component-url* "lisppaste"))) "Source"))) - " | " - ((a :href ,(araneida:urlstring *email-redirect-url*)) "Requests Email") - " | " - ((a :href "http://common-lisp.net/project/lisppaste") "Project home"))))) - (i "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively."))) + (<form method="post" action=?(urlstring *new-paste-url*)> + (<div class="controls"> + <input type="hidden" name="annotate" value=?annotate-string /> + "Please select a channel to lisppaste to: " + (<select name="channel"> + (<option value=""> "") + (mapcar (lambda (e) + (<option value=?e> e)) + *channels*)) + <input type="submit" value="Submit"/>)))))))) [1497 lines skipped]

1 0