October 2004 - cl-blog-cvs@common-lisp.net

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 29 Oct '04

29 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv20126 Modified Files: cl-blog.lisp Log Message: change trackback into a div, fix editing entries, conditionalize SBCL banner Date: Fri Oct 29 16:16:57 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.11 cl-blog/cl-blog.lisp:1.12 --- cl-blog/cl-blog.lisp:1.11 Fri Oct 22 03:13:47 2004 +++ cl-blog/cl-blog.lisp Fri Oct 29 16:16:55 2004 @@ -141,6 +141,8 @@ ((a :href ,(archives-url :category i :rss t)) "(RSS)") ))) + #+sbcl + ; who says reader macros in HTML generation are useless? ((p :align "center") ((a :href "http://www.sbcl.org/" :border "0") ((img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0")))) @@ -651,34 +653,35 @@ (number "number") (preview "preview")) request - (let ((entry (copy-entry (find-entry (parse-integer number))))) - (setf (blog-entry-contents entry) contents) - (setf (blog-entry-category entry) category) - (setf (blog-entry-title entry) title) + (let ((entry (find-entry (parse-integer number)))) (request-send-headers request :expires 0 :content-type "text/html; charset=iso-8859-1") (send-doctype request) (html-stream (request-stream request) (if (equalp preview "Preview") - (blog-wrap-page "Preview edit" - (list - (format-entry entry :display-actions nil) - '(p) - (blog-entry-form - (urlstring - (merge-url - *edit-entry-url* - (request-unhandled-part request))) - :number (prin1-to-string (blog-entry-number entry)) - :title title - :category category - :contents contents - :submit-button-text "Edit entry"))) - (if (not (find 0 (list title category contents) :key #'length)) - (progn - (change-blog-entry entry :title title :category category :contents contents) - (blog-wrap-page "Changed" + (let ((entry (copy-entry entry))) + (setf (blog-entry-contents entry) contents) + (setf (blog-entry-category entry) category) + (setf (blog-entry-title entry) title) + (blog-wrap-page "Preview edit" + (list + (format-entry entry :display-actions nil) + '(p) + (blog-entry-form + (urlstring + (merge-url + *edit-entry-url* + (request-unhandled-part request))) + :number (prin1-to-string (blog-entry-number entry)) + :title title + :category category + :contents contents + :submit-button-text "Edit entry")))) + (if (not (find 0 (list title category contents) :key #'length)) + (progn + (change-blog-entry entry :title title :category category :contents contents) + (blog-wrap-page "Changed" '(((div :id "entry-form") (h2 "Your entry has been modified."))))) (blog-wrap-page "Not changed" @@ -803,12 +806,13 @@ (blog-wrap-page "Posted" `(((div :id "entry-form") (h2 "Your new entry has been posted.") - ,@(when urls-pinged - `("Trackback pings have been sent to the following URLs:" - (ul - ,@(mapcar #'(lambda (url) - `(li ((a :href ,url) ,url))) - urls-pinged)))) + ((div :class "trackback") + ,@(when urls-pinged + `("Trackback pings have been sent to the following URLs:" + (ul + ,@(mapcar #'(lambda (url) + `(li ((a :href ,url) ,url))) + urls-pinged))))) )))) (blog-wrap-page "Not posted" '(((div :id "entry-form") @@ -863,7 +867,7 @@ *blog-short-name* (blog-entry-title entry)) (list* (format-entry entry) - `(p "Trackback pings for this entry are listed below. The URL to ping for this entry is: " (b ,(entry-trackback entry))) + `((div :class "trackback") "Trackback pings for this entry are listed below. The URL to ping for this entry is: " (b ,(entry-trackback entry))) (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) (defclass email-redirect-handler (handler) ())

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 22 Oct '04

