[cl-blog-cvs] CVS update: cl-blog/cl-blog.asd cl-blog/cl-blog.lisp cl-blog/trackback.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Wed Oct 20 01:30:22 UTC 2004
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 "<!--
+ ,@(if display-actions
+ (list (format nil "<!--
<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"
xmlns:dc=\"http://purl.org/dc/elements/1.1/\"
xmlns:trackback=\"http://madskills.com/public/xml/rss/module/trackback/\">
@@ -491,7 +495,7 @@
trackback:ping=\"~A\" />
</rdf:RDF>
-->
-" (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
More information about the Cl-blog-cvs
mailing list