#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

######################################################################
#
# Swap - client/server file transfer program
# Copyright (C) 2006 Markus Triska triska@gmx.at
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
#
######################################################################

# The server listens on two ports: $list_port and $transfer_port. A
# client connecting to $list_port is sent the protocol version,
# followed by newline, the list of files, followed by newline, and a
# list of their sizes, followed by newline. To request a file, the
# client connects to $transfer_port and sends a single line containing
# the file name and the offset to start the transfer from.  The same
# socket is used to transfer the requested data, and after that the
# server closes that connection.


set list_port 9583
set transfer_port 9584
set version 1
set gui 1

set directory ""

# Files and sizes offered by peer most recently connected to.
# Used in batch mode.
set remote_files {}
set remote_sizes {}

set shared_files {}
set shared_sizes {}

set toplevel_counter 0
array set fetches {}

proc nice_size {bytes} {
    if {$bytes < 1000} {
	return "$bytes B"
    } elseif {$bytes < pow(10, 6)} {
	return [format "%.2f KB" [expr {$bytes / 1000}]]
    } elseif {$bytes < pow(10, 9)} {
	return [format "%.2f MB" [expr {$bytes / pow(10,6)}]]
    } else {
	return [format "%.2f GB" [expr {$bytes / pow(10,9)}]]
    }
}


proc send_file {sock addr port} {
    set line [gets $sock]
    puts "$addr requests: $line"
    if {[llength $line] != 2} {
	puts "request error"
	close $sock
	return
    }

    global shared_files directory
    set name [lindex $line 0]
    set offset [lindex $line 1]
    if {[lsearch -exact $shared_files $name] == -1} {
	puts "requested file not found"
	close $sock
	return
    }
    set f [file join $directory $name]
    set size [file size $f]

    if {$offset > $size} {
	puts "invalid offset requested"
	close $sock
	return
    }

    fconfigure $sock -blocking 0
    fconfigure $sock -translation binary

    set fh [open $f]
    fconfigure $fh -translation binary
    seek $fh $offset
    fileevent $sock writable [list send_async $sock $fh]
}

proc send_async {sock fh} {
    set r [read $fh 512]
    puts -nonewline $sock $r
    if {[eof $fh]} {
	close $fh
	close $sock
    }
}


proc send_list {sock addr port} {
    global version shared_files shared_sizes
    puts "new connection from: $addr"
    fconfigure $sock -blocking 0
    puts $sock $version
    puts $sock $shared_files
    puts $sock $shared_sizes
    close $sock
}


proc quit_yesno {} {
    set response [tk_messageBox -icon question -type yesno -title "Quit" -message "Really quit?"]
    if {$response} { exit }
}

proc share_dir {dir} {
    global shared_files shared_sizes directory

    set f [lsort [glob -type {f r} [file join $dir "*"]]]
    set directory $dir
    set shared_sizes {}
    set shared_files {}
    puts "******************************"
    foreach name $f {
	puts "sharing $name"
	lappend shared_files [file tail $name]
	lappend shared_sizes [file size $name]
    }
}

proc choose_dir {} {
    set dir [tk_chooseDirectory -title "Shared directory" -mustexist 1]
    if {$dir == ""} return
    share_dir $dir
}


proc new_fetch_window {} {
    global toplevel_counter

    incr toplevel_counter
    set t [toplevel ".t$toplevel_counter"]
    wm title $t "Fetching..."

    pack [label $t.name] -side left -padx 5 -pady 5
    pack [label $t.percent] -side right -padx 5 -pady 5
    return $t
}

proc fetch_all {ip files sizes} {
    global fetches
    set w [new_fetch_window]

    set fetches($w-names) $files
    set fetches($w-sizes) $sizes
    set fetches($w-ip) $ip

    fetch_next $w
}

proc fetch_next {w} {
    global fetches transfer_port gui

    set skip 1
    while {$skip} {
	if {[llength $fetches($w-names)] == 0} {
	    if {$gui} { destroy $w }
	    return
	}

	set fetches($w-size) [lindex $fetches($w-sizes) 0]
	set name [lindex $fetches($w-names) 0]
	set size [lindex $fetches($w-sizes) 0]
	set fetches($w-sizes) [lreplace $fetches($w-sizes) 0 0]
	set fetches($w-names) [lreplace $fetches($w-names) 0 0]

	if {[file exists $name]} {
	    set local_size [file size $name]
	    if {$local_size < $size} {
		set fh [open $name a]
		set skip 0
	    }
	} else {
	    set local_size 0
	    set fh [open $name w]
	    set skip 0
	}
    }

    set fetches($w-local_size) $local_size
    set fetches($w-fh) $fh

    set cmd { set sock [socket $fetches($w-ip) $transfer_port] }
    if {[catch $cmd]} {
	if {$gui} {
	    tk_messageBox -message "Could not fetch $name. Aborting." -type ok
	}
	return
    }
    puts $sock [list $name $local_size]
    flush $sock

    if {$gui} {
	if {![winfo exists $w]} { return }

	$w.name configure -text $name
	set p 100
	if {$size > 0} {
	    set p [expr {round((double($local_size)/$size)*100)}]
	}
	$w.percent configure -text "$p\%"
	update
    } else {
	puts "fetching: $name"
    }

    set fetches($w-sock) $sock
    fconfigure $sock -blocking 0
    fconfigure $sock -translation binary
    fconfigure $fh -translation binary
    fileevent $sock readable [list fetch_async $w]
}


