# $Id: remote.tcl 1408 2008-05-11 11:29:45Z sergei $
# Implementation of Remote Controlling Clients (XEP-0146)
# via Ad-Hoc Commands (XEP-0050) for Tkabber.
#

namespace eval ::remote {
    array set commands {}
    array set sessions {}
    set prefix "::remote::sessions"

    custom::defgroup {Remote Control} \
	[::msgcat::mc "Remote control options."] -group Tkabber

    custom::defvar options(enable) 1 \
	[::msgcat::mc "Enable remote control."] \
	-type boolean -group {Remote Control}

    custom::defvar options(accept_from_myjid) 1 \
	[::msgcat::mc "Accept connections from my own JID."] \
	-type boolean -group {Remote Control}

    custom::defvar options(accept_list) "" \
	[::msgcat::mc "Accept connections from the listed JIDs."] \
	-type string -group {Remote Control}

    #custom::defvar options(show_my_resources) 1 \
    #	[::msgcat::mc "Show my own resources in the roster."] \
    #	-type boolean -group {Remote Control}
}
namespace eval ::remote::sessions {}

############################################

proc ::remote::allow_remote_control {connid from} {
    variable options

    if {!$options(enable)} {
	return 0
    }

    set from [string tolower $from]
    set myjid [string tolower \
		      [node_and_server_from_jid \
			   [jlib::connection_jid $connid]]]
    set bare_from [string tolower [node_and_server_from_jid $from]]

    if {$options(accept_from_myjid) && [cequal $myjid $bare_from]} {
	return 1
    }

    set accept_list [split [string tolower $options(accept_list)] " "]
    if {$bare_from != "" && [lsearch -exact $accept_list $bare_from] >= 0} {
	return 1
    }

    return 0
}

############################################
# Register and announce commands via disco

proc ::remote::register_command {node command name args} {
    variable commands

    set commands(command,$node) $command
    set commands(name,$node) $name
    lappend commands(nodes) $node

    ::disco::register_subnode $node \
	[namespace current]::common_command_infoitems_handler $name
}

proc ::remote::common_command_infoitems_handler {type connid from lang xmllist} {
    variable commands

    if {![allow_remote_control $connid $from]} {
	return {error cancel not-allowed}
    }

    jlib::wrapper:splitxml $xmllist tag vars isempty chdata children
    set node [jlib::wrapper:getattr $vars node]

    if {![cequal $node ""] && [info exists commands(command,$node)]} {
	if {[cequal $type info]} {
	    return \
		[list [jlib::wrapper:createtag identity \
			   -vars [list category automation \
				       type command-node \
				       name [::trans::trans $lang \
						 $commands(name,$node)]]] \
		      [jlib::wrapper:createtag feature \
			   -vars [list var $::NS(commands)]]]
	} else {
	    return {}
	}
    } else {
	return {error modify bad-request}
    }
}

proc ::remote::commands_list_handler {type connid from lang xmllist} {
    variable commands

    if {![allow_remote_control $connid $from]} {
	return {error cancel not-allowed}
    }

    set myjid [jlib::connection_jid $connid]

    switch -- $type {
	items {
	    set items {}
	    foreach node $commands(nodes) {
		lappend items [jlib::wrapper:createtag item \
				   -vars [list jid $myjid \
					       node $node \
					       name [::trans::trans $lang \
							 $commands(name,$node)]]]
	    }
	    return $items
	}
	info {
	    return [list [jlib::wrapper:createtag identity \
			      -vars [list category automation \
					  type command-list \
					  name [::trans::trans $lang \
						    "Remote control"]]]]
	}
    }
    return {}
}

::disco::register_feature $::NS(commands)
::disco::register_node $::NS(commands) \
    ::remote::commands_list_handler [::trans::trans "Remote control"]

#######################################
# Base engine.

proc ::remote::clear_session {session node} {
    variable commands
    variable sessions

    if {![info exists commands(command,$node)]} return

    $commands(command,$node) $session cancel {}

    upvar 0 $session state
    catch {unset sessions($state(connid),$state(from),$state(node),$state(id))}

    catch {unset $session}
}

