{
;;; ./jabberd.exe -D
;;; http://jabberd.jabberstudio.org/1.4/doc/?page=adminguide#intro
http://www.javaworld.com/javaworld/jw-07-2002/jw-0726-im_p.html
What is xml stream header id for?

}
(begin
  (import "java.net.InetAddress")
  (import "java.net.URLDecoder")
  (import "java.net.URLEncoder")
  (import "org.jabber.jabberbeans.*")
  (import "org.jabber.jabberbeans.Extension.IQAuthBuilder")
  (import "org.jabber.jabberbeans.Extension.IQRegisterBuilder")
  (import "org.jabber.jabberbeans.Extension.MessageBuilder")
  (import "org.jabber.jabberbeans.util.JID")
  (import "org.jabber.jabberbeans.util.PacketDebug")
  (import "scm.Handler")

  (load "elf/proxy.scm")
  )

(define genid
  (let ((i 0))
    (\\ () {g[(set! i (+ i 1))]})))

(define jabberHost "birchbeer.bbn.com")
(define-method (JID (o Object)) (JID (.toString o)))
(define-method (JID (s String)) (JID.fromString s))
(define-method (JID (j JID))    j)

(define jabberFrom (JID {[($ "user.name")]@[jabberHost]/Tracker}))

;;; Implement the PacketListener Interface.
(define (jabberPacketHandler proxy method args)
  (let ((L (or (and (isNull args) 0)
               (vector-length args)))
        (name (.getName method)))
  ;; (print `(method ,name args ,args))
    (case L
      ((0) (case name
             (("toString") "jabberPacketHandler")
             (("hashCode") (.hashCode "jabberPacketHandler"))
             (else         (error "jabberPacketHandler got" method))))
      ((1) ((case name
              (("sendFailed")     jabberSendFailed)
              (("receivedPacket") jabberReceivePacket)
              (("sentPacket")     jabberSentPacket)
              (("equals")         eq?)
             (else               (error "jabberPacketHandler got" method)))
            proxy
            (vector-ref args 0))))))

(define (jabberSendFailed ignored event) (print `(failed ,(.getPacket event))))
(define (jabberSentPacket ignored event)
  (set! S (.getPacket event))
  (print `(sent ,(.getPacket event))))

;;; List of packet handlers.
(define handlers '())
(define notfired (list 'notfire))

(define (addHandler once? action)
  (let ((h (Handler once? action)))
    (set! handlers (cons h handlers))
    (print `(addHandler ,(length handlers)))))

(define (removeHandler h)
  (set! handlers (filter (_ (not (eq? _ h))) handlers))
  (print `(removeHandler ,(length handlers))))

;;; Handler #(vector Handler ,once? ,action)
;;; once? - should this handler only run once?
;;; action - (Packet -> boolean) returns notfired if action did not
;;; fire on the packet.
(define (Handler once? action)
  (vector 'Handler once? action))

(define (handler:once?  h) (vr h 1))
(define (handler:action h) (vr h 2))

(define (fireHandlers p)
  ;; (print `(fireHandlers ,(length handlers)))
  (dolist (h handlers)
    ;; (print h)
    (let ((happy ((handler:action h) p)))
      (if (and (handler:once? h) (not (eq? happy notfired)))
          (removeHandler h)))))