proc fetch_async {w} {
    global fetches gui
    set sock $fetches($w-sock)
    set fh $fetches($w-fh)

    set r [read $sock 1024]
    set len [string length $r]
    if {$len > 0} {
	puts -nonewline $fh $r
	if {$gui} {
	    incr fetches($w-local_size) $len
	    set p [expr {round((double($fetches($w-local_size))/$fetches($w-size))*100)}]
	    set cmd { $w.percent configure -text "$p\%" }
	    if {[catch $cmd]} {
		close $fh
		close $sock
		return
	    }
	}
    }

    if {[eof $sock]} {
	close $fh
	close $sock
	if {!$gui} { puts "done" }
	fetch_next $w
    }
}


proc fetch_selected {ip files sizes lb} {
    global fetches
    set w [new_fetch_window]

    set fetches($w-names) {}
    set fetches($w-sizes) {}
    set fetches($w-ip) $ip

    foreach i [$lb curselection] {
	lappend fetches($w-names) [lindex $files $i]
	lappend fetches($w-sizes) [lindex $sizes $i]
    }
    fetch_next $w
}

proc display_remote {ip} {
    global list_port toplevel_counter version gui remote_sizes remote_files
    set cmd { set s [socket $ip $list_port] }
    if {[catch $cmd]} {
	if {$gui} {
	    tk_messageBox -message "Could not connect." -type ok
	} else {
	    puts "Could not connect."
	}
	return
    }
    # invoke server ==> allow connection to self
    update

    set v [gets $s]
    if {$v != $version} {
	puts "version mismatch (local: $version remote: $v)"
	return
    }

    set remote_files [gets $s]
    set remote_sizes [gets $s]

    close $s

    foreach size $remote_sizes {
	if {![string is integer $size]} {
	    puts "malignant server?"
	    set remote_files {}
	    set remote_sizes {}
	    break
	}
    }

    if {$gui} {
	incr toplevel_counter
	set t ".t$toplevel_counter"
	toplevel $t
	wm title $t "$ip"

	set f1 [frame $t.lst]
	set vsb [scrollbar $f1.vsbar -command "$f1.lb yview"]
	set hsb [scrollbar $f1.hsbar -command "$f1.lb xview" -orient h]
	set lb [listbox $f1.lb -width 30 -height 15 -xscrollcommand "$hsb set" \
		    -yscrollcommand "$vsb set" -selectmode multiple]


	grid $lb $vsb -sticky news
	grid $hsb -sticky ew

	grid rowconfigure $f1 0 -weight 1
	grid columnconfigure $f1 0 -weight 1

	set f2 [frame $t.get]

	set ba [button $f2.all -text "Fetch all" -command [list fetch_all $ip $remote_files $remote_sizes]]
	set bs [button $f2.sel -text "Fetch selected" \
		    -command [list fetch_selected $ip $remote_files $remote_sizes $lb]]

	pack $ba -side left -padx 5 -pady 5
	pack $bs -padx 5 -pady 5

	for {set i 0} {$i < [llength $remote_files]} {incr i} {
	    $lb insert end "[lindex $remote_files $i] ([nice_size [lindex $remote_sizes $i]])"
	}
	pack $f1 -padx 5 -pady 5 -expand yes -fill both
	pack $f2 -padx 5 -pady 5
    } else {
	foreach f $remote_files { puts $f }
    }
}

if {[catch "socket -server send_list $list_port"]} {
    puts "cannot start list server"
}

if {[catch "socket -server send_file $transfer_port"]} {
    puts "cannot start transfer server"
}

set dir_index [lsearch $argv "-share"]
if {$dir_index != -1} {
    incr dir_index
    if {$dir_index >= $argc} {
	puts "Usage: swap.tcl -share <directory>"
	exit
    } else {
	set directory [lindex $argv $dir_index]
	share_dir $directory
    }
}

if {[lsearch $argv "-nogui"] != -1} { set gui 0 }

set connect_index [lsearch $argv "-connect"]
if {$connect_index != -1} {
    incr connect_index
    if {$connect_index >= $argc} {
	puts "Usage: swap.tcl -connect <host>"
	exit
    } else {
	set host [lindex $argv $connect_index]
	display_remote $host
    }
}

if {[lsearch $argv "-fetchall"] != -1} {
    if {![info exists host]} {
	puts "Usage: swap.tcl -connect <host> -fetchall"
	exit
    }

    set w batch
    if {$gui} { set w [new_fetch_window] }

    set fetches($w-names) $remote_files
    set fetches($w-sizes) $remote_sizes
    set fetches($w-ip) $host

    fetch_next $w
}



set fetch_index [lsearch $argv "-fetch"]
if {$fetch_index != -1} {
    incr fetch_index
    if {($fetch_index >= $argc) || (![info exists host])} {
	puts "Usage: swap.tcl -connect <host> -fetch file1 file2 ..."
	exit
    }

    set w batch
    if {$gui} { set w [new_fetch_window] }

    set fetches($w-names) {}
    set fetches($w-sizes) {}
    set fetches($w-ip) $host
    while {$fetch_index < $argc} {
	set f [lindex $argv $fetch_index]
	set i [lsearch $remote_files $f]
	if {$i == -1 } {
	    puts "$f not provided"
	} else {
	    lappend fetches($w-names) $f
	    lappend fetches($w-sizes) [lindex $remote_sizes $i]
	}
	incr fetch_index
    }
    fetch_next $w
}

if {!$gui} {
    puts "waiting for connections..."
    vwait forever
} else {
    wm title . "Swap $version"
    wm protocol . WM_DELETE_WINDOW quit_yesno

    button .sh -text "Share..." -command choose_dir

    set f [frame .cn]
    entry $f.ip -width 30
    $f.ip insert end "127.0.0.1"
    button $f.cn -text "Connect..." -command {display_remote [.cn.ip get]}
    pack $f.ip -padx 5 -pady 5
    pack $f.cn -padx 5 -pady 5

    pack .sh -padx 5 -pady 5
    pack .cn
}