proc ::remote::create_session {node connid from lang} {
    variable commands
    variable sessions
    variable prefix

    if {![info exists commands(command,$node)]} return

    set id [rand 1000000000]
    while {[info exists sesssions($connid,$from,$node,$id)]} {
	set id [rand 1000000000]
    }

    set counter 1
    while {[info exists "${prefix}::${counter}"]} {
	incr counter
    }

    set session "${prefix}::${counter}"
    upvar 0 $session state

    set state(id) $id
    set state(connid) $connid
    set state(from) $from
    set state(node) $node
    set state(lang) $lang
    set sessions($connid,$from,$node,$id) $session

    return $session
}

proc ::remote::command_set_handler {connid from lang child} {
    variable commands
    variable sessions

    if {![allow_remote_control $connid $from]} {
	return {error cancel not-allowed}
    }

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

    set node [jlib::wrapper:getattr $vars node]
    set action [jlib::wrapper:getattr $vars action]
    set id [jlib::wrapper:getattr $vars sessionid]

    if {![info exists commands(command,$node)]} {
	return {error cancel item-not-found}
    }

    if {[cequal $id ""]} {
	# We use lang only when create session.
	# Probably it would be better to use it after every request.
	set session [create_session $node $connid $from $lang]
    } else {
	if {![info exists sessions($connid,$from,$node,$id)]} {
	    return [get_error modify bad-request bad-sessionid]
	}
	set session $sessions($connid,$from,$node,$id)
    }

    upvar 0 $session state
    set id $state(id)

    if {[cequal $action cancel]} {
	clear_session $session $node
	return [list result [jlib::wrapper:createtag command \
				 -vars [list xmlns $::NS(commands) \
					     sessionid $id \
					     node $node \
					     status canceled]]]
    }

    set result [$commands(command,$node) $session $action $children]

    set status [lindex $result 0]
    switch -- $status {
	error {
	    set error_type [lindex $result 1]
	    if {![cequal $error_type "modify"]} {
		clear_session $session $node
	    }
	    return $result
	}
	completed {
	    clear_session $session $node
	}
	executing {}
	default {
	    clear_session $session $node
	    return {error wait internal-server-error}
	}
    }

    return [list result [jlib::wrapper:createtag command \
			     -vars [list xmlns $::NS(commands) \
					 sessionid $id \
					 node $node \
					 status $status] \
			     -subtags [lrange $result 1 end]]]
}

iq::register_handler set command $::NS(commands) ::remote::command_set_handler

proc ::remote::get_error {type general {specific ""}} {
    set res [list error $type $general]
    if {![cequal $specific ""]} {
	lappend res -application-specific \
	    [jlib::wrapper:createtag $specific \
		 -vars [list xmlns $::NS(commands)]]
    }
    return $res
}


############################################
# Common functions for command implementations.

# Scheduler for one-step dialogs and wizards
proc ::remote::standart_scheduler {steps prefix session action children} {
    upvar 0 $session state

    if {[cequal $action cancel]} {
	for {set i 1} {$i <= $steps} {incr i} {
	    ${prefix}clear_step$i $session
	}
	return
    }

    if {![info exists state(step)] } {
	# First step

	if {[cequal $action "execute"] || [cequal $action ""]} {

	    set state(step) 1
	    return [${prefix}get_step$state(step) $session]

	} else {
	    return [::remote::get_error modify bad-request bad-action]
	}

    } elseif { ($state(step) < $steps) && ($state(step) > 0) } {
	# Inner step
	if {[cequal $action "next"] || [cequal $action "execute"] || [cequal $action ""]} {

	    set res [${prefix}set_step$state(step) $session $children]
	    if {[cequal [lindex $res 0] error]} {
		return $res
	    }

	    incr state(step)
	    return [${prefix}get_step$state(step) $session]

	} elseif {[cequal $action "prev"]} {

	    incr state(step) -1
	    ${prefix}clear_step$state(step) $session

	    return [${prefix}get_step$state(step) $session]

	} elseif {[cequal $action "complete"]} {

	    set res [${prefix}set_step$state(step) $session $children]
	    if {[cequal [lindex $res 0] error]} {
		return $res
	    }

	    return [${prefix}get_finish $session]

	} else {
	    return [::remote::get_error modify bad-request bad-action]
	}


    } elseif { $state(step) == $steps } {
	# Last step
	if {[cequal $action complete] || [cequal $action execute] || [cequal $action ""]} {

	    set res [${prefix}set_step$state(step) $session $children]
	    if {[cequal [lindex $res 0] error]} {
		return $res
	    }

	    return [${prefix}get_finish $session]

	} elseif {[cequal $action "prev"]} {

	    incr state(step) -1
	    ${prefix}clear_step$state(step) $session

	    return [${prefix}get_step$state(step) $session]

	} else {
	    return [::remote::get_error modify bad-request bad-action]
	}

    } else {
	return {error wait internal-server-error}
    }
}

