From bmastenbrook at common-lisp.net Sun Oct 17 20:40:42 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sun, 17 Oct 2004 22:40:42 +0200 Subject: [cl-blog-cvs] CVS update: Module imported: cl-blog Message-ID: 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 From bmastenbrook at common-lisp.net Sun Oct 17 20:41:25 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sun, 17 Oct 2004 22:41:25 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/.cvsignore Message-ID: 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 From bmastenbrook at common-lisp.net Tue Oct 19 01:33:08 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 19 Oct 2004 03:33:08 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/trackback.lisp cl-blog/cl-blog.lisp cl-blog/variable.lisp Message-ID: 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) + " + +1 +The specified blog entry could not be found. + +") + (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) + " + +0 + +"))) + 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 From bmastenbrook at common-lisp.net Tue Oct 19 01:38:12 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 19 Oct 2004 03:38:12 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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) ()) From bmastenbrook at common-lisp.net Wed Oct 20 01:30:22 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 20 Oct 2004 03:30:22 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.asd cl-blog/cl-blog.lisp cl-blog/trackback.lisp Message-ID: 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)" line) + (setf in-rdf nil) + (setf found nil))))))))) + (serious-condition () (return-from autodetect-ping-for-url nil)))) \ No newline at end of file From bmastenbrook at common-lisp.net Wed Oct 20 01:39:26 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 20 Oct 2004 03:39:26 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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 From bmastenbrook at common-lisp.net Wed Oct 20 01:42:11 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 20 Oct 2004 03:42:11 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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) ()) From bmastenbrook at common-lisp.net Fri Oct 22 01:06:01 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 22 Oct 2004 03:06:01 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp cl-blog/variable.lisp Message-ID: 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 at domain") +(defparameter *owner-email* "chandler at 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/")) From bmastenbrook at common-lisp.net Fri Oct 22 01:10:40 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 22 Oct 2004 03:10:40 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp cl-blog/variable.lisp Message-ID: 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") , at 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 From bmastenbrook at common-lisp.net Fri Oct 22 01:12:24 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 22 Oct 2004 03:12:24 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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") , at body)) From bmastenbrook at common-lisp.net Fri Oct 22 01:13:10 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 22 Oct 2004 03:13:10 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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") , at body)) From bmastenbrook at common-lisp.net Fri Oct 22 01:13:47 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 22 Oct 2004 03:13:47 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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")))) ) From bmastenbrook at common-lisp.net Fri Oct 29 14:16:58 2004 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 29 Oct 2004 16:16:58 +0200 Subject: [cl-blog-cvs] CVS update: cl-blog/cl-blog.lisp Message-ID: 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) ())