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

Last change on this file since 413 was 413, checked in by mmc, 18 years ago
  • Added <description> capability to output objects, including axes.
  • Fixed the ResultSet? so that it is more compact and supports the simulation number as a parameter. This is useful when there are datasets with wildly varying parameters.
File size: 40.1 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  Purdue Research Foundation
20#
21#  See the file "license.terms" for information on usage and
22#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
23# ======================================================================
24package require Itcl
25
26namespace eval Rappture { # forward declaration }
27namespace eval Rappture::filexfer {
28    variable enabled 0                 ;# set to 1 when this is running
29    variable port 0                    ;# start server on this port
30    variable cookie ""                 ;# magic cookie for applet auth
31    variable restrictClientAddress ""  ;# allow clients only from this addr
32    variable clients                   ;# maps client socket => status
33    variable buffer                    ;# request buffer for each client
34    variable access                    ;# maps spooled file => access cookie
35    variable uploadcmds                ;# callbacks for upload forms
36
37    variable sitelogo ""               ;# HTML for site logo in upload form
38    variable stylesheet ""             ;# URL for stylesheet address
39
40    # used to generate cookies -- see bakeCookie for details
41    variable cookieChars {
42        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
43        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
44        0 1 2 3 4 5 6 7 8 9
45    }
46
47    # maps client socket => socket protocol
48    # if it doesn't match, we warn user to restart the browser
49    variable protocol
50    set protocol(current) "1.0"
51
52    #
53    # Translates mime type => file extension
54    #        and file extension => mime type
55    #
56    # Used primarily for spooling data files.
57    #
58    variable mime2ext
59    variable ext2mime
60    variable mime2type
61
62    foreach {mtype ext type} {
63        text/plain                .txt    ascii
64        text/html                 .html   ascii
65        image/gif                 .gif    binary
66        image/jpeg                .jpg    binary
67        application/postscript    .ps     ascii
68        application/pdf           .pdf    binary
69        application/octet-stream  .jar    binary
70        application/octet-stream  .class  binary
71    } {
72        set mime2ext($mtype) $ext
73        set ext2mime($ext) $mtype
74        set mime2type($mtype) $type
75    }
76
77}
78
79# must use this name -- plugs into Rappture::resources::load
80proc filexfer_init_resources {} {
81    Rappture::resources::register \
82        filexfer_port Rappture::filexfer::option_port \
83        filexfer_cookie Rappture::filexfer::option_cookie \
84        filexfer_sitelogo Rappture::filexfer::option_sitelogo \
85        filexfer_stylesheet Rappture::filexfer::option_stylesheet
86}
87
88# ----------------------------------------------------------------------
89# USAGE: Rappture::filexfer::init
90#
91# Called in the main application to start listening to a particular
92# port and start acting like a filexfer server.  Returns 1 if the
93# server was enabled, and 0 otherwise.
94# ----------------------------------------------------------------------
95proc Rappture::filexfer::init {} {
96    variable enabled
97    variable port
98    variable clients
99
100    # keep a list of most recently activated clients
101    set clients(order) ""
102
103    #
104    # The port setting should have been set properly in the
105    # "resources" file loaded at the beginning of the app.
106    # If it wasn't, then don't do any filexfer.
107    #
108    if {$port > 0} {
109        #
110        # If the prescribed port is busy, then exit with a special
111        # status code so the middleware knows to try again with another
112        # port.
113        #
114        # OH NO! THE DREADED ERROR CODE 9!
115        #
116        if {[catch {socket -server Rappture::filexfer::accept $port}]} {
117            exit 9
118        }
119        set enabled 1
120
121        #
122        # Clean up all spooled files when this program shuts down.
123        # If we're running on nanoHUB, we'll get a SIGHUP signal
124        # when it's time to quit.  On the desktop, we'll get a
125        # <Destroy> event on the main window.
126        #
127        Rappture::signal SIGHUP filexfer Rappture::filexfer::cleanup
128
129        bind RapptureFilexfer <Destroy> Rappture::filexfer::cleanup
130        set btags [bindtags .]
131        set i [lsearch $btags RapptureFilexfer]
132        if {$i < 0} {
133            set btags [linsert $btags 0 RapptureFilexfer]
134            bindtags . $btags
135        }
136    }
137    return $enabled
138}
139
140# ----------------------------------------------------------------------
141# USAGE: Rappture::filexfer::enabled
142#
143# Clients use this to see if the filexfer stuff is up and running.
144# If so, then the GUI will provide "Download..." and other filexfer
145# options.  If not, then Rappture must be running within an
146# environment that doesn't support it.
147# ----------------------------------------------------------------------
148proc Rappture::filexfer::enabled {} {
149    variable enabled
150    return $enabled
151}
152
153# ----------------------------------------------------------------------
154# USAGE: Rappture::filexfer::spool <string> ?<filename>?
155#
156# Clients use this to send a file off to the user.  The <string>
157# is stored in a file called <filename> in the user's spool directory.
158# If there is already a file by that name, then the name is modified
159# to make it unique.  Once the string has been stored in the file,
160# a message is sent to all clients listening, letting them know
161# that the file is available.
162# ----------------------------------------------------------------------
163proc Rappture::filexfer::spool {string {filename "output.txt"}} {
164    global env
165    variable enabled
166    variable clients
167    variable protocol
168    variable access
169
170    if {$enabled} {
171        # make a spool directory, if we don't have one already
172        set dir ~/data/sessions/$env(SESSION)/spool
173        if {![file exists $dir]} {
174            catch {file mkdir $dir}
175        }
176
177        if {[file exists [file join $dir $filename]]} {
178            #
179            # Find a similar file name that doesn't conflict
180            # with an existing file:  e.g., output2.txt
181            #
182            set root [file rootname $filename]
183            set ext [file extension $filename]
184            set counter 2
185            while {1} {
186                set filename "$root$counter$ext"
187                if {![file exists [file join $dir $filename]]} {
188                    break
189                }
190                incr counter
191            }
192        }
193
194        set fid [open [file join $dir $filename] w]
195        fconfigure $fid -encoding binary -translation binary
196        puts -nonewline $fid $string
197        close $fid
198
199        set sent 0
200        set protoproblems 0
201        set access($filename) [bakeCookie]
202        foreach cid $clients(order) {
203            if {[info exists clients($cid)] && $clients($cid)} {
204                if {![string equal $protocol($cid) $protocol(current)]} {
205                    incr protoproblems
206                }
207                catch {
208                    puts $cid [format "url /spool/%s/%s?access=%s" \
209                        $env(SESSION) $filename $access($filename)]
210                }
211                set sent 1
212            }
213        }
214        if {!$sent} {
215            error "no clients"
216        }
217        if {$protoproblems == 1} {
218            error "old client"
219        } elseif {$protoproblems > 1} {
220            error "old clients"
221        }
222    }
223}
224
225# ----------------------------------------------------------------------
226# USAGE: Rappture::filexfer::upload <description> <callback>
227#
228# Clients use this to prompt the user to upload a file.  The string
229# <description> is sent to the user in a web form, and the user is
230# given the opportunity to upload a file.  If successful, the
231# <callback> is invoked to handle the uploaded information.
232# ----------------------------------------------------------------------
233proc Rappture::filexfer::upload {desc callback} {
234    variable enabled
235    variable sitelogo
236    variable stylesheet
237    variable uploadcmds
238
239    if {$enabled} {
240        set file [file join $RapptureGUI::library filexfer upload.html]
241        set fid [open $file r]
242        set html [read $fid]
243        close $fid
244
245        set cookie [bakeCookie]
246        set uploadcmds($cookie) $callback
247
248        set style ""
249        if {"" != $stylesheet} {
250            set style "<link rel=\"stylesheet\" type=\"text/css\" media=\"screen\" href=\"$stylesheet\"/>"
251        }
252
253        set html [string map [list \
254            @COOKIE@ $cookie \
255            @DESCRIPTION@ $desc \
256            @LOGO@ $sitelogo \
257            @STYLESHEET@ $style \
258        ] $html]
259
260        spool $html upload.html
261    }
262}
263
264# ----------------------------------------------------------------------
265# USAGE: Rappture::filexfer::cleanup
266#
267# Called when the application is shutting down to clean up
268# port and start acting like a filexfer server.  Returns 1 if the
269# server was enabled, and 0 otherwise.
270# ----------------------------------------------------------------------
271proc Rappture::filexfer::cleanup {} {
272    global env
273    set spool [file join ~/data/sessions $env(SESSION) spool]
274    file delete -force $spool
275}
276
277# ----------------------------------------------------------------------
278# USAGE: Rappture::filexfer::accept <clientId> <address> <port>
279#
280# Invoked automatically whenever a client tries to connect to this
281# server.  Validates the client's incoming <address> and sets up
282# callbacks to handle further communication.
283# ----------------------------------------------------------------------
284proc Rappture::filexfer::accept {cid addr port} {
285    variable restrictClientAddress
286
287    #
288    # If the client comes from anywhere but the restricted host,
289    # then deny the connection.  We should be getting connections
290    # only from within the firewall around our own system.
291    #
292    if {"" != $restrictClientAddress
293          && ![string equal $addr $restrictClientAddress]} {
294        close $cid
295    } else {
296        fileevent $cid readable [list Rappture::filexfer::handler $cid]
297        #
298        # Use binary mode for both input and output, so the
299        # byte counts (as in Content-Length:) are correct.
300        #
301        fconfigure $cid -buffering line -translation binary
302    }
303}
304
305# ----------------------------------------------------------------------
306# USAGE: Rappture::filexfer::handler <clientId>
307#
308# Invoked automatically whenever a message comes in from a client
309# to handle the message.
310# ----------------------------------------------------------------------
311proc Rappture::filexfer::handler {cid} {
312    variable buffer
313
314    if {[gets $cid line] < 0} {
315        # eof from client -- clean up
316        shutdown $cid
317    } else {
318        # clip out trailing carriage returns
319        regsub -all {\r$} $line "" line
320
321        #
322        # Is the first line of the request?  Then make sure
323        # that it's properly formed.
324        #
325        if {![info exists buffer($cid)]
326               && [regexp {^ *[A-Z]+ +[^ ]+ +HTTP/1\.[01]$} $line]} {
327            set buffer($cid) $line
328            return   ;# wait for more lines to dribble in...
329        } elseif {[info exists buffer($cid)]} {
330            set line [string trim $line]
331            if {"" == $line} {
332                regexp {^ *([A-Z]+) +} $buffer($cid) match type
333                if {$type == "POST"} {
334                    if {[regexp {Content-Length: *([0-9]+)} $buffer($cid) match len]} {
335                        set buffer($cid-post) [read $cid $len]
336                    }
337                    # finished post... process below...
338                } else {
339                    # finished get or other op... process below...
340                }
341            } else {
342                append buffer($cid) "\n" $line
343                return
344            }
345            # blank line -- process below...
346        } elseif {[regexp { +RAPPTURE(/[0-9\.]+)?$} $line]} {
347            set buffer($cid) $line
348            # special Rappture request -- process below...
349        } else {
350            response $cid error -message "Your browser sent a request that this server could not understand.<P>Malformed request: $line"
351            shutdown $cid
352            return
353        }
354
355        #
356        # We've seen a blank line at the end of a request.
357        # Time to process it...
358        #
359        set errmsg ""
360        set lines [split $buffer($cid) \n]
361        unset buffer($cid)
362        set headers(Connection) close
363
364        # extract the TYPE and URL from the request line
365        set line [lindex $lines 0]
366        set lines [lrange $lines 1 end]
367        if {![regexp {^ *([A-Z]+) +([^ ]+) +(HTTP/1\.[01])$} $line \
368              match type url proto]
369            && ![regexp { +(RAPPTURE(/[0-9\.]+)?)$} $line match proto]} {
370            set errmsg "Malformed request: $line"
371        }
372
373        if {[string match HTTP/* $proto]} {
374            #
375            # HANDLE HTTP/1.x REQUESTS...
376            #
377            while {"" == $errmsg && [llength $lines] > 0} {
378                # extract the "Header: value" lines
379                set line [lindex $lines 0]
380                set lines [lrange $lines 1 end]
381
382                if {[regexp {^ *([-a-zA-Z0-9_]+): *(.*)} $line \
383                      match key val]} {
384                    set headers($key) $val
385                } else {
386                    set errmsg [format "Request header field is missing colon separator.<P>\n<PRE>\n%s</PRE>" $line]
387                }
388            }
389
390            if {"" != $errmsg} {
391                # errors in the header
392                response $cid header -status "400 Bad Request" \
393                    -connection $headers(Connection)
394                response $cid error -message "Your browser sent a request that this server could not understand.<P>$errmsg"
395            } else {
396                # process the request...
397                switch -- $type {
398                    GET {
399                        request_GET $cid $url headers
400                    }
401                    POST {
402                        set postdata ""
403                        if {[info exists buffer($cid-post)]} {
404                            set postdata $buffer($cid-post)
405                            unset buffer($cid-post)
406                        }
407                        request_POST $cid $url headers $postdata
408                    }
409                    default {
410                        response $cid header \
411                            -status "400 Bad Request" \
412                            -connection $headers(Connection)
413                        response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
414                    }
415                }
416            }
417            if {$headers(Connection) == "close"} {
418                shutdown $cid
419            }
420        } elseif {[string match RAPPTURE* $proto]} {
421            #
422            # HANDLE SPECIAL RAPPTURE REQUESTS...
423            #
424            set vers "0.0"
425            if {[regexp {^ *(REGISTER) +([^ ]+) +([^ ]+) +([^ ]+) +RAPPTURE(/[0-9\.]+)?$} \
426                  $line match type user addr cookie vers]} {
427                  set vers [string trimleft $vers /]
428                request_REGISTER $cid $user $addr $cookie $vers
429            } elseif {[regexp {^ *UNREGISTER +RAPPTURE$} $line]} {
430                request_UNREGISTER $cid
431            } elseif {[regexp {^ *ACTIVATE +RAPPTURE$} $line]} {
432                request_ACTIVATE $cid
433            } elseif {[regexp {^ *DEACTIVATE +RAPPTURE$} $line]} {
434                request_DEACTIVATE $cid
435            } else {
436                response $cid header \
437                    -status "400 Bad Request" \
438                    -connection $headers(Connection)
439                response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
440            }
441        }
442    }
443}
444
445# ----------------------------------------------------------------------
446# USAGE: Rappture::filexfer::request_GET <clientId> <url> <headerVar>
447#
448# Used internally to handle GET requests on this server.  Looks for
449# the requested <url> and sends it back to <clientId> according to
450# the headers in the <headerVar> array in the calling scope.
451# ----------------------------------------------------------------------
452proc Rappture::filexfer::request_GET {cid url headerVar} {
453    global env
454    variable access
455    upvar $headerVar headers
456
457    #
458    # Look for any ?foo=1&bar=2 data embedded in the URL...
459    #
460    if {[regexp -indices {\?[a-zA-Z0-9_]+\=} $url match]} {
461        foreach {s0 s1} $match break
462        set args [string range $url [expr {$s0+1}] end]
463        set url [string range $url 0 [expr {$s0-1}]]
464
465        foreach part [split $args &] {
466            if {[llength [split $part =]] == 2} {
467                foreach {key val} [split $part =] break
468                set post($key) [urlDecode $val]
469            }
470        }
471    }
472
473    #
474    # Interpret the URL and fulfill the request...
475    #
476    if {$url == "/debug" && [info exists env(FILEXFER_DEBUG)]} {
477        variable port
478        variable cookie
479        #
480        # DEBUG MODE:  Put out a web page containing the applet
481        #   and parameters needed to drive this.  Allow only
482        #   if the FILEXFER_DEBUG environment variable is set.
483        #
484        response $cid header \
485            -status "200 OK" \
486            -connection $headers(Connection)
487        set s [clock seconds]
488        set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
489        puts $cid "Last-Modified: $date"
490
491        set user "???"
492        foreach var {USER USERNAME LOGNAME} {
493            if {[info exists env($var)]} {
494                set user $env($var)
495                break
496            }
497        }
498
499        response $cid body -type text/html -string [format {<html>
500<head><title>Rappture::filexfer Debug Page</title></head>
501<body BGCOLOR=White>
502This page contains the same Java applet that the nanoHUB includes
503on each Rappture tool page.  The applet connects back to the
504Rappture application and listens for file transfer requests
505coming from the user.
506<p>
507<applet CODE="filexfer.class" ARCHIVE="filexfer.jar" width=300 height=200>
508<param name="port" value="%s">
509<param name="user" value="%s">
510<param name="cookie" value="%s">
511</applet>
512</body>
513</html>
514} $port $user $cookie]
515    } elseif {[regexp {^/?spool\/([^/]+)/(.+)$} $url match session tail]} {
516        #
517        # Send back a spooled file...
518        #
519        set file [file join ~/data/sessions $session spool $tail]
520        set fname [file tail $file]
521
522        if {![info exists access($fname)]} {
523            response $cid header -status "404 Not Found"
524            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."
525        } elseif {![info exists post(access)]
526              || ![string equal $post(access) $access($fname)]} {
527            response $cid header -status "401 Unauthorized"
528            response $cid error -status "401 Unauthorized" -message "You do not have the proper credentials to access file $fname."
529        } else {
530            response $cid file -path $file -connection $headers(Connection)
531        }
532    } elseif {[regexp {^/?[a-zA-Z0-9_]+\.[a-zA-Z]+$} $url match]} {
533        #
534        # Send back an applet file...
535        #
536        set url [string trimleft $url /]
537        set file [file join $RapptureGUI::library filexfer $url]
538        response $cid file -path $file -connection $headers(Connection)
539    } else {
540        #
541        # BAD FILE REQUEST:
542        #   The user is trying to ask for a file outside of
543        #   the normal filexfer installation.  Treat it the
544        #   same as file not found.
545        response $cid header \
546            -status "404 Not Found" \
547            -connection $headers(Connection)
548        response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server."
549    }
550}
551
552# ----------------------------------------------------------------------
553# USAGE: Rappture::filexfer::request_POST <clientId> <url> \
554#          <headerVar> <postdata>
555#
556# Used internally to handle POST requests on this server.  Looks for
557# the requested <url> and sends it back to <clientId> according to
558# the headers in the <headerVar> array in the calling scope.
559# ----------------------------------------------------------------------
560proc Rappture::filexfer::request_POST {cid url headerVar postData} {
561    global env
562    variable access
563    upvar $headerVar headers
564
565    #
566    # Look for any ?foo=1&bar=2 data embedded in the URL...
567    #
568    if {[regexp -indices {\?[a-zA-Z0-9_]+\=} $url match]} {
569        foreach {s0 s1} $match break
570        set args [string range $url [expr {$s0+1}] end]
571        set url [string range $url 0 [expr {$s0-1}]]
572
573        foreach part [split $args &] {
574            if {[llength [split $part =]] == 2} {
575                foreach {key val} [split $part =] break
576                set post($key) [urlDecode $val]
577            }
578        }
579    } elseif {[string length $postData] > 0} {
580        #
581        # If we have explicit POST data, then it is one of two
582        # kinds.  It is either key=value&key=value&... or a
583        # multipart key/value assignment with -------boundary
584        # separators.
585        #
586        set part "single"
587        if {[info exists headers(Content-Type)]} {
588            set data $headers(Content-Type)
589            regsub -all { *; *} $data "\n" data
590            set type [lindex [split $data \n] 0]
591            if {$type == "multipart/form-data"} {
592                set part "multi"
593                foreach assmt [lrange [split $data \n] 1 end] {
594                    foreach {key val} [split $assmt =] break
595                    if {$key == "boundary"} {
596                        set boundary [string trimleft $val -]
597                    }
598                }
599            }
600        }
601
602        switch -- $part {
603            single {
604                # simple key=value&key=value&... case
605                foreach assmt [split $postData &] {
606                    if {[regexp {([^=]+)=(.*)} $assmt match key val]} {
607                        set post($key) [urlDecode $val]
608                    }
609                }
610            }
611            multi {
612                #
613                # Multipart data:
614                #  ----------------------------406765868666254505654602083
615                #  Content-Disposition: form-data; name="key"
616                #
617                #  value
618                #  ----------------------------406765868666254505654602083
619                #  ...
620                #
621                regsub -all {\r\n} $postData "\n" postData
622                set state "starting"
623                foreach line [split $postData \n] {
624                    switch $state {
625                      starting {
626                        if {[regexp "^-+$boundary" $line]} {
627                          catch {unset element}
628                          set state "header"
629                        }
630                      }
631                      header {
632                        if {"" == $line} {
633                          set state "body"
634                        } else {
635                          if {[regexp {Content-Disposition:} $line]} {
636                            regsub -all { *; *} $line "\n" line
637                            foreach assmt [lrange [split $line \n] 1 end] {
638                              foreach {key val} [split $assmt =] break
639                              set element($key) [string trim $val \"]
640                            }
641                          }
642                        }
643                      }
644                      body {
645                        if {[regexp "^-+$boundary" $line]} {
646                          if {[info exists element(name)]} {
647                            set post($element(name)) $element(data)
648                          }
649                          catch {unset element}
650                          set state "header"
651                        } else {
652                          if {[info exists element(data)]} {
653                            append element(data) "\n"
654                          }
655                          append element(data) $line
656                        }
657                      }
658                      default {
659                        error "unknown state $state in post data"
660                      }
661                    }
662                }
663            }
664            default {
665                error "unknown content type"
666            }
667        }
668    }
669
670    #
671    # Interpret the URL and fulfill the request...
672    #
673    if {$url == "/upload"} {
674        variable port
675        variable cookie
676        variable uploadcmds
677
678        if {[info exists post(callback)]
679              && [info exists uploadcmds($post(callback))]} {
680            # get the data -- either text or file
681            set dlist [list which $post(which)]
682            lappend dlist data $post($post(which))
683
684            # get the upload callback command
685            set cmd $uploadcmds($post(callback))
686            if {[catch "$cmd $dlist" result]} {
687                bgerror $result
688            }
689            unset uploadcmds($post(callback))
690        }
691
692        #
693        # Send back a response that closes the window that
694        # posted this form.
695        #
696        response $cid header -status "200 OK" \
697            -connection $headers(Connection)
698        set s [clock seconds]
699        set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
700        puts $cid "Last-Modified: $date"
701        response $cid body -type text/html -string {<html>
702<head>
703  <title>Upload Complete</title>
704  <script language="JavaScript">
705    function setup() {
706        window.close()
707    }
708    window.onload = setup;
709  </script>
710</head>
711<body>
712<b>Data uploaded successfully.  This window will now close.</b><br/>
713If this window doesn't close automatically, feel free to close it manually.
714</body>
715</html>}
716    } else {
717        #
718        # BAD FILE REQUEST:
719        #   The user is trying to ask for a file outside of
720        #   the normal filexfer installation.  Treat it the
721        #   same as file not found.
722        response $cid header \
723            -status "404 Not Found" \
724            -connection $headers(Connection)
725        response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server."
726    }
727}
728
729# ----------------------------------------------------------------------
730# USAGE: request_REGISTER <clientId> <user> <address> <cookie> <protocol>
731#
732# Used internally to handle REGISTER requests on this server.  A client
733# sends REGISTER requests when it wants to be notified of file transfer
734# operations.  The <cookie> must match the one for this server, so
735# we know we can trust the client.  The <protocol> tells us what version
736# of filexfer client we're talking to.  If the protocol doesn't match
737# the current version, we warn the user to restart his browser.
738# ----------------------------------------------------------------------
739proc Rappture::filexfer::request_REGISTER {cid user addr clientCookie proto} {
740    variable clients
741    variable cookie
742    variable protocol
743
744    if {![string equal $cookie $clientCookie]} {
745        response $cid header -status "401 Unauthorized"
746        response $cid error -status "401 Unauthorized" -message "Credentials are not recognized."
747    } else {
748        # add this client to the known listeners
749        set clients($cid) 0
750        set protocol($cid) $proto
751    }
752}
753
754# ----------------------------------------------------------------------
755# USAGE: request_UNREGISTER <clientId>
756#
757# Used internally to handle UNREGISTER requests on this server.
758# A client sends this request when it is being destroyed, to let
759# the server know that it no longer needs to handle this client.
760# ----------------------------------------------------------------------
761proc Rappture::filexfer::request_UNREGISTER {cid} {
762    variable clients
763
764    set i [lsearch -exact $cid $clients(order)]
765    if {$i >= 0} {
766        set clients(order) [lreplace $clients(order) $i $i]
767    }
768    catch {unset clients($cid)}
769}
770
771# ----------------------------------------------------------------------
772# USAGE: request_ACTIVATE <clientId>
773#
774# Used internally to handle ACTIVATE requests on this server.  A client
775# must first REGISTER with its cookie for authorization.  Then, as
776# its thread starts, it sends an ACTIVATE request, letting us know
777# that the client is ready to receive notifications.
778# ----------------------------------------------------------------------
779proc Rappture::filexfer::request_ACTIVATE {cid} {
780    variable clients
781
782    #
783    # Activate only if the client has already registered
784    # properly and is on our known list.
785    #
786    if {[info exists clients($cid)]} {
787        set clients($cid) 1
788
789        # move the most recently activated connection to the front
790        set i [lsearch -exact $cid $clients(order)]
791        if {$i >= 0} {
792            set clients(order) [lreplace $clients(order) $i $i]
793        }
794        set clients(order) [linsert $clients(order) 0 $cid]
795    }
796}
797
798# ----------------------------------------------------------------------
799# USAGE: request_DEACTIVATE <clientId>
800#
801# Used internally to handle DEACTIVATE requests on this server.  A client
802# must first REGISTER with its cookie for authorization.  Then, as
803# its thread starts, it sends an ACTIVATE request.  When its thread
804# stops (because the applet is swapped out of the web page), the
805# client sends a DEACTIVATE request, and we stop sending messages to
806# that client.
807# ----------------------------------------------------------------------
808proc Rappture::filexfer::request_DEACTIVATE {cid} {
809    variable clients
810
811    #
812    # Deactivate only if the client has already registered
813    # properly and is on our known list.
814    #
815    if {[info exists clients($cid)]} {
816        set clients($cid) 0
817
818        # remove this from the list of activated connections
819        set i [lsearch -exact $cid $clients(order)]
820        if {$i >= 0} {
821            set clients(order) [lreplace $clients(order) $i $i]
822        }
823    }
824}
825
826# ----------------------------------------------------------------------
827# USAGE: Rappture::filexfer::shutdown <clientId>
828#
829# Used internally to close and clean up a client connection.
830# Clears any data associated with the client.
831# ----------------------------------------------------------------------
832proc Rappture::filexfer::shutdown {cid} {
833    variable clients
834    variable buffer
835
836    catch {close $cid}
837
838    if {[info exists clients($cid)]} {
839        unset clients($cid)
840    }
841    set i [lsearch -exact $clients(order) $cid]
842    if {$i >= 0} {
843        set clients(order) [lreplace $clients(order) $i $i]
844    }
845
846    if {[info exists buffer($cid)] && "" != $buffer($cid)} {
847        unset buffer($cid)
848    }
849}
850
851# ----------------------------------------------------------------------
852# USAGE: response <channel> header -status <s> -connection <c>
853# USAGE: response <channel> body -string <s> -type <t>
854# USAGE: response <channel> error -message <m>
855# USAGE: response <channel> file -path <f>
856#
857# Used internally to generate responses to the client.  Returns a
858# string representing the requested response.
859# ----------------------------------------------------------------------
860proc Rappture::filexfer::response {cid what args} {
861    variable mime2ext
862    variable ext2mime
863    variable mime2type
864
865    switch -- $what {
866        header {
867            Rappture::getopts args params {
868                value -status ""
869                value -connection close
870            }
871            set s [clock seconds]
872            set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
873            puts $cid [format "HTTP/1.1 %s
874Date: %s
875Server: Rappture
876Connection: %s" $params(-status) $date $params(-connection)]
877        }
878
879        body {
880            Rappture::getopts args params {
881                value -string ""
882                value -type "auto"
883            }
884            if {$params(-type) == "auto"} {
885                if {[isbinary $params(-string)]} {
886                    set params(-type) "application/octet-stream"
887                } else {
888                    set params(-type) "text/plain"
889                }
890            }
891            puts $cid [format "Content-type: %s\nContent-length: %d\n" \
892                $params(-type) [string length $params(-string)]]
893
894            if {$mime2type($params(-type)) == "binary"} {
895                # binary data -- send data as raw bytes
896                set olde [fconfigure $cid -encoding]
897                fconfigure $cid -buffering none -encoding binary
898                puts -nonewline $cid $params(-string)
899                flush $cid
900                fconfigure $cid -buffering line -encoding $olde
901            } else {
902                # ascii data -- send normally
903                puts $cid $params(-string)
904            }
905        }
906
907        error {
908            Rappture::getopts args params {
909                value -status "400 Bad Request"
910                value -message ""
911            }
912            set heading [lrange $params(-status) 1 end]
913            set html [format "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
914<HTML><HEAD>
915<TITLE>%s</TITLE>
916</HEAD><BODY>
917<H1>%s</H1>
918%s
919</BODY></HTML>" $params(-status) $heading $params(-message)]
920            response $cid body -type text/html -string $html
921        }
922
923        file {
924            Rappture::getopts args params {
925                value -path ""
926                value -connection close
927            }
928            if {![file exists $params(-path)]} {
929                #
930                # FILE NOT FOUND:
931                #   The user is requesting some file that is not part of
932                #   the standard filexfer installation.
933                #
934                response $cid header \
935                    -status "404 Not Found" \
936                    -connection $params(-connection)
937
938                response $cid error -status "404 Not Found" -message "The requested file $params(-path) was not found on this server."
939            } elseif {[catch {
940                    set fid [open $params(-path) r]
941                    set data [read $fid]
942                    close $fid
943                } result]} {
944
945                response $cid error -status "500 Internal Server Error" -message "The requested file $params(-path) is not installed properly on this server."
946                response $cid header \
947                    -status "500 Internal Server Error" \
948                    -connection $params(-connection)
949            } else {
950                #
951                # READ AND RETURN THE FILE
952                #
953                set ext [file extension $params(-path)]
954                if {[info exists ext2mime($ext)]} {
955                    set mtype $ext2mime($ext)
956                } else {
957                    if {[isbinary $data]} {
958                        set mtype application/octet-stream
959                    } else {
960                        set mtype text/plain
961                    }
962                }
963
964                if {$mime2type($mtype) == "binary"} {
965                    # if this is binary data, read it again and get pure bytes
966                    catch {
967                        set fid [open $params(-path) r]
968                        fconfigure $fid -translation binary -encoding binary
969                        set data [read $fid]
970                        close $fid
971                    } result
972                }
973                response $cid header \
974                    -status "200 OK" \
975                    -connection $params(-connection)
976                set s [file mtime $params(-path)]
977                set date [clock format $s -format {%a, %d %b %Y %H:%M:%S %Z}]
978                puts $cid "Last-Modified: $date"
979
980                response $cid body -type $mtype -string $data
981            }
982        }
983    }
984}
985
986# ----------------------------------------------------------------------
987# USAGE: Rappture::filexfer::urlDecode <string>
988#
989# Used internally to decode a string in URL-encoded form back to
990# its normal ASCII equivalent.  Returns the input string, but with
991# any %XX characters translated back to their ASCII equivalents.
992# ----------------------------------------------------------------------
993proc Rappture::filexfer::urlDecode {string} {
994    while {[regexp -indices {%[0-9A-Fa-f][0-9A-Fa-f]} $string match]} {
995        foreach {p0 p1} $match break
996        set hex [string range $string [expr {$p0+1}] $p1]
997        set char [binary format c [scan $hex "%x"]]
998        set string [string replace $string $p0 $p1 $char]
999    }
1000    return $string
1001}
1002
1003# ----------------------------------------------------------------------
1004# USAGE: isbinary <string>
1005#
1006# Used internally to see if the given <string> has binary data.
1007# If so, then it must be treated differently.  Normal translation
1008# of carriage returns and line feeds must be suppressed.
1009# ----------------------------------------------------------------------
1010proc Rappture::filexfer::isbinary {string} {
1011    # look for binary characters, but avoid things like \t \n etc.
1012    return [regexp {[\000-\006\016-\037\177-\400]} $string]
1013}
1014
1015# ----------------------------------------------------------------------
1016# USAGE: bakeCookie
1017#
1018# Used internally to create a one-time use cookie, passed to clients
1019# to secure file transfer.  Only clients should know the cookie, so
1020# only clients will have access to files.
1021# ----------------------------------------------------------------------
1022proc Rappture::filexfer::bakeCookie {} {
1023    variable cookieChars
1024
1025    set cmax [expr {[llength $cookieChars]-1}]
1026    set cookie ""
1027    while {[string length $cookie] < 40} {
1028        set rindex [expr {round(rand()*$cmax)}]
1029        append cookie [lindex $cookieChars $rindex]
1030    }
1031    return $cookie
1032}
1033
1034# ----------------------------------------------------------------------
1035# USAGE: Rappture::filexfer::option_port <port>
1036#
1037# Called when the "filexfer_port" directive is encountered while
1038# parsing the "resources" file.  Assigns the port that the filexfer
1039# server should be listening to.
1040# ----------------------------------------------------------------------
1041proc Rappture::filexfer::option_port {newport} {
1042    variable port
1043    set port $newport
1044}
1045
1046# ----------------------------------------------------------------------
1047# USAGE: Rappture::filexfer::option_cookie <cookie>
1048#
1049# Called when the "filexfer_cookie" directive is encountered while
1050# parsing the "resources" file.  Assigns the port that the filexfer
1051# server should be listening to.
1052# ----------------------------------------------------------------------
1053proc Rappture::filexfer::option_cookie {newcookie} {
1054    variable cookie
1055    set cookie $newcookie
1056}
1057
1058# ----------------------------------------------------------------------
1059# USAGE: Rappture::filexfer::option_sitelogo <html>
1060#
1061# Called when the "filexfer_sitelogo" directive is encountered while
1062# parsing the "resources" file.  Stores the html text for later use
1063# in the filexfer upload form.  The site logo appears at the top of
1064# the form to identify the hub site that issued the form.
1065# ----------------------------------------------------------------------
1066proc Rappture::filexfer::option_sitelogo {html} {
1067    variable sitelogo
1068    set sitelogo $html
1069}
1070
1071# ----------------------------------------------------------------------
1072# USAGE: Rappture::filexfer::option_stylesheet <url>
1073#
1074# Called when the "filexfer_stylesheet" directive is encountered while
1075# parsing the "resources" file.  Stores the url for later use in the
1076# filexfer upload form.  The style sheet customizes the form to have
1077# a particular look for the hub site that issued the form.
1078# ----------------------------------------------------------------------
1079proc Rappture::filexfer::option_stylesheet {url} {
1080    variable stylesheet
1081    set stylesheet $url
1082}
Note: See TracBrowser for help on using the repository browser.