source: trunk/gui/scripts/filexfer.tcl @ 95

Last change on this file since 95 was 50, checked in by mmc, 19 years ago

Added support for file transfer with the desktop. Each Rappture
application acts like an http server, configured to listen on
a particular port according to the parameters found in the file
~/data/sessions/$SESSION/resources. When the server is active,
the GUI has a "Download..." button in the results area. A Java
client (in the filexfer directory) connects to the server and
listens for download requests. When the user clicks on "Download...",
the desired result is spooled to a file, and a Java client pops up
a web page requesting the file. This downloads the result to the
user's desktop.

Note that if the $SESSION environment variable is not set, these
changes do nothing.
File size: 28.2 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: filexfer - support for file transfer with user's desktop
3#
4#  This part supports the filexfer Java component that enables Rappture
5#  to transfer files to and from the user's desktop.  It acts as a
6#  web server.  When a Rappture application starts up, the user gets
7#  a Web page that has an embedded VNC applet and the filexfer applet.
8#  The Web page connects back to this server, which acts like a Web
9#  server and delivers up the filexfer applet.  Then, the applet
10#  connects back to the same server and stays in contact with the
11#  Rappture application.  Whenever Rappture needs to deliver a file
12#  to the user, it sends a message to the applet, which pops up a
13#  Web page that connects back to the Rappture application and pulls
14#  down the file.  When the user wants to upload a file, Rappture
15#  again sends a message to the applet, which presents a Web form
16#  and posts the file to the Rappture server.
17# ======================================================================
18#  AUTHOR:  Michael McLennan, Purdue University
19#  Copyright (c) 2004-2005
20#  Purdue Research Foundation, West Lafayette, IN
21# ======================================================================
22package require Itcl
23
24namespace eval Rappture { # forward declaration }
25namespace eval Rappture::filexfer {
26    variable enabled 0                 ;# set to 1 when this is running
27    variable port 9001                 ;# start server on this port
28    variable cookie ""                 ;# magic cookie for applet auth
29    variable restrictClientAddress ""  ;# allow clients only from this addr
30    variable clients                   ;# maps client socket => status
31    variable buffer                    ;# request buffer for each client
32    variable access                    ;# maps spooled file => access cookie
33
34    # used to generate cookies -- see bakeCookie for details
35    variable cookieChars {
36        a b c d e f g h i j k l m n o p q r s t u v w x y z
37        A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
38        0 1 2 3 4 5 6 7 8 9
39    }
40
41    #
42    # Translates mime type => file extension
43    #        and file extension => mime type
44    #
45    # Used primarily for spooling data files.
46    #
47    variable mime2ext
48    variable ext2mime
49    variable mime2type
50
51    foreach {mtype ext type} {
52        text/plain                .txt    ascii
53        text/html                 .html   ascii
54        image/gif                 .gif    binary
55        image/jpeg                .jpeg   binary
56        application/postscript    .ps     ascii
57        application/pdf           .pdf    binary
58        application/octet-stream  .jar    binary
59        application/octet-stream  .class  binary
60    } {
61        set mime2ext($mtype) $ext
62        set ext2mime($ext) $mtype
63        set mime2type($mtype) $type
64    }
65
66    #
67    # Set up a safe interpreter for loading filexfer options...
68    #
69    variable optionParser [interp create -safe]
70    foreach cmd [$optionParser eval {info commands}] {
71        $optionParser hide $cmd
72    }
73    # this lets us ignore unrecognized commands in the file:
74    $optionParser invokehidden proc unknown {args} {}
75
76    $optionParser alias filexfer_port Rappture::filexfer::option_port
77    $optionParser alias filexfer_cookie Rappture::filexfer::option_cookie
78}
79
80# ----------------------------------------------------------------------
81# USAGE: Rappture::filexfer::init
82#
83# Called in the main application to start listening to a particular
84# port and start acting like a filexfer server.  Returns 1 if the
85# server was enabled, and 0 otherwise.
86# ----------------------------------------------------------------------
87proc Rappture::filexfer::init {} {
88    global env
89    variable optionParser
90    variable enabled
91    variable port
92    variable clients
93
94    # keep a list of most recently activated clients
95    set clients(order) ""
96
97    #
98    # Look for a $SESSION variable and a file called
99    # ~/data/sessions/$SESSION/resources.  If found, then
100    # load the settings from that file and start a server
101    # for filexfer.
102    #
103    if {[info exists env(SESSION)]} {
104        set file ~/data/sessions/$env(SESSION)/resources
105        if {![file exists $file]} {
106            return 0
107        }
108        if {[catch {
109            set fid [open $file r]
110            set info [read $fid]
111            close $fid
112            $optionParser eval $info
113        } result]} {
114            after 1 [list tk_messageBox -title Error -icon error -message "Error in resources file:\n$reslt"]
115            return 0
116        }
117
118        #
119        # If the prescribed port is busy, then exit with a special
120        # status code so the middleware knows to try again with another
121        # port.
122        #
123        # OH NO! THE DREADED ERROR CODE 9!
124        #
125        if {[catch {socket -server Rappture::filexfer::accept $port}]} {
126            exit 9
127        }
128        set enabled 1
129    }
130    return $enabled
131}
132
133# ----------------------------------------------------------------------
134# USAGE: Rappture::filexfer::enabled
135#
136# Clients use this to see if the filexfer stuff is up and running.
137# If so, then the GUI will provide "Download..." and other filexfer
138# options.  If not, then Rappture must be running within an
139# environment that doesn't support it.
140# ----------------------------------------------------------------------
141proc Rappture::filexfer::enabled {} {
142    variable enabled
143    return $enabled
144}
145
146# ----------------------------------------------------------------------
147# USAGE: Rappture::filexfer::spool <string> ?<filename>?
148#
149# Clients use this to send a file off to the user.  The <string>
150# is stored in a file called <filename> in the user's spool directory.
151# If there is already a file by that name, then the name is modified
152# to make it unique.  Once the string has been stored in the file,
153# a message is sent to all clients listening, letting them know
154# that the file is available.
155# ----------------------------------------------------------------------
156proc Rappture::filexfer::spool {string {filename "output.txt"}} {
157    global env
158    variable enabled
159    variable clients
160    variable access
161
162    if {$enabled} {
163        set dir ~/data/sessions/$env(SESSION)
164        if {[file exists [file join $dir $filename]]} {
165            #
166            # Find a similar file name that doesn't conflict
167            # with an existing file:  e.g., output2.txt
168            #
169            set root [file rootname $filename]
170            set ext [file extension $filename]
171            set counter 2
172            while {1} {
173                set filename "$root$counter$ext"
174                if {![file exists [file join $dir $filename]]} {
175                    break
176                }
177                incr counter
178            }
179        }
180
181        set fid [open [file join $dir $filename] w]
182        puts $fid $string
183        close $fid
184
185        set cid [lindex $clients(order) 0]
186        if {$cid == ""} {
187            error "no clients"
188        }
189
190        set access($filename) [bakeCookie]
191        puts $cid "url /spool/$env(SESSION)/$filename?access=$access($filename)"
192    }
193}
194
195# ----------------------------------------------------------------------
196# USAGE: Rappture::filexfer::accept <clientId> <address> <port>
197#
198# Invoked automatically whenever a client tries to connect to this
199# server.  Validates the client's incoming <address> and sets up
200# callbacks to handle further communication.
201# ----------------------------------------------------------------------
202proc Rappture::filexfer::accept {cid addr port} {
203    variable restrictClientAddress
204
205    #
206    # If the client comes from anywhere but the restricted host,
207    # then deny the connection.  We should be getting connections
208    # only from within the firewall around our own system.
209    #
210    if {"" != $restrictClientAddress
211          && ![string equal $addr $restrictClientAddress]} {
212        close $cid
213    } else {
214        fileevent $cid readable [list Rappture::filexfer::handler $cid]
215        #
216        # Use auto cr/lf translation for input, but always use
217        # binary mode for output.  Otherwise, we'll put out a
218        # particular byte count for the body of a response, and
219        # it will be wrong after Tcl transforms cr/lf.  Also, some
220        # of our data is binary, and it has to be left alone.
221        #
222        fconfigure $cid -buffering line -translation {auto binary}
223    }
224}
225
226# ----------------------------------------------------------------------
227# USAGE: Rappture::filexfer::handler <clientId>
228#
229# Invoked automatically whenever a message comes in from a client
230# to handle the message.
231# ----------------------------------------------------------------------
232proc Rappture::filexfer::handler {cid} {
233    variable buffer
234
235    if {[gets $cid line] < 0} {
236        # eof from client -- clean up
237        cleanup $cid
238    } else {
239        #
240        # Is the first line of the request?  Then make sure
241        # that it's properly formed.
242        #
243        if {![info exists buffer($cid)]
244               && [regexp {^ *[A-Z]+ +[^ ]+ +HTTP/1\.[01]$} $line]} {
245            set buffer($cid) $line
246            return   ;# wait for more lines to dribble in...
247        } elseif {[info exists buffer($cid)]} {
248            set line [string trim $line]
249            if {"" != $line} {
250                append buffer($cid) "\n" $line
251                return
252            }
253            # blank line -- process below...
254        } elseif {[regexp { +RAPPTURE$} $line]} {
255            set buffer($cid) $line
256            # special Rappture request -- process below...
257        } else {
258            response $cid error -message "Your browser sent a request that this server could not understand.<P>Malformed request: $line"
259            cleanup $cid
260            return
261        }
262
263        #
264        # If a buffer already exists, then we're adding on
265        # to it.  Look for optional header information.  Don't
266        # parse it now--just add it to the buffer.  When we see
267        # a blank line, we process the request all at once.
268        #
269        set errmsg ""
270        set lines [split $buffer($cid) \n]
271        unset buffer($cid)
272        set headers(Connection) close
273
274        # extract the TYPE and URL from the request line
275        set line [lindex $lines 0]
276        set lines [lrange $lines 1 end]
277        if {![regexp {^ *([A-Z]+) +([^ ]+) +(HTTP/1\.[01])$} $line \
278              match type url protocol]
279            && ![regexp { +(RAPPTURE)$} $line match protocol]} {
280            set errmsg "Malformed request: $line"
281        }
282
283        if {[string match HTTP/* $protocol]} {
284            #
285            # HANDLE HTTP/1.x REQUESTS...
286            #
287            while {"" == $errmsg && [llength $lines] > 0} {
288                # extract the "Header: value" lines
289                set line [lindex $lines 0]
290                set lines [lrange $lines 1 end]
291
292                if {[regexp {^ *([-a-zA-Z0-9_]+): *(.*)} $line \
293                      match key val]} {
294                    set headers($key) $val
295                } else {
296                    set errmsg [format "Request header field is missing colon separator.<P>\n<PRE>\n%s</PRE>" $line]
297                }
298            }
299
300            if {"" != $errmsg} {
301                # errors in the header
302                response $cid header -status "400 Bad Request" \
303                    -connection $headers(Connection)
304                response $cid error -message "Your browser sent a request that this server could not understand.<P>$errmsg"
305            } else {
306                # process the request...
307                switch -- $type {
308                    GET {
309                        request_GET $cid $url headers
310                    }
311                    default {
312                        response $cid header \
313                            -status "400 Bad Request" \
314                            -connection $headers(Connection)
315                        response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
316                    }
317                }
318            }
319            if {$headers(Connection) == "close"} {
320                cleanup $cid
321            }
322        } elseif {$protocol == "RAPPTURE"} {
323            #
324            # HANDLE SPECIAL RAPPTURE REQUESTS...
325            #
326            if {[regexp {^ *(REGISTER) +([^ ]+) +([^ ]+) +([^ ]+) +RAPPTURE$} \
327                  $line match type user addr cookie]} {
328                request_REGISTER $cid $user $addr $cookie
329            } elseif {[regexp {^ *UNREGISTER +RAPPTURE$} $line]} {
330                request_UNREGISTER $cid
331            } elseif {[regexp {^ *ACTIVATE +RAPPTURE$} $line]} {
332                request_ACTIVATE $cid
333            } elseif {[regexp {^ *DEACTIVATE +RAPPTURE$} $line]} {
334                request_DEACTIVATE $cid
335            } else {
336                response $cid header \
337                    -status "400 Bad Request" \
338                    -connection $headers(Connection)
339                response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
340            }
341        }
342    }
343}
344
345# ----------------------------------------------------------------------
346# USAGE: Rappture::filexfer::request_GET <clientId> <url> <headerVar>
347#
348# Used internally to handle GET requests on this server.  Looks for
349# the requested <url> and sends it back to <clientId> according to
350# the headers in the <headerVar> array in the calling scope.
351# ----------------------------------------------------------------------
352proc Rappture::filexfer::request_GET {cid url headerVar} {
353    global env
354    variable access
355    upvar $headerVar headers
356
357    #
358    # Look for any ?foo=1&bar=2 data embedded in the URL...
359    #
360    if {[regexp -indices {\?[a-zA-Z0-9_]+\=} $url match]} {
361        foreach {s0 s1} $match break
362        set args [string range $url [expr {$s0+1}] end]
363        set url [string range $url 0 [expr {$s0-1}]]
364
365        foreach part [split $args &] {
366            if {[llength [split $part =]] == 2} {
367                foreach {key val} [split $part =] break
368                set post($key) $val
369            }
370        }
371    }
372
373    #
374    # Interpret the URL and fulfill the request...
375    #
376    if {$url == "/debug" && [info exists env(FILEXFER_DEBUG)]} {
377        variable port
378        variable cookie
379        #
380        # DEBUG MODE:  Put out a web page containing the applet
381        #   and parameters needed to drive this.  Allow only
382        #   if the FILEXFER_DEBUG environment variable is set.
383        #
384        response $cid header \
385            -status "200 OK" \
386            -connection $headers(Connection)
387        set s [clock seconds]
388        set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
389        puts $cid "Last-Modified: $date"
390
391        set user "???"
392        foreach var {USER USERNAME LOGNAME} {
393            if {[info exists env($var)]} {
394                set user $env($var)
395                break
396            }
397        }
398
399        response $cid body -type text/html -string [format {<html>
400<head><title>Rappture::filexfer Debug Page</title></head>
401<body BGCOLOR=White>
402This page contains the same Java applet that the nanoHUB includes
403on each Rappture tool page.  The applet connects back to the
404Rappture application and listens for file transfer requests
405coming from the user.
406<p>
407<applet CODE="filexfer.class" ARCHIVE="filexfer.jar" width=300 height=200>
408<param name="port" value="%s">
409<param name="user" value="%s">
410<param name="cookie" value="%s">
411</applet>
412</body>
413</html>
414} $port $user $cookie]
415    } elseif {[regexp {^/?spool\/(.+)$} $url match tail]} {
416        #
417        # Send back a spooled file...
418        #
419        set file [file join ~/data/sessions $tail]
420        set fname [file tail $file]
421
422        if {![info exists access($fname)]} {
423            response $cid header -status "404 Not Found"
424            response $cid error -status "404 Not Found" -message "The requested file <b>$fname</b> is missing.  It may have already been downloaded to your desktop.  You cannot refresh it from the same URL, for security reasons.<p>Instead, download the file again by going back to the original application."
425        } elseif {![info exists post(access)]
426              || ![string equal $post(access) $access($fname)]} {
427            response $cid header -status "401 Unauthorized"
428            response $cid error -status "401 Unauthorized" -message "You do not have the proper credentials to access file $fname."
429        } else {
430            response $cid file -path $file -connection $headers(Connection)
431            file delete -force $file
432            unset access($fname)
433        }
434    } elseif {[regexp {^/?[a-zA-Z0-9_]+\.[a-zA-Z]+$} $url match]} {
435        #
436        # Send back an applet file...
437        #
438        set url [string trimleft $url /]
439        set file [file join $Rappture::installdir filexfer $url]
440        response $cid file -path $file -connection $headers(Connection)
441    } else {
442        #
443        # BAD FILE REQUEST:
444        #   The user is trying to ask for a file outside of
445        #   the normal filexfer installation.  Treat it the
446        #   same as file not found.
447        response $cid header \
448            -status "404 Not Found" \
449            -connection $headers(Connection)
450        response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server."
451    }
452}
453
454# ----------------------------------------------------------------------
455# USAGE: request_REGISTER <clientId> <user> <address> <cookie>
456#
457# Used internally to handle REGISTER requests on this server.  A client
458# sends REGISTER requests when it wants to be notified of file transfer
459# operations.  The <cookie> must match the one for this server, so
460# we know we can trust the client.
461# ----------------------------------------------------------------------
462proc Rappture::filexfer::request_REGISTER {cid user addr clientCookie} {
463    variable clients
464    variable cookie
465
466    if {![string equal $cookie $clientCookie]} {
467        response $cid header -status "401 Unauthorized"
468        response $cid error -status "401 Unauthorized" -message "Credentials are not recognized."
469    } else {
470        # add this client to the known listeners
471        set clients($cid) 0
472    }
473}
474
475# ----------------------------------------------------------------------
476# USAGE: request_UNREGISTER <clientId>
477#
478# Used internally to handle UNREGISTER requests on this server.
479# A client sends this request when it is being destroyed, to let
480# the server know that it no longer needs to handle this client.
481# ----------------------------------------------------------------------
482proc Rappture::filexfer::request_UNREGISTER {cid} {
483    variable clients
484
485    set i [lsearch -exact $cid $clients(order)]
486    if {$i >= 0} {
487        set clients(order) [lreplace $clients(order) $i $i]
488    }
489    catch {unset clients($cid)}
490}
491
492# ----------------------------------------------------------------------
493# USAGE: request_ACTIVATE <clientId>
494#
495# Used internally to handle ACTIVATE requests on this server.  A client
496# must first REGISTER with its cookie for authorization.  Then, as
497# its thread starts, it sends an ACTIVATE request, letting us know
498# that the client is ready to receive notifications.
499# ----------------------------------------------------------------------
500proc Rappture::filexfer::request_ACTIVATE {cid} {
501    variable clients
502
503    #
504    # Activate only if the client has already registered
505    # properly and is on our known list.
506    #
507    if {[info exists clients($cid)]} {
508        set clients($cid) 1
509
510        # move the most recently activated connection to the front
511        set i [lsearch -exact $cid $clients(order)]
512        if {$i >= 0} {
513            set clients(order) [lreplace $clients(order) $i $i]
514        }
515        set clients(order) [linsert $clients(order) 0 $cid]
516    }
517}
518
519# ----------------------------------------------------------------------
520# USAGE: request_DEACTIVATE <clientId>
521#
522# Used internally to handle DEACTIVATE requests on this server.  A client
523# must first REGISTER with its cookie for authorization.  Then, as
524# its thread starts, it sends an ACTIVATE request.  When its thread
525# stops (because the applet is swapped out of the web page), the
526# client sends a DEACTIVATE request, and we stop sending messages to
527# that client.
528# ----------------------------------------------------------------------
529proc Rappture::filexfer::request_DEACTIVATE {cid} {
530    variable clients
531
532    #
533    # Deactivate only if the client has already registered
534    # properly and is on our known list.
535    #
536    if {[info exists clients($cid)]} {
537        set clients($cid) 0
538
539        # remove this from the list of activated connections
540        set i [lsearch -exact $cid $clients(order)]
541        if {$i >= 0} {
542            set clients(order) [lreplace $clients(order) $i $i]
543        }
544    }
545}
546
547# ----------------------------------------------------------------------
548# USAGE: Rappture::filexfer::cleanup <clientId>
549#
550# Used internally to close and clean up a client connection.
551# Clears any data associated with the client.
552# ----------------------------------------------------------------------
553proc Rappture::filexfer::cleanup {cid} {
554    variable clients
555    variable buffer
556
557    catch {close $cid}
558
559    if {[info exists clients($cid)]} {
560        unset clients($cid)
561    }
562    set i [lsearch -exact $clients(order) $cid]
563    if {$i >= 0} {
564        set clients(order) [lreplace $clients(order) $i $i]
565    }
566
567    if {[info exists buffer($cid)] && "" != $buffer($cid)} {
568        unset buffer($cid)
569    }
570}
571
572# ----------------------------------------------------------------------
573# USAGE: response <channel> header -status <s> -connection <c>
574# USAGE: response <channel> body -string <s> -type <t>
575# USAGE: response <channel> error -message <m>
576# USAGE: response <channel> file -path <f>
577#
578# Used internally to generate responses to the client.  Returns a
579# string representing the requested response.
580# ----------------------------------------------------------------------
581proc Rappture::filexfer::response {cid what args} {
582    variable mime2ext
583    variable ext2mime
584    variable mime2type
585
586    switch -- $what {
587        header {
588            Rappture::getopts args params {
589                value -status ""
590                value -connection close
591            }
592            set s [clock seconds]
593            set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
594            puts $cid [format "HTTP/1.1 %s
595Date: %s
596Server: Rappture
597Connection: %s" $params(-status) $date $params(-connection)]
598        }
599
600        body {
601            Rappture::getopts args params {
602                value -string ""
603                value -type "auto"
604            }
605            if {$params(-type) == "auto"} {
606                if {[isbinary $params(-string)]} {
607                    set params(-type) "application/octet-stream"
608                } else {
609                    set params(-type) "text/plain"
610                }
611            }
612            puts $cid [format "Content-type: %s\nContent-length: %d\n" \
613                $params(-type) [string length $params(-string)]]
614
615            if {$mime2type($params(-type)) == "binary"} {
616                # binary data -- send data as raw bytes
617                set olde [fconfigure $cid -encoding]
618                fconfigure $cid -buffering none -encoding binary
619                puts -nonewline $cid $params(-string)
620                flush $cid
621                fconfigure $cid -buffering line -encoding $olde
622            } else {
623                # ascii data -- send normally
624                puts $cid $params(-string)
625            }
626        }
627
628        error {
629            Rappture::getopts args params {
630                value -status "400 Bad Request"
631                value -message ""
632            }
633            set heading [lrange $params(-status) 1 end]
634            set html [format "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
635<HTML><HEAD>
636<TITLE>%s</TITLE>
637</HEAD><BODY>
638<H1>%s</H1>
639%s
640</BODY></HTML>" $params(-status) $heading $params(-message)]
641            response $cid body -type text/html -string $html
642        }
643
644        file {
645            Rappture::getopts args params {
646                value -path ""
647                value -connection close
648            }
649            if {![file exists $params(-path)]} {
650                #
651                # FILE NOT FOUND:
652                #   The user is requesting some file that is not part of
653                #   the standard filexfer installation.
654                #
655                response $cid header \
656                    -status "404 Not Found" \
657                    -connection $params(-connection)
658
659                response $cid error -status "404 Not Found" -message "The requested file $params(-path) was not found on this server."
660            } elseif {[catch {
661                    set fid [open $params(-path) r]
662                    set data [read $fid]
663                    close $fid
664                } result]} {
665
666                response $cid error -status "500 Internal Server Error" -message "The requested file $params(-path) is not installed properly on this server."
667                response $cid header \
668                    -status "500 Internal Server Error" \
669                    -connection $params(-connection)
670            } else {
671                #
672                # READ AND RETURN THE FILE
673                #
674                set ext [file extension $params(-path)]
675                if {[info exists ext2mime($ext)]} {
676                    set mtype $ext2mime($ext)
677                } else {
678                    if {[isbinary $data]} {
679                        set mtype application/octet-stream
680                    } else {
681                        set mtype text/plain
682                    }
683                }
684
685                if {$mime2type($mtype) == "binary"} {
686                    # if this is binary data, read it again and get pure bytes
687                    catch {
688                        set fid [open $params(-path) r]
689                        fconfigure $fid -translation binary -encoding binary
690                        set data [read $fid]
691                        close $fid
692                    } result
693                }
694                response $cid header \
695                    -status "200 OK" \
696                    -connection $params(-connection)
697                set s [file mtime $params(-path)]
698                set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
699                puts $cid "Last-Modified: $date"
700
701                response $cid body -type $mtype -string $data
702            }
703        }
704    }
705}
706
707# ----------------------------------------------------------------------
708# USAGE: isbinary <string>
709#
710# Used internally to see if the given <string> has binary data.
711# If so, then it must be treated differently.  Normal translation
712# of carriage returns and line feeds must be suppressed.
713# ----------------------------------------------------------------------
714proc Rappture::filexfer::isbinary {string} {
715    # look for binary characters, but avoid things like \t \n etc.
716    return [regexp {[\000-\006\016-\037\177-\400]} $string]
717}
718
719# ----------------------------------------------------------------------
720# USAGE: bakeCookie
721#
722# Used internally to create a one-time use cookie, passed to clients
723# to secure file transfer.  Only clients should know the cookie, so
724# only clients will have access to files.
725# ----------------------------------------------------------------------
726proc Rappture::filexfer::bakeCookie {} {
727    variable cookieChars
728
729    set cmax [expr {[llength $cookieChars]-1}]
730    set cookie ""
731    while {[string length $cookie] < 40} {
732        set rindex [expr {round(rand()*$cmax)}]
733        append cookie [lindex $cookieChars $rindex]
734    }
735    return $cookie
736}
737
738# ----------------------------------------------------------------------
739# USAGE: Rappture::filexfer::option_port <port>
740#
741# Called when the "filexfer_port" directive is encountered while
742# parsing the "resources" file.  Assigns the port that the filexfer
743# server should be listening to.
744# ----------------------------------------------------------------------
745proc Rappture::filexfer::option_port {newport} {
746    variable port
747    set port $newport
748}
749
750# ----------------------------------------------------------------------
751# USAGE: Rappture::filexfer::option_cookie <cookie>
752#
753# Called when the "filexfer_cookie" directive is encountered while
754# parsing the "resources" file.  Assigns the port that the filexfer
755# server should be listening to.
756# ----------------------------------------------------------------------
757proc Rappture::filexfer::option_cookie {newcookie} {
758    variable cookie
759    set cookie $newcookie
760}
Note: See TracBrowser for help on using the repository browser.