# $Id: filetransfer.tcl 1770 2009-03-31 15:22:21Z sergei $

###############################################################################
# File transfer via Jidlink

namespace eval ftjl {
    set winid 0
    set id 0
    set chunk_size 1024
    
    variable options

    custom::defgroup Jidlink \
	[::msgcat::mc "Jidlink options."] \
	-group {File Transfer}
}

proc ftjl::load {} {
    ::xmpp::iq::register set query jabber:iq:filexfer \
			 [namespace current]::ftjl::iq_set_handler

    ft::register_protocol jidlink \
	-priority 20 \
	-label "Jidlink" \
	-send [namespace current]::ftjl::send_file \
	-close [namespace current]::ftjl::send_file_close
}

proc ftjl::unload {} {
    ::xmpp::iq::unregister set query jabber:iq:filexfer

    ft::unregister_protocol jidlink

    namespace delete [namespace current]
}

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

proc ftjl::send_file {token} {
    upvar #0 $token state
    variable id
    variable files

    if {![info exists state(fd)]} return

    incr id
    set state(id) $id
    set files(token,$id) $token

    ::xmpp::sendIQ $state(xlib) set \
	-query [::xmpp::xml::create query \
		    -xmlns jabber:iq:filexfer \
		    -subelement [::xmpp::xml::create file \
					-attrs [list id $id \
						     name $state(name) \
						     size $state(size)] \
					-cdata $state(desc)]] \
	-to $state(jid) \
	-command [list [namespace current]::send_file_result $token]
}

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

proc ftjl::send_file_result {token status xml} {
    upvar #0 $token state

    if {![info exists state(fd)]} return

    if {[cequal $status ok]} return

    eval $state(command) \
	[list error \
	      [::msgcat::mc "Request failed: %s" [error_to_string $xml]]]
}

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

proc ftjl::send_file_request {xlib from lang id offset} {
    variable files

    if {![info exists files(token,$id)]} {
	return [list error cancel not-allowed \
		     -text [::trans::trans $lang "Invalid file ID"]]
    }

    set token $files(token,$id)
    upvar #0 $token state

    if {![info exists state(fd)]} {
	return [list error cancel not-allowed \
		     -text [::trans::trans $lang "Transfer is expired"]]
    }

    if {$state(xlib) != $xlib || $state(jid) != $from} {
	return [list error cancel not-allowed \
		     -text [::trans::trans $lang "Invalid file ID"]]
    }

    set state(key) [rand 1000000000]
    set state(offset) $offset
    set res \
	[::xmpp::xml::create query \
	     -xmlns jabber:iq:filexfer \
	     -subelement [::xmpp::xml::create file \
				-attrs [list id $id] \
				-subelement [::xmpp::xml::create key \
						    -cdata $state(key)]]]
    after idle [list [namespace current]::send_file_setup_connection $token]
    return [list result $res]
}

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

proc ftjl::send_file_setup_connection {token} {
    upvar #0 $token state
    variable chunk_size

    if {![info exists state(fd)]} return

    set res [jidlink::connect $state(xlib) $state(jid) $state(key)]

    if {$res == 0} {
	if {[info exists state(command)]} {
	    eval $state(command) [list error [::msgcat::mc "Jidlink connection failed"]]
	}
	return
    }

    set_status [::msgcat::mc "Transferring..."]

    # Transfer window may be destroyed during jidlink::connect
    if {![info exists state(fd)]} return

    set chunk [read $state(fd) $chunk_size]
    if {[catch {
	     while {$chunk != ""} {
		 jidlink::send_data $state(key) $chunk
		 update idletasks
		 eval $state(command) [list progress [tell $state(fd)]]
		 after 1000
		 set chunk [read $state(fd) $chunk_size]
	     }
	 }]} {
	if {[info exists state(command)]} {
	    eval $state(command) [list error [::msgcat::mc "Jidlink transfer failed"]]
	}
	return
    }

    eval $state(command) ok
}

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

proc ftjl::send_file_close {token} {
    upvar #0 $token state
    variable files

    if {![info exists state(fd)]} return

    catch {unset files(token,$state(id))}
    catch {jidlink::close $state(key)}
}

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