# Parse form result and returns array with values, check for correct form type
proc ::remote::standart_parseresult {children_b form_type} {
    set result {}
    foreach child $children_b {
	jlib::wrapper:splitxml $child tag vars isempty chdata children

	set xmlns  [jlib::wrapper:getattr $vars xmlns]
	set type  [jlib::wrapper:getattr $vars type]
	if {![cequal $tag x] || ![cequal $xmlns $::NS(data)]} {
	    continue
	}
	if {![cequal $type submit]} {
	    return [::remote::get_error modify bad-request bad-payload]
	}

	foreach field [::data::parse_xdata_results $children -hidden 1] {
	    lassign $field var type label values
	    if {[cequal $var FORM_TYPE]} {
		if {![cequal [lindex $values 0] $form_type]} {
		    return [::remote::get_error modify bad-request bad-payload]
		}
	    } else {
		lappend result $var $values
	    }
	}
    }

    return $result
}

############################
#Change status
namespace eval ::remote::change_status {}

proc ::remote::change_status::scheduler {session action children} {
    return [::remote::standart_scheduler 1 "[namespace current]::" \
					 $session $action $children]
}
::remote::register_command "http://jabber.org/protocol/rc#set-status" \
    ::remote::change_status::scheduler [::trans::trans "Change status"]

# step1:
# send standart form
proc ::remote::change_status::get_step1 {session} {
    global userstatus
    global textstatus
    global userpriority

    upvar 0 $session state
    set lang $state(lang)

    set fields {}

    lappend fields [data::createfieldtag hidden \
			-var FORM_TYPE \
			-values "http://jabber.org/protocol/rc"]

    lappend fields [data::createfieldtag title \
			-value [::trans::trans $lang "Change Status"]]
    lappend fields [data::createfieldtag instructions \
			-value [::trans::trans $lang \
				    "Choose status, priority, and\
				     status message"]]

    set options {}
    foreach {status statusdesc} \
	    [list available   [::trans::trans $lang "Available"]      \
		  chat        [::trans::trans $lang "Free to chat"]   \
		  away        [::trans::trans $lang "Away"]           \
		  xa          [::trans::trans $lang "Extended away"]  \
		  dnd         [::trans::trans $lang "Do not disturb"] \
		  unavailable [::trans::trans $lang "Unavailable"]] {
	lappend options [list $status $statusdesc]
    }
    lappend fields [data::createfieldtag list-single \
			-var status \
			-label [::trans::trans $lang "Status"] \
			-required 1 \
			-value $userstatus \
			-options $options]
    lappend fields [data::createfieldtag text-single \
			-var status-priority \
			-label [::trans::trans $lang "Priority"] \
			-value $userpriority \
			-required 1]
    lappend fields [data::createfieldtag text-multi \
			-var status-message \
			-label [::trans::trans $lang "Message"] \
			-values [split $textstatus "\n"]]

    return [list executing [jlib::wrapper:createtag x \
				-vars [list xmlns $::NS(data) \
					    type form] \
				-subtags $fields]]

}

proc ::remote::change_status::set_step1 {session children} {
    upvar 0 $session state

    set result [remote::standart_parseresult $children \
					     "http://jabber.org/protocol/rc"]

    if {[cequal [lindex $result 0] error]} {
	return $result
    }
    array set params $result

    if {![info exists params(status)] || \
	![info exists params(status-priority)] || \
	![info exists ::statusdesc($params(status))] || \
	[catch {expr int($params(status-priority))}]} {
	return [::remote::get_error modify bad-request bad-payload]
    }

    set state(textstatus) {}
    catch {
	set state(textstatus) \
	    [join $params(status-message) "\n"]
    }

    set state(userstatus) \
	[lindex $params(status) 0]
    set state(userpriority) \
	[lindex $params(status-priority) 0]

    return {}
}

