cl-blog-cvs

cl-blog-cvs@common-lisp.net

15 discussions

[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

[cl-blog-cvs] CVS update: cl-blog/trackback.lisp cl-blog/cl-blog.lisp cl-blog/variable.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-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 " +" (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

1 0

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

17 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv17882 Modified Files: .cvsignore Log Message: Ignore local changes to variable.lisp Date: Sun Oct 17 22:41:25 2004 Author: bmastenbrook Index: cl-blog/.cvsignore diff -u cl-blog/.cvsignore:1.1.1.1 cl-blog/.cvsignore:1.2 --- cl-blog/.cvsignore:1.1.1.1 Sun Oct 17 22:40:42 2004 +++ cl-blog/.cvsignore Sun Oct 17 22:41:25 2004 @@ -1 +1 @@ -password *.fasl *~ entries +password *.fasl *~ entries variable.lisp

1 0

[cl-blog-cvs] CVS update: Module imported: cl-blog
by Brian Mastenbrook 17 Oct '04

17 Oct '04

Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv17857 Log Message: Initial import Status: Vendor Tag: main Release Tags: HEAD N cl-blog/.cvsignore N cl-blog/cl-blog.lisp N cl-blog/package.lisp N cl-blog/variable.lisp N cl-blog/cl-blog.asd No conflicts created by this import Date: Sun Oct 17 22:40:42 2004 Author: bmastenbrook New module cl-blog added

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-blog-cvs