proc ftjl::recv_file_dialog {xlib from lang id name size date hash desc} {
    variable winid
    variable files
    variable result

    set w .rfd$winid

    while {[winfo exists $w]} {
	incr winid
	set w .rfd$winid
    }

    Dialog $w -title [::msgcat::mc "Receive file from %s" $from] \
	-separator 1 -anchor e -transient 0 \
	-modal none -default 0 -cancel 1


    set f [$w getframe]

    label $f.lname -text [::msgcat::mc "Name:"]
    label $f.name -text $name

    label $f.lsize -text [::msgcat::mc "Size:"]
    label $f.size -text $size

    label $f.ldesc -text [::msgcat::mc "Description:"]
    message $f.desc -width 10c -text $desc

    set dir $ft::options(download_dir)
    label $f.lsaveas -text [::msgcat::mc "Save as:"]
    entry $f.saveas -textvariable [namespace current]::saveas$winid
    variable saveas$winid [file join $dir $name]
    button $f.browsefile -text [::msgcat::mc "Browse..."] \
	-command [list [namespace current]::set_receive_file_name $w $winid $dir $name]

    set pbvar [namespace current]::progress$f.pb
    ProgressBar $f.pb -variable $pbvar
    $f.pb configure -maximum $size
    set $pbvar 0

    grid $f.lname   -row 0 -column 0 -sticky e
    grid $f.name    -row 0 -column 1 -sticky w
    
    grid $f.lsize   -row 1 -column 0 -sticky e
    grid $f.size    -row 1 -column 1 -sticky w
    
    grid $f.ldesc   -row 2 -column 0 -sticky en
    grid $f.desc    -row 2 -column 1 -sticky ewns -columnspan 2 -pady 1m

    grid $f.lsaveas -row 3 -column 0 -sticky e
    grid $f.saveas  -row 3 -column 1 -sticky ew
    grid $f.browsefile  -row 3 -column 2 -sticky ew

    grid $f.pb      -row 4 -column 0 -sticky ew -columnspan 3 -pady 2m

    grid columnconfigure $f 1 -weight 1 -minsize 8c
    grid rowconfigure $f 2 -weight 1
    
    $w add -text [::msgcat::mc "Receive"] -command \
	[list [namespace current]::recv_file_start $winid $size $pbvar $xlib $from $lang $id]
    $w add -text [::msgcat::mc "Cancel"] -command \
	[list [namespace current]::recv_file_cancel $winid $lang]
    bind .rfd$winid <Destroy> \
            [list [namespace current]::recv_file_failed $winid $lang]

    $w draw
    vwait [namespace current]::result($winid)
    set res $result($winid)
    unset result($winid)
    incr winid
    return $res
}

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

proc ftjl::set_receive_file_name {w winid dir fname} {
    variable saveas$winid

    set file [tk_getSaveFile -parent $w -initialdir $dir -initialfile $fname]
    if {$file != ""} {
	set saveas$winid $file
    }
}

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

proc ftjl::recv_file_start {winid size pbvar xlib user lang id} {
    variable saveas$winid
    variable files

    set filename [set saveas$winid]

    .rfd$winid itemconfigure 0 -state disabled
    set $pbvar 0

    #set files(filename,$key) $filename

    ::xmpp::sendIQ $xlib set \
	-query [::xmpp::xml::create query \
		    -xmlns jabber:iq:filexfer \
		    -subelement [::xmpp::xml::create file \
					-attrs [list id $id]]] \
	-to $user \
	-command [list [namespace current]::recv_file_reply \
		       $winid $size $pbvar $user $lang $id $filename]
}

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