proc ::remote::change_status::clear_step1 {session} {}

# finish:
# change status
# report
proc ::remote::change_status::get_finish {session} {
    global userstatus
    global textstatus
    global userpriority

    upvar 0 $session state
    set lang $state(lang)

    set textstatus $state(textstatus)
    set userpriority $state(userpriority)
    set userstatus $state(userstatus)

    return [list completed [jlib::wrapper:createtag note \
				-vars {type info} \
				-chdata \
				    [::trans::trans $lang \
					 "Status was changed successfully"]]]
}


############################
# Leave groupchats
namespace eval ::remote::leave_groupchats {}

proc ::remote::leave_groupchats::scheduler {session action children} {
    return [::remote::standart_scheduler 1 "[namespace current]::" $session $action $children]
}
::remote::register_command "http://jabber.org/protocol/rc#leave-groupchats" \
    ::remote::leave_groupchats::scheduler [::trans::trans "Leave groupchats"]

# step1:
# allow users to choose which chats to leave
proc ::remote::leave_groupchats::get_step1 {session} {
    upvar 0 $session state

    set options {}
    set lang $state(lang)
    set connid $state(connid)
    foreach chatid [lfilter chat::is_groupchat [chat::opened $connid]] {
	set jid [chat::get_jid $chatid]
	if {![cequal [get_jid_presence_info show $connid $jid] ""]} {
	    set nick [get_our_groupchat_nick $chatid]
	    lappend options [list $jid [format [::trans::trans $lang "%s at %s"] \
					       $nick $jid]]
	}
    }
    if {[llength $options] == 0} {
	return [list completed [jlib::wrapper:createtag note \
				    -vars {type info} \
				    -chdata [::trans::trans $lang \
						 "No groupchats to leave"]]]
    }

    set fields {}

    lappend fields [data::createfieldtag hidden \
			-var FORM_TYPE \
			-values "http://jabber.org/protocol/rc"]
    lappend fields [data::createfieldtag title \
			-value [::trans::trans $lang "Leave Groupchats"]]
    lappend fields [data::createfieldtag instructions \
			-value [::trans::trans $lang \
				    "Choose groupchats you want to leave"]]

    lappend fields [data::createfieldtag boolean \
			-var x-all \
			-label [::trans::trans $lang "Leave all groupchats"] \
			-value 0]
    lappend fields [data::createfieldtag list-multi \
			-var groupchats \
			-label [::trans::trans $lang "Groupchats"] \
			-required 1 \
			-options $options]
    lappend fields [data::createfieldtag text-single \
			-var x-reason \
			-label [::trans::trans $lang "Reason"]]

    return [list executing [jlib::wrapper:createtag x \
				-vars [list xmlns $::NS(data) \
					    type form] \
				-subtags $fields]]
}

proc ::remote::leave_groupchats::set_step1 {session children} {
    upvar 0 $session state

    set result [remote::standart_parseresult $children \
					     "http://jabber.org/protocol/rc"]
    if {[cequal [lindex $result 0] error]} {
	return $result
    }
    array set params $result

    if {![info exists params(groupchats)]} {
	return [::remote::get_error modify bad-request bad-payload]
    }

    set state(all) [lindex $params(x-all) 0]
    set state(groupchats) $params(groupchats)
    set state(reason) ""
    catch {
	set state(reason) [lindex $params(x-reason) 0]
    }
    return {}

}

proc ::remote::leave_groupchats::clear_step1 {session} {}

# finish step
# leave groupchats.
# report
proc ::remote::leave_groupchats::get_finish {session} {
    upvar 0 $session state

    set args [list -connection $state(connid)]
    set lang $state(lang)

    if {![cequal $state(reason) ""]} {
	lappend args -stat $state(reason)
    }

    # "all" workaround, will be removed soon
    if $state(all) {
	set connid $state(connid)
	set state(groupchats) ""

	foreach chatid [lfilter chat::is_groupchat [chat::opened $connid]] {
	    set jid [chat::get_jid $chatid]
	    if {![cequal [get_jid_presence_info show $connid $jid] ""]} {
		lappend state(groupchats) $jid
	    }
	}
    }

    foreach jid $state(groupchats) {
	eval [list send_presence unavailable -to $jid] $args
    }

    return [list completed [jlib::wrapper:createtag note \
				-vars {type info} \
				-chdata [::trans::trans $lang \
					     "Groupchats were leaved\
					      successfully"]]]
}

