David Easton 20 Oct 2004 - Here is a simple TFTP server written purely in Tcl but requiring TclUDP. It supports octet (binary) and nearly supports netascii (ascii) - see limitations below.
It has been tested by running it on Windows (Tcl 8.4.6) and using an HPUX 11i tftp client.
Limitations:
Feel free to fix/improve this and use it however you wish.
#
# TFTP Server/Daemon by David Easton, http://wiki.tcl.tk/21711
#
# Note: Transfers will be to/from the current directory if full path not given
# Note: Security rules should be added to securityCheckRead/securityCheckWrite
#
package provide tftpd 1.0
namespace eval tftpd {
package require udp
namespace export tftpd
variable S
set S(rexmt) 5000 ;# Per-packet timeout (ms)
set S(timeout) 25000 ;# Total timeout (ms)
set S(listenPort) 69 ;# TFTPD port
set S(verbose) 2 ;# Verbose output (2=high, 1=medium, 0=low/none)
}
# Returns: 0 - Passed security check
# 1 - Failed security check
proc tftpd::securityCheckRead {host file} {
verbose 1 "Running security check on sending $file to $host"
return 0
}
# Returns: 0 - Passed security check
# 1 - Failed security check
proc tftpd::securityCheckWrite {host file} {
verbose 1 "Running security check on writing $file from $host"
return 0
}
proc tftpd::verbose {level message} {
variable S
if { $level <= $S(verbose) } {
puts "$message"
}
}
proc tftpd::tftpd {} {
variable S
# Open listening port
set sock [udp_open $S(listenPort)]
fconfigure $sock -buffering none -translation binary
fileevent $sock readable [list tftpd::tftpdReceive $sock]
verbose 1 "Listening on UDP port: [udp_conf $sock -myport], sock: $sock"
}
proc tftpd::tftpdReceive {sock} {
set pkt [read $sock]
foreach {host port} [udp_conf $sock -peer] {break}
# Get packet type from 2nd byte
binary scan $pkt xc type
verbose 2 "Received type $type packet from $host:$port"
if { $type == 1 || $type == 2 } {
binary scan $pkt xxa* str
if {[regexp {([^\000]+)\000([^\000]+)\000} $str - filename mode]} {
verbose 2 "Filename: $filename, mode: $mode"
if { $mode != "octet" && $mode != "netascii" } {
sendError $sock 0 "Unsupported mode $mode"
} elseif { $type == 1 } {
startRead $sock $filename $mode $host $port
} else {
startWrite $sock $filename $mode $host $port
}
} else {
sendError $sock 0 "Invalid packet format"
}
} else {
sendError $sock 4 "Illegal TFTP operation"
}
}
proc tftpd::sockReceive {sock host port} {
variable S
set pkt [read $sock]
# Check that host and port are as expected
foreach {thishost thisport} [udp_conf $sock -peer] {break}
if { "$thishost" != "$host" || "$thisport" != "$port" } {
sendError $sock 5 "Unknown transfer ID"
return
}
cancelTimeout $sock
set S($sock,timAfterId) [after $S(timeout) [list tftpd::timeout $sock]]
# 1st 2 bytes determine the packet type
binary scan $pkt xc type
switch -- $type {
1 -
2 { # Error - should not get RRQ/WRQ here
sendError $sock 4 "Illegal TFTP operation"
}
3 { # DATA
binary scan $pkt xxSa* block data
set size [string length $data]
verbose 2 "DATA received (block $block, $size bytes)"
if { $block == $S($sock,lastblock) } {
# Already received, resend ACK
sendAck $sock $block
} elseif { $block == $S($sock,lastblock) + 1 } {
# New data, save to file and send ACK
puts -nonewline $S($sock,fid) $data
incr S($sock,lastblock)
sendAck $sock $block
} else {
# Unexpected block, send error
sendError 4 "Illegal TFTP operation, incorrect block number: $block"
}
# Stop if $size < 512
if { $size < 512 } {
verbose 1 "Receipt of $S($sock,file) complete"
closeSock $sock
}
}
4 { # ACK
binary scan $pkt xxS block
verbose 2 "ACK received (block $block)"
# Send the next block of data
incr block
sendData $sock $block
}
5 { # ERROR
binary scan xxxca* errCode errMsg
verbose 1 "ERROR $errCode $errMsg"
closeSock $sock
}
}
}
proc tftpd::timeout {sock} {
variable S
verbose 1 "Timed out for file $S($sock,file)"
closeSock $sock
}
proc tftpd::cancelTimeout {sock} {
variable S
catch {after cancel $S($sock,timAfterId)}
catch {after cancel $S($sock,pktAfterId)}
}
proc tftpd::closeSock {sock} {
variable S
cancelTimeout $sock
catch {close $sock}
catch {close $S($sock,fid)}
array unset S "$sock,*"
}
proc tftpd::startRead {sock filename mode host port} {
variable S
if {[securityCheckRead $host $filename]} {
sendError $sock 2 "Access violation"
} elseif { ![file exists $filename] } {
sendError $sock 1 "File $filename not found"
} elseif {[catch {open $filename r} fid]} {
sendError $sock 0 "Error opening file: $fid"
} else {
verbose 1 "Sending $filename, mode $mode to $host:$port"
if { $mode == "octet" } {
fconfigure $fid -translation binary -buffersize 512
}
# Create our new sending port
set newsock [udp_open]
udp_conf $newsock $host $port
fconfigure $newsock -buffering none -translation binary
# Listen for more replies
fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
set S($newsock,fid) $fid
set S($newsock,file) $filename
set S($newsock,lastblock) 65025 ;# This is 255*255
sendData $newsock 1
}
}
proc tftpd::startWrite {sock filename mode host port} {
variable S
if {[securityCheckWrite $host $filename]} {
sendError $sock 2 "Access violation"
} elseif { [file exists $filename] } {
sendError $sock 6 "File $filename already exists"
} elseif {[catch {open $filename w} fid]} {
sendError $sock 0 "Error opening file: $fid"
} else {
verbose 1 "Receiving $filename, mode $mode from $host:$port"
if { $mode == "octet" } {
fconfigure $fid -translation binary -buffersize 512
}
# Create our new sending port
set newsock [udp_open]
udp_conf $newsock $host $port
fconfigure $newsock -buffering none -translation binary
# Listen for more replies
fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
set S($newsock,fid) $fid
set S($newsock,file) $filename
set S($newsock,lastblock) 0 ;# Record last block received
sendAck $newsock 0
}
}
proc tftpd::sendData {sock block} {
variable S
# See if all block have been sent
if { $block > $S($sock,lastblock) } {
verbose 1 "Send $S($sock,file) complete"
closeSock $sock
return
}
# This could be a resend, so seek to correct place in file
seek $S($sock,fid) [expr {($block - 1) * 512}] start
set data [read $S($sock,fid) 512]
set len [string length $data]
# Mark as last block if less than 512 bytes
if { $len < 512 } {
set S($sock,lastblock) $block
}
verbose 2 "Sending block $block ($len bytes)"
puts $sock [binary format xcSa* 3 $block $data]
set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendData $sock $block]]
}
proc tftpd::sendAck {sock block} {
variable S
verbose 2 "Sending ACK (block $block)"
puts $sock [binary format xcS 4 $block]
set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendAck $sock $block]]
}
proc tftpd::sendError {sock errCode errMsg } {
verbose 1 "Sending error $errCode: $errMsg"
puts $sock [binary format xcxca*x 5 $errCode $errMsg]
}To use it, ensure that TclUDP is available and then:
package require tftpd tftpd::tftpd