# $Id$
namespace eval ft {
set winid 0
set chunk_size 4096
}
proc ft::send_file_dialog {user} {
variable winid
set w .sfd$winid
while {[winfo exists $w]} {
incr winid
set w .sfd$winid
}
variable filename$winid
Dialog $w -title [format [::msgcat::mc "Send file to %s"] $user] -separator 1 -anchor e -modal none \
-default 0 -cancel 1
set f [$w getframe]
label $f.lfile -text [::msgcat::mc "File to Send:"]
entry $f.file -textvariable ft::filename$winid
button $f.browsefile -text [::msgcat::mc "Browse..."] \
-command [list eval set ft::filename$winid {[tk_getOpenFile]}]
label $f.ldesc -text [::msgcat::mc "Description:"]
text $f.desc -width 40 -height 3
label $f.lip -text [::msgcat::mc "IP address:"]
entry $f.ip -textvariable ft::ip$winid
variable ip$winid 127.0.0.1
catch {
set ip$winid [info hostname]
set ip$winid [lindex [host_info addresses [set ip$winid]] 0]
}
catch {
set ip$winid [lindex [fconfigure $jlib::lib(sck) -sockname] 0]
}
ProgressBar $f.pb -variable ft::progress$f.pb
grid $f.lfile -row 0 -column 0 -sticky e
grid $f.file -row 0 -column 1 -sticky ew
grid $f.browsefile -row 0 -column 2 -sticky ew
grid $f.ldesc -row 1 -column 0 -sticky e
grid $f.desc -row 1 -column 1 -sticky ew -columnspan 2
grid $f.lip -row 2 -column 0 -sticky e
grid $f.ip -row 2 -column 1 -sticky ew -columnspan 2
grid $f.pb -row 3 -column 0 -sticky ew -columnspan 3
grid columnconfigure $f 1 -weight 1
$w add -text [::msgcat::mc "Send"] -command [list ft::send_file_start $winid $f $user]
$w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
incr winid
$w draw $f.file
}
proc ft::send_file_start {winid f user} {
set filename [$f.file get]
set desc [$f.desc get 0.0 end]
set ip [$f.ip get]
if {![file isfile $filename]} {
MessageDlg .filenofound$winid -aspect 50000 -icon error \
-message [format [::msgcat::mc "File not found or not regular file: %s"] $filename] -type user \
-buttons ok -default 0 -cancel 0
return
}
set fsize [file size $filename]
$f.pb configure -maximum $fsize
.sfd$winid itemconfigure 0 -state disabled
#destroy .sfd$winid
debugmsg filetransfer "SENDFILE: $filename; $desc; $ip"
set servsock [socket -server \
[list ft::send_file_accept $winid $filename] 0]
lassign [fconfigure $servsock -sockname] addr hostname port
set url [cconcat "http://$ip:$port/" [file tail $filename]]
jlib::send_iq set [jlib::wrapper:createtag query \
-vars {xmlns jabber:iq:oob} \
-subtags [list [jlib::wrapper:createtag url \
-chdata $url] \
[jlib::wrapper:createtag desc \
-chdata $desc]]] \
-to [get_jid_of_user $user]
bind .sfd$winid <Destroy> [list ft::send_file_cancel $winid $servsock]
}
proc ft::send_file_accept {winid filename chan addr port} {
variable chans
variable chanreadable$chan
if {[info exists chans($winid)]} {
close $chan
} else {
set chans($winid) $chan
}
fconfigure $chan -blocking 0 -encoding binary -buffering line
fileevent $chan readable [list set ft::chanreadable$chan 1]
set request " "
while {$request != ""} {
debugmsg filetransfer $request
vwait ft::chanreadable$chan
set request [gets $chan]
}
fileevent $chan readable {}
set fsize [file size $filename]
#debugmsg filetransfer $request
fconfigure $chan -translation binary
puts -nonewline $chan "HTTP/1.0 200 OK\n"
puts -nonewline $chan "Content-Length: $fsize\n"
puts -nonewline $chan "Content-Type: application/data\n\n"
set fd [open $filename]
fconfigure $fd -translation binary
fileevent $chan writable \
[list ft::send_file_transfer_chunk $winid $fd $chan]
}
proc ft::send_file_transfer_chunk {winid fd chan} {
variable chunk_size
set chunk [read $fd $chunk_size]
if {$chunk != ""} {
puts -nonewline $chan $chunk
set pb [.sfd$winid getframe].pb
variable progress$pb
set progress$pb [tell $fd]
} else {
fileevent $chan writable {}
close $fd
close $chan
variable chans
unset chans($winid)
destroy .sfd$winid
}
}
proc ft::send_file_cancel {winid sock} {
variable chans
if {[info exists chans($winid)]} {
close $chans($winid)
unset chans($winid)
}
bind .sfd$winid <Destroy> {}
close $sock
destroy .sfd$winid
}
###############################################################################
proc ft::recv_file_dialog {from urls desc} {
variable winid
set w .rfd$winid
while {[winfo exists $w]} {
incr winid
set w .rfd$winid
}
Dialog $w -title [format [::msgcat::mc "Receive file from %s"] $from] -separator 1 -anchor e \
-modal none -default 0 -cancel 1
# FIX
set url [lindex $urls 0]
set f [$w getframe]
label $f.lurl -text [::msgcat::mc "URL:"]
label $f.url -text $url
label $f.ldesc -text [::msgcat::mc "Description:"]
message $f.desc -width 40 -text $desc
label $f.lsaveas -text [::msgcat::mc "Save as:"]
entry $f.saveas -textvariable ft::saveas$winid
variable saveas$winid "/tmp/[file tail $url]"
ProgressBar $f.pb -variable ft::progress$f.pb
grid $f.lurl -row 0 -column 0 -sticky e
grid $f.url -row 0 -column 1 -sticky w
grid $f.ldesc -row 1 -column 0 -sticky e
grid $f.desc -row 1 -column 1 -sticky ew
grid $f.lsaveas -row 2 -column 0 -sticky e
grid $f.saveas -row 2 -column 1 -sticky ew
grid $f.pb -row 3 -column 0 -sticky ew -columnspan 2
grid columnconfigure $f 1 -weight 1
$w add -text [::msgcat::mc "Receive"] -command [list ft::recv_file_start $winid $url]
# TODO
$w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
incr winid
$w draw
}
package require http
proc ft::recv_file_start {winid url} {
variable saveas$winid
variable chunk_size
set filename [set saveas$winid]
.rfd$winid itemconfigure 0 -state disabled
set f [.rfd$winid getframe]
set fd [open $filename w]
fconfigure $fd -translation binary
set token [::http::geturl $url -channel $fd \
-blocksize $chunk_size \
-progress [list ft::recv_file_progress $f.pb] \
-command [list ft::recv_file_finish $winid]]
# .rfd$winid itemconfigure 1 \
# -command [list ft::recv_file_cancel $winid $token]
bind .rfd$winid <Destroy> [list ft::recv_file_cancel $winid $token]
}
proc ft::recv_file_progress {pb token total current} {
variable progress$pb
debugmsg filetransfer "$total $current"
$pb configure -maximum $total
set progress$pb $current
}
proc ft::recv_file_finish {winid token} {
upvar #0 $token state
debugmsg filetransfer "transfer $state(status)"
bind .rfd$winid <Destroy> {}
destroy .rfd$winid
}
proc ft::recv_file_cancel {winid token} {
::http::reset $token cancelled
destroy .rfd$winid
}
###############################################################################
# File transfer via Jidlink
namespace eval ftjl {
set winid 0
set id 0
set chunk_size 4096
}
#proc ftjl::add_groupchat_user_menu_items {m} {
# $m add command -label "Send file via Jidlink" \
# -command {ftjl::send_file_dialog $curgroupuser}
#}
#
#hook::add roster_create_groupchat_user_menu_hook \
# ftjl::add_groupchat_user_menu_items
proc ftjl::send_file_dialog {user} {
variable winid
set w .sfd$winid
while {[winfo exists $w]} {
incr winid
set w .sfd$winid
}
variable filename$winid
Dialog $w -title [format [::msgcat::mc "Send file to %s"] $user] -separator 1 -anchor e -modal none \
-default 0 -cancel 1
set f [$w getframe]
label $f.lfile -text [::msgcat::mc "File to Send:"]
entry $f.file -textvariable ft::filename$winid
button $f.browsefile -text [::msgcat::mc "Browse..."] \
-command [list eval set ft::filename$winid {[tk_getOpenFile]}]
label $f.ldesc -text [::msgcat::mc "Description:"]
text $f.desc -width 40 -height 3
ProgressBar $f.pb -variable [namespace current]::progress$f.pb
grid $f.lfile -row 0 -column 0 -sticky e
grid $f.file -row 0 -column 1 -sticky ew
grid $f.browsefile -row 0 -column 2 -sticky ew
grid $f.ldesc -row 1 -column 0 -sticky e
grid $f.desc -row 1 -column 1 -sticky ew -columnspan 2
grid $f.pb -row 2 -column 0 -sticky ew -columnspan 3
grid columnconfigure $f 1 -weight 1
$w add -text [::msgcat::mc "Send"] -command [list ftjl::send_file_start $winid $f $user]
$w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
incr winid
$w draw $f.file
}
proc ftjl::send_file_start {winid f user} {
set filename [$f.file get]
set desc [$f.desc get 0.0 "end -1c"]
if {![file isfile $filename]} {
MessageDlg .filenofound$winid -aspect 50000 -icon error \
-message [format [::msgcat::mc "File not found or not regular file: %s"] $filename] -type user \
-buttons ok -default 0 -cancel 0
return
}
set fsize [file size $filename]
$f.pb configure -maximum $fsize
.sfd$winid itemconfigure 0 -state disabled
#destroy .sfd$winid
debugmsg filetransfer "SENDFILE: $filename; $desc"
send_file_offer $user $filename $desc $winid
#bind .sfd$winid <Destroy> [list ft::send_file_cancel $winid $servsock]
}
proc ftjl::send_file_offer {user filename desc winid} {
variable id
variable files
incr id
set name [file tail $filename]
set size [file size $filename]
set files(filename,$id) $filename
set files(w,$id) .sfd$winid
jlib::send_iq set \
[jlib::wrapper:createtag query \
-vars {xmlns jabber:iq:filexfer} \
-subtags [list [jlib::wrapper:createtag file \
-vars [list id $id \
name $name \
size $size] \
-chdata $desc]]] \
-to $user -command ftjl::send_file_offer_reply
}
proc ftjl::send_file_offer_reply {res child} {
if {$res != "OK"} {
MessageDlg .auth_err -aspect 50000 -icon error \
-message [format [::msgcat::mc "Request failed: %s"] $child] -type user \
-buttons ok -default 0 -cancel 0
return
}
}
proc ftjl::send_file_request {from id offset} {
variable files
if {[info exists files(filename,$id)]} {
set key [random 1000000000]
set res \
[jlib::wrapper:createtag query \
-vars {xmlns jabber:iq:filexfer} \
-subtags [list \
[jlib::wrapper:createtag file \
-vars [list id $id] \
-subtags [list \
[jlib::wrapper:createtag \
key \
-chdata $key]]]]]
after idle [list ftjl::send_file_setup_connection \
$from $id $offset $key]
return [list result $res]
} else {
return [list error 401 "Invalid file id."]
}
}
proc ftjl::send_file_setup_connection {user id offset key} {
variable files
variable chunk_size
jidlink::connect $user $key
set w $files(w,$id)
if {![winfo exists $w]} {
jidlink::close $key
return
}
bind $w <Destroy> [list ftjl::send_file_close $key]
set filename $files(filename,$id)
set fd [open $filename]
fconfigure $fd -translation binary
set files(rfd,$key) $fd
set pb [$files(w,$id) getframe].pb
variable progress$pb
$pb configure -maximum [file size $filename]
#set chunk [read $fd]
set_status [::msgcat::mc "Transfering..."]
set chunk [read $fd $chunk_size]
catch {
while {$chunk != ""} {
jidlink::send_data $key $chunk
set progress$pb [tell $fd]
after 1000
set chunk [read $fd $chunk_size]
}
}
catch { close $fd }
catch { destroy $w }
jidlink::close $key
}
proc ftjl::send_file_close {key} {
variable files
catch { close $files(rfd,$key) }
#set w $files(w,$id)
#jidlink::close $key
#destroy $w
}
###############################################################################
proc ftjl::recv_file_dialog {from id name size date hash desc} {
variable winid
variable files
set w .rfd$winid
while {[winfo exists $w]} {
incr winid
set w .rfd$winid
}
Dialog $w -title [format [::msgcat::mc "Receive file from %s"] $from] -separator 1 -anchor e \
-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 40 -text $desc
label $f.lsaveas -text [::msgcat::mc "Save as:"]
entry $f.saveas -textvariable [namespace current]::saveas$winid
variable saveas$winid "/tmp/$name"
set pbvar [namespace current]::progress$f.pb
ProgressBar $f.pb -variable $pbvar
$f.pb configure -maximum $size
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 e
grid $f.desc -row 2 -column 1 -sticky ew
grid $f.lsaveas -row 3 -column 0 -sticky e
grid $f.saveas -row 3 -column 1 -sticky ew
grid $f.pb -row 4 -column 0 -sticky ew -columnspan 2
grid columnconfigure $f 1 -weight 1
$w add -text [::msgcat::mc "Receive"] -command \
[list ftjl::recv_file_start $winid $pbvar $from $id]
# TODO
$w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
incr winid
$w draw
}
proc ftjl::recv_file_start {winid pbvar user 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
jlib::send_iq set \
[jlib::wrapper:createtag query \
-vars {xmlns jabber:iq:filexfer} \
-subtags [list [jlib::wrapper:createtag file \
-vars [list id $id]]]] \
-to $user -command [list ftjl::recv_file_reply \
$winid $pbvar $user $id $filename]
}
proc ftjl::recv_file_reply {winid pbvar user id filename res child} {
variable files
if {$res != "OK"} {
# TODO
return
}
jlib::wrapper:splitxml $child tag vars isempty chdata children
if {$tag == "query"} {
foreach item $children {
jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
if {$tag1 == "file"} {
foreach item1 $children1 {
jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
chdata2 children2
if {$tag2 == "key"} {
set key $chdata2
set files(filename,$key) $filename
debugmsg filetransfer "RECV KEY: $key"
set fd [open $filename w]
fconfigure $fd -translation binary
set files(fd,$key) $fd
set w .rfd$winid
jidlink::set_readable_handler \
$key [list ftjl::recv_file_chunk $pbvar]
jidlink::set_closed_handler \
$key [list ftjl::closed $w]
}
}
}
}
}
}
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 $data"
puts -nonewline $files(fd,$key) $data
incr $pbvar [string bytelength $data]
debugmsg filetransfer [set $pbvar]
}
}
proc ftjl::closed {w key} {
variable files
if {[info exists files(filename,$key)]} {
debugmsg filetransfer CLOSE
catch { close $files(fd,$key) }
catch { destroy $w }
unset files(filename,$key)
set_status [::msgcat::mc "Connection closed"]
}
}
proc ftjl::iq_set_handler {from child} {
debugmsg filetransfer "FTJL set: [list $from $child]"
jlib::wrapper:splitxml $child tag vars isempty chdata children
if {$tag == "query"} {
foreach item $children {
jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
if {$tag1 == "file"} {
if {[jlib::wrapper:getattr $vars1 name] != ""} {
ftjl::recv_file_dialog \
$from \
[jlib::wrapper:getattr $vars1 id] \
[jlib::wrapper:getattr $vars1 name] \
[jlib::wrapper:getattr $vars1 size] \
[jlib::wrapper:getattr $vars1 date] \
[jlib::wrapper:getattr $vars1 hash] \
$chdata1
return [list result {}]
} else {
return [ftjl::send_file_request $from \
[jlib::wrapper:getattr $vars1 id] \
[jlib::wrapper:getattr $vars1 offset]]
}
}
}
} else {
# TODO
}
}
iq::register_handler set query jabber:iq:filexfer ftjl::iq_set_handler