| 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
|---|
| 2 | # ---------------------------------------------------------------------- |
|---|
| 3 | # COMPONENT: filexfer - support for file transfer with user's desktop |
|---|
| 4 | # |
|---|
| 5 | # Supports interactions with the filexfer middleware, enabling |
|---|
| 6 | # Rappture to transfer files to and from the user's desktop. |
|---|
| 7 | # Files are downloaded by invoking "exportfile", and uploaded by |
|---|
| 8 | # invoking "importfile". The middleware handles the rest. |
|---|
| 9 | # ====================================================================== |
|---|
| 10 | # AUTHOR: Michael McLennan, Purdue University |
|---|
| 11 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
|---|
| 12 | # |
|---|
| 13 | # See the file "license.terms" for information on usage and |
|---|
| 14 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 15 | # ====================================================================== |
|---|
| 16 | package require BLT |
|---|
| 17 | |
|---|
| 18 | namespace eval Rappture { # forward declaration } |
|---|
| 19 | namespace eval Rappture::filexfer { |
|---|
| 20 | variable enabled 0 ;# set to 1 when middleware is in place |
|---|
| 21 | variable commands ;# complete path to exportfile/importfile |
|---|
| 22 | variable job ;# used to manage bgexec jobs |
|---|
| 23 | } |
|---|
| 24 | |
|---|
| 25 | # ---------------------------------------------------------------------- |
|---|
| 26 | # USAGE: Rappture::filexfer::init |
|---|
| 27 | # |
|---|
| 28 | # Called in the main application to see if the filexfer middleware |
|---|
| 29 | # is installed. Returns 1 if the middleware is installed, and 0 |
|---|
| 30 | # otherwise. |
|---|
| 31 | # ---------------------------------------------------------------------- |
|---|
| 32 | proc Rappture::filexfer::init {} { |
|---|
| 33 | variable enabled |
|---|
| 34 | variable commands |
|---|
| 35 | |
|---|
| 36 | # |
|---|
| 37 | # Look for the exportfile/importfile commands and see if |
|---|
| 38 | # they appear to be working. If we have both, then this |
|---|
| 39 | # is "enabled". |
|---|
| 40 | # |
|---|
| 41 | foreach op {export import} { |
|---|
| 42 | set prog "${op}file" |
|---|
| 43 | set path [auto_execok $prog] |
|---|
| 44 | if {"" == $path} { |
|---|
| 45 | foreach dir {/apps/bin /apps/filexfer/bin} { |
|---|
| 46 | set p [file join $dir $prog] |
|---|
| 47 | if {[file executable $p]} { |
|---|
| 48 | set path $p |
|---|
| 49 | break |
|---|
| 50 | } |
|---|
| 51 | } |
|---|
| 52 | } |
|---|
| 53 | if {[file executable $path]} { |
|---|
| 54 | # the new filexfer has a --provenance arg for file names |
|---|
| 55 | set info [exec $path --help 2>@1] |
|---|
| 56 | if {[regexp -- {--provenance} $info]} { |
|---|
| 57 | lappend path --provenance |
|---|
| 58 | } |
|---|
| 59 | set commands($op) $path |
|---|
| 60 | } else { |
|---|
| 61 | return 0 |
|---|
| 62 | } |
|---|
| 63 | } |
|---|
| 64 | |
|---|
| 65 | return [set enabled 1] |
|---|
| 66 | } |
|---|
| 67 | |
|---|
| 68 | # ---------------------------------------------------------------------- |
|---|
| 69 | # USAGE: Rappture::filexfer::enabled |
|---|
| 70 | # |
|---|
| 71 | # Clients use this to see if the filexfer stuff is up and running. |
|---|
| 72 | # If so, then the GUI will provide "Download..." and other filexfer |
|---|
| 73 | # options. If not, then Rappture must be running within an |
|---|
| 74 | # environment that doesn't support it. As a backup, Rappture provides |
|---|
| 75 | # file load/save operations instead. |
|---|
| 76 | # ---------------------------------------------------------------------- |
|---|
| 77 | proc Rappture::filexfer::enabled {} { |
|---|
| 78 | variable enabled |
|---|
| 79 | return $enabled |
|---|
| 80 | } |
|---|
| 81 | |
|---|
| 82 | # ---------------------------------------------------------------------- |
|---|
| 83 | # USAGE: Rappture::filexfer::label upload|download |
|---|
| 84 | # |
|---|
| 85 | # Clients use this to query the proper label for an "upload" or |
|---|
| 86 | # "download" opertion. These are usually "Upload..." and "Download", |
|---|
| 87 | # but could change to "Load File..." and "Save As..." for applications |
|---|
| 88 | # in desktop mode. |
|---|
| 89 | # ---------------------------------------------------------------------- |
|---|
| 90 | proc Rappture::filexfer::label {operation} { |
|---|
| 91 | switch -- $operation { |
|---|
| 92 | upload { |
|---|
| 93 | if {[Rappture::filexfer::enabled]} { |
|---|
| 94 | return "Upload..." |
|---|
| 95 | } else { |
|---|
| 96 | return "Load File..." |
|---|
| 97 | } |
|---|
| 98 | } |
|---|
| 99 | uploadWord { |
|---|
| 100 | if {[Rappture::filexfer::enabled]} { |
|---|
| 101 | return "Upload" |
|---|
| 102 | } else { |
|---|
| 103 | return "Browse" |
|---|
| 104 | } |
|---|
| 105 | } |
|---|
| 106 | download { |
|---|
| 107 | if {[Rappture::filexfer::enabled]} { |
|---|
| 108 | return "Download" |
|---|
| 109 | } else { |
|---|
| 110 | return "Save As..." |
|---|
| 111 | } |
|---|
| 112 | } |
|---|
| 113 | downloadWord { |
|---|
| 114 | if {[Rappture::filexfer::enabled]} { |
|---|
| 115 | return "Download" |
|---|
| 116 | } else { |
|---|
| 117 | return "Save" |
|---|
| 118 | } |
|---|
| 119 | } |
|---|
| 120 | default { |
|---|
| 121 | error "bad option \"$operation\": should be upload, uploadWord, download, or downloadWord" |
|---|
| 122 | } |
|---|
| 123 | } |
|---|
| 124 | } |
|---|
| 125 | |
|---|
| 126 | |
|---|
| 127 | # ---------------------------------------------------------------------- |
|---|
| 128 | # USAGE: Rappture::filexfer::upload <toolName> <controlList> <callback> |
|---|
| 129 | # |
|---|
| 130 | # Clients use this to prompt the user to upload a file. The string |
|---|
| 131 | # <toolName> is used to identify the application within the web form. |
|---|
| 132 | # The <controlList> is a list of controls that could be uploaded: |
|---|
| 133 | # |
|---|
| 134 | # { <id1> <label1> <desc1> <id2> <label2> <desc2> ... } |
|---|
| 135 | # |
|---|
| 136 | # The user is prompted for each of the controls in <controlList>. |
|---|
| 137 | # If successful, the <callback> is invoked to handle the uploaded |
|---|
| 138 | # information. If anything goes wrong, the same callback is used |
|---|
| 139 | # to post errors near the widget that invoked this operation. |
|---|
| 140 | # |
|---|
| 141 | # The <id> is usually a Rappture path for the control that is being |
|---|
| 142 | # uploaded into. It is passed along to the <callback>, so that code |
|---|
| 143 | # knows where to put the result. If <id> is "@@<dir>", then the file |
|---|
| 144 | # is uploaded into the specified directory <dir> using the name that |
|---|
| 145 | # comes from the remote upload. |
|---|
| 146 | # ---------------------------------------------------------------------- |
|---|
| 147 | proc Rappture::filexfer::upload {tool controlList callback} { |
|---|
| 148 | global env |
|---|
| 149 | variable enabled |
|---|
| 150 | variable commands |
|---|
| 151 | variable job |
|---|
| 152 | |
|---|
| 153 | if {$enabled} { |
|---|
| 154 | set cmd $commands(import) |
|---|
| 155 | if {"" != $tool} { |
|---|
| 156 | lappend cmd --for "for $tool" |
|---|
| 157 | } |
|---|
| 158 | |
|---|
| 159 | set dir ~/data/sessions/$env(SESSION)/spool |
|---|
| 160 | if {![file exists $dir]} { |
|---|
| 161 | catch {file mkdir $dir} |
|---|
| 162 | } |
|---|
| 163 | |
|---|
| 164 | set i 0 |
|---|
| 165 | foreach {path label desc} $controlList { |
|---|
| 166 | set file [file join $dir upload[pid]-[incr i]] |
|---|
| 167 | set file2path($file) $path |
|---|
| 168 | set file2label($file) $label |
|---|
| 169 | lappend cmd --label $label $file |
|---|
| 170 | } |
|---|
| 171 | |
|---|
| 172 | uplevel #0 [list $callback error "Upload starting...\nA web browser page should pop up on your desktop. Use that form to handle the upload operation.\n\nIf the upload form doesn't pop up, make sure that you're allowing pop ups from this site. If it still doesn't pop up, you may be having trouble with the version of Java installed for your browser. See our Support area for details.\n\nClick anywhere to dismiss this message."] |
|---|
| 173 | |
|---|
| 174 | set job(output) "" |
|---|
| 175 | set job(error) "" |
|---|
| 176 | |
|---|
| 177 | set status [catch {eval \ |
|---|
| 178 | blt::bgexec ::Rappture::filexfer::job(control) \ |
|---|
| 179 | -output ::Rappture::filexfer::job(output) \ |
|---|
| 180 | -error ::Rappture::filexfer::job(error) \ |
|---|
| 181 | $cmd |
|---|
| 182 | } result] |
|---|
| 183 | |
|---|
| 184 | if {$status == 0} { |
|---|
| 185 | set changed "" |
|---|
| 186 | set errs "" |
|---|
| 187 | foreach line [split $job(output) \n] { |
|---|
| 188 | # the new filexfer reports "file <= desktopName" |
|---|
| 189 | # the old one just reports "file" |
|---|
| 190 | set remote "" |
|---|
| 191 | if {![regexp {(.+) +<= +(.+)} $line match file remote]} { |
|---|
| 192 | set file [string trim $line] |
|---|
| 193 | } |
|---|
| 194 | |
|---|
| 195 | # load the uploaded for this control |
|---|
| 196 | set status [catch { |
|---|
| 197 | set fid [open $file r] |
|---|
| 198 | fconfigure $fid -translation binary -encoding binary |
|---|
| 199 | set info [read $fid] |
|---|
| 200 | close $fid |
|---|
| 201 | if {[string match @@* $file2path($file)]} { |
|---|
| 202 | if {$remote ne "" && $remote ne "@CLIPBOARD"} { |
|---|
| 203 | set dir [string range $file2path($file) 2 end] |
|---|
| 204 | if {$dir eq ""} { set dir [pwd] } |
|---|
| 205 | set newloc [file join $dir $remote] |
|---|
| 206 | file rename -force -- $file $newloc |
|---|
| 207 | } |
|---|
| 208 | } else { |
|---|
| 209 | file delete -force $file |
|---|
| 210 | } |
|---|
| 211 | } result] |
|---|
| 212 | |
|---|
| 213 | if {$status != 0} { |
|---|
| 214 | append errs "Error loading data for \"$file2label($file)\":\n$result\n" |
|---|
| 215 | } else { |
|---|
| 216 | lappend changed $file2path($file) |
|---|
| 217 | set cmd [list $callback path $file2path($file) local $file data $info] |
|---|
| 218 | if {$remote ne ""} { |
|---|
| 219 | lappend cmd remote $remote |
|---|
| 220 | } |
|---|
| 221 | uplevel #0 $cmd |
|---|
| 222 | } |
|---|
| 223 | } |
|---|
| 224 | if {[llength $changed] == 0} { |
|---|
| 225 | set errs "The form was empty, so none of your controls were changed. In order to upload a file, you must select the file name--or enter text into the copy/paste area--before pushing the Upload button." |
|---|
| 226 | } |
|---|
| 227 | if {[string length $errs] > 0} { |
|---|
| 228 | uplevel #0 [list $callback error $errs] |
|---|
| 229 | } |
|---|
| 230 | } else { |
|---|
| 231 | uplevel #0 [list $callback error $job(error)] |
|---|
| 232 | } |
|---|
| 233 | } else { |
|---|
| 234 | # |
|---|
| 235 | # Filexfer via importfile is disabled. This tool must be |
|---|
| 236 | # running in a desktop environment. Instead of uploading, |
|---|
| 237 | # perform a "Load File..." operation with a standard file |
|---|
| 238 | # selection dialog. |
|---|
| 239 | # |
|---|
| 240 | set i 0 |
|---|
| 241 | foreach {path label desc} $controlList { |
|---|
| 242 | set file [tk_getOpenFile -title "Load File: $label"] |
|---|
| 243 | if {"" != $file} { |
|---|
| 244 | set cmds { |
|---|
| 245 | # try to read first as binary |
|---|
| 246 | set fid [open $file r] |
|---|
| 247 | fconfigure $fid -encoding binary -translation binary |
|---|
| 248 | set info [read $fid] |
|---|
| 249 | close $fid |
|---|
| 250 | if {![Rappture::encoding::is binary $info]} { |
|---|
| 251 | # not binary? then re-read and translate CR/LF |
|---|
| 252 | set fid [open $file r] |
|---|
| 253 | set info [read $fid] |
|---|
| 254 | close $fid |
|---|
| 255 | } |
|---|
| 256 | } |
|---|
| 257 | if {[catch $cmds err]} { |
|---|
| 258 | uplevel #0 [list $callback error "Error loading file [file tail $file]: $err"] |
|---|
| 259 | } else { |
|---|
| 260 | uplevel #0 [list $callback path $path data $info filename $file] |
|---|
| 261 | } |
|---|
| 262 | } |
|---|
| 263 | } |
|---|
| 264 | } |
|---|
| 265 | } |
|---|
| 266 | |
|---|
| 267 | # ---------------------------------------------------------------------- |
|---|
| 268 | # USAGE: Rappture::filexfer::download <string> ?<filename>? |
|---|
| 269 | # |
|---|
| 270 | # Clients use this to send a file off to the user. The <string> |
|---|
| 271 | # is stored in a file called <filename> in the user's spool directory. |
|---|
| 272 | # If there is already a file by that name, then the name is modified |
|---|
| 273 | # to make it unique. Once the string has been stored in the file, |
|---|
| 274 | # a message is sent to all clients listening, letting them know |
|---|
| 275 | # that the file is available. |
|---|
| 276 | # |
|---|
| 277 | # If anything goes wrong, this function returns a string that should |
|---|
| 278 | # be displayed to the user to explain the problem. |
|---|
| 279 | # ---------------------------------------------------------------------- |
|---|
| 280 | proc Rappture::filexfer::download {string {filename "output.txt"}} { |
|---|
| 281 | global env |
|---|
| 282 | variable enabled |
|---|
| 283 | variable commands |
|---|
| 284 | variable job |
|---|
| 285 | |
|---|
| 286 | if {$enabled} { |
|---|
| 287 | # make a spool directory, if we don't have one already |
|---|
| 288 | set dir ~/data/sessions/$env(SESSION)/spool |
|---|
| 289 | if {![file exists $dir]} { |
|---|
| 290 | catch {file mkdir $dir} |
|---|
| 291 | } |
|---|
| 292 | |
|---|
| 293 | if {[file exists [file join $dir $filename]]} { |
|---|
| 294 | # |
|---|
| 295 | # Find a similar file name that doesn't conflict |
|---|
| 296 | # with an existing file: e.g., output2.txt |
|---|
| 297 | # |
|---|
| 298 | set root [file rootname $filename] |
|---|
| 299 | set ext [file extension $filename] |
|---|
| 300 | set counter 2 |
|---|
| 301 | while {1} { |
|---|
| 302 | set filename "$root$counter$ext" |
|---|
| 303 | if {![file exists [file join $dir $filename]]} { |
|---|
| 304 | break |
|---|
| 305 | } |
|---|
| 306 | incr counter |
|---|
| 307 | } |
|---|
| 308 | } |
|---|
| 309 | |
|---|
| 310 | # |
|---|
| 311 | # Save the file in the spool directory, then have it |
|---|
| 312 | # exported. |
|---|
| 313 | # |
|---|
| 314 | if {[catch { |
|---|
| 315 | set file [file join $dir $filename] |
|---|
| 316 | set fid [open $file w] |
|---|
| 317 | fconfigure $fid -encoding binary -translation binary |
|---|
| 318 | puts -nonewline $fid $string |
|---|
| 319 | close $fid |
|---|
| 320 | } result]} { |
|---|
| 321 | return $result |
|---|
| 322 | } |
|---|
| 323 | |
|---|
| 324 | set job(output) "" |
|---|
| 325 | set job(error) "" |
|---|
| 326 | |
|---|
| 327 | # Make sure we normalize the file name here. Don't count |
|---|
| 328 | # on filexfer command understanding tildes. |
|---|
| 329 | set file [file normalize $file] |
|---|
| 330 | |
|---|
| 331 | set status [catch {blt::bgexec ::Rappture::filexfer::job(control) \ |
|---|
| 332 | -output ::Rappture::filexfer::job(output) \ |
|---|
| 333 | -error ::Rappture::filexfer::job(error) \ |
|---|
| 334 | $commands(export) --timeout 300 --delete $file} result] |
|---|
| 335 | |
|---|
| 336 | if {$status != 0} { |
|---|
| 337 | return $Rappture::filexfer::job(error) |
|---|
| 338 | } |
|---|
| 339 | } else { |
|---|
| 340 | # |
|---|
| 341 | # Filexfer via exportfile is disabled. This tool must be |
|---|
| 342 | # running in a desktop environment. Instead of downloading, |
|---|
| 343 | # perform a "Save As..." operation with a standard file |
|---|
| 344 | # selection dialog. |
|---|
| 345 | # |
|---|
| 346 | set file [tk_getSaveFile -title "Save As..." -initialfile $filename] |
|---|
| 347 | # FIXME: Why is there a grab still pending? |
|---|
| 348 | set grab [grab current] |
|---|
| 349 | if { $grab != "" } { |
|---|
| 350 | grab release $grab |
|---|
| 351 | } |
|---|
| 352 | if {"" != $file} { |
|---|
| 353 | if {[catch { |
|---|
| 354 | set fid [open $file w] |
|---|
| 355 | if {[Rappture::encoding::is binary $string]} { |
|---|
| 356 | fconfigure $fid -encoding binary -translation binary |
|---|
| 357 | puts -nonewline $fid $string |
|---|
| 358 | } else { |
|---|
| 359 | puts $fid $string |
|---|
| 360 | } |
|---|
| 361 | close $fid |
|---|
| 362 | } result]} { |
|---|
| 363 | return $result |
|---|
| 364 | } |
|---|
| 365 | } |
|---|
| 366 | } |
|---|
| 367 | return "" |
|---|
| 368 | } |
|---|
| 369 | |
|---|
| 370 | # ---------------------------------------------------------------------- |
|---|
| 371 | # USAGE: Rappture::filexfer::webpage <url> |
|---|
| 372 | # |
|---|
| 373 | # Clients use this to pop up a web page for the specified <url> on |
|---|
| 374 | # the user's desktop. The <url> should start with http:// or https://. |
|---|
| 375 | # If anything goes wrong, this function beeps. |
|---|
| 376 | # ---------------------------------------------------------------------- |
|---|
| 377 | proc Rappture::filexfer::webpage {url} { |
|---|
| 378 | if {[regexp -nocase {^https?://} $url]} { |
|---|
| 379 | foreach prog { |
|---|
| 380 | clientaction |
|---|
| 381 | /usr/lib/hubzero/clientaction |
|---|
| 382 | /apps/bin/clientaction |
|---|
| 383 | /apps/xvnc/bin/clientaction |
|---|
| 384 | /usr/lib/mw/bin/clientaction |
|---|
| 385 | "" |
|---|
| 386 | } { |
|---|
| 387 | if {"" != [auto_execok $prog]} { |
|---|
| 388 | break |
|---|
| 389 | } |
|---|
| 390 | } |
|---|
| 391 | if {"" != $prog} { |
|---|
| 392 | exec $prog url $url & |
|---|
| 393 | return |
|---|
| 394 | } |
|---|
| 395 | } |
|---|
| 396 | bell |
|---|
| 397 | } |
|---|