################################
# Forward unread messages
namespace eval ::remote::forward {
    array set unread {}
}

proc ::remote::forward::scheduler {session action children} {
    return [::remote::standart_scheduler 1 "[namespace current]::" $session $action $children]
}
::remote::register_command "http://jabber.org/protocol/rc#forward" \
    ::remote::forward::scheduler [::trans::trans "Forward unread messages"]

# step1:
# form with list of unreaded correspondence
proc ::remote::forward::get_step1 {session} {
    upvar 0 $session state
    variable unread

    set options {}
    set lang $state(lang)
    set connid $state(connid)
    foreach id [array names unread] {
	lassign $id type chatid
	if {![cequal [chat::get_connid $chatid] $connid]} continue

	set jid [chat::get_jid $chatid]
	set name [::roster::itemconfig $connid \
				       [::roster::find_jid $connid $jid] \
				       -name]
	if {![cequal $name ""]} {
	    set name [format "%s (%s)" $name $jid]
	} else {
	    set name $jid
	}

	set count [llength $unread($id)]

	switch -- $type {
	    chat      { set msg [::trans::trans $lang "%s: %s chat message(s)"] }
	    groupchat { set msg [::trans::trans $lang "%s: %s groupchat message(s)"] }
	    headline  { set msg [::trans::trans $lang "%s: %s headline message(s)"] }
	    normal    { set msg [::trans::trans $lang "%s: %s normal message(s)"] }
	    default   { set msg [::trans::trans $lang "%s: %s unknown message(s)"] }
	}

	lappend options [list $id [format $msg $name $count]]
    }
    if {[llength $options] == 0} {
	return [list completed [jlib::wrapper:createtag note \
				    -vars {type info} \
				    -chdata \
					[::trans::trans $lang \
					     "There are no unread messages"]]]
    }

    set fields {}

    lappend fields [data::createfieldtag hidden \
    			-var FORM_TYPE \
    			-values "tkabber:plugins:remote:forward_form"]
    lappend fields [data::createfieldtag title \
			-value [::trans::trans $lang \
				    "Forward Unread Messages"]]
    lappend fields [data::createfieldtag instructions \
			-value [::trans::trans $lang \
				    "Choose chats or groupchats from which you\
				     want to forward messages"]]

    lappend fields [data::createfieldtag boolean \
			-var all \
			-label [::trans::trans $lang "Forward all messages"] \
			-value 0]
    lappend fields [data::createfieldtag list-multi \
			-var chats \
			-label [::trans::trans $lang "Forward messages from"] \
			-required 1 \
			-options $options]

    return [list executing [jlib::wrapper:createtag x \
				-vars [list xmlns $::NS(data) \
					    type form] \
				-subtags $fields]]
}

proc ::remote::forward::set_step1 {session children} {
    upvar 0 $session state

    set result [remote::standart_parseresult $children \
					     "tkabber:plugins:remote:forward_form"]
    if {[cequal [lindex $result 0] error]} {
	return $result
    }
    array set params $result

    if {![info exists params(chats)]} {
	return [::remote::get_error modify bad-request bad-payload]
    }

    set state(all) [lindex $params(all) 0]
    set state(chats) $params(chats)
    return {}
}

proc ::remote::forward::clear_step1 {session} {}

# finish:
# forward selected unread messages
# report
proc ::remote::forward::get_finish {session} {
    upvar 0 $session state
    variable unread

    set connid $state(connid)
    set lang $state(lang)
    set oto [jlib::connection_jid $connid]
    set target $state(from)

    # "all" workaround, will be removed soon
    if $state(all) {
	set state(chats) {}

	foreach id [array names unread] {
	    lassign $id type chatid
	    if {![cequal [chat::get_connid $chatid] $connid]} continue
	    lappend state(chats) $id
	}
    }

    foreach id $state(chats) {
	forward_messages $id $connid $oto $target
    }

    return [list completed \
		 [jlib::wrapper:createtag note \
		      -vars {type info} \
		      -chdata [::trans::trans $lang \
				   "Unread messages were forwarded\
				    successfully"]]]
}