(define (jabberReceivePacket ignored event)
  (let ((p (.getPacket event)))
    (set! R p)
    (print `(received ,p))
    (fireHandlers p)))

;;; List of JID's of online people.
(define FRIENDS '())

(define (presenceHandler p)
  (if (instanceof p Presence.class)
      (let ((from (.getFromAddress p)))
        (print `(presenceHandler ,from))
        (if (not (member from FRIENDS))
            (set! FRIENDS (cons from FRIENDS)))
        #t)))

(addHandler #f presenceHandler)

(define MESSAGES '())

;;; Save all incoming messages.
(define (messageHandler p)
  (cond ((instanceof p Message.class)
         (print p)
         (set! MESSAGES (cons p MESSAGES)))))
(addHandler #f messageHandler)

(define jabberBean
  (let ((it (ConnectionBean.)))
    ;; (.addPacketListener it (PacketDebug.))
    (.addPacketListener it (Proxy (.getClassLoader PacketListener.class)
                                  (array Class.class PacketListener.class)
                                  jabberPacketHandler))
    it))

(define (jbConnect)
  (.connect jabberBean (InetAddress.getByName jabberHost)))

(define (jbQuery type id builder . kvs)
  (define (loop kvs)
    (if (null? kvs)
        builder
        (begin (.set builder (car kvs) (cadr kvs))
               (loop (cddr kvs)))))
  (.build (with (InfoQueryBuilder.)
                .setType type
                .setIdentifier id
                .addExtension
                (.build (loop kvs)))))

(define (jabberRegister user password)
  ;; Register a new user.
  (.send jabberBean
         (jbQuery "set" "set-1"
                  (IQRegisterBuilder.)
                  "username" user
                  "password" password)))

;;; A box contains a value, one thread waits for it, another fills it.
(define (Box) (cons #f #f))
(define (box-empty? box) (not (cdr box)))

(define (box-ref box)
  (synchronize
   box
   (lambda (box)
     (while (box-empty? box) (.wait box))
     (car box))))

(define (box-set! box value)
  (synchronize
   box
   (lambda (box)
     (set-car! box value)
     (set-cdr! box #t)
     (.notify box))))

'(define (example)
  (let ((box (Box)))
    (.start (Thread.
             (lambda ()
               (Thread.sleep 5000L)
               (box-set! box 3))))
    (box-ref box)))

(define-macro (send/wait jabberBean packet response)
  `(let ((box (Box)))
     (addHandler
      #t
      (lambda (p)
        (box-set! box (,response p))
        #t))
     (.send ,jabberBean ,packet)
     (box-ref box)))

(define (jabberRegister user password)
  ;; Register a new user.
  (send/wait
   jabberBean
   (jbQuery "set" "set-1"
            (IQRegisterBuilder.)
            "username" user
            "password" password)
   (\\ (p)
    (if (equal? (.getIdentifier p) "set-1")
        (not (equal? (.getErrorCode p) "409"))
        notfired))))

;;; (jabberRegister ($ "user.name") "jabber")

(define (jbLogin user password resource)
  ;; Login. resource is your client "Tracker" in this case.
  ;; Your jabber ID (JID) will be user@jabberHost/resource.
  (send/wait
   jabberBean
   (.build (with (InfoQueryBuilder.)
                 .setIdentifier "set-1"
                 .setType "set"
                 .addExtension
                 (.build (with (IQAuthBuilder.)
                               .setUsername user
                               .setPassword password
                               .setResource resource))))
   (\\ (p)
    (if (equal? (.getIdentifier p) "set-1")
        (equal? (.getType p) "result")
        notfired))))

(define (jbRegisterFields R)
  (map* identity (.getNames# (.nextElement (.Extensions (.getPacket R))))))

(define (jbPresence)
  ;; Announce your Presences
  (.send jabberBean (.build (PresenceBuilder.))))
;;; jbMessage: JID String String -> void
(define (jbMessage to subject body)
  ;; Send a message.
  (.send jabberBean
         (Message.
          (with (MessageBuilder.)
                .setType "chat"
                .setToAddress (JID to)
                .setFromAddress jabberFrom
                .setSubject subject
                .setBody body))))

(define (jbStart)
  (jbConnect)
  (jbLogin ($ "user.name") "jabber" "Tracker")
  (jbPresence))

{
(jbMessage "kanderso@birchbeer.bbn.com" "hello" "Did you get this?")
}

(define (evalHandler p)
  (if (instanceof p Message.class)
      (let ((result (tryCatch
                     `(ok ,(eval (string->expr(.getBody p))))
                     (lambda (e) `(error ,(.toString e))))))
        (jbMessage
         (.getFromAddress p)
         ""
         (printingToString
          (\\ (s) (for-each (\\ (x) (print x s)) result)))))))

(define (evalMessage to exp)
  (let ((result (tryCatch `(ok ,(eval exp))
                          (lambda (e) `(error ,(.toString e))))))
    (jbMessage
     to
     ""
     (printingToString
      (\\ (s) (for-each (\\ (x) (print x s)) result))))))

(define (remindMessage to interval what)
  (.start (Thread. (\\ () (Thread.sleep interval)
                    (jbMessage to "" what)))))

(define (evalHandler p)
  (if (instanceof p Message.class)
      (let ((to (.getFromAddress p))
            (exp (string->expr(.getBody p))))
        (print `(evalHandler ,to ,exp))
        (if (pair? exp)
            (case (car exp)
              ((remind) (apply remindMessage to (cdr exp)))
              ((report) (apply reportMessage to (map eval (cdr exp))))
              (else (evalMessage to exp)))
            (evalMessage to exp)))))

(addHandler #f evalHandler)

(define (usedMemory)
  (let ((r (Runtime.getRuntime)))
    `(usedMemory ,(- (.totalMemory r) (.freeMemory r)))))

(define TASKS (java.util.HashMap.))

(define (reportMessage to interval what)
  (.start
   (Thread.
    (\\ ()
     (dotimes (i 10)
       (Thread.sleep interval)
       (jbMessage to "" (.toString (what))))))))