July 2009 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] edi changed trunk/thirdparty/cl-unicode/
by BKNR Commits 22 Jul '09

22 Jul '09

Revision: 4439 Author: edi URL: http://bknr.net/trac/changeset/4439 Fix typo U trunk/thirdparty/cl-unicode/doc/index.html U trunk/thirdparty/cl-unicode/util.lisp Modified: trunk/thirdparty/cl-unicode/doc/index.html =================================================================== --- trunk/thirdparty/cl-unicode/doc/index.html 2009-07-22 16:29:00 UTC (rev 4438) +++ trunk/thirdparty/cl-unicode/doc/index.html 2009-07-22 18:21:41 UTC (rev 4439) @@ -802,7 +802,7 @@ [Function] <a class=none name='property-symbol'>property-symbol name => symbol, name</a> <blockquote> -Returns a symbol in the <code>CL-UNICODE-NAMES</code> packages (which is only +Returns a symbol in the <code>CL-UNICODE-NAMES</code> package (which is only used for this purpose) which can stand in for the string <code>name</code> in look-ups. The symbol's name is the result of <a href="#canonicalize-name">canonicalizing</a> and then Modified: trunk/thirdparty/cl-unicode/util.lisp =================================================================== --- trunk/thirdparty/cl-unicode/util.lisp 2009-07-22 16:29:00 UTC (rev 4438) +++ trunk/thirdparty/cl-unicode/util.lisp 2009-07-22 18:21:41 UTC (rev 4439) @@ -53,7 +53,7 @@ :simple-calls t))) (defun property-symbol (name) - "Returns a symbol in the CL-UNICODE-NAMES packages \(which is only + "Returns a symbol in the CL-UNICODE-NAMES package \(which is only used for this purpose) which can stand in for the string NAME in look-ups. The symbol's name is the result of \"canonicalizing\" and then upcasing NAME. @@ -277,4 +277,4 @@ (if *previous-readtables* (pop *previous-readtables*) (copy-readtable nil))) - (values)) \ No newline at end of file + (values))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/request.lisp
by BKNR Commits 22 Jul '09

22 Jul '09

Revision: 4438 Author: hans URL: http://bknr.net/trac/changeset/4438 Patch by Peter Seibel, his words: I think the actual problem I had was some code that did essentially: (with-foo-output ((send-headers)) (expand-template-file)) where expand-template-file calls code that uses post-parameters to get at, well, post parameters. It's not clear how to easily turn that code inside out so all the parameters are gathered in advance of calling send-headers. U trunk/thirdparty/hunchentoot/request.lisp Modified: trunk/thirdparty/hunchentoot/request.lisp =================================================================== --- trunk/thirdparty/hunchentoot/request.lisp 2009-07-11 22:16:55 UTC (rev 4437) +++ trunk/thirdparty/hunchentoot/request.lisp 2009-07-22 16:29:00 UTC (rev 4438) @@ -352,7 +352,12 @@ (get-parameters request)) (defmethod post-parameters :before ((request request)) - (maybe-read-post-parameters :request request)) + ;; Force here because if someone calls POST-PARAMETERS they actually + ;; want them, regardless of why the RAW-POST-DATA has been filled + ;; in. (For instance, if SEND-HEADERS has been called, filling in + ;; RAW-POST-DATA, and then subsequent code calls POST-PARAMETERS, + ;; without the :FORCE flag POST-PARAMETERS would return NIL.) + (maybe-read-post-parameters :request request :force t)) (defun post-parameters* (&optional (request *request*)) "Returns an alist of the POST parameters associated with the REQUEST

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/handlers.lisp
by BKNR Commits 11 Jul '09

11 Jul '09

