# $Id: caps.tcl 1464 2008-07-03 06:42:29Z sergei $
# Entity capabilities support (XEP-0115)

package require sha1
package require md5
package require base64

namespace eval caps {
    set ::NS(caps) http://jabber.org/protocol/caps
    variable caps_node ""

    custom::defgroup Plugins \
	[::msgcat::mc "Plugins options."] \
	-group Tkabber

    custom::defgroup Caps \
	[::msgcat::mc "Options for entity capabilities plugin."] \
	-group Plugins

    custom::defvar options(enable) 1 \
	[::msgcat::mc "Enable announcing entity capabilities in\
		       every outgoing presence."] \
	-group Caps -type boolean

    custom::defvar options(hash) sha-1 \
	[::msgcat::mc "Use the specified function to hash supported\
		       features list."] \
	-group Caps -type options -values {md5 MD5 sha-1 SHA-1}
}

proc caps::hash {identities features extras hash} {

    set binidentities {}
    foreach id $identities {
	lappend binidentities [encoding convertto utf-8 $id]
    }

    set binfeatures {}
    foreach fe $features {
	lappend binfeatures [encoding convertto utf-8 $fe]
    }

    set binextra {}
    foreach eform $extras {
	set bineform {}
	foreach extra $eform {
	    lassign $extra var type label values
	    switch -- $var/$type {
		FORM_TYPE/hidden {
		    set form_type [encoding convertto utf-8 [lindex $values 0]]
		}
		default {
		    set binex {}
		    foreach val $values {
			lappend binex [encoding convertto utf-8 $val]
		    }
		    lappend bineform \
			    [linsert [lsort -ascii $binex] 0 \
				     [encoding convertto utf-8 $var]]
		}
	    }
	}
	set bineform1 {}
	foreach ex [lsort -ascii -index 0 $bineform] {
	    lappend bineform1 [join $ex "<"]
	}
	lappend binextra [linsert $bineform1 0 $form_type]
    }

    set binextra1 {}
    foreach b [lsort -ascii -index 0 $binextra] {
	lappend binextra1 [join $b "<"]
    }

    set binstr [join [concat [lsort -ascii $binidentities] \
			     [lsort -ascii $binfeatures] \
			     $binextra1] "<"]

    if {[string equal $binstr ""]} {
	return ""
    }

    append binstr "<"

    switch -- $hash {
	md5 {
	    if {[catch {::md5::md5 -hex $binstr} hex]} {
		# Old md5 package.
		set hex [::md5::md5 $binstr]
	    }
	    set binhash [binary format H32 $hex]
	}
	sha-1 {
	    set binhash [binary format H40 [::sha1::sha1 $binstr]]
	}
	default {
	    # Unsupported hash type
	    return ""
	}
    }
    return [base64::encode $binhash]
}

proc caps::info_to_hash {child hash} {
    set identities {}
    set features {}
    set extras {}

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    foreach ch $children {
	jlib::wrapper:splitxml $ch tag1 vars1 isempty1 chdata1 children1
	switch -- $tag1 {
	    identity {
		set category [jlib::wrapper:getattr $vars1 category]
		set type [jlib::wrapper:getattr $vars1 type]
		set lang [jlib::wrapper:getattr $vars1 xml:lang]
		set name [jlib::wrapper:getattr $vars1 name]
		lappend identities $category/$type/$lang/$name
	    }
	    feature {
		set var [jlib::wrapper:getattr $vars1 var]
		if {![string equal $var ""]} {
		    lappend features $var
		}
	    }
	    x {
		if {[string equal [jlib::wrapper:getattr $vars1 xmlns] \
				  $::NS(data)] && \
			[string equal [jlib::wrapper:getattr $vars1 type] \
				      result]} {
		    lappend extras \
			    [data::parse_xdata_results $children1 -hidden 1]
		}
	    }
	}
    }
    return [hash $identities $features $extras $hash]
}

