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