(define-module (gnubba xmpp)
  #:use-module (sxml simple)
  #:use-module ((sxml xpath) #:select (sxpath))
  #:use-module ((srfi srfi-1) #:select (find))
  #:export (iq iq?
            presence presence?
            message message?
            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-syntax register-stanza-handler
  (lambda (s)
    "Register handler function that will be executed when a stanza is
encountered that matches the given predicate."
    (syntax-case s ()
      ((_ guard handler)
       (if (eqv? #t (syntax->datum #'guard))
           #'(set! *stanza-handlers* (cons `(,(lambda _ #t) . ,handler) *stanza-handlers*))
           #'(set! *stanza-handlers* (cons `(,guard . ,handler) *stanza-handlers*))))
      ((_ handler)
       #'(set! *stanza-handlers* (cons `(,(lambda _ #t) . ,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)))
           (if (predicate stanza)
               (handler stanza)
               #f)))
       *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) args))))

(define* (run-handler-loop port #:optional (log-port #t))
  "Repeatedly check for incoming stanzas.  When a stanza handler
exists it is executed in parallel.  A handler may register new
handlers."
  (while (not (or (port-closed? port)
                  (eof-object? (peek-char port))))
    (catch #t
      (lambda _
        (let ((stanza (xml->sxml port #:trim-whitespace? #t)))
          ;; TODO: handle the stanza in a non-blocking manner!
          (handle-stanza stanza)
          ;; no tight loop, please
          (sleep 1)))
      (lambda (key . args)
        (format log-port "ERROR: in handler loop: ~a ~a\n" key args)
        key)))
  (format log-port "port was closed.\n"))


(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)))
  `(*TOP* (iq ,(drop-empty-attr `(@ (from ,from)
                                    (to ,to)
                                    (type ,type)
                                    (id ,id)))
              ,body)))

(define (message to body)
  `(*TOP* (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)))))
    `(*TOP* ,(if body
                 `(presence ,attr ,body)
                 `(presence ,attr)))))


(define (stanza-find-property property-name stanza)
  "Return the value of a given stanza property or #f if there is
none."
  (let ((property ((sxpath `(* @ ,property-name)) stanza)))
    (if (null? property)
        #f
        (cadar property))))

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


(define (iq?       stanza) (not (null? ((sxpath '(iq))       stanza))))
(define (message?  stanza) (not (null? ((sxpath '(message))  stanza))))
(define (presence? stanza) (not (null? ((sxpath '(presence)) stanza))))