FoAM/groworld
12
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

improved tls support

Browse source
This commit is contained in:
nik gaffney 2009-04-01 12:15:16 +02:00
parent 0720747d47
commit 8ae4992d1c
1 changed files with 61 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

82
comm/xmpp.scm
View file

@ -1,6 +1,19 @@
;;; A basic XMPP library which should conform to RFCs 3920 and 3921 ;;; 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 ;;; Authors
;;; ;;;
@ -8,15 +21,15 @@
;;; ;;;
;;; Requirements ;;; Requirements
;;; ;;;
;;; PLT for now. ;;; PLT for now. TLS requires a version of PLT > 4.1.5.3
;;; ;;;
;;; Commentary ;;; Commentary
;;; ;;;
;;; Still a long way from implementing even a minimal subset of XMPP ;;; Still a long way from implementing even a minimal subset of XMPP
;;; ;;;
;;; features implemented ;;; 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 ;;; - authenticate using an existing account
;;; - send messages (rfc 3921 sec.4) ;;; - send messages (rfc 3921 sec.4)
;;; - send presence (rfc 3921 sec.5) ;;; - send presence (rfc 3921 sec.5)
@ -25,9 +38,9 @@
;;; ;;;
;;; features to implement ;;; features to implement
;;; - account creation ;;; - account creation
;;; - managing subscription (rfc 3921 sec.6) ;;; - managing subscriptions (rfc 3921 sec.6)
;;; - rosters (rfc 3921 sec.7) ;;; - 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 ;;; - encrypted connections using tls on port 5222
;;; - correct namespaces in sxml ;;; - correct namespaces in sxml
;;; - message types ;;; - message types
@ -39,11 +52,10 @@
;;; - rfc 3920 ;;; - rfc 3920
;;; - rfc 3921 ;;; - rfc 3921
;;; ;;;
;;; bugs and/or improvements ;;; bugs and/or improvements
;;; - read-async & repsonse-handler ;;; - read-async & repsonse-handler
;;; - ssax:xml->sxml or lazy:xml->sxml ;;; - ssax:xml->sxml or lazy:xml->sxml
;;; - default handlers ;;; - default handlers
;;; - ssl read/write sequence
;;; - chatbot exmples ;;; - chatbot exmples
;;; ;;;
@ -55,7 +67,6 @@
;with-xmpp-session ;with-xmpp-session
) )
(require (planet lizorkin/sxml:2:1/sxml)) (require (planet lizorkin/sxml:2:1/sxml))
(require (planet lizorkin/ssax:2:0/ssax)) (require (planet lizorkin/ssax:2:0/ssax))
(require mzlib/os) (require mzlib/os)
@ -73,11 +84,6 @@
(define port 5222) (define port 5222)
(define ssl-port 5223) (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) (define (open-connection machine port handler)
(let-values (((in out) (let-values (((in out)
(tcp-connect machine port))) (tcp-connect machine port)))
@ -93,14 +99,12 @@
(close-input-port in))) (close-input-port in)))
(define (read-async 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) (define ssxml srl:sxml->xml-noindent)
@ -128,7 +132,7 @@
(define (starttls) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>") (define (starttls) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")
;; messages ;; messages
(define (message to body) (define (message to body)
(ssxml `(message (@ (to ,to)) (body ,body)))) (ssxml `(message (@ (to ,to)) (body ,body))))
@ -194,7 +198,6 @@
(define (parse-xmpp-response str) (define (parse-xmpp-response str)
(when (> (string-length str) 0) (when (> (string-length str) 0)
(newline)
(let ((sz (ssax:xml->sxml (open-input-string (clean str)) '()))) (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '())))
;;(let ((sz (lazy:xml->sxml (open-input-string str) '()))) ;;(let ((sz (lazy:xml->sxml (open-input-string str) '())))
(cond (cond
@ -213,7 +216,7 @@
(display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))) (display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz))))
(define (print-iq 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) (define (print-presence sz)
(display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))) (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status))))
@ -224,24 +227,20 @@
;; QND hack to filter out anything not a message, iq or presence ;; QND hack to filter out anything not a message, iq or presence
(define (clean str) (define (clean str)
(let ((test (substring str 0 3))) (let ((test (substring str 0 3)))
(cond ((string-ci=? test "<me") str) (cond ((string-ci=? test "<me") str)
((string-ci=? test "<iq") str) ((string-ci=? test "<iq") str)
((string-ci=? test "<pr") str) ((string-ci=? test "<pr") str)
(else "<null/>")))) (else "<null/>"))))
;; repsonse handler
;; response handler
(define (xmpp-response-handler in) (define (xmpp-response-handler in)
(thread (lambda () (thread (lambda ()
(let loop () (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))))) (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) ;; jid splicing (assuming the jid is in the format user@host/resource)
(define (jid-user jid) (define (jid-user jid)
(string-take jid (string-index jid #\@))) (string-take jid (string-index jid #\@)))
@ -259,6 +258,7 @@
(let ((v (string-index jid #\/))) (let ((v (string-index jid #\/)))
(when v (string-take-right jid (- (string-length jid) v 1))))) (when v (string-take-right jid (- (string-length jid) v 1)))))
;;;; ;; ; ; ;; ;; ;;;; ; ;;;; ;; ; ; ;; ;; ;;;; ;
;; ;;
;; interfaces ;; interfaces
@ -270,9 +270,9 @@
(user (jid-user ,jid)) (user (jid-user ,jid))
(resource (jid-resource ,jid))) (resource (jid-resource ,jid)))
(let-values (((in out) (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) (file-stream-buffer-mode out 'line)
(xmpp-response-handler in) (xmpp-response-handler in)
(send (xmpp-stream host)) (send (xmpp-stream host))
@ -286,5 +286,5 @@
(close-input-port in)))) (close-input-port in))))
) ;; end module ) ;; end module