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