22 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv22276 Modified Files: cl-blog.lisp Log Message: more bugfix! Date: Fri Oct 22 03:13:47 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.10 cl-blog/cl-blog.lisp:1.11 --- cl-blog/cl-blog.lisp:1.10 Fri Oct 22 03:13:09 2004 +++ cl-blog/cl-blog.lisp Fri Oct 22 03:13:47 2004 @@ -141,7 +141,7 @@ ((a :href ,(archives-url :category i :rss t)) "(RSS)") ))) - (p :align "center" + ((p :align "center") ((a :href "http://www.sbcl.org/" :border "0") ((img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0")))) )

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 22 Oct '04

22 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv22252 Modified Files: cl-blog.lisp Log Message: Center it Date: Fri Oct 22 03:13:09 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.9 cl-blog/cl-blog.lisp:1.10 --- cl-blog/cl-blog.lisp:1.9 Fri Oct 22 03:12:23 2004 +++ cl-blog/cl-blog.lisp Fri Oct 22 03:13:09 2004 @@ -141,9 +141,9 @@ ((a :href ,(archives-url :category i :rss t)) "(RSS)") ))) - (p) - ((a :href "http://www.sbcl.org/" :border "0") - ((img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0"))) + (p :align "center" + ((a :href "http://www.sbcl.org/" :border "0") + ((img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0")))) ) ((div :id "content") ,@body))

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 22 Oct '04

22 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv22228 Modified Files: cl-blog.lisp Log Message: bug fix woot! Date: Fri Oct 22 03:12:23 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.8 cl-blog/cl-blog.lisp:1.9 --- cl-blog/cl-blog.lisp:1.8 Fri Oct 22 03:10:39 2004 +++ cl-blog/cl-blog.lisp Fri Oct 22 03:12:23 2004 @@ -143,7 +143,7 @@ ))) (p) ((a :href "http://www.sbcl.org/" :border "0") - (img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0")) + ((img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0"))) ) ((div :id "content") ,@body))

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp cl-blog/variable.lisp
by Brian Mastenbrook 22 Oct '04

22 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv22202 Modified Files: cl-blog.lisp variable.lisp Log Message: Add a SBCL link! Date: Fri Oct 22 03:10:39 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.7 cl-blog/cl-blog.lisp:1.8 --- cl-blog/cl-blog.lisp:1.7 Fri Oct 22 03:05:58 2004 +++ cl-blog/cl-blog.lisp Fri Oct 22 03:10:39 2004 @@ -141,6 +141,9 @@ ((a :href ,(archives-url :category i :rss t)) "(RSS)") ))) + (p) + ((a :href "http://www.sbcl.org/" :border "0") + (img :src "http://www.sbcl.org/sbclbutton.png" :alt "(get 'sbcl)" :border "0")) ) ((div :id "content") ,@body)) Index: cl-blog/variable.lisp diff -u cl-blog/variable.lisp:1.3 cl-blog/variable.lisp:1.4 --- cl-blog/variable.lisp:1.3 Fri Oct 22 03:05:58 2004 +++ cl-blog/variable.lisp Fri Oct 22 03:10:39 2004 @@ -39,10 +39,11 @@ (defparameter *blog-url-root* (merge-url (make-url :scheme "http" - :host "www.iscblog.info") + :host "localhost" + :port 8080) "/blog/")) -(defparameter *internal-http-port* 1082) +(defparameter *internal-http-port* 8080) ;;; You shouldn't need to edit below this line ;;; LINE

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp cl-blog/variable.lisp
by Brian Mastenbrook 22 Oct '04

