initial commit

1 files changed, 99 insertions, 0 deletions

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)))))))))