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 HP-UX 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 2005' - (Thanks for a great server David) Fixed error handler tftpd::tftpdReceive to look at the packet data.
David Easton '9 Feb 2005' - Thanks Craig, I'm glad it is of use to you.
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
verbose 2 "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 -nonewline $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 -nonewline $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 -nonewline $sock [binary format xcxca*x 5 $errCode $errMsg]
}To use it, ensure that TclUDP is available and then:
package require tftpd tftpd::tftpd
Jeff Smith '3 March 2005' Just gave the server a try, backing up the configuration file from a cisco router. I got part of the file transfered to the server but the router threw some errors. I was wondering if I was running into one of the limitations you mentioned above or am I doing something wrong.
The output from the router is
Router#copy run tftp Address or name of remote host []? 10.8.201.1 Destination filename [Router-confg]? mttd.cfg ! TFTP: unexpected packet with unknown opcode.! TFTP: unexpected packet with unknown opcode.. TFTP: unexpected packet with unknown opcode.! TFTP: unexpected packet with unknown opcode.. TFTP: unexpected packet with unknown opcode.. TFTP: unexpected packet with unknown opcode. %Error writing tftp://10.8.201.1/mttd.cfg (Write error). TFTP: unexpected packet with unknown opcode.! Router#
The output from the TFTP server is
(udp1.0.6) 5 % tftpd::tftpd Listening on UDP port: 69, sock: sock364 Received type 2 packet from 10.9.181.3:53657 on port 69 <-- WRQ 10.9.181.3:53657 (file mttd.cfg, mode octet) Running security check on writing mttd.cfg from 10.9.181.3 Receiving mttd.cfg, mode octet from 10.9.181.3:53657 ACK --> (block 0) <-- DATA (block 1, 512 bytes) ACK --> (block 1) <-- DATA (block 1, 512 bytes) ACK --> (block 1) <-- DATA (block 2, 512 bytes) ACK --> (block 2) <-- DATA (block 2, 512 bytes) ACK --> (block 2) <-- DATA (block 2, 512 bytes) ACK --> (block 2) <-- DATA (block 2, 512 bytes) ACK --> (block 2) <-- DATA (block 3, 512 bytes) ACK --> (block 3) <-- DATA (block 3, 512 bytes) ACK --> (block 3) <-- DATA (block 3, 512 bytes) ACK --> (block 3) <-- DATA (block 3, 512 bytes) ACK --> (block 3) <-- DATA (block 3, 512 bytes) ACK --> (block 3) <-- DATA (block 3, 0 bytes) ACK --> (block 3) Receipt of mttd.cfg complete Closing port 1357 (udp1.0.6) 6 %
David Easton 3 March 2005 This is not a problem that I'm aware of. The Cisco router is not recognising many of the ACK messages and so is resending the same data blocks several times. However, it obviously does sometimes recognise them as sometimes it sends the next data block - weird. The security is OK as it starts to send the file. The TFTP server thinks it is in octet mode and so it is not a netascii problem. All I can think of is to check that the Cisco router thinks it is using octet (binary) mode. Perhaps someone else will have other ideas.
Jeff Smith 8 March 2005 I had luck with the Cisco router when I added a "-nonewline" after the "puts" statement in the "sendAck" procedure.
David Easton 8 March 2005 I've tested "-nonewline" with the HP-UX 11i tftp client and that works, so I've added it to the above code in both the "sendAck" and "sendError" procedure. Thanks for the improvement.
Vidar Johannessen 4 July 2008 When transferring a binary file: For each 512 sized packet sent, there is also sent a “Malformed packet” with one data byte = 0a (line feed). Adding -nonewline in procedure tftpd::sendData right after puts solved the problem.
David Easton 4 July 2008 I've changed the "sendData" proc to add in this improvement. Thank you.
WimLeflere 2013-09-18 To allow reads and writes from IPv4 addresses in the private ranges change the security check to the following:
if { [::ip::type $host] eq "private" } {
return 0
} else {
return 1
}ip package from tcllib required
package require ip
WimLeflere - 2013-09-18 08:50:56
For ActiveTcl 8.5.11 on Windows XP
Find out where Tcl looks for packages with the following command:
set auto_path
Create a folder (ex. tftpd) in one of the directories (ex. C:\Tcl\lib) and save David's code to a file (ex. tftpd.tcl) in that folder.
Create a pkgIndex.tcl file with the pkg_mkIndex command, this file tells Tcl how to load your package.
pkg_mkIndex C:/Tcl/lib/tftpd
Install TclUDP
teacup install udp
To run the server, execute the following code:
package require tftpd tftpd::tftpd vwait __forever__