A WhatsApp (Web) transport for XMPP.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

298 lines
14KB

  1. (in-package :whatsxmpp)
  2. (defun get-user-id (jid)
  3. "Get the user ID of JID, or NIL if none exists."
  4. (with-prepared-statement
  5. (get-user "SELECT id FROM users WHERE jid = ?")
  6. (let ((stripped (strip-resource jid)))
  7. (bind-parameters get-user stripped)
  8. (when (sqlite:step-statement get-user)
  9. (first (column-values get-user))))))
  10. (defun get-user-jid (id)
  11. "Get the user JID for the ID, or NIL if none exists."
  12. (with-prepared-statement
  13. (get-user "SELECT jid FROM users WHERE id = ?")
  14. (bind-parameters get-user id)
  15. (when (sqlite:step-statement get-user)
  16. (first (column-values get-user)))))
  17. (defun get-user-contact-localparts (uid)
  18. "Returns a list of all contact localparts for UID."
  19. (with-prepared-statements
  20. ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
  21. (bind-parameters get-stmt uid)
  22. (loop
  23. while (sqlite:step-statement get-stmt)
  24. collect (sqlite:statement-column-value get-stmt 0))))
  25. (defun get-user-chat-id (uid localpart)
  26. "Get the user chat ID of LOCALPART for UID, or NIL if none exists."
  27. (with-prepared-statements
  28. ((get-stmt "SELECT id FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
  29. (bind-parameters get-stmt uid localpart)
  30. (when (sqlite:step-statement get-stmt)
  31. (with-bound-columns (id) get-stmt
  32. id))))
  33. (defun get-user-chat-localpart (chat-id)
  34. "Get the user chat localpart for CHAT-ID, or NIL if none exists."
  35. (with-prepared-statements
  36. ((get-stmt "SELECT wa_jid FROM user_chats WHERE id = ?"))
  37. (bind-parameters get-stmt chat-id)
  38. (when (sqlite:step-statement get-stmt)
  39. (with-bound-columns (localpart) get-stmt
  40. localpart))))
  41. (defun get-user-chat-subject (uid localpart)
  42. "Get the user chat subject of LOCALPART for UID, or NIL if none exists."
  43. (with-prepared-statements
  44. ((get-stmt "SELECT subject FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
  45. (bind-parameters get-stmt uid localpart)
  46. (when (sqlite:step-statement get-stmt)
  47. (with-bound-columns (subject) get-stmt
  48. subject))))
  49. (defun get-user-chat-resource (uid localpart)
  50. "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
  51. (with-prepared-statements
  52. ((get-stmt "SELECT user_resource FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
  53. (bind-parameters get-stmt uid localpart)
  54. (when (sqlite:step-statement get-stmt)
  55. (with-bound-columns (resource) get-stmt
  56. (when (and resource (> (length resource) 0))
  57. resource)))))
  58. (defun get-participant-resource (chat-id localpart)
  59. "Get the participant resource for LOCALPART in CHAT-ID, or NIL if none exists."
  60. (with-prepared-statements
  61. ((get-stmt "SELECT resource FROM user_chat_members WHERE chat_id = ? AND wa_jid = ?"))
  62. (bind-parameters get-stmt chat-id localpart)
  63. (when (sqlite:step-statement get-stmt)
  64. (with-bound-columns (resource) get-stmt
  65. (when (and resource (> (length resource) 0))
  66. resource)))))
  67. (defun get-user-chat-joined (uid localpart)
  68. "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
  69. (with-prepared-statements
  70. ((get-stmt "SELECT ucj.jid FROM user_chats AS uc, user_chat_joined AS ucj WHERE uc.user_id = ? AND uc.wa_jid = ? AND uc.id = ucj.chat_id"))
  71. (bind-parameters get-stmt uid localpart)
  72. (loop
  73. while (sqlite:step-statement get-stmt)
  74. append (column-values get-stmt))))
  75. (defun get-contact-name (uid localpart &key no-phone-number)
  76. "Get a name for LOCALPART, a possible contact for the user with ID UID."
  77. (with-prepared-statements
  78. ((get-stmt "SELECT name, notify FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
  79. (bind-parameters get-stmt uid localpart)
  80. (when (sqlite:step-statement get-stmt)
  81. (with-bound-columns (name notify) get-stmt
  82. (or name notify (unless no-phone-number (substitute #\+ #\u localpart)))))))
  83. (defun get-contact-status (uid localpart)
  84. "Get the contact status text for LOCALPART, a possible contact for the user with ID UID."
  85. (declare (type integer uid) (type string localpart))
  86. (with-prepared-statements
  87. ((get-stmt "SELECT status FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
  88. (bind-parameters get-stmt uid localpart)
  89. (when (sqlite:step-statement get-stmt)
  90. (with-bound-columns (status) get-stmt
  91. status))))
  92. (defun insert-user-message (uid xmpp-id wa-id)
  93. "Inserts a mapping between the message IDs XMPP-ID and WA-ID for the user UID."
  94. (with-prepared-statements
  95. ((insert-stmt "INSERT INTO user_messages (user_id, xmpp_id, wa_id) VALUES (?, ?, ?)"))
  96. (bind-parameters insert-stmt uid xmpp-id wa-id)
  97. (sqlite:step-statement insert-stmt)))
  98. (defun insert-user-chat (uid wa-id)
  99. "Inserts a user chat with localpart WA-ID into the database for the user with UID."
  100. (with-prepared-statements
  101. ((insert-stmt "INSERT INTO user_chats (user_id, wa_jid) VALUES (?, ?) ON CONFLICT DO NOTHING"))
  102. (bind-parameters insert-stmt uid wa-id)
  103. (sqlite:step-statement insert-stmt)))
  104. (defun lookup-wa-msgid (uid wa-msgid)
  105. "Look up the XMPP ID for the WhatsApp message ID WA-MSGID, when received for the user UID."
  106. (with-prepared-statements
  107. ((get-stmt "SELECT xmpp_id FROM user_messages WHERE user_id = ? AND wa_id = ?"))
  108. (bind-parameters get-stmt uid wa-msgid)
  109. (when (sqlite:step-statement get-stmt)
  110. (with-bound-columns (xid) get-stmt
  111. xid))))
  112. (defun lookup-xmpp-msgid (uid xmpp-msgid)
  113. "Look up the WhatsApp message ID for the XMPP message ID XMPP-MSGID, when received for the user UID."
  114. (with-prepared-statements
  115. ((get-stmt "SELECT wa_id FROM user_messages WHERE user_id = ? AND xmpp_id = ?"))
  116. (bind-parameters get-stmt uid xmpp-msgid)
  117. (when (sqlite:step-statement get-stmt)
  118. (with-bound-columns (wid) get-stmt
  119. wid))))
  120. (defun get-contact-localparts (uid)
  121. "Get a list of contact localparts for the user with ID UID."
  122. (with-prepared-statements
  123. ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
  124. (bind-parameters get-stmt uid)
  125. (loop
  126. while (sqlite:step-statement get-stmt)
  127. collect (with-bound-columns (localpart) get-stmt localpart))))
  128. (defun get-user-groupchats (uid)
  129. "Get a list of groupchat info (cons pairs of LOCALPART . SUBJECT) for the user with ID UID."
  130. (with-prepared-statements
  131. ((get-stmt "SELECT wa_jid, subject FROM user_chats WHERE user_id = ?"))
  132. (bind-parameters get-stmt uid)
  133. (loop
  134. while (sqlite:step-statement get-stmt)
  135. collect (with-bound-columns (localpart subject) get-stmt (cons localpart subject)))))
  136. (defun insert-xmpp-message (xm)
  137. "Inserts XM, a groupchat XMPP-MESSAGE, into the database."
  138. (assert (uiop:string-prefix-p "g" (conversation xm)) () "Tried to insert XMPP message for non-groupchat conversation ~A" (conversation xm))
  139. (let* ((chat-id (or
  140. (get-user-chat-id (uid xm) (conversation xm))
  141. (error "Couldn't find chat id for conversation ~A / uid ~A"
  142. (conversation xm) (uid xm))))
  143. (local-time:*default-timezone* local-time:+utc-zone+)
  144. (ts-unix (local-time:timestamp-to-unix (timestamp xm))))
  145. (with-prepared-statements
  146. ((insert-stmt "INSERT INTO user_chat_history (user_id, chat_id, user_from, ts_unix, xmpp_id, orig_id, body, oob_url) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"))
  147. (bind-parameters insert-stmt (1 (uid xm)) (2 chat-id) (3 (from xm)) (4 ts-unix) (5 (xmpp-id xm)) (6 (orig-id xm)) (7 (body xm)) (8 (oob-url xm)))
  148. (sqlite:step-statement insert-stmt))))
  149. (defun lookup-wa-msgid-in-history (uid wa-msgid)
  150. "Look up the XMPP ID for the WhatsApp message ID WA-MSGID, when received for the user UID."
  151. (with-prepared-statements
  152. ((get-stmt "SELECT xmpp_id FROM user_chat_history WHERE user_id = ? AND orig_id = ?"))
  153. (bind-parameters get-stmt uid wa-msgid)
  154. (when (sqlite:step-statement get-stmt)
  155. (with-bound-columns (xid) get-stmt
  156. xid))))
  157. (defun user-archiving-enabled-p (uid)
  158. "Returns a generalized boolean for whether the user with ID UID has archiving enabled or not."
  159. (with-prepared-statements
  160. ((get-stmt "SELECT enable_archiving FROM users WHERE id = ?"))
  161. (bind-parameters get-stmt uid)
  162. (when (sqlite:step-statement get-stmt)
  163. (with-bound-columns (ena) get-stmt
  164. (not (eql ena 0))))))
  165. (defun user-set-archiving-state (uid enabled)
  166. "Set the user's archiving state for the user with ID UID to ENABLED (either T or NIL)."
  167. (let ((ena (if enabled 1 0)))
  168. (with-prepared-statements
  169. ((set-stmt "UPDATE users SET enable_archiving = ? WHERE id = ?"))
  170. (bind-parameters set-stmt ena uid)
  171. (sqlite:step-statement set-stmt))))
  172. (defun jid-admin-p (jid)
  173. "Returns a generalized boolean for whether the JID is a bridge administrator."
  174. (with-prepared-statements
  175. ((get-stmt "SELECT id FROM administrators WHERE jid = ?"))
  176. (bind-parameters get-stmt jid)
  177. (when (sqlite:step-statement get-stmt)
  178. t)))
  179. (defun db-unregister-user (uid)
  180. "Unregister the user with ID UID."
  181. (with-prepared-statements
  182. ((remove-user-stmt "DELETE FROM users WHERE id = ?")
  183. (remove-contacts-stmt "DELETE FROM user_contacts WHERE user_id = ?")
  184. (remove-messages-stmt "DELETE FROM user_messages WHERE user_id = ?")
  185. (remove-chats-stmt "DELETE FROM user_chats WHERE user_id = ?")
  186. (get-chats-stmt "SELECT id FROM user_chats WHERE user_id = ?")
  187. (remove-chat-members-stmt "DELETE FROM user_chat_members WHERE chat_id = ?")
  188. (remove-chat-joined-stmt "DELETE FROM user_chat_joined WHERE chat_id = ?")
  189. (remove-chat-history-stmt "DELETE FROM user_chat_history WHERE user_id = ?"))
  190. (with-transaction ()
  191. (bind-parameters get-chats-stmt uid)
  192. (loop
  193. while (sqlite:step-statement get-chats-stmt)
  194. do (with-bound-columns (chatid) get-chats-stmt
  195. (loop
  196. for stmt in (list remove-chat-members-stmt remove-chat-joined-stmt remove-chat-history-stmt)
  197. do (progn
  198. (sqlite:reset-statement stmt)
  199. (bind-parameters stmt chatid)
  200. (sqlite:step-statement stmt)))))
  201. (loop
  202. for stmt in (list remove-chats-stmt remove-messages-stmt remove-contacts-stmt remove-user-stmt)
  203. do (progn
  204. (sqlite:reset-statement stmt)
  205. (bind-parameters stmt uid)
  206. (sqlite:step-statement stmt))))))
  207. (defun get-chat-history-ts (uid chat-id xmpp-id)
  208. "Look up the UNIX timestamp for the given UID, CHAT-ID and XMPP-ID."
  209. (with-prepared-statements
  210. ((get-stmt "SELECT ts_unix FROM user_chat_history WHERE user_id = ? AND chat_id = ? AND xmpp_id = ?"))
  211. (bind-parameters get-stmt uid chat-id xmpp-id)
  212. (when (sqlite:step-statement get-stmt)
  213. (with-bound-columns (tsu) get-stmt
  214. tsu))))
  215. (defun query-archive (uid chat-id &key start end (limit 100) reference-stanza-id forward-page)
  216. "Query the chat history archive for the chat identified by CHAT-ID and UID. Optionally narrow the query using START and END (UNIX timestamps), returning at most LIMIT items (which is clamped to 100).
  217. If an RSM REFERENCE-STANZA-ID is provided, narrow the query to be either after (T) or before (NIL) the history entry with that stanza ID, depending on the value of FORWARD-PAGE (see brackets)."
  218. (let ((statement (make-string-output-stream))
  219. (localpart (get-user-chat-localpart chat-id))
  220. (local-time:*default-timezone* local-time:+utc-zone+)
  221. (args (list chat-id uid)) ; WARNING this list is nreverse'd later!
  222. (items-returned 0)
  223. (sqlite-stmt))
  224. (format statement "SELECT user_from, ts_unix, xmpp_id, orig_id, body, oob_url FROM user_chat_history WHERE user_id = ? AND chat_id = ?")
  225. (when reference-stanza-id
  226. (let ((reference-ts (or
  227. (get-chat-history-ts uid chat-id reference-stanza-id)
  228. (error "Couldn't locate reference stanza ID ~A" reference-stanza-id))))
  229. (if forward-page
  230. (setf start reference-ts)
  231. (setf end reference-ts))))
  232. (when start
  233. (format statement " AND ts_unix > ?")
  234. (push start args))
  235. (when end
  236. (format statement " AND ts_unix < ?")
  237. (push end args))
  238. (unless limit
  239. (setf limit 100))
  240. (when (> limit 100)
  241. (setf limit 100)) ; clamp me owo
  242. ;; We copy a trick from biboumi: in order to figure out whether there are
  243. ;; more results if not for the limit existing, simply increment the limit
  244. ;; by 1 and see if you get the extra element.
  245. (format statement " ORDER BY ts_unix ~A LIMIT ~A" (if forward-page "ASC" "DESC") (1+ limit))
  246. (setf args (nreverse args))
  247. (bt:with-recursive-lock-held (*db-lock*)
  248. (let ((stmt-text (get-output-stream-string statement)))
  249. (setf sqlite-stmt (sqlite:prepare-statement *db* stmt-text)))
  250. (loop
  251. for param in args
  252. for n from 1
  253. do (sqlite:bind-parameter sqlite-stmt n param))
  254. (values
  255. (funcall
  256. (if forward-page #'identity #'nreverse)
  257. (loop
  258. while (sqlite:step-statement sqlite-stmt)
  259. do (incf items-returned)
  260. while (<= items-returned limit)
  261. collect (with-bound-columns (from ts-unix xmpp-id orig-id body oob-url) sqlite-stmt
  262. (make-instance 'xmpp-message
  263. :uid uid
  264. :conversation localpart
  265. :from from
  266. :timestamp (local-time:unix-to-timestamp ts-unix)
  267. :xmpp-id xmpp-id
  268. :orig-id orig-id
  269. :body body
  270. :oob-url oob-url))))
  271. (<= items-returned limit)))))