code reingepasted

Lisp-Geekend.mw

@@ -18,3 +18,105 @@
 
 * Webprogrammierung ([http://common-lisp.net/movies/hello-world.torrent UnCommonWeb Hello World])
 "It was pretty slick when Marco fixed an error in some code while Firefox was blocked trying to display the page, then was able to compile the fixed code and finish serving the request to the browser."
+
+==xmpp-demo.lisp==
+<pre>
+(defpackage :xmpp-demo
+    (:use "COMMON-LISP" "EXCL" "XMPP" "MP"
+	  "NET.ASERVE" "NET.HTML.GENERATOR"))
+(in-package :xmpp-demo)
+
+(defclass bot-connection (connection)
+  ((event-thread :accessor event-thread)))
+
+(defmethod authenticate ((con bot-connection))
+  (auth con "blitz" cl-user::*jabber-pw* "allegrocl"))
+
+(defmethod start-event-thread ((con bot-connection))
+  (setf (event-thread con)
+	(process-run-function "xmpp"
+			      (lambda ()
+				(receive-stanza-loop con)))))
+
+;; Parsing
+
+(defun ensure-keyword (str)
+  (values (intern (string-upcase str) "KEYWORD")))
+
+(defun parse-command (str)
+  (multiple-value-bind (match? whole cmd rest)
+      (match-re "(\\S+)\\s*(.*)" str)
+    (if match?
+	(values (ensure-keyword cmd) rest)
+	(error "Invalid command."))))
+
+;; -> CMD arg
+
+;; Links
+
+(defvar *links* nil)
+
+(defstruct link
+  url submitter)
+
+;; Handler fun
+
+(defvar *cn* nil
+  "Our current connection")
+
+(defun start-it ()
+  (setq *cn* (connect :hostname "spaceboyz.net"
+		      :class 'bot-connection))
+  (authenticate *cn*)
+  (start-event-thread *cn*))
+
+(defmethod handle ((con bot-connection) (event message))
+  (handler-case
+      (multiple-value-bind (cmd parameter)
+	  (parse-command (body event))
+	(case cmd
+	  (:hello (message con (from event) "Hello you!"))
+	  (:url (push (make-link :url parameter
+				 :submitter (from event))
+		      *links*))
+	))
+    (t (c) (message con "blitz@spaceboyz.net"
+		   (format nil "~A" c)))))
+
+
+;; HTML
+
+(defun html-redirect (url &optional (delay 0))
+  (html
+   (:html
+    (:head ((:meta :http-equiv "Refresh"
+		   :content (format nil "~A; URL=~A" delay url)))))))
+
+(defun xmpp-render (req ent)
+  (with-http-response (req ent)
+    (with-http-body (req ent)
+      (let ((go (request-query-value "go" req)))
+	(if go
+	    (let ((submitter (link-submitter (find go *links* :key 'link-url :test 'string=))))
+	      (when submitter
+		(message *cn* submitter
+			 (format nil "Your link ~A was followed." go)))
+	      (html-redirect go))
+	    (html
+	     (:html
+	      (:body (:h1 "XMPP Demo")
+		     (:table
+		      (:tr (:th "Submitter")
+			   (:th "URL"))
+		      (loop for link in *links*
+			    do (html
+				(:tr (:td (:princ-safe (link-submitter link)))
+				     (:td ((:a :href (format nil "/xmpp?~A"
+							     (query-to-form-urlencoded
+							      (list (cons "go" (link-url link))))))
+					   (:princ-safe (link-url link)))))))))
+	      )))))))
+
+(publish :path "/xmpp"
+	 :function 'xmpp-render)
+</pre>