Merge branch 'master' of ssh://dave@fo.am/var/git/groworld
This commit is contained in:
commit
94abe40b9e
1 changed files with 61 additions and 61 deletions
|
@ -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
|
||||||
|
@ -43,7 +56,6 @@
|
||||||
;;; - 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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -229,19 +232,15 @@
|
||||||
((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
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue