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 "urn:xmpp:jingle:0"
  26   "Jingle namespace (XEP-0166)")
  27
  28 (defconst jingle-error-ns "urn:xmpp:jingle:errors:0"
  29   "Jingle error namespace (XEP-0166)")
  30
  31 (defconst jingle-rtp-ns "urn:xmpp:jingle:apps:rtp:0"
  32   "Jingle RTP Sessions namespace (XEP-0167)")
  33
  34 (defconst jingle-ice-udp-ns "urn:xmpp:jingle:transports:ice-udp:0"
  35   "Jingle ICE namespace (XEP-0176)")
  36
  37 (defvar jingle-acct-sid-map (make-hash-table :test 'equal)
  38   "Mapping from pairs of JIDs and Jingle SIDs to FSMs.
  39 The JID is the full JID of the account using the session.")
  40
  41 (defconst tox-name "net.sourceforge.emacs-jabber.Tox"
  42   "Well-known D-BUS name of the tox service.")
  43
  44 (defconst tox-path "/net/sourceforge/emacs_jabber/Tox"
  45   "Well-known path of the main Tox object.")
  46
  47 (defconst tox-interface "net.sourceforge.emacs_jabber.Tox"
  48   "Interface of main Tox object.")
  49
  50 (defconst tox-session-interface "net.sourceforge.emacs_jabber.ToxSession"
  51   "Interface of ToxSession object.")
  52
  53 (define-fsm jingle
  54   :start ((jc sid role jid) "Start a Jingle FSM.
  55 \(Specifically, for Jingle Audio, as that's all we support for now.)
  56 JC is the account we're using.
  57 SID is a string, the session ID.
  58 ROLE is either :initiator or :target.
  59 JID is the full JID of the partner."
  60           (let ((state-data (list :jc jc :jid jid :sid sid :role role)))
  61             (setq state-data (jingle-create-tox-session fsm state-data))
  62             (list
  63              (ecase (plist-get state-data :role)
  64                (:initiator
  65                 :initiate)
  66                (:target
  67                 :wait-for-initiate))
  68              state-data))))
  69
  70 (defun jingle-create-tox-session (fsm state-data)
  71   "Helper function to create a Tox session.
  72 Accepts, modifies, and returns STATE-DATA."
  73   ;; XXX: should this always be bidirectional?
  74   (let* ((tox-session
  75           (dbus-call-method :session tox-name tox-path tox-interface
  76                             "CreateSession"
  77                             :byte 3))   ;3=bidirectional stream
  78          ;; Find the codecs that we support
  79          (our-codecs
  80           (dbus-call-method :session tox-name tox-session tox-session-interface
  81                             "GetLocalCodecs")))
  82     (setq state-data (plist-put state-data :tox-session tox-session))
  83     (setq state-data (plist-put state-data :our-codecs our-codecs))
  84
  85     (fsm-debug-output "tox-session: %S, our-codecs: %S" tox-session our-codecs)
  86     ;; Set up the pipeline, so we can search for transport candidates.
  87     (fsm-debug-output "About to call SetDefaultAudioSink")
  88     (dbus-call-method :session tox-name tox-session tox-session-interface
  89                       "SetDefaultAudioSink")
  90     (fsm-debug-output "About to call SetOggVorbisAudioSource")
  91     (dbus-call-method :session tox-name tox-session tox-session-interface
  92                       "SetOggVorbisAudioSource"
  93                       "/home/magnus/musik/computervirus.ogg")
  94     ;; There, now we just wait for the NativeCandidatesPrepared signal...
  95     ;; NO!  Don't do like those dead people do!  That signal will never
  96     ;; come.  I don't know why, though...
  97     (fsm-debug-output "About to register signal")
  98     (dbus-register-signal :session tox-name tox-session tox-session-interface
  99                           "NativeCandidatesPrepared"
 100                           (lexical-let ((fsm fsm))
 101                             (lambda (components)
 102                               (fsm-send-sync
 103                                fsm
 104                                (cons :native-candidates-prepared components)))))
 105     ;; This is more like it.  At least it will provide us with some
 106     ;; debugging information.
 107     (dbus-register-signal :session tox-name tox-session tox-session-interface
 108                           "NewNativeCandidate"
 109                           (lexical-let ((fsm fsm))
 110                             (lambda (components)
 111                               (fsm-send-sync
 112                                fsm
 113                                (cons :new-native-candidate components)))))
 114     ;; And we also want to know about state changes.
 115     (dbus-register-signal :session tox-name tox-session tox-session-interface
 116                           "StateChanged"
 117                           (lexical-let ((fsm fsm))
 118                             (lambda (state direction)
 119                               (fsm-send-sync
 120                                fsm
 121                                (list :state-changed state direction)))))
 122     ;; And about active candidate pairs.
 123     (dbus-register-signal :session tox-name tox-session tox-session-interface
 124                           "NewActiveCandidatePair"
 125                           (lexical-let ((fsm fsm))
 126                             (lambda (native-candidate remote-candidate)
 127                               (fsm-send-sync
 128                                fsm
 129                                (list :new-active-candidate-pair
 130                                      native-candidate remote-candidate)))))
 131     (fsm-debug-output "Waiting")
 132     state-data))
 133
 134 (define-enter-state jingle nil
 135   (fsm state-data)
 136   ;; clean up
 137   (let ((tox-session (plist-get state-data :tox-session)))
 138     (when tox-session
 139       (ignore-errors
 140         (dbus-call-method :session tox-name tox-session tox-session-interface
 141                           "Destroy"))))
 142   (remhash (cons (jabber-connection-jid (plist-get state-data :jc))
 143                  (plist-get state-data :sid))
 144            jingle-acct-sid-map)
 145   (list nil nil))
 146
 147 (define-enter-state jingle :initiate
 148   (fsm state-data)
 149   (let ((jc (plist-get state-data :jc))
 150         (jid (plist-get state-data :jid))
 151         (sid (plist-get state-data :sid))
 152         (payload-types (mapcar
 153                         (lambda (codec)
 154                           `(payload-type
 155                             ((id . ,(number-to-string (nth 0 codec)))
 156                              (name . ,(nth 1 codec))
 157                              ;; (nth 2 codec) is media type;
 158                              ;; should we filter out
 159                              ;; non-audio codecs?  then
 160                              ;; again, the value seems to be
 161                              ;; bogus...
 162                              (clockrate . ,(number-to-string (nth 3 codec)))
 163                              ,@(let ((channels (nth 4 codec)))
 164                                  (unless (= channels 0)
 165                                    `((channels . ,(number-to-string channels))))))
 166                             ,@(mapcar
 167                                (lambda (param)
 168                                  `(parameter
 169                                    ((name . ,(nth 0 param))
 170                                     (value . ,(nth 1 param)))))
 171                                (nth 5 codec))))
 172                         (plist-get state-data :our-codecs))))
 173     (jabber-send-iq jc jid "set"
 174                     `(jingle ((xmlns . ,jingle-ns)
 175                               (action . "session-initiate")
 176                               (initiator . ,(jabber-connection-jid jc))
 177                               (sid . ,sid))
 178                              (content
 179                               ((creator . "initiator")
 180                                (name . "foo")
 181                                (senders . "initiator"))
 182                               (description
 183                                ((xmlns . ,jingle-rtp-ns)
 184                                 (media . "audio"))
 185                                ,@payload-types)
 186                               (transport ((xmlns . ,jingle-ice-udp-ns)))))
 187                     (lambda (jc iq fsm)
 188                       (fsm-send-sync fsm (cons :iq-result iq)))
 189                     fsm
 190                     (lambda (jc iq fsm)
 191                       (fsm-send-sync fsm (cons :iq-error iq)))
 192                     fsm)
 193     (list state-data nil)))
 194
 195 (define-state jingle :initiate
 196   (fsm state-data event callback)
 197   (case (car-safe event)
 198     (:iq-result
 199      ;; Receiver provisionally accepted the session request.  Move on
 200      ;; to PENDING.
 201      (list :pending state-data))
 202     (:iq-error
 203      (message "Couldn't initiate Jingle audio session: %s"
 204               (jabber-parse-error (jabber-iq-error (cdr event))))
 205      (list nil state-data))
 206     (:new-native-candidate
 207      (let ((components (cdr event)))
 208        ;; XXX: keep them all
 209        (setq state-data (plist-put state-data :native-candidates (list (cdr event))))
 210        (jingle-send-native-candidate state-data components)
 211        (list :initiate state-data)))))
 212
 213 (define-state jingle :wait-for-initiate
 214   (fsm state-data event callback)
 215   (case (car-safe event)
 216     (:iq-set
 217      (let* ((jc (plist-get state-data :jc))
 218             (iq (cdr event))
 219             (from (jabber-xml-get-attribute iq 'from))
 220             (id (jabber-xml-get-attribute iq 'id))
 221             (jingle (jabber-iq-query iq))
 222             ;; XXX: could be more than one...
 223             (content (car (jabber-xml-get-children jingle 'content)))
 224             ;; XXX: is it really audio?
 225             (audio-content (find jingle-rtp-ns (jabber-xml-node-children content)
 226                                  :test 'string=
 227                                  :key 'jabber-xml-get-xmlns))
 228             (payload-types (jabber-xml-get-children audio-content 'payload-type)))
 229        ;; There are very few reasons for which we should not send an
 230        ;; acknowledgement here; see section 6.3.2 of XEP-0166.
 231        ;; Notably, we might want to check that there is a presence
 232        ;; subscription.
 233        (jabber-send-iq jc from "result" ()
 234                        nil nil nil nil id)
 235
 236        (cond
 237         ;; Make sure audio is in the list of contents.  We can
 238         ;; negotiate away other content types later.
 239         ((null audio-content)
 240          (jingle-send-iq state-data "session-terminate"
 241                          '((reason () (unsupported-applications))))
 242          (list nil state-data))
 243
 244         ;; Make sure ICE is in the list of transports.
 245         ((not (member* jingle-ice-udp-ns
 246                        (jabber-xml-get-children content 'transport)
 247                        :test 'string=
 248                        :key 'jabber-xml-get-xmlns))
 249          (jingle-send-iq state-data "session-terminate"
 250                          '((reason () (unsupported-transports))))
 251          (list nil state-data))
 252
 253         (t
 254          (let ((tox-session (plist-get state-data :tox-session))
 255                (their-codecs (mapcar
 256                               (lambda (pt)
 257                                 (jabber-xml-let-attributes
 258                                     (id name clockrate channels) pt
 259                                   (list :struct
 260                                         :int32 (string-to-number id)
 261                                         :string name
 262                                         :byte 0
 263                                         :uint32 (string-to-number clockrate)
 264                                         :uint32 (if channels
 265                                                     (string-to-number channels)
 266                                                   1)
 267                                         (cons
 268                                          :array
 269                                          (or
 270                                           (mapcar
 271                                            (lambda (param)
 272                                              (jabber-xml-let-attributes
 273                                                  (name value) param
 274                                                (list :dict-entry :string name :string value)))
 275                                            (jabber-xml-get-children pt 'parameter))
 276                                           (list :signature "{ss}"))))))
 277                               payload-types)))
 278            (fsm-debug-output "Their codecs are %S" their-codecs)
 279            ;; Tell tox what codecs the remote side supports
 280            (dbus-call-method
 281             :session tox-name tox-session tox-session-interface
 282             "SetRemoteCodecs"
 283             ;;'((array (struct int32 string byte uint32 uint32 (array (dict-entry string string)))))
 284             their-codecs)
 285
 286            ;; Check if we have any codecs in common
 287            (let ((codec-intersection
 288                   (dbus-call-method
 289                    :session tox-name tox-session tox-session-interface
 290                    "GetCodecIntersection")))
 291              (fsm-debug-output "The codec intersection is %S" codec-intersection)
 292              (setq state-data
 293                    (plist-put
 294                     state-data
 295                     :codec-intersection codec-intersection))
 296
 297              (if codec-intersection
 298                  ;; So, now we know that we stand a basic chance of fulfilling
 299                  ;; the request.  Let's move on to PENDING.
 300                  (list :pending state-data)
 301
 302                ;; Or, it might turn out that we don't have any codecs
 303                ;; in common with our partner.
 304                (jingle-send-iq state-data "session-terminate"
 305                                '((reason () (media-error))))
 306                (list nil state-data))))))))))
 307
 308 (define-state jingle :pending
 309   (fsm state-data event callback)
 310
 311   (case (car-safe event)
 312     (:state-changed
 313      (let ((state (car (assq (second event)
 314                              '((0 . :disconnected)
 315                                (1 . :connecting)
 316                                (2 . :connected)))))
 317            (direction (car (assq (third event)
 318                                  '((1 . :send-only)
 319                                    (2 . :receive-only)
 320                                    (3 . :send-and-receive))))))
 321        (fsm-debug-output "Got :state-changed; new state %s, new direction %s"
 322                          state direction)
 323        ;; Still, not sure what we should do here...
 324        ))))
 325
 326 (defun jingle-send-iq (state-data action payload)
 327   "Send a Jingle IQ stanza from within a Jingle FSM.
 328 STATE-DATA is the state data plist of the FSM.
 329 ACTION is the value of the action attribute of the <jingle/>
 330 element.
 331 PAYLOAD is a list of XML elements to include as children
 332 of the <jingle/> element.
 333 The recipient and the SID are determined from STATE-DATA."
 334   (let ((jc (plist-get state-data :jc))
 335         (jid (plist-get state-data :jid))
 336         (role (plist-get state-data :role))
 337         (sid (plist-get state-data :sid)))
 338     (jabber-send-iq
 339      jc jid "set"
 340      `(jingle ((xmlns . ,jingle-ns)
 341                (action . ,action)
 342                (initiator
 343                 . ,(ecase role
 344                      (:initiator
 345                       (jabber-connection-jid jc))
 346                      (:target
 347                       jid)))
 348                (sid . ,sid))
 349               ,@payload)
 350      ;; XXX: we probably want error checking, to see if our partner
 351      ;; went offline.
 352      nil nil nil nil)))
 353
 354 (defun jingle-send-native-candidate (state-data candidate)
 355   "Send a native candidate for ICE-UDP.
 356 The CANDIDATE is a list of components, as provided by the
 357 NewNativeCandidate signal of Tox."
 358   (jingle-send-iq state-data "transport-info"
 359                   `((content
 360                      ((creator . "initiator")
 361                       (name . "foo"))
 362                      (transport
 363                       ((xmlns . ,jingle-ice-udp-ns))
 364                       ,@(mapcar
 365                          (lambda (c)
 366                            `(candidate
 367                              ((component . ,(number-to-string (nth 1 c)))
 368                               ;; foundation?
 369                               ;; generation?
 370                               (ip . ,(nth 2 c))
 371                               ;; network?
 372                               (port . ,(number-to-string (nth 3 c)))
 373                               (protocol . ,(nth 4 c))
 374                               (priority . ,(nth 7 c))
 375                               ;; how to translate type?
 376                               )))
 377                          candidate))))))
 378
 379 (add-to-list 'jabber-iq-set-xmlns-alist
 380              (cons jingle-ns 'jabber-jingle-incoming-iq))
 381 (defun jabber-jingle-incoming-iq (jc iq)
 382   (jabber-xml-let-attributes
 383    (sid action) (jabber-iq-query iq)
 384    (unless (and sid action)
 385      (jabber-signal-error "modify" 'bad-request))
 386    (let ((fsm (gethash (cons (jabber-connection-jid jc) sid) jingle-acct-sid-map)))
 387      (cond
 388       (fsm
 389        (fsm-send-sync fsm (cons :iq-set iq)))
 390       ((string= action "session-initiate")
 391        (condition-case e
 392            (setq fsm (start-jingle jc sid :target (jabber-xml-get-attribute iq 'from)))
 393          (error
 394           (jabber-signal-error "wait" 'internal-server-error
 395                                (concat "Couldn't accept Jingle session: "
 396                                        (error-message-string e)))))
 397        (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)
 398        (fsm-send-sync fsm (cons :iq-set iq)))
 399       (t
 400        (jabber-signal-error "modify" 'bad-request
 401                             (format "Session \"%s\" unknown" sid)
 402                             `((unknown-session ((xmlns . ,jingle-error-ns))))))))))
 403
 404 (defun jabber-jingle-start-audio-session (jc jid)
 405   (interactive
 406    (list (jabber-read-account)
 407          (jabber-read-jid-completing "Voice call to: " nil nil nil 'full)))
 408   (let* ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time)))
 409          (fsm (start-jingle jc sid :initiator jid)))
 410     (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)))
 411
 412
 413 (provide 'jabber-tox)