commit c45064ac6588aaedf589893a14c730ecd039021a Author: nik gaffney Date: Thu Apr 2 17:49:11 2009 +0200 seed diff --git a/LICENCE b/LICENCE new file mode 100644 index 0000000..fc8a5de --- /dev/null +++ b/LICENCE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.md b/README.md new file mode 100644 index 0000000..a38eed2 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ + +# Gibberish + +A basic module for IM using the Jabber/XMPP protocol with PLT Scheme. + +## Protocol Support + +Should eventually implement XMPP-Core and XMPP-IM to conform with RFCs 3920 and 3921. + +## example chat client + +(require xmpp) + +(define (read-input prompt) + (display prompt) + (read-line (current-input-port))) + +(define (chat) + (let ((jid (read-input "jid: ")) + (pass (read-input "password: ")) + (to (read-input "chat with: "))) + (with-xmpp-session jid pass + (set-xmpp-handler 'message print-message) + (let loop () + (let ((msg (read-line (current-input-port)))) + (send (message to msg)) + (loop)))))) + + +## possiby interesting extensions to implement. http://xmpp.org/extensions/ + +* XEP-0047: In-Band Bytestreams +* XEP-0066: Out of Band Data +* XEP-0030: Service Discovery +* XEP-0060: Publish-Subscribe +* XEP-0045: Multi-User Chat +* XEP-0149: Time Periods +* XEP-0166: Jingle +* XEP-0174: Serverless Messaging +* XEP-0199: XMPP Ping +* XEP-0224: Attention +* XEP-0077: In-Band Registration + diff --git a/gibebrish.scrbl b/gibebrish.scrbl new file mode 100644 index 0000000..7cbea64 --- /dev/null +++ b/gibebrish.scrbl @@ -0,0 +1,28 @@ +#lang scribble/doc +@(require scribble/manual) + +@title{Gibberish} + +@title{Example chat client} + +@schemeblock[ + + (require xmpp) + + (define (read-input prompt) + (display prompt) + (read-line (current-input-port))) + + (define (chat2) + (let ((jid (read-input "jid: ")) + (pass (read-input "password: ")) + (to (read-input "chat with: "))) + (with-xmpp-session jid pass + (set-xmpp-handler 'message print-message) + (let loop () + (let ((msg (read-line (current-input-port)))) + (send (message to msg)) + (loop)))))) + ] + + diff --git a/info.ss b/info.ss new file mode 100644 index 0000000..13fa154 --- /dev/null +++ b/info.ss @@ -0,0 +1,20 @@ +#lang setup/infotab +;; http://docs.plt-scheme.org/planet/Developing_Packages_for_PLaneT.html + +(define name "gibberish") + +(define 'blurb "A client library for the XMPP or Jabber protocol.") + +(define 'release-notes "") + +(define 'categories '(xml net)) + +(define 'homepage "") + +(define 'primary-file "xmpp.scm") + +(define 'repositories "4.x") + +(define 'required-core-version "4.1.5") + +(define scribblings '("gibberish.scrbl" ())) diff --git a/xmpp.scm b/xmpp.scm new file mode 100644 index 0000000..abe6bfa --- /dev/null +++ b/xmpp.scm @@ -0,0 +1,290 @@ +;;; A basic XMPP library which should conform to RFCs 3920 and 3921 +;;; +;;; 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 +;;; +;;; nik gaffney +;;; +;;; Requirements +;;; +;;; 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 +;;; - 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) +;;; - parse (some) xml reponses from server +;;; - handlers for responses +;;; +;;; features to implement +;;; - account creation +;;; - managing subscriptions (rfc 3921 sec.6) +;;; - rosters (rfc 3921 sec.7) +;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6) +;;; - encrypted connections using tls on port 5222 +;;; - correct namespaces in sxml +;;; - message types +;;; - maintain session ids +;;; - maintain threads +;;; - error handling +;;; - events +;;; - [...] +;;; - rfc 3920 +;;; - rfc 3921 +;;; +;;; bugs and/or improvements +;;; - read-async & repsonse-handler +;;; - ssax:xml->sxml or lazy:xml->sxml +;;; - default handlers +;;; - 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) + (require mzlib/defmacro) + (require scheme/tcp) + (require openssl) + (require srfi/13) + + ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; + ;; + ;; networking + ;; + ;;;;;; ;; ;; ; ; ; ; + + (define port 5222) + (define ssl-port 5223) + + (define (open-connection machine port handler) + (let-values (((in out) + (tcp-connect machine port))) + (handler in out) + (close-output-port out) + (close-input-port in))) + + (define (open-ssl-connection machine port handler) + (let-values (((in out) + (ssl-connect machine port 'tls))) + (handler in out) + (close-output-port out) + (close-input-port in))) + + (define (read-async in) + (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) + + ;;;;;; ; ; ; ; ;; ;;;;;; ; + ;; + ;; XMPP stanzas + ;; + ;;;;;;;;;; ;;; ; ;; ; ; + + ;; intialization + (define (xmpp-stream host) + (string-append "")) + + ;; authentication + (define (xmpp-auth username password resource) + (ssxml `(iq (@ (type "set") (id "auth")) + (query (@ (xmlns "jabber:iq:auth")) + (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 + (define (message to body) + (ssxml `(message (@ (to ,to)) (body ,body)))) + + ;; presence + (define (presence #:from (from "") + #:to (to "") + #:type (type "") + #:show (show "") + #:status (status "")) + (cond ((not (string=? status "")) + (ssxml `(presence (@ (type "probe")) (status ,status)))) + ((string=? type "") "") + (else (ssxml `(presence (@ (type ,type))))))) + + + ;; curried stanza disection (sxml stanza -> string) + (define ((sxpath-element xpath) stanza) + (let ((node ((sxpath xpath) stanza))) + (if (empty? node) "" (car node)))) + + ;; message + (define message-from (sxpath-element "message/@from/text()")) + (define message-to (sxpath-element "message/@to/text()")) + (define message-id (sxpath-element "message/@id/text()")) + (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()")) + + + ;;;;;;;;; ; ;; ; ; ;; ;; ; ; + ;; + ;; parsing & message/iq/error handlers + ;; - minimal parsing + ;; - handlers match on a tag (eg. 'message) + ;; - handlers are called with a single relevant xmpp stanza + ;; + ;;;;;; ;; ; ; ;; ; + + (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)) + + (define (run-xmpp-handler type sz) + (let ((fcn (dict-ref xmpp-handlers type #f))) + (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) + (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '()))) + ;;(let ((sz (lazy:xml->sxml (open-input-string str) '()))) + (cond + ((equal? '(null) (cadr sz)) + (newline)) + ((equal? 'message (caadr sz)) + (run-xmpp-handler 'message sz)) + ((equal? 'iq (caadr sz)) + (run-xmpp-handler 'iq sz)) + ((equal? 'presence (caadr sz)) + (run-xmpp-handler 'presence sz)) + (else (run-xmpp-handler 'unknown sz)))))) + + ;; 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)))) + + (define (print-presence sz) + (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))) + + (define (print-stanza sz) + (display (format "? ?? -> ~%~a~%" sz))) + + ;; 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 "")))) + + + ;; response handler + (define (xmpp-response-handler in) + (thread (lambda () + (let loop () + (parse-xmpp-response (read-async in)) + (sleep 0.1) ;; slight delay to avoid a tight loop + (loop))))) + + ;; 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) (flush-output out)) + (file-stream-buffer-mode out 'line) + (xmpp-response-handler in) + (send (xmpp-stream host)) + (send (xmpp-session host)) + ;(send starttls) + (send (xmpp-auth user ,pass resource)) + (send (presence)) + (send (presence #:status "Available")) + ,@body + (close-output-port out) + (close-input-port in)))) + + + ) ;; end module +