|
1 # |
|
2 # Copyright 2004-2006 Intel Corporation |
|
3 # |
|
4 # Licensed under the Apache License, Version 2.0 (the "License"); |
|
5 # you may not use this file except in compliance with the License. |
|
6 # You may obtain a copy of the License at |
|
7 # |
|
8 # http://www.apache.org/licenses/LICENSE-2.0 |
|
9 # |
|
10 # Unless required by applicable law or agreed to in writing, software |
|
11 # distributed under the License is distributed on an "AS IS" BASIS, |
|
12 # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
|
13 # See the License for the specific language governing permissions and |
|
14 # limitations under the License. |
|
15 # |
|
16 |
|
17 |
|
18 # |
|
19 # Simple client/server code that scans a directory for new data and sends |
|
20 # that data to a remote host. |
|
21 # |
|
22 # usage: simple_ftp server <dir> <logfile> |
|
23 # usage: simple_ftp client <dir> <logfile> <host> |
|
24 # |
|
25 # |
|
26 |
|
27 set port 17600 |
|
28 set period 1000 |
|
29 |
|
30 set blocksz 8192 |
|
31 |
|
32 |
|
33 |
|
34 proc time {} { |
|
35 global starttime |
|
36 return " [clock seconds] :: [expr [clock clicks -milliseconds] - $starttime] :: " |
|
37 } |
|
38 |
|
39 #proc time {} { |
|
40 # return [clock seconds] |
|
41 #} |
|
42 |
|
43 proc timef {} { |
|
44 return [clock format [clock seconds]] |
|
45 } |
|
46 |
|
47 proc scan_dir {host dir} { |
|
48 global period |
|
49 |
|
50 puts "scanning dir $dir..." |
|
51 set files [glob -nocomplain -- "$dir/*"] |
|
52 |
|
53 foreach file $files { |
|
54 file stat $file file_stat |
|
55 |
|
56 if {$file_stat(type) != "file"} { |
|
57 continue |
|
58 } |
|
59 |
|
60 set len $file_stat(size) |
|
61 if {$len == 0} { |
|
62 continue |
|
63 } |
|
64 |
|
65 set sent_file 0 |
|
66 while {$sent_file != 1} { |
|
67 set sent_file [send_file $host $file] |
|
68 # after 2000 |
|
69 } |
|
70 |
|
71 file delete -force $file |
|
72 } |
|
73 |
|
74 after $period scan_dir $host $dir |
|
75 } |
|
76 |
|
77 proc ack_arrived {sock} { |
|
78 global got_ack ack_timer |
|
79 after cancel $ack_timer |
|
80 set got_ack 1 |
|
81 |
|
82 set ack [gets $sock] |
|
83 if [eof $sock] { |
|
84 puts " [time] eof waiting for ack!" |
|
85 set got_ack 0 |
|
86 fileevent $sock readable |
|
87 return |
|
88 } |
|
89 if {$ack != "ACK"} { |
|
90 puts "[time] ERROR in ack_arrived: got '$ack', expected ACK" |
|
91 set got_ack 0 |
|
92 fileevent $sock readable |
|
93 return |
|
94 } |
|
95 } |
|
96 |
|
97 proc ack_timeout {} { |
|
98 global got_ack |
|
99 set got_ack 0 |
|
100 puts " [time] ack_timeout" |
|
101 } |
|
102 |
|
103 proc send_file {host file} { |
|
104 global port |
|
105 global logfd |
|
106 global blocksz |
|
107 global got_ack |
|
108 global ack_timer |
|
109 global sock |
|
110 set fd [open $file] |
|
111 |
|
112 puts "[time] trying to send file $file size [file size $file]" |
|
113 |
|
114 if {! [info exists sock]} { |
|
115 while { [ catch {socket $host $port } sock] } { |
|
116 puts "[time] Trying to connect, will try again after 2 seconds " |
|
117 after 2000 |
|
118 } |
|
119 |
|
120 fconfigure $sock -translation binary |
|
121 fconfigure $sock -encoding binary |
|
122 } |
|
123 |
|
124 if [catch { |
|
125 puts -nonewline $sock "[file tail $file] " |
|
126 flush $sock |
|
127 # after 500 |
|
128 puts $sock "[file size $file]" |
|
129 flush $sock |
|
130 }] { |
|
131 puts $sock "[time] failure in sending header " |
|
132 close $sock |
|
133 unset sock |
|
134 close $fd |
|
135 return -1 |
|
136 } |
|
137 |
|
138 # read the handshake ack |
|
139 # set got_ack -1 |
|
140 # fileevent $sock readable "ack_arrived $sock" |
|
141 # set ack_timer [after 10000 ack_timeout] |
|
142 # vwait got_ack |
|
143 |
|
144 # if {!$got_ack} { |
|
145 # puts "[time] timeout waiting for handshake ack" |
|
146 # close $fd |
|
147 # close $sock |
|
148 # unset sock |
|
149 # return -1 |
|
150 # } |
|
151 # puts "[time] got handshake ack -- sending file" |
|
152 |
|
153 |
|
154 while {![eof $fd]} { |
|
155 if {[catch { |
|
156 set payload [read $fd $blocksz] |
|
157 puts "[time] sending [string length $payload] byte chunk" |
|
158 puts -nonewline $sock $payload |
|
159 flush $sock |
|
160 } ]} { |
|
161 |
|
162 puts "[time] failure at sender " |
|
163 close $sock |
|
164 unset sock |
|
165 close $fd |
|
166 return -1 |
|
167 } |
|
168 } |
|
169 |
|
170 close $fd |
|
171 |
|
172 puts "[time] :: file actually sent $file" |
|
173 puts $logfd "[time] :: file actually sent [file tail $file] " |
|
174 flush $logfd |
|
175 |
|
176 return 1 |
|
177 # wait for an ack or timeout |
|
178 # puts "[time] sent whole file, waiting for ack" |
|
179 # fconfigure $sock -blocking 0 |
|
180 # set got_ack -1 |
|
181 # fileevent $sock readable "ack_arrived $sock" |
|
182 # set ack_timer [after 5000 ack_timeout] |
|
183 # vwait got_ack |
|
184 |
|
185 # if {$got_ack} { |
|
186 # puts "[time] :: file actually sent $file" |
|
187 # puts $logfd "[time] :: file actually sent [file tail $file] " |
|
188 # flush $logfd |
|
189 # |
|
190 # return 1 |
|
191 # } else { |
|
192 # puts "[time] :: file sent but not acked" |
|
193 # close $sock |
|
194 # unset sock |
|
195 # return -1 |
|
196 |
|
197 } |
|
198 } |
|
199 |
|
200 proc recv_files {dest_dir} { |
|
201 global port |
|
202 global conns |
|
203 puts "[time] waiting for files: $dest_dir" |
|
204 set conns(main) [socket -server "new_client $dest_dir" $port] |
|
205 } |
|
206 |
|
207 |
|
208 proc new_client {dest_dir sock addr port} { |
|
209 global conns |
|
210 |
|
211 puts "[time] Accept $sock from $addr port $port" |
|
212 |
|
213 # Used for debugging |
|
214 set conns(addr,$sock) [list $addr $port] |
|
215 |
|
216 fconfigure $sock -translation binary |
|
217 fconfigure $sock -encoding binary |
|
218 fconfigure $sock -blocking 0 |
|
219 |
|
220 fileevent $sock readable "header_arrived $dest_dir $sock" |
|
221 } |
|
222 |
|
223 proc header_arrived {dest_dir sock} { |
|
224 global length_remaining |
|
225 global conns |
|
226 global partial |
|
227 |
|
228 puts "[time] header arrived" |
|
229 |
|
230 if {[eof $sock]} { |
|
231 puts "[time] Close $conns(addr,$sock) EOF received header.. " |
|
232 close $sock |
|
233 unset conns(addr,$sock) |
|
234 return |
|
235 } |
|
236 |
|
237 # try to read a line |
|
238 set L [gets $sock] |
|
239 while {$L == ""} { |
|
240 puts "[time] partial header line received... waiting for more" |
|
241 after 20 |
|
242 set L [gets $sock] |
|
243 } |
|
244 |
|
245 if {[info exists partial($sock)]} { |
|
246 puts "[time] merging partial line '$partial($sock)' with '$L'" |
|
247 set L "$partial($sock)$L" |
|
248 unset partial($sock) |
|
249 } |
|
250 |
|
251 foreach {filename length} $L {} |
|
252 |
|
253 puts "[time] getting file $filename length $length" |
|
254 |
|
255 # puts $sock "ACK" |
|
256 # flush $sock |
|
257 |
|
258 set to_fd [open "$dest_dir/$filename" w] |
|
259 set length_remaining($sock) $length |
|
260 |
|
261 fileevent $sock readable "file_arrived $filename $to_fd $dest_dir $sock" |
|
262 } |
|
263 |
|
264 |
|
265 proc file_arrived {file to_fd dest_dir sock} { |
|
266 |
|
267 global logfd |
|
268 global conns |
|
269 global length_remaining |
|
270 |
|
271 if {[eof $sock]} { |
|
272 puts "[time] Close $conns(addr,$sock) EOF received file" |
|
273 close $sock |
|
274 unset conns(addr,$sock) |
|
275 return |
|
276 } |
|
277 |
|
278 |
|
279 set payload [read $sock $length_remaining($sock)] |
|
280 puts -nonewline $to_fd $payload |
|
281 set got [string length $payload] |
|
282 set todo [expr $length_remaining($sock) - $got] |
|
283 puts "got $got byte chunk ($todo to go)" |
|
284 |
|
285 if {$todo < 0} { |
|
286 error "negative todo" |
|
287 } |
|
288 |
|
289 if {$todo == 0} { |
|
290 # puts $sock "ACK" |
|
291 # flush $sock |
|
292 # puts "[time] sending ack for file $file" |
|
293 |
|
294 fileevent $sock readable "header_arrived $dest_dir $sock" |
|
295 puts $logfd "[time] :: got file [file tail $file] at [timef]" |
|
296 close $to_fd |
|
297 flush $logfd |
|
298 |
|
299 } |
|
300 |
|
301 set length_remaining($sock) $todo |
|
302 } |
|
303 |
|
304 |
|
305 # Define a bgerror proc to print the error stack when errors occur in |
|
306 # event handlers |
|
307 proc bgerror {err} { |
|
308 global errorInfo |
|
309 puts "tcl error: $err\n$errorInfo" |
|
310 } |
|
311 |
|
312 proc usage {} { |
|
313 puts "usage: simple_ftp server <dir> <logfile>" |
|
314 puts "usage: simple_ftp client <dir> <logfile> <host>" |
|
315 exit -1 |
|
316 } |
|
317 |
|
318 set argc [llength $argv] |
|
319 if {$argc < 3} { |
|
320 usage |
|
321 } |
|
322 |
|
323 |
|
324 set mode [lindex $argv 0] |
|
325 set dir [lindex $argv 1] |
|
326 set logfile [lindex $argv 2] |
|
327 set logfd [open $logfile w] |
|
328 |
|
329 set starttime [clock clicks -milliseconds] |
|
330 puts "Starting in $mode, dir is $dir at [timef]" |
|
331 |
|
332 |
|
333 if {$mode == "server"} { |
|
334 recv_files $dir |
|
335 } elseif {$mode == "client"} { |
|
336 set host [lindex $argv 3] |
|
337 scan_dir $host $dir |
|
338 } else { |
|
339 error "unknown mode $mode" |
|
340 } |
|
341 |
|
342 vwait forever |