Merge branch 'master' of ssh://dave@fo.am/var/git/groworld

comm/xmpp.scm

@@ -1,6 +1,19 @@
 ;;; A basic XMPP library which should conform to RFCs 3920 and 3921
 ;;;
-;;; Copyright (C) 2009 FoAM vzw. LGPL.
+;;; Copyright (C) 2009 FoAM vzw. 
+;;;
+;;;  This package is free software: you can redistribute it and/or
+;;;  modify it under the terms of the GNU Lesser General Public
+;;;  License as published by the Free Software Foundation, either
+;;;  version 3 of the License, or (at your option) any later version.
+;;;
+;;;  This program is distributed in the hope that it will be useful,
+;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;  Lesser General Public License for more details.
+;;;
+;;;  You can find a copy of the GNU Lesser General Public License at
+;;;  http://www.gnu.org/licenses/lgpl-3.0.html.
 ;;;
 ;;; Authors 
 ;;;
@@ -8,15 +21,15 @@
 ;;;
 ;;; Requirements
 ;;;
-;;;  PLT for now.
+;;;  PLT for now. TLS requires a version of PLT > 4.1.5.3
 ;;;
 ;;; Commentary
 ;;;
 ;;;  Still a long way from implementing even a minimal subset of XMPP
 ;;; 
 ;;;  features implemented
-;;;   - establish plaintext connections on port 5222
+;;;   - plaintext sessions on port 5222
-;;;   - partial "old sytle" ssl connections on port 5223
+;;;   - "old sytle" ssl sessions on port 5223
 ;;;   - authenticate using an existing account
 ;;;   - send messages (rfc 3921 sec.4)
 ;;;   - send presence (rfc 3921 sec.5)
@@ -25,9 +38,9 @@
 ;;;
 ;;;  features to implement
 ;;;   - account creation
-;;;   - managing subscription (rfc 3921 sec.6)
+;;;   - managing subscriptions (rfc 3921 sec.6)
 ;;;   - rosters (rfc 3921 sec.7)
-;;;   - plaintext/ssl/tls negotiation (rfc 3920 sec.5 & 6)
+;;;   - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6) 
 ;;;   - encrypted connections using tls on port 5222
 ;;;   - correct namespaces in sxml
 ;;;   - message types
@@ -43,7 +56,6 @@
 ;;;   - read-async & repsonse-handler
 ;;;   - ssax:xml->sxml or lazy:xml->sxml
 ;;;   - default handlers
-;;;   - ssl read/write sequence
 ;;;   - chatbot exmples
 ;;;
 
@@ -55,7 +67,6 @@
            ;with-xmpp-session
            )
   
- 
   (require (planet lizorkin/sxml:2:1/sxml))
   (require (planet lizorkin/ssax:2:0/ssax))
   (require mzlib/os)
@@ -73,11 +84,6 @@
   (define port 5222)
   (define ssl-port 5223)
   
-  (define ssl-write-flag #t) ;; semaphore for half-duplex ssl 
-
-  (define (ssl-write b)
-    (set! ssl-write-flag b))  
-  
   (define (open-connection machine port handler)
     (let-values (((in out)
                   (tcp-connect machine port))) 
@@ -93,14 +99,12 @@
       (close-input-port in)))
   
   (define (read-async in)
-    (define bstr (make-bytes 0 0))
+    (bytes->string/utf-8 (list->bytes (read-async-bytes in))))
-    (when (byte-ready? in)
+  
-      (if (eq? (peek-byte in) eof)
+  (define (read-async-bytes in)
-          (break-thread (current-thread))
+    (let ((bstr '()))
-          (begin
+      (when (sync/timeout 0 in)
-            (set! bstr (bytes-append bstr 
+        (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr))
-                                     (make-bytes 1 (read-byte in)) 
-                                     (read-async in)))))) bstr)
   
   (define ssxml srl:sxml->xml-noindent) 
   
@@ -194,7 +198,6 @@
   
   (define (parse-xmpp-response str)
     (when (> (string-length str) 0)
-      (newline)
       (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '())))
         ;;(let ((sz (lazy:xml->sxml (open-input-string str) '())))
         (cond
@@ -229,19 +232,15 @@
             ((string-ci=? test "<pr") str)
             (else "<null/>"))))
   
-  ;; repsonse handler
+  
+  ;; response handler
   (define (xmpp-response-handler in)
     (thread (lambda () 
               (let loop () 
-                (when ssl-write-flag
+                (parse-xmpp-response (read-async in))
-                  (parse-xmpp-response (bytes->string/utf-8 (read-async in))))
+                (sleep 0.1) ;; slight delay to avoid a tight loop
-                (sleep 0.1)
                 (loop)))))
   
-  ;; ideally something like this would work.. . 
-  (define (xmmp-read-stanza in)
-    (parse-xmpp-response (read-line in)))
-  
   ;; jid splicing (assuming the jid is in the format user@host/resource)
   (define (jid-user jid)
     (string-take jid (string-index jid #\@)))
@@ -259,6 +258,7 @@
     (let ((v (string-index jid #\/)))
       (when v (string-take-right jid (- (string-length jid) v 1)))))    
 
+  
   ;;;;  ;; ; ; ;; ;;   ;;;; ;
   ;;
   ;; interfaces
@@ -270,9 +270,9 @@
            (user (jid-user ,jid))
            (resource (jid-resource ,jid)))
        (let-values (((in out)
-                     ;;(ssl-connect host ssl-port 'tls)))
+                     (ssl-connect host ssl-port 'tls)))
-                     (tcp-connect host port)))
+         ;;(tcp-connect host port)))
-         (define (send str) (fprintf out "~A~%" str))
+         (define (send str) (fprintf out "~A~%" str) (flush-output out))
          (file-stream-buffer-mode out 'line)
          (xmpp-response-handler in) 
          (send (xmpp-stream host))