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:
See:
Feel free to fix/improve this and use it however you wish.
David Easton 21 Oct 2004 - Updated to make it more resilient following testing with TFTP Client
Craig French '9 Feb 2004' - (Thanks for a great server David) Fixed error handler tftpd::tftpdReceive to look at the packet data.
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 ;# Print output (2=high, 1=medium, 0=low)
}
# Returns: 0 - Passed security check
# 1 - Failed security check
proc tftpd::securityCheckRead {host file} {
verbose 1 "Running security check on sending $file to $host"
if { $host != "127.0.0.1" } {
return 1
} else {
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"
if { $host != "127.0.0.1" } {
return 1
} else {
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}
set type "???"
# Get packet type from 2nd byte
binary scan $pkt xc type
verbose 2 "Received type $type packet from $host:$port on port [udp_conf $sock -myport]"
if { $type == 1 || $type == 2 } {
binary scan $pkt xxa* str
if {[regexp {([^\000]+)\000([^\000]+)\000} $str - filename mode]} {
if { $mode != "octet" && $mode != "netascii" } {
sendError $sock 0 "Unsupported mode $mode"
} elseif { $type == 1 } {
verbose 2 "<-- RRQ $host:$port (file $filename, mode $mode)"
startRead $sock $filename $mode $host $port
} else {
verbose 2 "<-- WRQ $host:$port (file $filename, mode $mode)"
startWrite $sock $filename $mode $host $port
}
} else {
verbose 2 "<-- RRQ/WRQ $host:$port (Invalid packet)"
sendError $sock 0 "Invalid packet format"
}
} else {
verbose 2 "<-- Unexpected type $type $host:$port ([string length $pkt] bytes)"
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
set type ???
binary scan $pkt xc type
switch -- $type {
1 -
2 { # Error - should not get RRQ/WRQ here
verbose2 "RRQ/WRQ received on port [udp_conf $sock -myport]"
sendError $sock 4 "Illegal TFTP operation"
closeSock $sock
}
3 { # DATA
binary scan $pkt xxSa* block data
set size [string length $data]
verbose 2 "<-- DATA (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 (block $block)"
# Send the next block of data
incr block
sendData $sock $block
}
5 { # ERROR
binary scan $pkt xxxca* errCode errMsg
verbose 1 "<-- ERROR ($errCode $errMsg)"
closeSock $sock
}
default {
verbose 2 "<-- Unknown type ([string length $pkt] bytes) received on port [udp_conf $sock -myport]"
closeSock $sock
}
}
}
proc tftpd::timeout {sock} {
variable S
if {[info exists S($sock,file)]} {
verbose 1 "Timed out for file $S($sock,file)"
} else {
verbose 1 "Timed out"
}
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
verbose 2 "Closing port [udp_conf $sock -myport]"
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
set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
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
set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
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 "DATA --> (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 "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 "ERROR --> ($errCode $errMsg)"
puts $sock [binary format xcxca*x 5 $errCode $errMsg]
}
package require tftpd
tftpd::tftpdTo use it, ensure that TclUDP is available and then:
package require tftpd tftpd::tftpd