#############################
# Forward namespace

# forwards messages
# leaves marks that they were forwarded.
# cleanup arrays
proc ::remote::forward::forward_messages {id connid oto target} {
    variable unread
    variable msgdata

    lassign $id type chatid

    if {![info exists unread($id)]} { return }

    foreach elem $unread($id) {

	switch -- $type {
	    groupchat -
	    chat {
		lassign $elem date ofrom body x
	    }
	    normal {
		lassign $msgdata($elem) date ofrom body x
	    }
	}

	lappend x [jlib::wrapper:createtag addresses \
		       -vars [list xmlns $::NS(xaddress)] \
		       -subtags [list [jlib::wrapper:createtag address \
					   -vars [list type ofrom \
						       jid $ofrom]] \
				      [jlib::wrapper:createtag address \
					   -vars [list type oto \
						       jid $oto]]]]

	lappend x [jlib::wrapper:createtag x \
		       -vars [list xmlns "jabber:x:delay" \
				   stamp $date]]

	jlib::send_msg $target -body $body \
			       -type $type \
			       -xlist $x \
			       -connection $connid

	switch -- $type {
	    normal {
		set lab \
		    [Label $elem.forwlab \
			   -text [::msgcat::mc \
				      "This message was forwarded to %s" \
				      $target]]
		pack $lab -anchor w -fill none -expand no -before $elem.title

		catch {unset msgdata($elem)}
	    }
	}
    }

    catch {unset unread($id)}
    switch -- $type {
	groupchat -
	chat {
	    after idle \
		  [list ::chat::add_message $chatid $ofrom info \
			[::msgcat::mc "All unread messages were forwarded to %s." \
			     $target] \
			{}]
	}
    }
}

# store message into the unread if type == chat
proc ::remote::forward::draw_message_handler {chatid from type body extras} {
    variable unread

    if {[ifacetk::chat_window_is_active $chatid]} return

    if {![lcontain {chat groupchat} $type]} return
#    if {![cequal chat $type]} return

    set date [clock format [clock seconds] -format "%Y%m%dT%H:%M:%S" -gmt 1]

    set message [list $date $from $body $extras]
    set id [list $type $chatid]
    lappend unread($id) $message

    return 0
}

hook::add draw_message_hook ::remote::forward::draw_message_handler 19

# clear list of unread messages with type == chat
proc ::remote::forward::trace_number_msg {var1 chatid mode} {
    variable unread

    if { $::ifacetk::number_msg($chatid) == 0 } {
	set type $::chat::chats(type,$chatid)
	set id [list $type $chatid]
	catch {unset unread($id)}
    }

}

trace variable ::ifacetk::number_msg r ::remote::forward::trace_number_msg

# store message with type == normal
proc ::remote::forward::message_process_x \
     {rowvar bodyvar f x connid from id type replyP} {
    upvar 2 $rowvar row
    upvar 2 $bodyvar body
    variable unread
    variable msgdata

    if {!$replyP || [cequal $type error]} {
	return
    }

    set id [list normal [chat::chatid $connid $from]]

    if {![info exists unread($id)]} {
	set unread($id) {}
    }

    set msgwin [winfo toplevel $f]

    bindtags $msgwin [concat [bindtags $msgwin] tag$msgwin]
    bind tag$msgwin <Destroy> \
	 +[list [namespace current]::on_msgwin_destroy $msgwin $id]
    lappend unread($id) $msgwin

    set date [clock format [clock seconds] -format "%Y%m%dT%H:%M:%S" -gmt 1]
    set msgdata($msgwin) [list $date $from $body $x]

    return
}

hook::add message_process_x_hook ::remote::forward::message_process_x

# clear chat message with type == normal if it was closed
proc ::remote::forward::on_msgwin_destroy {msgwin id} {
    variable unread
    variable msgdata

    if {![info exists unread($id)]} return

    if {[set index [lsearch -exact $unread($id) $msgwin]] >= 0} {
	set unread($id) [lreplace $unread($id) $index $index]
	catch {unset msgdata($msgwin)}
    }

    if { [llength $unread($id)] == 0 } {
	catch {unset unread($id)}
    }
}

