blob: 9b9440819be449ef85b6575a24a9e6b9f1c6f662 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
(define-module (gnubba xep-0114)
#:use-module (gnubba sha1)
#:use-module (gnubba sugar)
#: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
(xmpp-> sock 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)))))))))
|
