/rfc/xmpp.scm
Scheme | 528 lines | 415 code | 53 blank | 60 comment | 0 complexity | 6dde5c029d87e0c3e676308c526d04b0 MD5 | raw file
- ;;;
- ;;; xmpp.scm - XMPP(RFC3920, RFC3921) client library for the Gauche.
- ;;;
- ;;; rfc.xmpp
- ;;;
- ;;; Copyright (c) 2010 Teruaki Gemma(teruakigemma@gmail.com)
- ;;;
- ;;;
- ;;; Permission is hereby granted, free of charge, to any person obtaining
- ;;; a copy of this software and associated documentation files (the
- ;;; "Software"), to deal in the Software without restriction, including
- ;;; without limitation the rights to use, copy, modify, merge, publish,
- ;;; distribute, sublicense, and/or sell copies of the Software, and to
- ;;; permit persons to whom the Software is furnished to do so, subject to
- ;;; the following conditions:
- ;;;
- ;;; The above copyright notice and this permission notice shall be
- ;;; included in all copies or substantial portions of the Software.
- ;;;
- ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
- ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
- ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
- ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
- ;;;
- ;;; $Id$
- ;;;
- (define-module rfc.xmpp
- (use srfi-1)
- (use srfi-13)
- (use srfi-14)
- (use util.list)
- (use gauche.net)
- (use gauche.uvector)
- (use sxml.ssax)
- (use sxml.sxpath)
- (use sxml.tools)
- (use sxml.serializer)
- (use rfc.md5)
- (use rfc.base64)
- (use math.mt-random)
- (export <xmpp-error>
- <xmpp-connection>
- xmpp-connect
- xmpp-disconnect
- call-with-xmpp-connection
- xmpp-receive-stanza
- xmpp-bind
- xmpp-session
- xmpp-message
- xmpp-presence
- xmpp-subscribe
- xmpp-subscribed
- xmpp-unsubscribe
- xmpp-unsubscribed
- xmpp-iq
- xmpp-get-roster
- xmpp-push-roster
- xmpp-get-privacy-lists-names
- xmpp-get-privacy-lists
- xmpp-set-privacy-lists
- xmpp-auth
- xmpp-auth-select-mechanism
- xmpp-sasl-anonymous
- xmpp-sasl-plain
- xmpp-sasl-digest-md5
- )
- )
- (select-module rfc.xmpp)
- (define *default-port* 5222)
- (define *mt* (make <mersenne-twister> :seed (sys-time)))
- (define-constant *alnum* (list->vector (char-set->list (char-set-union char-set:lower-case char-set:digit))))
- (define (random-id)
- (let1 len (vector-length *alnum*)
- (list->string
- (map (lambda (x)
- (vector-ref *alnum* (mt-random-integer *mt* len)))
- (iota 8)))))
- (define-condition-type <xmpp-error> <error> #f)
- (define-class <xmpp-connection> ()
- ((socket :init-keyword :socket)
- (socket-iport :init-keyword :socket-iport)
- (socket-oport :init-keyword :socket-oport)
- (id)
- (from)
- (to)
- (version)
- (xml:lang :init-keyword :xml:lang)
- (features)
- (stream-default-namespace)
- (jid-domain-part :init-keyword :jid-domain-part)
- (hostname :init-keyword :hostname)
- (port :init-keyword :port)
- (channel :init-form (channel-essential))))
- (define-method write-object ((conn <xmpp-connection>) out)
- (format out "<connection to ~A:~A> ~A"
- (ref conn 'hostname)
- (ref conn 'port)
- (socket-status (ref conn 'socket))))
- ;; Channel is a hash-table.
- ;; Its key is a predicate function for a stanza and
- ;; the value is a handler for the stanza the predicate is true.
- (define (channel-essential)
- (define (handle-stream conn sxml)
- (set! (ref conn 'id)
- ((if-car-sxpath '(http://etherx.jabber.org/streams:stream @ id *text*)) sxml))
- (set! (ref conn 'from)
- ((if-car-sxpath '(http://etherx.jabber.org/streams:stream @ from *text*)) sxml))
- (set! (ref conn 'to)
- ((if-car-sxpath '(http://etherx.jabber.org/streams:stream @ to *text*)) sxml))
- (set! (ref conn 'version)
- ((if-car-sxpath '(http://etherx.jabber.org/streams:stream @ version *text*)) sxml))
- (set! (ref conn 'xml:lang)
- ((if-car-sxpath '(http://etherx.jabber.org/streams:stream @ xml:lang *text*)) sxml))
- (and-let* ((version (ref conn 'version)))
- (when (< (string->number version) 1.0)
- (error <xmpp-error> "The server using a too old version of XMPP stream. version:" version))))
- (define (handle-features conn sxml)
- (set! (ref conn 'features) ((sxpath '(http://etherx.jabber.org/streams:features *)) sxml)))
- `((,(if-sxpath '(http://etherx.jabber.org/streams:stream)) . ,handle-stream)
- (,(if-sxpath '(http://etherx.jabber.org/streams:features)) . ,handle-features)))
- (define (xmpp-connect hostname . args)
- (let-keywords args ((port *default-port*)
- (jid-domain-part #f)
- (xml:lang #f))
- (let* ((socket (make-client-socket 'inet hostname port))
- (conn (make <xmpp-connection>
- :socket socket
- :socket-iport (socket-input-port socket :buffering :none)
- :socket-oport (socket-output-port socket)
- :hostname hostname
- :port port
- :jid-domain-part jid-domain-part
- :xml:lang xml:lang)))
- (begin-xml-stream conn)
- (xmpp-receive-stanza conn) ; stream
- (xmpp-receive-stanza conn) ; features
- conn)))
- (define-method xmpp-disconnect ((conn <xmpp-connection>))
- (end-xml-stream conn)
- (let1 s (ref conn 'socket)
- (socket-close s)
- (socket-shutdown s SHUT_RDWR)))
- (define (call-with-xmpp-connection hostname proc . args)
- (let1 conn (apply xmpp-connect (cons hostname args))
- (unwind-protect (proc conn)
- (xmpp-disconnect conn))))
- (define-method xmpp-receive-stanza ((conn <xmpp-connection>))
- (define (FINISH-ELEMENT elem-gi attributes namespaces parent-seed seed)
- (define (RES-NAME->SXML res-name)
- (string->symbol (string-append (symbol->string (car res-name)) ":" (symbol->string (cdr res-name)))))
- (let ((seed (ssax:reverse-collect-str-drop-ws seed))
- (attrs (attlist-fold (lambda (attr accum)
- (cons (list (if (symbol? (car attr))
- (car attr)
- (RES-NAME->SXML (car attr)))
- (cdr attr))
- accum))
- '()
- attributes)))
- (cons (cons (if (symbol? elem-gi)
- elem-gi
- (RES-NAME->SXML elem-gi))
- (if (null? attrs)
- seed
- (cons (cons '@ attrs) seed)))
- parent-seed)))
- (define elem-parser (ssax:make-elem-parser (lambda (elem-gi attributes namespaces expected-content seed)
- '())
- FINISH-ELEMENT
- (lambda (string1 string2 seed)
- (if (string=? "" string2)
- (cons string1 seed)
- (cons* string2 string1 seed)))
- ()))
- (define (read-stanza inp)
- (call/cc
- (lambda (return)
- (while #t
- (when (char-ready? inp)
- (receive (_ token) (ssax:read-char-data inp #t (lambda _ #t) #t)
- (cond
- ((eof-object? token)
- (error <xmpp-error> "The connection closed by peer."))
- ((equal? token '(START . (stream . stream)))
- ;; <stream:stream> XMPP stream start.
- (receive
- (elem-gi attributes namespaces elem-content-model)
- (ssax:complete-start-tag '(stream . stream) inp #f '() '())
- (set! (ref conn 'stream-default-namespace) namespaces)
- (return (cons '*TOP* (FINISH-ELEMENT elem-gi attributes namespaces '() '())))))
- ((equal? token '(END . (stream . stream)))
- ;;</stream:stream> XMPP stream end.
- (return '(end-tag-of-stream)))
- ((eq? 'PI (xml-token-kind token))
- ;; if you need to process the xml PI, try a following line.
- ;;`(*PI* ,(xml-token-head token) ,(ssax:read-pi-body-as-string inp)))
- (ssax:skip-pi inp))
- ((eq? 'START (xml-token-kind token))
- (return (cons '*TOP*
- (elem-parser (xml-token-head token) inp #f '() (ref conn 'stream-default-namespace) #f '()))))
- (else
- ;;something wrong
- (error <xmpp-error> "Oops. Something wrong at XMPP parsing:" (read-char inp))))))))))
- (flush (ref conn 'socket-oport))
- (let1 stanza (read-stanza (ref conn 'socket-iport))
- (for-each (lambda (x)
- (receive (pred handler) (car+cdr x)
- (when (pred stanza)
- (handler conn stanza))))
- (ref conn 'channel))
- stanza))
- (define-syntax with-output-to-connection
- (syntax-rules ()
- ((_ conn body ...)
- (with-output-to-port (ref conn 'socket-oport)
- (lambda ()
- body
- ...
- (flush))))))
- (define (print-sxml sxml)
- (srl:sxml->xml sxml (current-output-port)))
- (define (filter-map-extra . args)
- (filter-map (lambda (x)
- (and (not (null? x)) x))
- args))
- ;;
- ;; Operators for communicating over the XML stream
- ;;
- ;;"Begin XML stream. This should be the first thing to happen on a
- ;; newly connected connection."
- (define-method begin-xml-stream ((conn <xmpp-connection>) . args)
- (let-keywords args ((xml-identifier #t))
- (with-output-to-connection conn
- (when xml-identifier
- (print "<?xml version='1.0' ?>"))
- (format #t "<stream:stream to='~a' ~a xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
- (or (ref conn 'jid-domain-part) (ref conn 'hostname))
- (if (ref conn 'xml:lang)
- (format #f "xml:lang='~a'" (ref conn 'xml:lang))
- "")))))
- ;;"Closes the XML stream. At this point you'd have to
- ;; call BEGIN-XML-STREAM if you wished to communicate with
- ;; the server again."
- (define-method end-xml-stream ((conn <xmpp-connection>))
- (with-output-to-connection conn
- (print "</stream:stream>")))
- (define-syntax xmpp-message
- (syntax-rules ()
- ((_ (conn args ...))
- (xmpp-message (conn args ...) #f))
- ((_ (conn args ...) extra ...)
- (let-keywords (list args ...) ((from #f)
- (id #f)
- (to #f)
- (type "normal")
- (xml:lang #f))
- (with-output-to-connection conn
- (print-sxml `(message (|@| ,@(cond-list
- (from `(from ,from))
- (id `(id ,id))
- (to `(to ,to))
- (type `(type ,type))
- (xml:lang `(xml:lang ,xml:lang))))
- ,@(filter-map-extra extra ...))))))))
- (define-syntax xmpp-presence
- (syntax-rules ()
- ((_ (conn args ...))
- (xmpp-presence (conn args ...) #f))
- ((_ (conn args ...) extra ...)
- (let-keywords (list args ...) ((from #f)
- (id #f)
- (to #f)
- (type #f)
- (xml:lang #f))
- (with-output-to-connection conn
- (print-sxml `(presence (|@| ,@(cond-list
- (from `(from ,from))
- (id `(id ,id))
- (to `(to ,to))
- (type `(type ,type))
- (xml:lang `(xml:lang ,xml:lang))))
- ,@(filter-map-extra extra ...))))))))
- ;;
- ;; Managing Subscriptions
- ;;
- (define-method xmpp-subscribe ((conn <xmpp-connection>) to)
- (xmpp-presence (conn :type "subscribe" :to to)))
- (define-method xmpp-subscribed ((conn <xmpp-connection>) to)
- (xmpp-presence (conn :type "subscribed" :to to)))
- (define-method xmpp-unsubscribe ((conn <xmpp-connection>) to)
- (xmpp-presence (conn :type "unsubscribe" :to to)))
- (define-method xmpp-unsubscribed ((conn <xmpp-connection>) to)
- (xmpp-presence (conn :type "unsubscribed" :to to)))
- (define-syntax xmpp-iq
- (syntax-rules ()
- ((_ (conn args ...))
- (xmpp-iq (conn args ...) #f))
- ((_ (conn args ...) extra ...)
- (let-keywords (list args ...) ((from #f)
- (id (random-id))
- (to #f)
- (type "get")
- (xml:lang #f))
- (with-output-to-connection conn
- (print-sxml `(iq (|@| ,@(cond-list
- (from `(from ,from))
- (id `(id ,id))
- (to `(to ,to))
- (#t `(type ,type))
- (xml:lang `(xml:lang ,xml:lang))))
- ,@(filter-map-extra extra ...))))))))
- ;;
- ;; Basic operations
- ;;
- (define-method xmpp-bind ((conn <xmpp-connection>) resource)
- (xmpp-iq (conn :type "set")
- `(bind (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-bind"))
- (resource ,resource))))
- (define-method xmpp-session ((conn <xmpp-connection>))
- (xmpp-iq (conn :type "set")
- `(session (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))
- ;;
- ;; Roster Management
- ;;
- (define-method xmpp-get-roster ((conn <xmpp-connection>))
- (xmpp-iq (conn :type "get")
- '(query (|@| (xmlns "jabber:iq:roster")))))
- (define-method xmpp-push-roster ((conn <xmpp-connection>) items)
- (xmpp-iq (conn :type "set")
- `(query (|@| (xmlns "jabber:iq:roster"))
- ,@items)))
- ;;
- ;; Blocking Communication
- ;;
- (define-method xmpp-get-privacy-lists-names ((conn <xmpp-connection>))
- (xmpp-iq (conn :type "get")
- `(query (|@| (xmlns "jabber:iq:privacy")))))
- (define-method xmpp-get-privacy-lists ((conn <xmpp-connection>) names)
- (xmpp-iq (conn :type "get")
- `(query (|@| (xmlns "jabber:iq:privacy"))
- ,@(map (lambda (name)
- `(list (|@| (name ,name))))
- names))))
- (define-method xmpp-set-privacy-lists ((conn <xmpp-connection>) body)
- (xmpp-iq (conn :type "set")
- `(query (|@| (xmlns "jabber:iq:privacy"))
- ,@body)))
- ;; --- SASL Authentication---
- (define-method xmpp-auth ((conn <xmpp-connection>) username password)
- (define mechanism-has-digest-md5?
- (if-car-sxpath '(// (urn:ietf:params:xml:ns:xmpp-sasl:mechanism ((equal? "DIGEST-MD5"))))))
- (define mechanism-has-plain?
- (if-car-sxpath '(// (urn:ietf:params:xml:ns:xmpp-sasl:mechanism ((equal? "PLAIN"))))))
- (define mechanism-has-anonymous?
- (if-car-sxpath '(// (urn:ietf:params:xml:ns:xmpp-sasl:mechanism ((equal? "ANONYMOUS"))))))
- (let1 features (ref conn 'features)
- (cond ((mechanism-has-digest-md5? features)
- (xmpp-sasl-digest-md5 conn username password))
- ((mechanism-has-plain? features)
- (xmpp-sasl-plain conn username password))
- ((mechanism-has-anonymous? features)
- (xmpp-sasl-anonymous conn)))))
- (define-method xmpp-auth-select-mechanism ((conn <xmpp-connection>) mechanism)
- (with-output-to-connection conn
- (print-sxml `(auth (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")
- (mechanism ,mechanism))))))
- (define (if-successful-restart-stream conn reply)
- (if (eq? (caadr reply) 'urn:ietf:params:xml:ns:xmpp-sasl:success)
- (begin
- (begin-xml-stream conn :xml-identifier #f)
- (xmpp-receive-stanza conn) ; stream
- (xmpp-receive-stanza conn) ; features
- :success)
- :failure))
- (define-method xmpp-sasl-anonymous ((conn <xmpp-connection>))
- (with-output-to-connection conn
- (print-sxml `(auth (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")
- (mechanism "ANONYMOUS")))))
- (if-successful-restart-stream conn (xmpp-receive-stanza conn)))
- (define-method xmpp-sasl-plain ((conn <xmpp-connection>) username password)
- (with-output-to-connection conn
- (print-sxml `(auth (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")
- (mechanism "PLAIN"))
- ,(base64-encode-string (string-join `("" ,username ,password) "\u0000")))))
- (if-successful-restart-stream conn (xmpp-receive-stanza conn)))
- (define-method xmpp-sasl-digest-md5 ((conn <xmpp-connection>) username password)
- ;; We immediately return when any auth steps have failed.
- (define (step1 return)
- (let1 initial-challenge (xmpp-receive-stanza conn)
- (if (eq? (caadr initial-challenge) 'urn:ietf:params:xml:ns:xmpp-sasl:challenge)
- (let1 challenge-string (base64-decode-string (sxml:string-value initial-challenge))
- (make-digest-md5-response username password (ref conn 'hostname) challenge-string))
- (return initial-challenge))))
- (define (step2 return response rspauth-expected)
- (let* ((second-challenge (xmpp-receive-stanza conn))
- (rspauth (assoc-ref (parse-challenge (base64-decode-string (sxml:string-value second-challenge))) "rspauth")))
- (or (and (eq? (caadr second-challenge) 'urn:ietf:params:xml:ns:xmpp-sasl:challenge)
- (string=? rspauth-expected rspauth))
- (return second-challenge))))
- (if-successful-restart-stream
- conn
- (call/cc
- (lambda (return)
- (with-output-to-connection conn
- (print-sxml `(auth (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")
- (mechanism "DIGEST-MD5")))))
- (receive (response rspauth) (step1 return)
- (with-output-to-connection conn
- (print-sxml `(response (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl"))
- ,(base64-encode-string response))))
- (step2 return response rspauth))
- (with-output-to-connection conn
- (print-sxml `(response (|@| (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")))))
- (xmpp-receive-stanza conn)))))
- (define (parse-challenge str)
- (filter-map (lambda (x)
- (rxmatch-if (#/^([^=]+)=(.*)/ x)
- (#f key value)
- ;; strip double-quotes.
- (rxmatch-if (#/^\"(.*)\"$/ value)
- (#f s)
- (cons key s)
- (cons key value))
- #f))
- (string-split str ",")))
- (define (make-digest-md5-response username password hostname challenge)
- (define (dblq str)
- (string-append "\"" str "\""))
- (let1 l (parse-challenge challenge)
- (let ((nonce (assoc-ref l "nonce"))
- (qop (assoc-ref l "qop"))
- (charset (assoc-ref l "charset"))
- (digest-uri (string-append "xmpp/" hostname))
- (cnonce (make-cnonce))
- (realm "")
- (nc "00000001"))
- (let ((rsp (digest-md5 username #f realm password digest-uri nonce cnonce nc qop #t))
- (rspauth-expected (digest-md5 username #f realm password digest-uri nonce cnonce nc qop #f)))
- (values (string-join (map (cut string-join <> "=")
- `(("username" ,(dblq username))
- ("realm" ,(dblq realm))
- ("nonce" ,(dblq nonce))
- ("cnonce" ,(dblq cnonce))
- ("digest-uri" ,(dblq digest-uri))
- ("response" ,rsp)
- ("nc" ,nc)
- ("qop" ,qop)
- ("charset" ,charset)))
- ",")
- rspauth-expected)))))
- (define (make-cnonce)
- (let1 uv (make-u32vector 4)
- (mt-random-fill-u32vector! *mt* uv)
- (base64-encode-string (u32vector->string uv))))
- (define (digest-md5 authc-id authz-id realm password digest-uri nonce cnonce nc qop request)
- (and-let* ((X (string-join `(,authc-id ,realm ,password) ":"))
- (Y (md5-digest-string X))
- (A1 (string-join (if authz-id
- `(,Y ,nonce ,cnonce ,authz-id)
- `(,Y ,nonce ,cnonce))
- ":"))
- (A2 (string-join `(,(if request
- "AUTHENTICATE"
- "")
- ,digest-uri)
- ":"))
- (HA1 (digest-hexify (md5-digest-string A1)))
- (HA2 (digest-hexify (md5-digest-string A2)))
- (KD (string-join `(,HA1 ,nonce ,nc ,cnonce ,qop ,HA2) ":"))
- (Z (digest-hexify (md5-digest-string KD))))
- Z))
- (provide "rfc/xmpp")