Revision: 4437 Author: hans URL: http://bknr.net/trac/changeset/4437 More Hunchentoot 1.0 (?) fixes. U trunk/bknr/web/src/web/handlers.lisp Modified: trunk/bknr/web/src/web/handlers.lisp =================================================================== --- trunk/bknr/web/src/web/handlers.lisp 2009-07-11 22:06:37 UTC (rev 4436) +++ trunk/bknr/web/src/web/handlers.lisp 2009-07-11 22:16:55 UTC (rev 4437) @@ -484,7 +484,7 @@ (when (or (search ".." pathnames-argument) (eql #\/ (aref pathnames-argument 0))) (error 'invalid-pathname-syntax :pathnames-argument pathnames-argument)) - (let* ((*default-pathname-defaults* (page-handler-destination handler)) + (let* ((*default-pathname-defaults* (pathname (page-handler-destination handler))) (filenames (if (directory-handler-filename-separator handler) (mapcar #'pathname (split (directory-handler-filename-separator handler) pathnames-argument)) @@ -500,11 +500,11 @@ (defmethod handler-matches-p ((handler directory-handler)) (and (call-next-method) - (let ((*default-pathname-defaults* (page-handler-destination handler))) + (let ((*default-pathname-defaults* (pathname (page-handler-destination handler)))) (some #'probe-file (request-relative-pathnames handler))))) (defmethod handle ((handler directory-handler)) - (let* ((*default-pathname-defaults* (page-handler-destination handler)) + (let* ((*default-pathname-defaults* (pathname (page-handler-destination handler))) (last-modified (reduce #'max (mapcar #'file-write-date (request-relative-pathnames handler))))) (handle-if-modified-since last-modified) (let (open-files)

1 0

[bknr-cvs] hans changed trunk/projects/hello-web/src/init.lisp
by BKNR Commits 11 Jul '09

11 Jul '09

Revision: 4436 Author: hans URL: http://bknr.net/trac/changeset/4436 port to hunchentoot-1.0 U trunk/projects/hello-web/src/init.lisp Modified: trunk/projects/hello-web/src/init.lisp =================================================================== --- trunk/projects/hello-web/src/init.lisp 2009-07-06 12:02:30 UTC (rev 4435) +++ trunk/projects/hello-web/src/init.lisp 2009-07-11 22:06:37 UTC (rev 4436) @@ -1,6 +1,6 @@ (in-package :hello-web) -(defun startup (&key debug (port *webserver-port*)) +(defun startup (&key (port *webserver-port*)) (close-store) ;; XXX hack hack hack (mapcar #'cl-gd::load-foreign-library @@ -22,7 +22,7 @@ (make-rss-channel "default" "BKNR Hello Web" "default RSS channel of the BKNR hello web site" *website-url*)) (publish-hello-web) - (setq hunchentoot:*catch-errors-p* (not debug)) (when *webserver* - (hunchentoot:stop-server *webserver*)) - (setq *webserver* (hunchentoot:start-server :port port))) + (hunchentoot:stop *webserver*)) + (setq *webserver* (make-instance 'hunchentoot:acceptor :port port)) + (hunchentoot:start *webserver*))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/taskmaster.lisp
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4435 Author: hans URL: http://bknr.net/trac/changeset/4435 Remote debugging. U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 11:26:02 UTC (rev 4434) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 12:02:30 UTC (rev 4435) @@ -132,14 +132,14 @@ ;; worker thread. One such problem exists in ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on ;; some platforms in certain situations. - ;; Need to bind *ACCEPTOR* so that LOG-MESSAGE can do its work. - (let ((*acceptor* (taskmaster-acceptor taskmaster))) - (handler-case - (bt:make-thread (lambda () - (process-connection *acceptor* socket)) - :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))) + (handler-case + (bt:make-thread (lambda () + (process-connection (taskmaster-acceptor taskmaster) socket)) + :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))) - (error (cond) + (error (cond) + ;; Need to bind *ACCEPTOR* so that LOG-MESSAGE can do its work. + (let ((*acceptor* (taskmaster-acceptor taskmaster))) (log-message *lisp-errors-log-level* "Error while creating worker thread for new incoming connection: ~A" cond)))))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/taskmaster.lisp
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4434 Author: hans URL: http://bknr.net/trac/changeset/4434 Another fix... U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 11:22:34 UTC (rev 4433) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 11:26:02 UTC (rev 4434) @@ -132,14 +132,16 @@ ;; worker thread. One such problem exists in ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on ;; some platforms in certain situations. - (handler-case - (bt:make-thread (lambda () - (process-connection (taskmaster-acceptor taskmaster) socket)) - :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))) + ;; Need to bind *ACCEPTOR* so that LOG-MESSAGE can do its work. + (let ((*acceptor* (taskmaster-acceptor taskmaster))) + (handler-case + (bt:make-thread (lambda () + (process-connection *acceptor* socket)) + :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))) - (error (cond) - (log-message *lisp-errors-log-level* - "Error while creating worker thread for new incoming connection: ~A" cond)))) + (error (cond) + (log-message *lisp-errors-log-level* + "Error while creating worker thread for new incoming connection: ~A" cond))))) ;; LispWorks implementation

1 0

[bknr-cvs] hans changed trunk/projects/planetwit/
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4433 Author: hans URL: http://bknr.net/trac/changeset/4433 ignore data files _U trunk/projects/planetwit/ Property changes on: trunk/projects/planetwit ___________________________________________________________________ Name: svn:ignore + planetwit.dat planetwit-auth.dat

1 0

[bknr-cvs] hans changed trunk/projects/planetwit/
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4432 Author: hans URL: http://bknr.net/trac/changeset/4432 add clojure sources A trunk/projects/planetwit/http-client.clj A trunk/projects/planetwit/load.clj A trunk/projects/planetwit/planetwit.clj Added: trunk/projects/planetwit/http-client.clj =================================================================== --- trunk/projects/planetwit/http-client.clj (rev 0) +++ trunk/projects/planetwit/http-client.clj 2009-07-06 11:18:51 UTC (rev 4432) @@ -0,0 +1,35 @@ +;; Clojure interface to the xlightweb HTTP client/server library +;; +;; Copyright 2008 Hans Huebner +;; All rights reserved + +(ns http + (:import (org.apache.commons.codec.binary Base64) + (org.xlightweb.client HttpClient) + (org.xlightweb HttpRequest))) + +(def method-string-map {:get "GET" + :post "POST"}) + +(defn method-string [keyword] + (or (method-string-map keyword) + (throw (Error. (format "Invalid request method %s" keyword))))) + +(defn make-request [url method content-type content] + (if (and content-type content) + (HttpRequest. (method-string method) url content-type content) + (HttpRequest. (method-string method) url))) + +(defn simple-http-request + [url attributes] + (let [{:keys [method content-type content client basic-authorization], :or {method :get}} attributes + client (or client (HttpClient.)) + request (make-request url method content-type content)] + (when basic-authorization + (. request (addHeader "Authorization" + (format "Basic %s" + (String. (. (Base64.) (encode (. basic-authorization getBytes)))))))) + (let [response (. client call request)] + {:status (. response getStatus) + :content-type (. response getContentType) + :body (. (. response getBlockingBody) readString)}))) \ No newline at end of file Added: trunk/projects/planetwit/load.clj =================================================================== --- trunk/projects/planetwit/load.clj (rev 0) +++ trunk/projects/planetwit/load.clj 2009-07-06 11:18:51 UTC (rev 4432) @@ -0,0 +1,8 @@ +(load-file "http-client.clj") +(load-file "planetwit.clj") +(loop [] + (println "polling") + (planetwit/poll) + (println "sleeping") + (. java.lang.Thread (sleep 300000)) + (recur)) Added: trunk/projects/planetwit/planetwit.clj =================================================================== --- trunk/projects/planetwit/planetwit.clj (rev 0) +++ trunk/projects/planetwit/planetwit.clj 2009-07-06 11:18:51 UTC (rev 4432) @@ -0,0 +1,67 @@ +(ns planetwit + (:require [clojure.zip :as zip] + [clojure.xml :as xml]) + (:use clojure.contrib.duck-streams + clojure.contrib.zip-filter.xml)) + +(def +state-file+ "/home/hans/clojure/planetwit/planetwit.dat") +(def +twitter-url+ "http://twitter.com/statuses/update.xml") +(def +twitter-auth-file+ "/home/hans/clojure/planetwit/planetwit-auth.dat") + +(defn read-file [file-name & defaults] + (try + (with-in-str (slurp file-name) + (read)) + (catch java.io.FileNotFoundException e + (if (pos? (count defaults)) + (first defaults) + (throw (java.io.FileNotFoundException. (format "File %s not found" file-name))))))) + +(defn write-file [data file-name] + (spit file-name (with-out-str (pr data)))) + +(defn load-data [] + (read-file +state-file+ #{})) + +(defn save-data [data] + (write-file data +state-file+)) + +(defn feed-to-zip [url] + (zip/xml-zip (xml/parse url))) + +(defn update-twitter-status [auth-file status] + (http/simple-http-request +twitter-url+ + {:method :post + :basic-authorization (read-file auth-file) + :content-type "application/x-www-form-urlencoded" + :content (format "status=%s&source=planetlisp" (java.net.URLEncoder/encode status))})) + +(defn maybe-post-twit [items] + (let [twitter-status (cond + (< 1 (count items)) + (format "%d new items posted" (count items)) + (= 1 (count items)) + (format "new: %s" (first items)))] + (when twitter-status + (update-twitter-status +twitter-auth-file+ twitter-status)))) + +(defn poll + "Poll planet lisp, check for new postings, update Twitter status when new postings have appeared" + [] + (save-data + (let [old-data (load-data) + process + (fn [items new-data new-items] + (if items + (let [item (first items) + guid (first (xml-> item :guid text)) ] + (recur (rest items) + (conj new-data guid) + (if (old-data guid) + new-items + (conj new-items (first (xml-> item :title text)))))) + (do + (maybe-post-twit new-items) + new-data)))] + (process (xml-> (feed-to-zip "http://planet.lisp.org/rss20.xml") :channel :item) + #{} []))))

