jabber parrot bot

parrot.scm

(use iconv)
(use loudmouth)
(use lolevel)

(define-constant jhost   "talk.google.com")
(define-constant jresource "Home")

(define *iconv-desc* (iconv-open "euc-jp" "utf-8"))

(define (lm:debug-print title msg)
  (print (format "~a : ~a" title (iconv *iconv-desc* msg))))

(define (send-presence conn)
  (lm:call-with-message-with-sub-type
   #f *LM-MESSAGE-TYPE-PRESENCE* *LM-MESSAGE-SUB-TYPE-AVAILABLE*
   (lambda (m)
     (lm:safe-connection-send conn m))))

(define (send-message conn to msg)
  (lm:call-with-message
   to *LM-MESSAGE-TYPE-MESSAGE*
   (lambda (m)
     (lm:message-node-add-child (lm:message-node? m) "body" msg)
     (lm:safe-connection-send conn m))))

(define (roster? conn)
  (lm:call-with-message-with-sub-type
   #f *LM-MESSAGE-TYPE-IQ* *LM-MESSAGE-SUB-TYPE-GET*
   (lambda (m)
     (let ((q (lm:message-node-add-child (lm:message-node? m) "query" #f)))
       (lm:message-node-attribute! q "xmlns" "jabber:iq:roster")
       (lm:debug-print
        "send-roster"
        (lm:message-node-to-string (lm:message-node? m)))
       (lm:debug-print
        "reply roster"
        (lm:message-node-to-string
         (lm:message-node? (lm:safe-connection-send-with-reply-and-block conn m))))))))

(define main-loop-new
  (foreign-safe-lambda c-pointer
                       "g_main_loop_new"
                       c-pointer bool))
(define main-loop-run
  (foreign-safe-lambda void
                       "g_main_loop_run"
                       c-pointer))

(define (id-from-attribute attr)
  (car (string-split attr "/")))

(define read-password
  (foreign-safe-lambda c-string "getpass" c-string))

(lm:define-message-handler
 msg-cb
 (conn mes data)
 (let ((node (lm:message-node? mes)))
   (lm:debug-print "message"
                   (lm:message-node-to-string node))
   (let ((chat (lm:message-node-attribute? node "type"))
         (jid (lm:message-node-attribute? node "to")))
     (if (and (and chat (string=? "chat" chat))
              (and jid  (string=? (id-from-attribute jid) (pointer->object data))))
         (let* ((from (lm:message-node-attribute? node "from"))
                (body (lm:message-node-find-child node "body"))
                (from-msg (if body
                              (lm:message-node-get-value body)
                              #f)))
           (if from-msg
               (send-message conn from from-msg))))
     *LM-HANDLER-RESULT-REMOVE-MESSAGE*)))

(lm:define-message-handler
 presence-cb
 (conn mes data)
 (let ((node (lm:message-node? mes)))
   (lm:debug-print "presence"
                   (lm:message-node-to-string node))
   *LM-HANDLER-RESULT-REMOVE-MESSAGE*))

(define (main jid jpasswd)
    (lm:call-with-connection
     jhost
     (lambda (conn)
       (lm:call-with-ssl
        #f #f #f #f
        (lambda (ssl)
          (lm:connection-ssl! conn ssl)))

       (lm:connection-port! conn 5223)
       (lm:connection-jid! conn jid)

       (lm:call-with-message-handler
        presence-cb #f #f
        (lambda (handler)
          (lm:connection-register-message-handler conn handler
                                                  *LM-MESSAGE-TYPE-PRESENCE*
                                                  *LM-HANDLER-PRIORITY-LAST*)))

       (lm:call-with-message-handler
        msg-cb (object->pointer jid) #f
        (lambda (handler)
          (lm:connection-register-message-handler conn handler
                                                  *LM-MESSAGE-TYPE-MESSAGE*
                                                  *LM-HANDLER-PRIORITY-NORMAL*)))

       (lm:call-with-connection-open-and-block
        conn
        (lambda ()
          (lm:safe-connection-authenticate-and-block conn jid jpasswd jresource)

          (roster? conn)

          (send-presence conn)

          (pp "message loop...")
          (let ((ctx (main-loop-new #f #f)))
            (main-loop-run ctx))
          )))))

(let ((jid (begin
             (display "User: ")
             (read-line)))
      (jpasswd (read-password "Password: ")))
  (main jid jpasswd))