Rewrite codec querying

[emacs-jabber-tox.git] / jabber-tox.el

;; jabber-tox.el - Jingle support using TOX

;; Copyright (C) 2008 - Magnus Henoch - mange@freemail.hu

;; This file is (soon) a part of jabber.el.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

(require 'dbus)
(require 'fsm)
(require 'cl)

(defconst jingle-ns "urn:xmpp:jingle:0"
  "Jingle namespace (XEP-0166)")

(defconst jingle-error-ns "urn:xmpp:jingle:errors:0"
  "Jingle error namespace (XEP-0166)")

(defconst jingle-rtp-ns "urn:xmpp:jingle:apps:rtp:0"
  "Jingle RTP Sessions namespace (XEP-0167)")

(defconst jingle-ice-udp-ns "urn:xmpp:jingle:transports:ice-udp:0"
  "Jingle ICE namespace (XEP-0176)")

(defvar jingle-acct-sid-map (make-hash-table :test 'equal)
  "Mapping from pairs of JIDs and Jingle SIDs to FSMs.
The JID is the full JID of the account using the session.")

(defconst tox-name "net.sourceforge.emacs-jabber.Tox"
  "Well-known D-BUS name of the tox service.")

(defconst tox-path "/net/sourceforge/emacs_jabber/Tox"
  "Well-known path of the main Tox object.")

(defconst tox-interface "net.sourceforge.emacs_jabber.Tox"
  "Interface of main Tox object.")

(defconst tox-session-interface "net.sourceforge.emacs_jabber.ToxSession"
  "Interface of ToxSession object.")

(define-fsm jingle
  :start ((jc sid role jid) "Start a Jingle FSM.
\(Specifically, for Jingle Audio, as that's all we support for now.)
JC is the account we're using.
SID is a string, the session ID.
ROLE is either :initiator or :target.
JID is the full JID of the partner."
          (let ((state-data (list :jc jc :jid jid :sid sid :role role)))
            (setq state-data (jingle-create-tox-session fsm state-data))
            (list
             (ecase (plist-get state-data :role)
               (:initiator
                :initiate)
               (:target
                :wait-for-initiate))
             state-data))))

(defun jingle-create-tox-session (fsm state-data)
  "Helper function to create a Tox session.
Accepts, modifies, and returns STATE-DATA."
  ;; XXX: should this always be bidirectional?
  (let* ((tox-session
          (dbus-call-method :session tox-name tox-path tox-interface
                            "CreateSession"
                            :byte 3))   ;3=bidirectional stream
         ;; Find the codecs that we support
         (our-codecs
          (dbus-call-method :session tox-name tox-session tox-session-interface
                            "GetLocalCodecs")))
    (setq state-data (plist-put state-data :tox-session tox-session))
    (setq state-data (plist-put state-data :our-codecs our-codecs))

    (fsm-debug-output "tox-session: %S, our-codecs: %S" tox-session our-codecs)
    ;; Set up the pipeline, so we can search for transport candidates.
    (fsm-debug-output "About to call SetDefaultAudioSink")
    (dbus-call-method :session tox-name tox-session tox-session-interface
                      "SetDefaultAudioSink")
    (fsm-debug-output "About to call SetOggVorbisAudioSource")
    (dbus-call-method :session tox-name tox-session tox-session-interface
                      "SetOggVorbisAudioSource"
                      "/home/magnus/musik/computervirus.ogg")
    ;; There, now we just wait for the NativeCandidatesPrepared signal...
    ;; NO!  Don't do like those dead people do!  That signal will never
    ;; come.  I don't know why, though...
    (fsm-debug-output "About to register signal")
    (dbus-register-signal :session tox-name tox-session tox-session-interface
                          "NativeCandidatesPrepared"
                          (lexical-let ((fsm fsm))
                            (lambda (components)
                              (fsm-send-sync 
                               fsm 
                               (cons :native-candidates-prepared components)))))
    ;; This is more like it.  At least it will provide us with some
    ;; debugging information.
    (dbus-register-signal :session tox-name tox-session tox-session-interface
                          "NewNativeCandidate"
                          (lexical-let ((fsm fsm))
                            (lambda (components)
                              (fsm-send-sync 
                               fsm 
                               (cons :new-native-candidate components)))))
    (fsm-debug-output "Waiting")
    state-data))

(define-enter-state jingle nil
  (fsm state-data)
  ;; clean up
  (let ((tox-session (plist-get state-data :tox-session)))
    (when tox-session
      (ignore-errors
        (dbus-call-method :session tox-name tox-session tox-session-interface
                          "Destroy"))))
  (remhash (cons (jabber-connection-jid (plist-get state-data :jc))
                 (plist-get state-data :sid))
           jingle-acct-sid-map)
  (list nil nil))

(define-enter-state jingle :initiate
  (fsm state-data)
  (let ((jc (plist-get state-data :jc))
        (jid (plist-get state-data :jid))
        (sid (plist-get state-data :sid))
        (payload-types (mapcar 
                        (lambda (codec)
                          `(payload-type
                            ((id . ,(number-to-string (nth 0 codec)))
                             (name . ,(nth 1 codec))
                             ;; (nth 2 codec) is media type;
                             ;; should we filter out
                             ;; non-audio codecs?  then
                             ;; again, the value seems to be
                             ;; bogus...
                             (clockrate . ,(number-to-string (nth 3 codec)))
                             ,@(let ((channels (nth 4 codec)))
                                 (unless (= channels 0)
                                   `((channels . ,(number-to-string channels))))))
                            ,@(mapcar 
                               (lambda (param)
                                 `(parameter
                                   ((name . ,(nth 0 param))
                                    (value . ,(nth 1 param)))))
                               (nth 5 codec))))
                        (plist-get state-data :our-codecs))))
    (jabber-send-iq jc jid "set"
                    `(jingle ((xmlns . ,jingle-ns)
                              (action . "session-initiate")
                              (initiator . ,(jabber-connection-jid jc))
                              (sid . ,sid))
                             (content
                              ((creator . "initiator")
                               (name . "foo")
                               (senders . "initiator"))
                              (description 
                               ((xmlns . ,jingle-rtp-ns)
                                (media . "audio"))
                               ,@payload-types)
                              (transport ((xmlns . ,jingle-ice-udp-ns)))))
                    (lambda (jc iq fsm)
                      (fsm-send-sync fsm (cons :iq-result iq))) 
                    fsm
                    (lambda (jc iq fsm)
                      (fsm-send-sync fsm (cons :iq-error iq)))
                    fsm)
    (list state-data nil)))

(define-state jingle :initiate
  (fsm state-data event callback)
  (case (car-safe event)
    (:iq-result
     ;; Receiver provisionally accepted the session request.  Move on
     ;; to PENDING.
     (list :pending state-data))
    (:iq-error
     (message "Couldn't initiate Jingle audio session: %s"
              (jabber-parse-error (jabber-iq-error (cdr event))))
     (list nil state-data))
    (:new-native-candidate
     (let ((components (cdr event)))
       ;; XXX: keep them all
       (setq state-data (plist-put state-data :native-candidates (list (cdr event))))
       (jingle-send-native-candidate state-data components)
       (list :initiate state-data)))))

(define-state jingle :wait-for-initiate
  (fsm state-data event callback)
  (case (car-safe event)
    (:iq-set
     (let* ((jc (plist-get state-data :jc))
            (iq (cdr event))
            (from (jabber-xml-get-attribute iq 'from))
            (id (jabber-xml-get-attribute iq 'id))
            (jingle (jabber-iq-query iq))
            ;; XXX: could be more than one...
            (content (car (jabber-xml-get-children jingle 'content)))
            ;; XXX: is it really audio?
            (audio-content (find jingle-rtp-ns (jabber-xml-node-children content)
                                 :test 'string=
                                 :key 'jabber-xml-get-xmlns))
            (payload-types (jabber-xml-get-children audio-content 'payload-type)))
       ;; There are very few reasons for which we should not send an
       ;; acknowledgement here; see section 6.3.2 of XEP-0166.
       ;; Notably, we might want to check that there is a presence
       ;; subscription.
       (jabber-send-iq jc from "result" ()
                       nil nil nil nil id)

       (cond
        ;; Make sure audio is in the list of contents.  We can
        ;; negotiate away other content types later.
        ((null audio-content)
         (jingle-send-iq state-data "session-terminate"
                         '(reason () (unsupported-applications)))
         (list nil state-data))

        ;; Make sure ICE is in the list of transports.
        ((not (member* jingle-ice-udp-ns 
                       (jabber-xml-get-children content 'transport)
                       :test 'string=
                       :key 'jabber-xml-get-xmlns))
         (jingle-send-iq state-data "session-terminate"
                         '(reason () (unsupported-transports)))
         (list nil state-data))
                               
        (t
         (let ((tox-session (plist-get state-data :tox-session)))
           ;; Tell tox what codecs the remote side supports
           (dbus-call-method
            :session tox-name tox-session tox-session-interface
            "SetRemoteCodecs"
            ;;'((array (struct int32 string byte uint32 uint32 (array (dict-entry string string)))))
            (mapcar
             (lambda (pt)
               (jabber-xml-let-attributes 
                   (id name clockrate channels) pt
                 (list :struct
                       :int32 (string-to-number id)
                       :string name
                       :byte 0
                       :uint32 clockrate
                       :uint32 channels
                       (cons
                        :array
                        (or
                         (mapcar
                          (lambda (param)
                            (jabber-xml-let-attributes
                                (name value) param
                              (list :dict-entry :string name :string value)))
                          (jabber-xml-get-children pt 'parameter))
                         (list :signature "{ss}"))))))
             payload-types))

           ;; Check if we have any codecs in common
           (let ((codec-intersection
                  (dbus-call-method
                   :session tox-name tox-session tox-session-interface
                   "GetCodecIntersection")))
             (setq state-data
                   (plist-put 
                    state-data
                    :codec-intersection codec-intersection))

             (if codec-intersection
                 ;; So, now we know that we stand a basic chance of fulfilling
                 ;; the request.  Let's move on to PENDING.
                 (list :pending state-data)

               ;; Or, it might turn out that we don't have any codecs
               ;; in common with our partner.
               (jingle-send-iq state-data "session-terminate"
                               '(reason () (media-error)))
               (list nil state-data))))))))))

(define-state jingle :wait-for-codec-intersection
  (fsm state-data event callback)

;;       ;; Good enough, provisionally accept.
;;       (jabber-send-iq jc from "result" ()
;;                       nil nil nil nil id)
;;       (list :pending state-data)))))))

  )

(defun jingle-send-iq (state-data action payload)
  "Send a Jingle IQ stanza from within a Jingle FSM.
STATE-DATA is the state data plist of the FSM.
ACTION is the value of the action attribute of the <jingle/>
element.
PAYLOAD is a list of XML elements to include as children
of the <jingle/> element.
The recipient and the SID are determined from STATE-DATA."
  (let ((jc (plist-get state-data :jc))
        (jid (plist-get state-data :jid))
        (role (plist-get state-data :role))
        (sid (plist-get state-data :sid)))
    (jabber-send-iq
     jc jid "set"
     `(jingle ((xmlns . ,jingle-ns)
               (action . ,action)
               (initiator 
                . ,(ecase role
                     (:initiator
                      (jabber-connection-jid jc))
                     (:target
                      jid)))
               (sid . ,sid))
              ,@payload)
     ;; XXX: we probably want error checking, to see if our partner
     ;; went offline.
     nil nil nil nil)))

(defun jingle-send-native-candidate (state-data candidate)
  "Send a native candidate for ICE-UDP.
The CANDIDATE is a list of components, as provided by the
NewNativeCandidate signal of Tox."
  (jingle-send-iq state-data "transport-info"
                  `(content
                    ((creator . "initiator")
                     (name . "foo"))
                    (transport 
                     ((xmlns . ,jingle-ice-udp-ns))
                     ,@(mapcar
                        (lambda (c)
                          `(candidate
                            ((component . ,(number-to-string (nth 1 c)))
                             ;; foundation?
                             ;; generation?
                             (ip . ,(nth 2 c))
                             ;; network?
                             (port . ,(number-to-string (nth 3 c)))
                             (protocol . ,(nth 4 c))
                             (priority . ,(nth 7 c))
                             ;; how to translate type?
                             )))
                        candidate)))))

(add-to-list 'jabber-iq-set-xmlns-alist
             (cons jingle-ns 'jabber-jingle-incoming-iq))
(defun jabber-jingle-incoming-iq (jc iq)
  (jabber-xml-let-attributes
   (sid action) (jabber-iq-query iq)
   (unless (and sid action)
     (jabber-signal-error "modify" 'bad-request))
   (let ((fsm (gethash (cons (jabber-connection-jid jc) sid) jingle-acct-sid-map)))
     (cond
      (fsm
       (fsm-send-sync fsm (cons :iq-set iq)))
      ((string= action "session-initiate")
       (condition-case e
           (setq fsm (start-jingle jc sid :target (jabber-xml-get-attribute iq 'from)))
         (error
          (jabber-signal-error "wait" 'internal-server-error
                               (concat "Couldn't accept Jingle session: "
                                       (error-message-string e)))))
       (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)
       (fsm-send-sync fsm (cons :iq-set iq)))
      (t
       (jabber-signal-error "modify" 'bad-request
                            (format "Session \"%s\" unknown" sid)
                            `((unknown-session ((xmlns . ,jingle-error-ns))))))))))

(defun jabber-jingle-start-audio-session (jc jid)
  (interactive
   (list (jabber-read-account)
         (jabber-read-jid-completing "Voice call to: " nil nil nil 'full)))
  (let* ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time)))
         (fsm (start-jingle jc sid :initiator jid)))
    (puthash (cons (jabber-connection-jid jc) sid) fsm jingle-acct-sid-map)))


(provide 'jabber-tox)