1 0

[bknr-cvs] hans changed trunk/projects/planetwit/
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4431 Author: hans URL: http://bknr.net/trac/changeset/4431 Add directory for the Planet Lisp autotwitter application. A trunk/projects/planetwit/

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/taskmaster.lisp
by BKNR Commits 06 Jul '09

06 Jul '09

Revision: 4430 Author: hans URL: http://bknr.net/trac/changeset/4430 Move the HANDLER-CASE to the right place in the code, ugh. U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 08:47:23 UTC (rev 4429) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-07-06 09:17:00 UTC (rev 4430) @@ -127,9 +127,19 @@ #-:lispworks (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) - (bt:make-thread (lambda () - (process-connection (taskmaster-acceptor taskmaster) socket)) - :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) + ;; We are handling all conditions here as we want to make sure that + ;; the acceptor process never crashes while trying to create a + ;; worker thread. One such problem exists in + ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on + ;; some platforms in certain situations. + (handler-case + (bt:make-thread (lambda () + (process-connection (taskmaster-acceptor taskmaster) socket)) + :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))) + + (error (cond) + (log-message *lisp-errors-log-level* + "Error while creating worker thread for new incoming connection: ~A" cond)))) ;; LispWorks implementation @@ -153,17 +163,8 @@ (zerop (mod *worker-counter* *cleanup-interval*))) (when *cleanup-function* (funcall *cleanup-function*))) - ;; We are handling all conditions here as we want to make sure that - ;; the acceptor process never crashes while trying to create a - ;; worker thread. One such problem exists in - ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on - ;; some platforms in certain situations. - (handler-case - (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" - (multiple-value-list - (get-peer-address-and-port handle))) - nil #'process-connection - (taskmaster-acceptor taskmaster) handle) - (error (cond) - (log-message *lisp-errors-log-level* - "Error while creating worker thread for new incoming connection: ~A" cond)))) + (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" + (multiple-value-list + (get-peer-address-and-port handle))) + nil #'process-connection + (taskmaster-acceptor taskmaster) handle))

1 0