Split code into multiple functions.
This commit is contained in:
thibault
parent
853a0b5f20
commit
634c79b730
163
jabber-mam.el
163
jabber-mam.el
|
|
@ -1,9 +1,5 @@
|
|||
;; jabber-mam.el - XEP-0313 Message Archive Management
|
||||
|
||||
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
|
||||
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
|
||||
|
||||
;; SSL-Connection Parts:
|
||||
;; Copyright (C) 2017 - Thibault Marin - thibault.marin@gmx.com
|
||||
|
||||
;; This file is a part of jabber.el.
|
||||
|
|
@ -53,21 +49,25 @@ described in http://xmpp.org/extensions/xep-0313.html#support."
|
|||
(defvar jabber-mam-lock nil
|
||||
"Synchronization variable to return MAM results synchronously.")
|
||||
|
||||
(defun jabber-mam-make-base-query (jid jid-with)
|
||||
"Build basic query requesting messages between JID and JID-WITH."
|
||||
`(x ((xmlns . "jabber:x:data")
|
||||
(type . "submit"))
|
||||
(field ((var . "FORM_TYPE")
|
||||
(type . "hidden"))
|
||||
(value () ,jabber-mam-namespace))
|
||||
(field ((var . "id"))
|
||||
(value () ,jid))
|
||||
(field ((var . "with"))
|
||||
(value () ,jid-with))))
|
||||
|
||||
(defun jabber-mam-make-query (jid jid-with start-time end-time number after)
|
||||
"Build request for server requesting archived messages.
|
||||
Request messages between JID and JID-WITH between START-TIME and END-TIME
|
||||
limiting to NUMBER results. AFTER is used when paging through multiple result
|
||||
sets: it contains the ID (returned by the server) for the last message in each
|
||||
result set."
|
||||
(let* ((xxmlns `(x ((xmlns . "jabber:x:data")
|
||||
(type . "submit"))
|
||||
(field ((var . "FORM_TYPE")
|
||||
(type . "hidden"))
|
||||
(value () ,jabber-mam-namespace))
|
||||
(field ((var . "id"))
|
||||
(value () ,jid))
|
||||
(field ((var . "with"))
|
||||
(value () ,jid-with))))
|
||||
(let* ((xxmlns (jabber-mam-make-base-query jid jid-with))
|
||||
(query `(query ((xmlns . ,jabber-mam-namespace)))))
|
||||
(when start-time
|
||||
(add-to-list 'xxmlns `(field ((var . "start"))
|
||||
|
|
@ -92,6 +92,79 @@ result set."
|
|||
(add-to-list 'query setxmlns t)))
|
||||
query))
|
||||
|
||||
(defun jabber-mam-process-entry (mam-result)
|
||||
"Extract message information from MAM-RESULT and add to results list.
|
||||
The output message information is stored in `jabber-mam-results'
|
||||
in the same format as the one used by the file archive. The
|
||||
message is dropped if the function fails to fully extract the
|
||||
message information (timestamp, from/to, body)."
|
||||
(let* ((mam-fwd (car (jabber-xml-get-children mam-result 'forwarded)))
|
||||
;; Get <message> tag
|
||||
(mam-msg (when (jabber-xml-get-children mam-fwd 'message)
|
||||
(car (jabber-xml-get-children mam-fwd 'message))))
|
||||
;; Get timestamp
|
||||
(mam-stamp (when (jabber-xml-get-children mam-fwd 'delay)
|
||||
(jabber-xml-get-attribute
|
||||
(car (jabber-xml-get-children mam-fwd 'delay)) 'stamp)))
|
||||
;; Get message body
|
||||
(mam-msg-body
|
||||
(when (and mam-msg (jabber-xml-get-children mam-msg 'body))
|
||||
(car (jabber-xml-get-children mam-msg 'body))))
|
||||
;; Render message body
|
||||
(mam-msg-body-txt
|
||||
(when mam-msg-body
|
||||
(substring (format "%s" (cdr (cdr mam-msg-body))) 1 -1)))
|
||||
;; Get <from> tag
|
||||
(mam-msg-from
|
||||
(when mam-msg
|
||||
(let ((mam-msg-from-t (jabber-jid-user (jabber-xml-get-attribute
|
||||
mam-msg 'from))))
|
||||
(if (string= mam-msg-from-t mam-jid-me) "me"
|
||||
mam-msg-from-t))))
|
||||
;; Get <to> tag
|
||||
(mam-msg-to
|
||||
(when mam-msg
|
||||
(let ((mam-msg-to-t (jabber-jid-user (jabber-xml-get-attribute
|
||||
mam-msg 'to))))
|
||||
(if (string= mam-msg-to-t mam-jid-me) "me"
|
||||
mam-msg-to-t))))
|
||||
;; Get message direction (from "me" or to "me")
|
||||
(mam-msg-dir (cond ((string= mam-msg-from "me") "out")
|
||||
((string= mam-msg-to "me") "in")
|
||||
(t "me"))))
|
||||
(when (and mam-stamp mam-msg-dir mam-msg-from mam-msg-to mam-msg-body-txt)
|
||||
;; Push to results list
|
||||
(push (vector
|
||||
mam-stamp mam-msg-dir mam-msg-from mam-msg-to mam-msg-body-txt)
|
||||
jabber-mam-results))))
|
||||
|
||||
(defun jabber-mam-process-fin (xml-data)
|
||||
"Process final server response from XML-DATA and determine the next action.
|
||||
This function handles the server response corresponding to the
|
||||
end of a result set. If the <complete> tag is found, then no
|
||||
subsequent query is required (`jabber-mam-done' is set to t). If
|
||||
the result set is not complete, the <last-id> tag is stored (in
|
||||
`jabber-mam-last-id') and used to initialize a continuation
|
||||
request.
|
||||
|
||||
In both cases, the lock (`jabber-mam-lock') is released for the caller
|
||||
\('jabber-mam-query') to continue."
|
||||
(let* ((fin (jabber-xml-get-children xml-data 'fin))
|
||||
(complete (jabber-xml-get-attribute (car fin) 'complete))
|
||||
(set (jabber-xml-get-children (car fin) 'set))
|
||||
(last
|
||||
(when set (jabber-xml-get-children (car set) 'last)))
|
||||
(last-id (when last (cadr (cdr (car last))))))
|
||||
(if (and (or (not complete) (not (string= complete "true"))) last-id)
|
||||
;; Result set is not complete, next request should start with
|
||||
;; `last-id'
|
||||
(setq jabber-mam-last-id last-id)
|
||||
;; Result set is complete
|
||||
(setq jabber-mam-done t))
|
||||
;; Release lock
|
||||
(setq jabber-mam-lock t)
|
||||
nil))
|
||||
|
||||
(add-to-list 'jabber-message-chain 'jabber-handle-incoming-mam-message)
|
||||
(defun jabber-handle-incoming-mam-message (jc xml-data)
|
||||
"Manage results from MAM request with connection JC and content XML-DATA.
|
||||
|
|
@ -103,68 +176,14 @@ Result Set Management. Paging through results is performed in the
|
|||
xml-data 'to)))
|
||||
(mam-result (car (jabber-xml-get-children xml-data 'result))))
|
||||
(when (jabber-xml-get-children mam-result 'forwarded)
|
||||
;; Extract message information (direction, timestamp, body)
|
||||
(let* ((mam-fwd (car (jabber-xml-get-children
|
||||
mam-result 'forwarded)))
|
||||
(mam-msg
|
||||
(when (jabber-xml-get-children mam-fwd 'message)
|
||||
(car (jabber-xml-get-children mam-fwd 'message))))
|
||||
(mam-stamp
|
||||
(when (jabber-xml-get-children mam-fwd 'delay)
|
||||
(jabber-xml-get-attribute
|
||||
(car (jabber-xml-get-children mam-fwd 'delay)) 'stamp)))
|
||||
(mam-msg-body
|
||||
(when (and mam-msg (jabber-xml-get-children mam-msg 'body))
|
||||
(car (jabber-xml-get-children mam-msg 'body))))
|
||||
(mam-msg-body-txt
|
||||
(when mam-msg-body
|
||||
(substring (format "%s" (cdr (cdr mam-msg-body))) 1 -1)))
|
||||
(mam-msg-from
|
||||
(when mam-msg
|
||||
(let ((mam-msg-from-t (jabber-jid-user
|
||||
(jabber-xml-get-attribute
|
||||
mam-msg 'from))))
|
||||
(if (string= mam-msg-from-t mam-jid-me)
|
||||
"me"
|
||||
mam-msg-from-t))))
|
||||
(mam-msg-to
|
||||
(when mam-msg
|
||||
(let ((mam-msg-to-t (jabber-jid-user
|
||||
(jabber-xml-get-attribute
|
||||
mam-msg 'to))))
|
||||
(if (string= mam-msg-to-t mam-jid-me)
|
||||
"me"
|
||||
mam-msg-to-t))))
|
||||
(mam-msg-dir
|
||||
(cond ((string= mam-msg-from "me")
|
||||
"out")
|
||||
((string= mam-msg-to "me")
|
||||
"in")
|
||||
(t "me"))))
|
||||
(when (and mam-stamp mam-msg-dir mam-msg-from mam-msg-to
|
||||
mam-msg-body-txt)
|
||||
(push (vector mam-stamp mam-msg-dir mam-msg-from
|
||||
mam-msg-to mam-msg-body-txt)
|
||||
jabber-mam-results))))))
|
||||
;; Extract message information (direction, timestamp, body), push
|
||||
;; to results list
|
||||
(jabber-mam-process-entry mam-result))))
|
||||
((jabber-xml-get-children xml-data 'fin)
|
||||
;; End of set, determine if a subsequent query is required (if the
|
||||
;; result is not complete).
|
||||
;; Extract "complete" attribute from <fin> tag and <last> id
|
||||
(let* ((fin (jabber-xml-get-children xml-data 'fin))
|
||||
(complete (jabber-xml-get-attribute (car fin) 'complete))
|
||||
(set (jabber-xml-get-children (car fin) 'set))
|
||||
(last
|
||||
(when set (jabber-xml-get-children (car set) 'last)))
|
||||
(last-id (when last (cadr (cdr (car last))))))
|
||||
(if (and (or (not complete) (not (string= complete "true"))) last-id)
|
||||
;; Result set is not complete, next request should start with
|
||||
;; `last-id'
|
||||
(setq jabber-mam-last-id last-id)
|
||||
;; Result set is complete
|
||||
(setq jabber-mam-done t))
|
||||
;; Release lock
|
||||
(setq jabber-mam-lock t)
|
||||
nil))
|
||||
(jabber-mam-process-fin (xml-data)))
|
||||
(t nil)))
|
||||
|
||||
(defun jabber-mam-query (jc jid-me jid-with start-time end-time number
|
||||
|
|
@ -174,7 +193,6 @@ JC is jabber connection. Messages between users with JIDs JID-ME JID and
|
|||
JID-WITH JID with timestamp between START-TIME and END-TIME are retrieved. The
|
||||
set of results is limited to NUMBER messages. DIRECTION is either \"in\" or
|
||||
\"out\", or t for no limit on direction (this parameter is currently ignored)."
|
||||
|
||||
;; Initialize output and lock
|
||||
(setq jabber-mam-results (list))
|
||||
(setq jabber-mam-done nil)
|
||||
|
|
@ -195,6 +213,7 @@ set of results is limited to NUMBER messages. DIRECTION is either \"in\" or
|
|||
;; Wait for results
|
||||
(while (not jabber-mam-lock)
|
||||
(sit-for 1))
|
||||
;; Update counter for remaining messages
|
||||
(when (integerp number)
|
||||
(setq number-left (- number (length jabber-mam-results)))
|
||||
(setq jabber-mam-done (or jabber-mam-done
|
||||
|
|
|
|||
Loading…
Reference in New Issue