diff options
| -rw-r--r-- | README | 2 | ||||
| -rw-r--r-- | sha1.scm | 33 | ||||
| -rw-r--r-- | xep-0114.scm | 99 | ||||
| -rw-r--r-- | xmpp.scm | 153 |
4 files changed, 287 insertions, 0 deletions
@@ -0,0 +1,2 @@ +Gnubba is written in Guile Scheme and should eventually become a +general purpose XMPP library. diff --git a/sha1.scm b/sha1.scm new file mode 100644 index 0000000..6b3cb37 --- /dev/null +++ b/sha1.scm @@ -0,0 +1,33 @@ +(define-module (gnubba sha1) + #:use-module (rnrs bytevectors) + #:use-module (system foreign) + #:use-module (ice-9 iconv) + #:export (sha1)) + +(define-syntax GCRY_MD_SHA1 + ;; Value defined in /usr/include/gcrypt.h + (identifier-syntax 2)) + +(define* (sha1 string #:optional style) + (hex-string (sha1-bytevector (string->bytevector string "UTF-8")))) + +(define (hex-string bv) + "Convert bytevector into string of two-digit hex numbers." + (string-concatenate (map (lambda (n) + (let ((s (number->string n 16))) + (if (eq? 1 (string-length s)) + (string-concatenate (list "0" s)) + s))) + (bytevector->u8-list bv)))) + +(define sha1-bytevector + (let ((hash (pointer->procedure void + (dynamic-func "gcry_md_hash_buffer" + (dynamic-link "libgcrypt")) + `(,int * * ,size_t)))) + (lambda (bv) + "Return the SHA256 of BV as a bytevector." + (let ((digest (make-bytevector 20))) + (hash GCRY_MD_SHA1 (bytevector->pointer digest) + (bytevector->pointer bv) (bytevector-length bv)) + digest)))) diff --git a/xep-0114.scm b/xep-0114.scm new file mode 100644 index 0000000..f882530 --- /dev/null +++ b/xep-0114.scm @@ -0,0 +1,99 @@ +(define-module (gnubba xep-0114) + #:use-module (gnubba sha1) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (sxml simple) + #:export (with-component)) + + +(define component-port 5347) + + +(define (stream-header component-name) + (string-concatenate (list "<stream:stream xmlns='jabber:component:accept' xmlns:stream='http://etherx.jabber.org/streams' to='" component-name "'>"))) + + +(define (generate-handshake stream-id shared-secret) + (sha1 (string-concatenate (list stream-id shared-secret)))) + + +;; Establish a component connection and execute actions. +(define-syntax with-component + (syntax-rules () + ((with-component domain shared-secret exp ...) + (begin + (define addr (make-socket-address AF_INET INADDR_LOOPBACK component-port)) + (define sock (socket AF_INET SOCK_STREAM 0)) + + (define (get-attribute name response) + (define (get-attributes) + "Extract key value pairs from a string and return as alist." + (map (lambda (res) + (cons (match:substring res 1) + (match:substring res 3))) + (list-matches "([^= ]+)=(['\"])([^ ]+)\\2" response))) + (let ((found (assoc name (get-attributes)))) + (unless found + (throw 'stream-error 'attribute-not-found name response)) + found)) + + (define (close-stream) + ;; TODO: make sure this is understood as "</stream:stream>" + (display "</stream>" sock) + ;; TODO: wait for other side to also send a closing tag before terminating the connection + (close-port sock)) + + (define (write-to-stream msg) + "Write msg to sock and return a single response tag. Ignore <?xml..> tag." + (when msg + (display msg sock)) + (let ((response-string (read-delimited ">" sock))) + (if (string-match "<?xml" response-string) + (let ((response-string (read-delimited ">" sock))) + response-string) + response-string))) + + (catch #t + (lambda () + (connect sock addr) + (let ((response (write-to-stream (stream-header domain)))) + ;; server must reply with either an error or a stream header + ;; TODO: should not match against literal string + (unless (string-match "<stream:stream" response) + (throw 'stream-error 'stream response)) + (let ((stream-id (cdr (get-attribute "id" response)))) + ;; send handshake + (sxml->xml `(handshake ,(generate-handshake stream-id shared-secret)) sock) + (let* ((ns '((stream . "http://etherx.jabber.org/streams"))) + (response (xml->sxml sock #:namespaces ns #:trim-whitespace? #t))) + ;; expect empty handshake element as acknowlegement + (unless (equal? 'handshake (caadr response)) + (throw 'stream-error 'handshake response)) + + (display "Connected to XMPP server!\n") + + ;; Handlers are passed as expressions that + ;; are evaluated in the xmpp monad. + (display "Registering handlers...\n") + (begin + exp ...) + + ;; Blocking wait for stanzas. At this + ;; point, new handler can only be + ;; registered by previously registered + ;; handlers. + (display "Starting listener loop.\n") + (run-handler-loop sock) + + ;; close connection at the end + (display "Closing stream.\n") + (close-stream))))) + (lambda (key . args) + (if (and (equal? 'system-error key) + (string-prefix? "connect" (car args))) + (begin + ;; connection refused or something + (display (format #t "ERROR: ~S\n" (cdr args)))) + (begin + (display (format #t "ERROR: ~S. Closing stream. (~S)\n" key args)) + (close-stream))))))))) diff --git a/xmpp.scm b/xmpp.scm new file mode 100644 index 0000000..ed6ab7e --- /dev/null +++ b/xmpp.scm @@ -0,0 +1,153 @@ +(define-module (gnubba xmpp) + #:use-module (sxml simple) + #:use-module ((srfi srfi-1) #:select (find)) + #:export (iq + presence + stanza-id + stanza-to + stanza-from + stanza-type + register-temp-stanza-handler-for-id + register-stanza-handler + run-handler-loop + )) + + +;; TODO: it's ugly to have global variables like this. Can this be +;; scoped inside the loop or with-component/with-connection functions? +(define *stanza-handlers* '()) +(define *stanza-id-handlers* (make-hash-table)) + +(define (register-stanza-handler predicate handler) + "Register handler function that will be executed when a stanza is +encountered that matches the given predicate." + (set! *stanza-handlers* (cons `(,predicate . ,handler) *stanza-handlers*))) + +(define (register-temp-stanza-handler-for-id stanza-id handler) + "Register handler function that will be executed when a stanza with +the given id is encountered by the parser. Upon execution the handler +is unregistered." + (hash-set! *stanza-id-handlers* stanza-id + (lambda (stanza) + (begin + (hash-remove! *stanza-id-handlers* stanza-id) + (handler stanza))))) + +(define (try-stanza-handlers stanza) + "Run all matching handlers in *stanza-handlers*." + (map (lambda (pair) + (let ((predicate (car pair)) + (handler (cdr pair))) + (when (predicate stanza) + (handler stanza)))) + *stanza-handlers*)) + +(define (handle-stanza stanza) + "Check if handler for this stanza id exists and run it if it exists. Then try all other handlers." + (let ((id-handler (hash-ref *stanza-id-handlers* (stanza-id stanza)))) + (catch 'halt + (lambda () + (when id-handler (id-handler stanza)) + (try-stanza-handlers stanza)) + (lambda (key . args) + ;; return whatever argument was passed to 'halt + (car args))))) + +(define (run-handler-loop port) + "Repeatedly check for incoming stanzas. When a stanza handler exists it is executed in parallel. A handler may register new handlers." + (catch #t + (lambda () + (while (not (port-closed? port)) + (let ((stanza (xml->sxml port #:trim-whitespace? #t))) + (format #t "received a stanza: ~s\n" stanza) + ;; TODO: handle the stanza in a non-blocking manner! + (handle-stanza stanza) + ;; no tight loop, please + (sleep 1))) + (display "port was closed.\n")) + (lambda (key . args) + (format #t "ERROR: in handler loop: ~a ~a\n" key args) + key))) + + +(define next-stanza-id! + (let ((id 0)) + (lambda (type) + "Return a new stanza id. Never returns the same id." + (let ((res (format #f "gnubba-~4,'0X-~a" id (symbol->string type)))) + (set! id (1+ id)) + res)))) + +(define (drop-empty-attr attributes) + `(@ ,@(filter (lambda (attr) + (not (string-null? (cadr attr)))) + (cdr attributes)))) + +(define* (iq body #:key + (from "") + (to "") + (type "get") + (id (next-stanza-id! 'iq))) + `(iq ,(drop-empty-attr `(@ (from ,from) + (to ,to) + (type ,type) + (id ,id))) + ,body)) + +(define (message to body) + `(message (@ (to ,to)) (body ,body))) + +(define* (presence #:optional body #:key + (from "") + (to "") + (type "") + (id (next-stanza-id! 'pres))) + (let ((attr (drop-empty-attr + `(@ (type ,type) + (from ,from) + (to ,to) + (id ,id))))) + (if body + `(presence ,attr ,body) + `(presence ,attr)))) + + +(define (stanza-find-property property-name stanza) + "Return the given property of a stanza or #f if there is none." + (let ((properties (cadr stanza))) + (if (equal? '@ (car properties)) + (let ((res (find (lambda (prop) (eq? property-name (car prop))) + (cdr properties)))) + (if res + (cadr res) + #f))))) + +;; generate accessor functions for various stanza attributes +(for-each + (lambda (attr) + (eval `(define ,(symbol-append 'stanza- attr) + (lambda (stanza) (stanza-find-property (quote ,attr) stanza))) + (current-module))) + '(from to type id)) + +;; TODO: here again with macros: +;; (define-syntax define-attribute +;; (lambda (form) +;; (syntax-case form () +;; ((define-attribute attr) +;; (identifier? #'attr) +;; (with-syntax +;; ((name (datum->syntax #'attr (symbol-append 'stanza- (syntax->datum #'attr))))) +;; #'(define (name stanza) +;; (stanza-find-property 'attr stanza))))))) + +;; (define-syntax-rule (define-attributes (attr ...)) +;; (begin (define-attribute attr) ...)) + +;; (define-attributes (from to type id)) + + +;; TODO: define some useful predicates +(define (iq? stanza) #f) +(define (message? stanza) #f) +(define (presence? stanza) #f) |