# filetransfer.tcl --
#
#       This file is a part of Jidlink Tkabber plugin. It implements
#       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]::iq_set_handler

    ft::register_protocol jidlink \
        -priority 20 \
        -label "Jidlink" \
        -send [namespace current]::send_file \
        -close [namespace current]::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 {$status eq "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] \
        -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]]
            }
        }
    }
}

# vim:ft=tcl:ts=8:sw=4:sts=4:et
