From 8ae4992d1cdf780597e51ad2be7922a8bc78a84f Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Wed, 1 Apr 2009 12:15:16 +0200 Subject: [PATCH] improved tls support --- comm/xmpp.scm | 122 +++++++++++++++++++++++++------------------------- 1 file changed, 61 insertions(+), 61 deletions(-) diff --git a/comm/xmpp.scm b/comm/xmpp.scm index 9c7b70c..abe6bfa 100644 --- a/comm/xmpp.scm +++ b/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 -;;; - partial "old sytle" ssl connections on port 5223 +;;; - plaintext sessions on port 5222 +;;; - "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 @@ -39,23 +52,21 @@ ;;; - rfc 3920 ;;; - rfc 3921 ;;; -;;; bugs and/or improvements +;;; bugs and/or improvements ;;; - read-async & repsonse-handler ;;; - ssax:xml->sxml or lazy:xml->sxml ;;; - default handlers -;;; - ssl read/write sequence ;;; - chatbot exmples ;;; (module xmpp scheme - + (provide (all-defined-out) ;open-connection ;open-ssl-connection ;with-xmpp-session ) - (require (planet lizorkin/sxml:2:1/sxml)) (require (planet lizorkin/ssax:2:0/ssax)) (require mzlib/os) @@ -72,11 +83,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) @@ -93,15 +99,13 @@ (close-input-port in))) (define (read-async in) - (define bstr (make-bytes 0 0)) - (when (byte-ready? in) - (if (eq? (peek-byte in) eof) - (break-thread (current-thread)) - (begin - (set! bstr (bytes-append bstr - (make-bytes 1 (read-byte in)) - (read-async in)))))) bstr) - + (bytes->string/utf-8 (list->bytes (read-async-bytes in)))) + + (define (read-async-bytes in) + (let ((bstr '())) + (when (sync/timeout 0 in) + (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr)) + (define ssxml srl:sxml->xml-noindent) ;;;;;; ; ; ; ; ;; ;;;;;; ; @@ -113,7 +117,7 @@ ;; intialization (define (xmpp-stream host) (string-append "")) - + ;; authentication (define (xmpp-auth username password resource) (ssxml `(iq (@ (type "set") (id "auth")) @@ -121,17 +125,17 @@ (username ,username) (password ,password) (resource ,resource))))) - + (define (xmpp-session host) (ssxml `(iq (@ (to ,host) (type "set") (id "session")) (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))) (define (starttls) "") - ;; messages + ;; messages (define (message to body) (ssxml `(message (@ (to ,to)) (body ,body)))) - + ;; presence (define (presence #:from (from "") #:to (to "") @@ -156,19 +160,19 @@ (define message-type (sxpath-element "message/@type/text()")) (define message-body (sxpath-element "message/body/text()")) (define message-subject (sxpath-element "message/subject/text()")) - + ;; info/query (define iq-type (sxpath-element "iq/@type/text()")) (define iq-id (sxpath-element "iq/@id/text()")) (define iq-error-type (sxpath-element "iq/error/@type/text()")) (define iq-error-text (sxpath-element "iq/error/text()")) (define iq-error (sxpath-element "iq/error")) - + ;; presence (define presence-show (sxpath-element "presence/show/text()")) (define presence-from (sxpath-element "presence/@from/text()")) (define presence-status (sxpath-element "presence/status/text()")) - + ;;;;;;;;; ; ;; ; ; ;; ;; ; ; ;; @@ -180,7 +184,7 @@ ;;;;;; ;; ; ; ;; ; (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths) - + (define (set-xmpp-handler type fcn) (dict-set! xmpp-handlers type fcn)) @@ -189,12 +193,11 @@ (when fcn (begin (display (format "attempting to run handler ~a.~%" fcn)) (fcn sz))))) - + ;; no real parsing yet. dispatches any received xml stanzas as sxml (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 @@ -211,10 +214,10 @@ ;; example handlers to print stanzas or their contents (define (print-message sz) (display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))) - + (define (print-iq sz) - (display (format "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))) - + (display (format "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))) + (define (print-presence sz) (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))) @@ -224,55 +227,52 @@ ;; QND hack to filter out anything not a message, iq or presence (define (clean str) (let ((test (substring str 0 3))) - (cond ((string-ci=? test "")))) - - ;; repsonse handler + (cond ((string-ci=? test "")))) + + + ;; response handler (define (xmpp-response-handler in) (thread (lambda () (let loop () - (when ssl-write-flag - (parse-xmpp-response (bytes->string/utf-8 (read-async in)))) - (sleep 0.1) + (parse-xmpp-response (read-async in)) + (sleep 0.1) ;; slight delay to avoid a tight loop (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 #\@))) - + (define (jid-host jid) (let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1))) (v (string-index s #\/))) (if v (string-take s v) s ))) - + (define (jid-resource jid) (let ((r (jid-resource-0 jid))) (if (void? r) (gethostname) r))) - + (define (jid-resource-0 jid) (let ((v (string-index jid #\/))) (when v (string-take-right jid (- (string-length jid) v 1))))) + ;;;; ;; ; ; ;; ;; ;;;; ; ;; ;; interfaces ;; ;;;;; ;; ;;;; ; ;; ; - + (defmacro with-xmpp-session (jid pass . body) `(let ((host (jid-host ,jid)) (user (jid-user ,jid)) (resource (jid-resource ,jid))) (let-values (((in out) - ;;(ssl-connect host ssl-port 'tls))) - (tcp-connect host port))) - (define (send str) (fprintf out "~A~%" str)) + (ssl-connect host ssl-port 'tls))) + ;;(tcp-connect host port))) + (define (send str) (fprintf out "~A~%" str) (flush-output out)) (file-stream-buffer-mode out 'line) (xmpp-response-handler in) (send (xmpp-stream host)) @@ -280,11 +280,11 @@ ;(send starttls) (send (xmpp-auth user ,pass resource)) (send (presence)) - (send (presence #:status "Available")) + (send (presence #:status "Available")) ,@body (close-output-port out) (close-input-port in)))) - - -) ;; end module + + + ) ;; end module