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.

31 lines
1.7 KiB

  1. (in-package :whatsxmpp)
  2. (defun request-http-upload-slot (comp service-jid filename size mime-type)
  3. "Requests an XEP-0363 HTTP Upload slot from the service at SERVICE-JID, aiming to upload the file with FILENAME, SIZE (in bytes) and MIME-TYPE. Returns a promise that resolves with a list of the form ((PUT-URL . ((HEADER-NAME . HEADER-VALUE) ...)) GET-URL)."
  4. (declare (type xmpp-component comp) (type string service-jid filename mime-type) (type integer size))
  5. (attach
  6. (with-iq (comp service-jid)
  7. (cxml:with-element "request"
  8. (cxml:attribute "xmlns" +file-upload-ns+)
  9. (cxml:attribute "filename" filename)
  10. (cxml:attribute "size" (write-to-string size))
  11. (cxml:attribute "content-type" mime-type)))
  12. (lambda (results)
  13. (let ((slot-node (get-node-named results "slot")))
  14. (unless slot-node
  15. (error "Malformed XEP-0363 response: no <slot/>"))
  16. (let* ((children (child-elements slot-node))
  17. (put-node (get-node-named children "put"))
  18. (get-node (get-node-named children "get"))
  19. (headers '()))
  20. (unless (and put-node get-node)
  21. (error "Malformed XEP-0363 response: PUT or GET nodes missing"))
  22. (loop
  23. for node across (child-elements put-node)
  24. do (let ((name (dom:tag-name node)))
  25. (when (equal name "header")
  26. (setf headers (cons
  27. (cons (dom:get-attribute node "name")
  28. (dom:node-value (elt (child-elements node) 0)))
  29. headers)))))
  30. `((,(dom:get-attribute put-node "url") . ,headers) ,(dom:get-attribute get-node "url")))))))