proc caps::get_presence_x {varname connid status} {
    variable options
    variable caps_node
    upvar 2 $varname var

    if {!$options(enable)} return

    lassign [disco::info_query_get_handler \
		    $connid "" \
		    [jlib::get_lang] \
		    [jlib::wrapper:createtag query \
			    -vars [list xmlns $::NS(disco_info)]]] \
	    res child

    if {![string equal $res result]} return

    set ver [info_to_hash $child $options(hash)]
    if {[string equal $ver ""]} return

    lappend var [jlib::wrapper:createtag c \
		     -vars [list xmlns $::NS(caps) \
				 hash $options(hash) \
				 node http://tkabber.jabber.ru/ \
				 ver $ver]]
    set caps_node http://tkabber.jabber.ru/#$ver

    return
}

hook::add presence_xlist_hook [namespace current]::caps::get_presence_x

proc caps::disco_reply {varname type node connid from lang child} {
    variable caps_node
    upvar 2 $varname res

    if {$type != "info" || $node != $caps_node} return

    set res [disco::info_query_get_handler \
		    $connid "" \
		    [jlib::get_lang] \
		    [jlib::wrapper:createtag query \
			    -vars [list xmlns $::NS(disco_info)]]]
    if {[string equal [lindex $res 0] result]} {
	jlib::wrapper:splitxml [lindex $res 1] tag vars isempty chdata children
	lappend vars node $caps_node
	lset res 1 [jlib::wrapper:createtag $tag \
			-vars $vars \
			-chdata $chdata \
			-subtags $children]
    }
    return stop
}

hook::add disco_node_reply_hook [namespace current]::caps::disco_reply

# TODO match caps hash to a set of features
proc caps::process_presence {connid from type x args} {
    variable htype
    variable hver

    switch -- $type {
	unavailable {
	    catch {unset htype($connid,$from)}
	    catch {unset hver($connid,$from)}
	}
	available {
	    foreach xs $x {
		jlib::wrapper:splitxml $xs tag vars isempty chdata children
		if {[string equal [jlib::wrapper:getattr $vars xmlns] \
				  $::NS(caps)]} {
		    set hash [jlib::wrapper:getattr $vars hash]
		    if {[string equal $hash ""]} {
			set hash sha-1
		    }
		    set htype($connid,$from) $hash
		    set hver($connid,$from) [jlib::wrapper:getattr $vars ver]
		    return
		}
	    }
	    # Unset caps if they aren't included in <presence/>
	    catch {unset htype($connid,$from)}
	    catch {unset hver($connid,$from)}
	}
    }
}

hook::add client_presence_hook [namespace current]::caps::process_presence

proc caps::clean {connid} {
    variable htype
    variable hver

    array unset htype $connid,*
    array unset hver $connid,*
}

hook::add disconnected_hook [namespace current]::caps::clean

proc caps::info_receive \
     {connid jid node res identities features extras featured_nodes} {
    variable hidentities
    variable hfeatures
    variable htype
    variable hver

    if {![string equal $res OK]} return
    if {![info exists hver($connid,$jid)]} return

    set ids {}
    foreach id $identities {
	set category [jlib::wrapper:getattr $id category]
	set type [jlib::wrapper:getattr $id type]
	if {![string equal $category ""] && ![string equal $type ""]} {
	    lappend ids $category/$type
	}
    }
    set fes {}
    foreach fe $features {
	set var [jlib::wrapper:getattr $fe var]
	if {![string equal $var ""]} {
	    lappend fes $var
	}
    }
    if {![string equal [hash $ids $fes $extras $htype($connid,$jid)] \
		       $hver($connid,$jid)]} {
	return
    }

    set hidentities($htype($connid,$jid),$hver($connid,$jid)) $ids
    set hfeatures($htype($connid,$jid),$hver($connid,$jid)) $fes
}

hook::add disco_info_hook [namespace current]::caps::info_receive

