initial commit

4 files changed, 287 insertions, 0 deletions

diff --git a/README b/README
new file mode 100644
index 0000000..f403d01
--- /dev/null
+++ b/README
@@ -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)