proc ftjl::recv_file_reply {winid size pbvar user lang id filename status xml} {
    variable files

    if {$status != "ok"} {
	recv_file_failed $winid $lang
	after idle \
	    [list MessageDlg .auth_err -aspect 50000 -icon error \
		  -message [::msgcat::mc "Receiving file failed: %s" \
					 [error_to_string $xml]] -type user \
		  -buttons ok -default 0 -cancel 0]
	return
    }

    ::xmpp::xml::split $xml tag xmlns attrs cdata subels

    if {$tag == "query"} {
	foreach item $subels {
	    ::xmpp::xml::split $item stag sxmlns sattrs scdata ssubels
	    if {$stag == "file"} {
		foreach sitem $ssubels {
		    ::xmpp::xml::split $sitem sstag ssxmlns ssattrs sscdata sssubels
		    if {$sstag == "key"} {
			set key $sscdata
			set files(filename,$key) $filename
			debugmsg filetransfer "RECV KEY: $key"

			set fd [open $filename w]
			fconfigure $fd -translation binary

			set files(fd,$key) $fd

			jidlink::set_readable_handler \
			    $key [list [namespace current]::recv_file_chunk $pbvar]
			jidlink::set_closed_handler \
			    $key [list [namespace current]::recv_file_finish $winid $size]
		    }
		}
	    }
	}
    }
}

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

proc ftjl::recv_file_chunk {pbvar key} {
    variable files

    if {[info exists files(filename,$key)]} {
	set data [jidlink::read_data $key]

	debugmsg filetransfer \
	    "RECV into $files(filename,$key) data length [string length $data]"

	puts -nonewline $files(fd,$key) $data

	incr $pbvar [string length $data]
	debugmsg filetransfer [set $pbvar]
    }

}

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

proc ftjl::recv_file_failed {winid lang} {
    variable result

    bind .rfd$winid <Destroy> {}
    set result($winid) \
	[list error modify undefined-condition \
	      -text [::trans::trans $lang "File transfer is failed"]]
}

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

proc ftjl::recv_file_finish {winid size key} {
    variable files
    variable result

    if {[info exists files(filename,$key)]} {
	debugmsg filetransfer CLOSE
	catch { close $files(fd,$key) }
	set fsize [file size $files(filename,$key)]
	unset files(filename,$key)
	set_status [::msgcat::mc "Connection closed"]
    }
    if {[winfo exists .rfd$winid]} {
	bind .rfd$winid <Destroy> {}
	destroy .rfd$winid
	
	if {$fsize != $size} {
	    if {$fsize < $size} {
		set msg "Transfer interrupted (File size is too small)"
	    } else {
		set msg "File size is too large"
	    }
	    after idle \
		[list MessageDlg .auth_err -aspect 50000 -icon error \
		      -message [::msgcat::mc "Receiving file failed: %s" \
				    $msg] \
		      -type user \
		      -buttons ok -default 0 -cancel 0]
	}
    }
    set result($winid) {result {}}
}

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

proc ftjl::recv_file_cancel {winid lang} {
    variable result

    catch {
	bind .rfd$winid <Destroy> {}
	destroy .rfd$winid
    }
    set result($winid) \
	[list error cancel not-allowed \
	      -text [::trans::trans $lang "File transfer is refused"]]
}

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

proc ftjl::iq_set_handler {xlib from xml args} {
    debugmsg filetransfer "FTJL set: [list $from $xml]"

    ::xmpp::xml::split $xml tag xmlns attrs cdata subels

    if {$tag != "query"} {
	return {error modify bad-request}
    }

    set lang [::xmpp::xml::getAttr $args -lang en]

    foreach item $subels {
	::xmpp::xml::split $item stag sxmlns sattrs scdata ssubels
	if {$stag == "file"} {
	    if {[::xmpp::xml::getAttr $sattrs name] != ""} {
		return [recv_file_dialog $xlib $from $lang \
		       [::xmpp::xml::getAttr $sattrs id] \
		       [::xmpp::xml::getAttr $sattrs name] \
		       [::xmpp::xml::getAttr $sattrs size] \
		       [::xmpp::xml::getAttr $sattrs date] \
		       [::xmpp::xml::getAttr $sattrs hash] \
		       $scdata]
	    } else {
		return [send_file_request $xlib $from $lang \
			    [::xmpp::xml::getAttr $sattrs id] \
			    [::xmpp::xml::getAttr $sattrs offset]]
	    }
	}
    }
}

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

