jabber-tox.el

   1 ;; jabber-tox.el - Jingle support using TOX
   2
   3 ;; Copyright (C) 2008 - Magnus Henoch - mange@freemail.hu
   4
   5 ;; This file is (soon) a part of jabber.el.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, write to the Free Software
  19 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20
  21 (require 'dbus)
  22 (require 'fsm)
  23 (require 'cl)
  24
  25 (defconst jingle-ns "http://www.xmpp.org/extensions/xep-0166.html#ns"
  26   "Jingle namespace (XEP-0166)")
  27
  28 (defconst jingle-error-ns "http://www.xmpp.org/extensions/xep-0166.html#ns-errors"
  29   "Jingle error namespace (XEP-0166)")
  30
  31 (defconst jingle-audio-ns "http://www.xmpp.org/extensions/xep-0167.html#ns"
  32   "Jingle Audio namespace (XEP-0167)")
  33
  34 (defconst jingle-ice-udp-ns "http://www.xmpp.org/extensions/xep-0176.html#ns-udp"
  35   "Jingle ICE namespace (XEP-0176)")
  36
  37 (defconst jingle-udp-ns "http://www.xmpp.org/extensions/xep-0177.html"
  38   "Jingle Raw UDP namespace (XEP-0177)")
  39
  40 (defvar jingle-acct-sid-map (make-hash-table :test 'equal)
  41   "Mapping from pairs of JIDs and Jingle SIDs to FSMs.
  42 The JID is the full JID of the account using the session.")
  43
  44 (defconst tox-name "net.sourceforge.emacs-jabber.Tox"
  45   "Well-known D-BUS name of the tox service.")
  46
  47 (defconst tox-path "/net/sourceforge/emacs_jabber/Tox"
  48   "Well-known path of the main Tox object.")
  49
  50 (defconst tox-interface "net.sourceforge.emacs_jabber.Tox"
  51   "Interface of main Tox object.")
  52
  53 (defconst tox-session-interface "net.sourceforge.emacs_jabber.ToxSession"
  54   "Interface of ToxSession object.")
  55
  56 (define-fsm jingle
  57   :start ((jc sid role jid) "Start a Jingle FSM.
  58 \(Specifically, for Jingle Audio, as that's all we support for now.)
  59 JC is the account we're using.
  60 SID is a string, the session ID.
  61 ROLE is either :initiator or :target.
  62 JID is the full JID of the partner."
  63           (list :allocate
  64                 (list :jc jc :jid jid :sid sid :role role))))
  65
  66 (define-enter-state jingle :allocate
  67   (fsm state-data)
  68   ;; Allocate a ToxSession object.
  69   (let* ((tox-session
  70           (dbus-call-method :session tox-name tox-path tox-interface
  71                             "CreateSession"
  72                             :byte 3))   ;3=bidirectional stream
  73          ;; Find the codecs that we support
  74          (our-codecs
  75           (dbus-call-method :session tox-name tox-session tox-session-interface
  76                             "GetLocalCodecs")))
  77     (fsm-debug-output "tox-session: %S, our-codecs: %S" tox-session our-codecs)
  78     ;; Set up the pipeline, so we can search for transport candidates.
  79     (fsm-debug-output "About to call SetDefaultAudioSink")
  80     (dbus-call-method :session tox-name tox-session tox-session-interface
  81                       "SetDefaultAudioSink")
  82     (fsm-debug-output "About to call SetOggVorbisAudioSource")
  83     (dbus-call-method :session tox-name tox-session tox-session-interface
  84                       "SetOggVorbisAudioSource"
  85                       "/home/magnus/musik/computervirus.ogg")
  86     ;; There, now we just wait for the NativeCandidatesPrepared signal...
  87     ;; NO!  Don't do like those dead people do!  That signal will never
  88     ;; come.  I don't know why, though...
  89     (fsm-debug-output "About to register signal")
  90     (dbus-register-signal :session tox-name tox-session tox-session-interface
  91                           "NativeCandidatesPrepared"
  92                           (lexical-let ((fsm fsm))
  93                             (lambda (components)
  94                               (fsm-send-sync
  95                                fsm
  96                                (cons :native-candidates-prepared components)))))
  97     ;; This is more like it.  At least it will provide us with some
  98     ;; debugging information.
  99     (dbus-register-signal :session tox-name tox-session tox-session-interface
 100                           "NewNativeCandidate"
 101                           (lexical-let ((fsm fsm))
 102                             (lambda (components)
 103                               (fsm-send-sync
 104                                fsm
 105                                (cons :new-native-candidate components)))))
 106     (fsm-debug-output "Waiting")
 107     (list (plist-put
 108            (plist-put
 109             state-data
 110             :tox-session tox-session)
 111            :our-codecs our-codecs)
 112           nil)))
 113
 114 (define-enter-state jingle nil
 115   (fsm state-data)
 116   ;; clean up
 117   (let ((tox-session (plist-get state-data :tox-session)))
 118     (when tox-session
 119       (ignore-errors
 120         (dbus-call-method :session tox-name tox-session tox-session-interface
 121                           "Destroy"))))
 122   (list nil nil))
 123
 124 (define-state jingle :allocate
 125   (fsm state-data event callback)
 126   (case (car-safe event)
 127     (:new-native-candidate
 128      (setq state-data (plist-put state-data :native-candidates (list (cdr event))))
 129      (list (ecase (plist-get state-data :role)
 130              (:initiator
 131               :initiate)
 132              (:target
 133               :wait-for-initiate))
 134            state-data))
 135
 136     (:native-candidates-prepared
 137      ;; this code is currently unnecessary, as we never get the
 138      ;; native-candidates-prepared signal
 139      (let ((components (cdr event)))
 140        (fsm-debug-output "The native candidates are %S" components)
 141        (setq state-data (plist-put state-data :native-candidates components))
 142        (list (ecase (plist-get state-data :role)
 143              (:initiator
 144               :initiate)
 145              (:target
 146               :wait-for-initiate))
 147              state-data)))
 148
 149     (:iq-set
 150      :defer)))
 151
 152 (define-enter-state jingle :initiate
 153   (fsm state-data)
 154   (let ((jc (plist-get state-data :jc))
 155         (jid (plist-get state-data :jid))
 156         (sid (plist-get state-data :sid)))
 157     (jabber-send-iq jc jid "set"
 158                     `(jingle ((xmlns . ,jingle-ns)
 159                               (action . "session-initiate")
 160                               (initiator . ,(jabber-connection-jid jc))
 161                               (sid . ,sid))
 162                              (content
 163                               ((creator . ,(jabber-connection-bare-jid jc))
 164                                (name . "foo")
 165                                (senders . "initiator"))
 166                               (transport ((xmlns . ,jingle-ice-udp-ns)))))
 167                     (lambda (jc iq fsm)
 168                       (fsm-send-sync fsm (cons :iq-result iq)))
 169                     fsm
 170                     (lambda (jc iq fsm)
 171                       (fsm-send-sync fsm (cons :iq-error iq)))
 172                     fsm)
 173     (list state-data nil)))
 174
 175 (define-state jingle :initiate
 176   (fsm state-data event callback)
 177   (case (car-safe event)
 178     (:iq-result
 179      ;; Receiver provisionally accepted the session request.  Move on
 180      ;; to PENDING.
 181      (list :pending state-data))
 182     (:iq-error
 183      (message "Couldn't initiate Jingle audio session: %s"
 184               (jabber-parse-error (jabber-iq-error (cdr event))))
 185      (list nil state-data))))
 186
 187 (define-state jingle :wait-for-initiate
 188   (fsm state-data event callback)
 189   (case (car-safe event)
 190     (:iq-set
 191      (let* ((jc (plist-get state-data :jc))
 192             (iq (cdr event))
 193             (from (jabber-xml-get-attribute iq 'from))
 194             (id (jabber-xml-get-attribute iq 'id))
 195             (jingle (jabber-iq-query iq))
 196             (contents (car (jabber-xml-get-children jingle 'content)))
 197             (audio-content (find jingle-audio-ns (jabber-xml-node-children contents)
 198                                  :test 'string=
 199                                  :key 'jabber-xml-get-xmlns))
 200             (payload-types (jabber-xml-get-children audio-content 'payload-type)))
 201        (cond
 202         ;; Make sure audio is in the list of contents.  We can
 203         ;; negotiate away other content types later.
 204         ((null audio-content)
 205          (jabber-send-iq-error jc from id
 206                                jingle
 207                                "cancel"
 208                                'feature-not-implemented
 209                                nil
 210                                `((unsupported-content ((xmlns . ,jingle-error-ns)))))
 211          (list nil state-data))
 212
 213         ;; Make sure ICE is in the list of transports.
 214         ((not (member* jingle-ice-udp-ns
 215                        (jabber-xml-get-children audio-content 'transport)
 216                        :test 'string=
 217                        :key 'jabber-xml-get-xmlns))
 218          (jabber-send-iq-error jc from id
 219                                jingle
 220                                "cancel"
 221                                'feature-not-implemented
 222                                nil
 223                                `((unsupported-transports ((xmlns . ,jingle-error-ns)))))
 224          (list nil state-data))
 225
 226         (t
 227          ;; Allocate a new ToxSession object.
 228          (dbus-call-method nil tox-name tox-path tox-interface
 229                            "CreateSession"
 230                            (lexical-let ((jingle-fsm fsm))
 231                              (lambda (dbus-fsm msg)
 232                                (ecase (dbus-message-type msg)
 233                                  (:error
 234                                   (fsm-send jingle-fsm
 235                                             (cons :error
 236                                                   (dbus-error-to-string msg))))
 237                                  (:method-return
 238                                   (fsm-send jingle-fsm
 239                                             (cons :ok
 240                                                   (first (dbus-message-body-values msg))))))))
 241                            'byte 3)
 242
 243          (list :tox-wait (plist-put
 244                           (plist-put state-data :iq-id id)
 245                           :payload-types payload-types))))))))
 246
 247 (define-state jingle :tox-wait
 248   (fsm state-data event callback)
 249   ;; Wait for our ToxSession to be allocated
 250   (case (car-safe event)
 251     (:error
 252      ;; Some error occurred.  Bail out.
 253      (let ((jc (plist-get state-data :jc))
 254            (jid (plist-get state-data :jid))
 255            (id (plist-get state-data :iq-id)))
 256        (jabber-send-iq-error jc jid id nil "wait" 'internal-server-error (cdr event))
 257
 258        (list nil state-data)))
 259
 260     (:ok
 261      ;; ToxSession created.
 262      (let ((tox-session (cdr event)))
 263        (setq state-data (plist-put state-data :tox-session tox-session))
 264
 265        ;; Tell tox what codecs the remote side supports
 266        (dbus-call-method nil tox-name tox-session tox-session-interface
 267                          "SetRemoteCodecs"
 268                          'ignore
 269                          '((array (struct int32 string byte uint32 uint32 (array (dict-entry string string)))))
 270                          (mapcar
 271                           (lambda (pt)
 272                             (jabber-xml-let-attributes
 273                              (id name clockrate channels) pt
 274                              (list id name 0 clockrate channels
 275                                    (mapcar
 276                                     (lambda (param)
 277                                       (jabber-xml-let-attributes
 278                                        (name value) param
 279                                        (list name value)))
 280                                     (jabber-xml-get-children pt 'parameter)))))
 281                           (plist-get state-data :payload-types)))
 282
 283        ;; Check if we have any codecs in common
 284        (dbus-call-method nil tox-name tox-session tox-session-interface
 285                          "GetCodecIntersection"
 286                          (lexical-let ((jingle-fsm fsm))
 287                            (lambda (dbus-fsm msg)
 288                              (ecase (dbus-message-type msg)
 289                                  (:error
 290                                   (fsm-send jingle-fsm
 291                                             (cons :error
 292                                                   (dbus-error-to-string msg))))
 293                                  (:method-return
 294                                   (fsm-send jingle-fsm
 295                                             (cons :ok
 296                                                   (first (dbus-message-body-values msg)))))))))
 297
 298        (list :wait-for-codec-intersection state-data)))))
 299
 300 (define-state jingle :wait-for-codec-intersection
 301   (fsm state-data event callback)
 302
 303 ;;       ;; Good enough, provisionally accept.
 304 ;;       (jabber-send-iq jc from "result" ()
 305 ;;                       nil nil nil nil id)
 306 ;;       (list :pending state-data)))))))
 307
 308   )
 309
 310 (add-to-list 'jabber-iq-set-xmlns-alist
 311              (cons jingle-ns 'jabber-jingle-incoming-iq))
 312 (defun jabber-jingle-incoming-iq (jc iq)
 313   (jabber-xml-let-attributes
 314    (sid action) (jabber-iq-query iq)
 315    (unless (and sid action)
 316      (jabber-signal-error "modify" 'bad-request))
 317    (let ((fsm (gethash (cons (jabber-connection-jid jc) sid) jingle-acct-sid-map)))
 318      (cond
 319       (fsm
 320        (fsm-send-sync fsm (cons :iq-set iq)))
 321       ((string= action "session-initiate")
 322        (setq fsm (start-jingle jc sid :target (jabber-xml-get-attribute iq 'from)))
 323        (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)
 324        (fsm-send-sync fsm (cons :iq-set iq)))
 325       (t
 326        (jabber-signal-error "modify" 'unexpected-request
 327                             (format "Session \"%s\" unknown" sid)))))))
 328
 329 (defun jabber-jingle-start-audio-session (jc jid)
 330   (interactive
 331    (list (jabber-read-account)
 332          (jabber-read-jid-completing "Voice call to: " nil nil nil 'full)))
 333   (let* ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time)))
 334          (fsm (start-jingle jc sid :initiator jid)))
 335     (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)))
 336
 337
 338 (provide 'jabber-tox)