22 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv22119 Modified Files: cl-blog.lisp variable.lisp Log Message: Remove unnecessary *no-css* now that stylesheets are fixed Date: Fri Oct 22 03:05:58 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.6 cl-blog/cl-blog.lisp:1.7 --- cl-blog/cl-blog.lisp:1.6 Wed Oct 20 03:42:11 2004 +++ cl-blog/cl-blog.lisp Fri Oct 22 03:05:58 2004 @@ -76,36 +76,27 @@ ""))) (encode-for-pre (urlstring url)))) -(defvar *no-css* nil) - (defvar *use-editor* nil) -(defclass no-cell-phone-css-mixin () ()) +(defclass use-htmlarea-mixin () ()) -(defmethod handle-request-response :around ((handler no-cell-phone-css-mixin) method request) - (if (some #'(lambda (e) (search "NetFront" e)) (request-header request :user-agent)) - (let ((*no-css* t) - (*use-editor* nil)) - (call-next-method)) - (if (some #'(lambda (e) (or - (and (search "Gecko" e) - (not (search "WebKit" e))) - (search "MSIE" e))) - (request-header request :user-agent)) - (let ((*no-css* nil) - (*use-editor* (and *allow-html-editor* t))) +(defmethod handle-request-response :around ((handler use-htmlarea-mixin) method request) + (if (some #'(lambda (e) (or + (and (search "Gecko" e) + (not (search "WebKit" e))) + (search "MSIE" e))) + (request-header request :user-agent)) + (let ((*use-editor* (and *allow-html-editor* t))) (call-next-method)) - (call-next-method)))) + (call-next-method))) (defun blog-wrap-page (title body) `(html (head (title ,title) - ,@(unless *no-css* - (loop for style in *page-css* + ,@(loop for style in *page-css* with primary = t collect `((link :rel ,(if primary "stylesheet" "alternate stylesheet") :title ,(car style) :type "text/css" :href ,(cdr style))) do (setf primary nil)) - ) ,@(if *use-editor* '(((script :type "text/javascript") "_editor_url = \"/htmlarea/\"; @@ -248,11 +239,11 @@ (defclass validate-unhandled-part-mixin () ((validate-lambda :initarg :validate-lambda :initform (constantly t) :accessor validate-lambda))) -(defclass main-handler (handler no-cell-phone-css-mixin) ()) +(defclass main-handler (handler use-htmlarea-mixin) ()) (defclass authenticate-mixin () ()) -(defclass new-entry-handler (handler authenticate-mixin no-cell-phone-css-mixin) ()) +(defclass new-entry-handler (handler authenticate-mixin use-htmlarea-mixin) ()) (defun entry-from-regexp-validator (regexp) (lambda (unhandled-part) @@ -263,12 +254,12 @@ 0)))) (and str (find-entry (parse-integer str)))))) -(defclass display-entry-handler (handler validate-unhandled-part-mixin no-cell-phone-css-mixin) +(defclass display-entry-handler (handler validate-unhandled-part-mixin use-htmlarea-mixin) ((validate-lambda :initarg :validate-lambda :initform (entry-from-regexp-validator "^(\\d+)$") :accessor validate-lambda))) -(defclass edit-entry-handler (handler validate-unhandled-part-mixin authenticate-mixin no-cell-phone-css-mixin) +(defclass edit-entry-handler (handler validate-unhandled-part-mixin authenticate-mixin use-htmlarea-mixin) ((validate-lambda :initarg :validate-lambda :initform (entry-from-regexp-validator "^(\\d+)$") :accessor validate-lambda))) @@ -278,7 +269,7 @@ :initform (entry-from-regexp-validator "^(\\d+)$") :accessor validate-lambda))) -(defclass delete-entry-handler (handler validate-unhandled-part-mixin authenticate-mixin no-cell-phone-css-mixin) +(defclass delete-entry-handler (handler validate-unhandled-part-mixin authenticate-mixin use-htmlarea-mixin) ((validate-lambda :initarg :validate-lambda :initform (entry-from-regexp-validator "^(\\d+)$") :accessor validate-lambda))) @@ -292,7 +283,7 @@ 0))) (and str (find str *categories* :test #'string-equal)))))) -(defclass archives-handler (handler no-cell-phone-css-mixin #+nil validate-unhandled-part-mixin) +(defclass archives-handler (handler use-htmlarea-mixin #+nil validate-unhandled-part-mixin) (#+nil (validate-lambda :initarg :validate-lambda :initform (category-from-regexp-validator "^/(\\w+)$") @@ -921,4 +912,4 @@ (install-handler (http-listener-handler *listener*) (make-instance 'trackback-handler) - (urlstring *trackback-url*) nil) \ No newline at end of file + (urlstring *trackback-url*) nil) Index: cl-blog/variable.lisp diff -u cl-blog/variable.lisp:1.2 cl-blog/variable.lisp:1.3 --- cl-blog/variable.lisp:1.2 Tue Oct 19 03:33:06 2004 +++ cl-blog/variable.lisp Fri Oct 22 03:05:58 2004 @@ -1,12 +1,12 @@ (in-package :cl-blog) -(defparameter *blog-short-name* "A CL Blog!") +(defparameter *blog-short-name* "Instant Social Conversion") (defparameter *blog-subtitle* "Notes on technology and politics") -(defparameter *users* '("a-user")) +(defparameter *users* '("chandler" "number6")) -(defparameter *owner-email* "owner@domain") +(defparameter *owner-email* "chandler(a)unmutual.info") (defparameter *people-links* '(("http://planet.lisp.org/" . "Planet Lisp") @@ -30,7 +30,8 @@ (defparameter *allow-html-editor* t) ; if non-nil, use HTMLArea at /htmlarea/ ; for browsers which support it -(defparameter *categories* '("Technology" +(defparameter *categories* '("Politics" + "Technology" "Personal" "Education" "Lisp" @@ -38,10 +39,10 @@ (defparameter *blog-url-root* (merge-url (make-url :scheme "http" - :host "localhost" :port 8080) + :host "www.iscblog.info") "/blog/")) -(defparameter *internal-http-port* 8080) +(defparameter *internal-http-port* 1082) ;;; You shouldn't need to edit below this line ;;; LINE @@ -72,11 +73,9 @@ #-sbcl 'araneida:threaded-reverse-proxy-listener :translations - #+nil `((,(araneida:urlstring *blog-url-root*) ,(araneida:urlstring fwd-url))) - #-nil nil - :address #(0 0 0 0) + :address #(127 0 0 1) :port (araneida:url-port fwd-url)))) (defparameter *new-entry-url* (merge-url *blog-url-root* "new")) @@ -93,4 +92,4 @@ (defparameter *email-redirect-url* (merge-url *blog-url-root* "email")) -(defparameter *trackback-url* (merge-url *blog-url-root* "trackback/")) \ No newline at end of file +(defparameter *trackback-url* (merge-url *blog-url-root* "trackback/"))

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 20 Oct '04

20 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv3159 Modified Files: cl-blog.lisp Log Message: LESS STUPID LINKAGE Date: Wed Oct 20 03:42:11 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.5 cl-blog/cl-blog.lisp:1.6 --- cl-blog/cl-blog.lisp:1.5 Wed Oct 20 03:39:25 2004 +++ cl-blog/cl-blog.lisp Wed Oct 20 03:42:11 2004 @@ -869,7 +869,7 @@ *blog-short-name* (blog-entry-title entry)) (list* (format-entry entry) - `(p "Trackback pings for this entry are listed below. The URL to ping for this entry is: " ((a :href ,(entry-trackback entry)) ,(entry-trackback entry))) + `(p "Trackback pings for this entry are listed below. The URL to ping for this entry is: " (b ,(entry-trackback entry))) (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) (defclass email-redirect-handler (handler) ())

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 20 Oct '04

20 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv3127 Modified Files: cl-blog.lisp Log Message: LESS (format t ...) Date: Wed Oct 20 03:39:25 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.4 cl-blog/cl-blog.lisp:1.5 --- cl-blog/cl-blog.lisp:1.4 Wed Oct 20 03:30:09 2004 +++ cl-blog/cl-blog.lisp Wed Oct 20 03:39:25 2004 @@ -248,13 +248,7 @@ (defclass validate-unhandled-part-mixin () ((validate-lambda :initarg :validate-lambda :initform (constantly t) :accessor validate-lambda))) -(defclass timing-mixin () ()) - -(defmethod handle-request-response :around ((handler timing-mixin) method request) - (format t "user-agent is ~S~%" (request-header request :user-agent)) - (call-next-method)) - -(defclass main-handler (handler timing-mixin no-cell-phone-css-mixin) ()) +(defclass main-handler (handler no-cell-phone-css-mixin) ()) (defclass authenticate-mixin () ()) @@ -769,7 +763,6 @@ ;; Right now, trackback.lisp is only present on SBCL. #+sbcl (let ((urls (search-for-trackbacks-for-text (blog-entry-contents entry)))) - (format t "urls is ~S~%" urls) (loop for url in urls for ping = (trackback:autodetect-ping-for-url url) if ping

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.asd cl-blog/cl-blog.lisp cl-blog/trackback.lisp
by Brian Mastenbrook 20 Oct '04

20 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv2156 Modified Files: cl-blog.asd cl-blog.lisp trackback.lisp Log Message: Final details on implementation of trackback ping Date: Wed Oct 20 03:30:11 2004 Author: bmastenbrook Index: cl-blog/cl-blog.asd diff -u cl-blog/cl-blog.asd:1.1.1.1 cl-blog/cl-blog.asd:1.2 --- cl-blog/cl-blog.asd:1.1.1.1 Sun Oct 17 22:40:42 2004 +++ cl-blog/cl-blog.asd Wed Oct 20 03:30:09 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: cl-blog.asd,v 1.1.1.1 2004/10/17 20:40:42 bmastenbrook Exp $ +;;;; $Id: cl-blog.asd,v 1.2 2004/10/20 01:30:09 bmastenbrook Exp $ ;;;; $Source: /project/cl-blog/cvsroot/cl-blog/cl-blog.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -20,4 +20,5 @@ :cl-base64 :md5 :html-encode :cl-ppcre) :components ((:file "package") (:file "variable" :depends-on ("package")) - (:file "cl-blog" :depends-on ("package" "variable")))) \ No newline at end of file + #+sbcl (:file "trackback") + (:file "cl-blog" :depends-on ("package" "variable" #+sbcl "trackback")))) \ No newline at end of file Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.3 cl-blog/cl-blog.lisp:1.4 --- cl-blog/cl-blog.lisp:1.3 Tue Oct 19 03:38:12 2004 +++ cl-blog/cl-blog.lisp Wed Oct 20 03:30:09 2004 @@ -14,6 +14,7 @@ ((title :initarg :title :accessor trackback-title) (url :initarg :url :accessor trackback-url) (excerpt :initarg :excerpt :accessor trackback-excerpt) + (time :initarg :time :accessor trackback-time) (blog-name :initarg :blog-name :accessor trackback-blog-name))) (defvar *blog-entries* nil) @@ -159,11 +160,12 @@ *entry-path*)) (defun make-trackback-constructor (trackback) - (with-slots (title url excerpt blog-name) trackback + (with-slots (title url excerpt time blog-name) trackback `(make-instance 'trackback :title ,title :url ,url :excerpt ,excerpt + :time ,time :blog-name ,blog-name))) (defun blog-entry-write-to-file (entry) @@ -230,7 +232,8 @@ :time (get-universal-time) :contents contents))) (push new-entry *blog-entries*) - (blog-entry-write-to-file new-entry))) + (blog-entry-write-to-file new-entry) + new-entry)) (defun change-blog-entry (entry &key (category (blog-entry-category entry)) (title (blog-entry-title entry)) @@ -480,7 +483,8 @@ (defun format-entry (entry &key (display-link t) (display-actions t)) `((div :class "entry") - ,(format nil " -" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry)) +" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry)))) ((div :class "entry-head") (h2 ,(blog-entry-title entry)) @@ -514,7 +518,10 @@ `(((div :class "entry-footer") ,@(if display-link `(((a :class "entry-footer" :href ,(entry-link entry)) - "Permanent Link"))) + ,(if (blog-entry-trackbacks entry) + (format nil "Permanent Link (~A)" + (length (blog-entry-trackbacks entry))) + "Permanent Link")))) " | " ((a :class "entry-footer" :href ,(edit-entry-link entry)) "Edit") @@ -525,11 +532,12 @@ (defun format-trackback (trackback) `((div :class "entry") ((div :class "entry-head") - ((:a :href ,(encode-for-http (trackback-url trackback))) + ((:a :href ,(trackback-url trackback)) ,(encode-for-pre (trackback-title trackback))) ((div :class "entry-data") "From " - ,(encode-for-pre (trackback-blog-name trackback)) + (i ,(encode-for-pre (trackback-blog-name trackback))) + " on " ,(format-entry-date (trackback-time trackback)) )) ((div :class "entry-text") ,(encode-for-pre (trackback-excerpt trackback))) @@ -744,6 +752,34 @@ (request-stream request) `(html (body (h1 "No page for you!")))))))) +(defun search-for-trackbacks-for-text (text) + (let ((url-regexp "(?i)(http://[^ \"]+)([ .,)!?\"]|$)")) + (loop for (match new-begin) = (multiple-value-list (cl-ppcre:scan url-regexp text)) + for url = nil + while match + do (let ((got-url (elt (nth-value 1 (cl-ppcre:scan-to-strings url-regexp text)) 0))) + (setf text (subseq text new-begin)) + (setf url got-url)) + if url collect url))) + +(defun strip-html (text) + (cl-ppcre:regex-replace-all "<(\"[^\"]+\"|[^>\"])*>" text "")) + +(defun autotrackback-entry (entry) + ;; Right now, trackback.lisp is only present on SBCL. + #+sbcl + (let ((urls (search-for-trackbacks-for-text (blog-entry-contents entry)))) + (format t "urls is ~S~%" urls) + (loop for url in urls + for ping = (trackback:autodetect-ping-for-url url) + if ping + do (trackback:ping ping :title (urlstring-escape (blog-entry-title entry)) + :url (urlstring-escape (entry-link entry)) + :excerpt (urlstring-escape (strip-html (blog-entry-contents entry))) + :blog-name *blog-short-name*) + if ping + collect url))) + (defmethod handle-request-response ((handler new-entry-handler) (method (eql :post)) request) (with-body-params ((title "title") (category "category") @@ -774,11 +810,19 @@ :contents contents ))) (if (not (find 0 (list title category contents) :key #'length)) - (progn - (new-blog-entry :title title :category category :contents contents) - (blog-wrap-page "Posted" - '(((div :id "entry-form") - (h2 "Your new entry has been posted."))))) + (let* ((entry + (new-blog-entry :title title :category category :contents contents)) + (urls-pinged (ignore-errors (autotrackback-entry entry)))) + (blog-wrap-page "Posted" + `(((div :id "entry-form") + (h2 "Your new entry has been posted.") + ,@(when urls-pinged + `("Trackback pings have been sent to the following URLs:" + (ul + ,@(mapcar #'(lambda (url) + `(li ((a :href ,url) ,url))) + urls-pinged)))) + )))) (blog-wrap-page "Not posted" '(((div :id "entry-form") (h2 "Please fill in all fields!")))))))))) @@ -805,7 +849,8 @@ ") (let ((trackback (make-instance 'trackback :title title :url url - :excerpt excerpt :blog-name blog-name))) + :excerpt excerpt :time (get-universal-time) + :blog-name blog-name))) (setf (blog-entry-trackbacks entry) (nconc (blog-entry-trackbacks entry) (list trackback))) (blog-entry-write-to-file entry) @@ -830,8 +875,9 @@ (blog-wrap-page (format nil "~A: ~A" *blog-short-name* (blog-entry-title entry)) - (cons (format-entry entry) - (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) + (list* (format-entry entry) + `(p "Trackback pings for this entry are listed below. The URL to ping for this entry is: " ((a :href ,(entry-trackback entry)) ,(entry-trackback entry))) + (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) (defclass email-redirect-handler (handler) ()) Index: cl-blog/trackback.lisp diff -u cl-blog/trackback.lisp:1.1 cl-blog/trackback.lisp:1.2 --- cl-blog/trackback.lisp:1.1 Tue Oct 19 03:33:06 2004 +++ cl-blog/trackback.lisp Wed Oct 20 03:30:09 2004 @@ -1,8 +1,8 @@ ;;;; trackback.lisp - standalone trackback ping (defpackage :trackback - (:use :common-lisp :sb-bsd-sockets :split-sequence) - (:export :ping)) + (:use :common-lisp :sb-bsd-sockets :split-sequence :cl-ppcre) + (:export :ping :autodetect-ping-for-url)) (in-package :trackback) (defun encode (str table) @@ -35,31 +35,54 @@ (string (code-char 13)) (string (code-char 10))))) -(defun url-post (url content-type content) - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url))) - (declare (ignore port)) +(defun open-socket (host port) + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (socket-connect - s (car (host-ent-addresses (get-host-by-name (url-host url)))) - (url-port url)) - (let ((stream (socket-make-stream s :input t :output t :buffering :full))) - ;; we are exceedingly unportable about proper line-endings here. - ;; Anyone wishing to run this under non-SBCL should take especial care - (format stream "POST ~A HTTP/1.1~AHost: ~A~AUser-Agent: CLiki Bot~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content) - (force-output stream) - (list - (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) - (loop for line = (read-line stream nil nil) - until (or (null line) (eql (length line) 0) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) - stream)))) + s (car (host-ent-addresses (get-host-by-name host))) + port) + (socket-make-stream s :input t :output t :buffering :full))) + +(defun http-post (url content-type content) + (let* ((host (url-host url)) + (port (url-port url)) + (stream (open-socket host port))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "POST ~A HTTP/1.1~AHost: ~A~AUser-Agent: CLiki Bot~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (eql (length line) 0) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) + +(defun http-get (url) + (let* ((host (url-host url)) + (port (url-port url)) + (stream (open-socket host port))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (zerop (length line)) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) (defun mini-xml-read (xml-string) (let ((cur-xml (list nil)) @@ -120,7 +143,7 @@ (handler-case (sb-ext:with-timeout 5 (destructuring-bind (response headers stream) - (url-post trackback-url "application/x-www-form-urlencoded" + (http-post trackback-url "application/x-www-form-urlencoded" (format nil "~{url=~A&title=~A&excerpt=~A&blog_name=~A~}" (mapcar #'encode-for-url (list url title excerpt blog-name)))) @@ -161,4 +184,37 @@ (values nil "Unknown error") t))) (if stream (close stream))))) - (sb-ext:timeout () (values nil "Recieved timeout"))))) + (serious-condition () (return-from ping nil))))) + +(defmacro aif2 (test-form if-form &optional else-form) + (let ((test-val (gensym))) + `(multiple-value-bind (,test-val it) ,test-form + (if ,test-val + ,if-form + ,@(if else-form (list else-form)))))) + +(defun autodetect-ping-for-url (url) + (handler-case + (sb-ext:with-timeout 2 + (destructuring-bind (response headers stream) (http-get url) + (declare (ignore headers)) + (unwind-protect + (if (not (eql response 200)) + (return-from autodetect-ping-for-url nil) + (progn + (loop for line = (read-line stream nil nil) + with in-rdf = nil + with found = nil + while line + do (progn + (if (scan "(?i)<rdf:description" line) + (setf in-rdf t)) + (aif2 (scan-to-strings "(?i)rdf:about=\"(.+)\"" line) + (if (string= (elt it 0) url) + (setf found t))) + (aif2 (and found (scan-to-strings "(?i)trackback:ping=\"(.+)\"" line)) + (return-from autodetect-ping-for-url (elt it 0))) + (when (scan "(?i)</rdf:rdf>" line) + (setf in-rdf nil) + (setf found nil))))))))) + (serious-condition () (return-from autodetect-ping-for-url nil)))) \ No newline at end of file

1 0

[cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp
by Brian Mastenbrook 19 Oct '04

19 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv4188 Modified Files: cl-blog.lisp Log Message: More integration Date: Tue Oct 19 03:38:12 2004 Author: bmastenbrook Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.2 cl-blog/cl-blog.lisp:1.3 --- cl-blog/cl-blog.lisp:1.2 Tue Oct 19 03:33:06 2004 +++ cl-blog/cl-blog.lisp Tue Oct 19 03:38:12 2004 @@ -522,6 +522,19 @@ ((a :class "entry-footer" :href ,(delete-entry-link entry)) "Delete")))))) +(defun format-trackback (trackback) + `((div :class "entry") + ((div :class "entry-head") + ((:a :href ,(encode-for-http (trackback-url trackback))) + ,(encode-for-pre (trackback-title trackback))) + ((div :class "entry-data") + "From " + ,(encode-for-pre (trackback-blog-name trackback)) + )) + ((div :class "entry-text") + ,(encode-for-pre (trackback-excerpt trackback))) + )) + (defmethod handle-request-response ((handler main-handler) method request) (request-send-headers request :expires 0 :content-type "text/html; charset=iso-8859-1") @@ -817,7 +830,8 @@ (blog-wrap-page (format nil "~A: ~A" *blog-short-name* (blog-entry-title entry)) - (list (format-entry entry)))))) + (cons (format-entry entry) + (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) (defclass email-redirect-handler (handler) ())

1 0