Browse files

seed

  • Loading branch information...
0 parents commit c45064ac6588aaedf589893a14c730ecd039021a @zzkt committed Apr 2, 2009
Showing with 546 additions and 0 deletions.
  1. +165 −0 LICENCE
  2. +43 −0 README.md
  3. +28 −0 gibebrish.scrbl
  4. +20 −0 info.ss
  5. +290 −0 xmpp.scm
165 LICENCE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ 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.
43 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
+
28 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))))))
+ ]
+
+
20 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" ()))
290 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 <nik@fo.am>
+;;;
+;;; 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 "<?xml version='1.0'?><stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='" host "' xmlns='jabber:client'>"))
+
+ ;; 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) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")
+
+ ;; 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 "") "<presence/>")
+ (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 "<me") str)
+ ((string-ci=? test "<iq") str)
+ ((string-ci=? test "<pr") str)
+ (else "<null/>"))))
+
+
+ ;; 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
+

0 comments on commit c45064a

Please sign in to comment.