[cl-blog-cvs] CVS update: cl-blog/trackback.lisp cl-blog/cl-blog.lisp cl-blog/variable.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Oct 19 01:33:08 UTC 2004
Update of /project/cl-blog/cvsroot/cl-blog
In directory common-lisp.net:/tmp/cvs-serv4142
Modified Files:
cl-blog.lisp variable.lisp
Added Files:
trackback.lisp
Log Message:
Initial trackback support; more integration to come
Date: Tue Oct 19 03:33:07 2004
Author: bmastenbrook
Index: cl-blog/cl-blog.lisp
diff -u cl-blog/cl-blog.lisp:1.1.1.1 cl-blog/cl-blog.lisp:1.2
--- cl-blog/cl-blog.lisp:1.1.1.1 Sun Oct 17 22:40:42 2004
+++ cl-blog/cl-blog.lisp Tue Oct 19 03:33:06 2004
@@ -7,7 +7,14 @@
(title :initarg :title :accessor blog-entry-title)
(time :initarg :time :accessor blog-entry-time)
(revised-time :initarg :revised-time :initform 0 :accessor blog-entry-revised-time)
- (contents :initarg :contents :accessor blog-entry-contents)))
+ (contents :initarg :contents :accessor blog-entry-contents)
+ (trackbacks :initarg :trackbacks :accessor blog-entry-trackbacks :initform nil)))
+
+(defclass trackback ()
+ ((title :initarg :title :accessor trackback-title)
+ (url :initarg :url :accessor trackback-url)
+ (excerpt :initarg :excerpt :accessor trackback-excerpt)
+ (blog-name :initarg :blog-name :accessor trackback-blog-name)))
(defvar *blog-entries* nil)
@@ -151,12 +158,20 @@
(merge-pathnames (prin1-to-string (blog-entry-number entry))
*entry-path*))
+(defun make-trackback-constructor (trackback)
+ (with-slots (title url excerpt blog-name) trackback
+ `(make-instance 'trackback
+ :title ,title
+ :url ,url
+ :excerpt ,excerpt
+ :blog-name ,blog-name)))
+
(defun blog-entry-write-to-file (entry)
(ensure-directories-exist (blog-entry-path entry))
(with-open-file (file (blog-entry-path entry)
:direction :output
:if-exists :supersede)
- (with-slots (category user number title time revised-time contents) entry
+ (with-slots (category user number title time revised-time contents trackbacks) entry
(when (find-package :cl-blog-nothing)
(delete-package (find-package :cl-blog-nothing)))
(let ((*package* (make-package :cl-blog-nothing)))
@@ -170,7 +185,8 @@
:title ,title
:time ,time
:revised-time ,revised-time
- :contents ,contents)
+ :contents ,contents
+ :trackbacks (list ,@(mapcar #'make-trackback-constructor trackbacks)))
*blog-entries*) file)
(delete-package *package*))))))
@@ -260,6 +276,11 @@
:initform (entry-from-regexp-validator "^(\\d+)$")
:accessor validate-lambda)))
+(defclass trackback-handler (handler validate-unhandled-part-mixin)
+ ((validate-lambda :initarg :validate-lambda
+ :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)
((validate-lambda :initarg :validate-lambda
:initform (entry-from-regexp-validator "^(\\d+)$")
@@ -441,6 +462,10 @@
(urlstring (merge-url *display-entry-url*
(prin1-to-string (blog-entry-number entry)))))
+(defun entry-trackback (entry)
+ (urlstring (merge-url *trackback-url*
+ (prin1-to-string (blog-entry-number entry)))))
+
(defun edit-entry-link (entry)
(urlstring
(merge-url
@@ -455,6 +480,18 @@
(defun format-entry (entry &key (display-link t) (display-actions t))
`((div :class "entry")
+ ,(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/\">
+<rdf:Description
+ rdf:about=\"~A\"
+ dc:identifier=\"~A\"
+ dc:title=\"~A\"
+ trackback:ping=\"~A\" />
+</rdf:RDF>
+-->
+" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry))
((div :class "entry-head")
(h2
,(blog-entry-title entry))
@@ -733,6 +770,40 @@
'(((div :id "entry-form")
(h2 "Please fill in all fields!"))))))))))
+(defmethod handle-request-response ((handler trackback-handler) (method (eql :post)) request)
+ (with-body-params ((title "title")
+ (url "url")
+ (excerpt "excerpt")
+ (blog-name "blog_name"))
+ request
+ (request-send-headers request :expires 0
+ :content-type "text/xml; charset=iso-8859-1")
+ (let ((entry
+ (let ((str (elt (nth-value 1 (cl-ppcre:scan-to-strings
+ "^(\\d+)$" (request-unhandled-part request))) 0)))
+ (and str (find-entry (parse-integer str))))))
+ (if (not entry)
+ (format (request-stream request)
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
+<response>
+<error>1</error>
+<message>The specified blog entry could not be found.</message>
+</response>
+")
+ (let ((trackback (make-instance 'trackback
+ :title title :url url
+ :excerpt excerpt :blog-name blog-name)))
+ (setf (blog-entry-trackbacks entry)
+ (nconc (blog-entry-trackbacks entry) (list trackback)))
+ (blog-entry-write-to-file entry)
+ (format (request-stream request)
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
+<response>
+<error>0</error>
+</response>
+")))
+ t)))
+
(defmethod handle-request-response ((handler display-entry-handler) method request)
(let ((entry
(let ((str (elt (nth-value 1 (cl-ppcre:scan-to-strings
@@ -794,3 +865,7 @@
(install-handler (http-listener-handler *listener*)
(make-instance 'email-redirect-handler)
(urlstring *email-redirect-url*) t)
+
+(install-handler (http-listener-handler *listener*)
+ (make-instance 'trackback-handler)
+ (urlstring *trackback-url*) nil)
\ No newline at end of file
Index: cl-blog/variable.lisp
diff -u cl-blog/variable.lisp:1.1.1.1 cl-blog/variable.lisp:1.2
--- cl-blog/variable.lisp:1.1.1.1 Sun Oct 17 22:40:42 2004
+++ cl-blog/variable.lisp Tue Oct 19 03:33:06 2004
@@ -38,7 +38,7 @@
(defparameter *blog-url-root*
(merge-url (make-url :scheme "http"
- :host "localhost")
+ :host "localhost" :port 8080)
"/blog/"))
(defparameter *internal-http-port* 8080)
@@ -72,8 +72,10 @@
#-sbcl
'araneida:threaded-reverse-proxy-listener
:translations
+ #+nil
`((,(araneida:urlstring *blog-url-root*)
,(araneida:urlstring fwd-url)))
+ #-nil nil
:address #(0 0 0 0)
:port (araneida:url-port fwd-url))))
@@ -90,3 +92,5 @@
(defparameter *delete-entry-url* (merge-url *blog-url-root* "delete/"))
(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
More information about the Cl-blog-cvs
mailing list