blob: 42a9f82bce3fbfcdab3c4926b33396ad339ec0a9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
#!./tclsh
# $Id: export 391 2007-01-25 03:53:59Z mikes@u.washington.edu $
# ========================================================================
# Copyright 2006 University of Washington
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# ========================================================================
# export
#
# Purpose: CGI script to download exported folder
#
# Input:
set export_vars {
}
#set export_via_ip_address 1
#set export_via_local_hostname 1
# inherit global config
source ../alpine.tcl
set mailextension ".mbx"
proc WPServerIP {} {
global _wp
catch {
set ip 127.0.0.1
set sid [socket -async [info hostname] [expr {([string length $_wp(serverport)]) ? $_wp(serverport) : 80}]]
set ip [lindex [ fconfigure $sid -sockname ] 0]
close $sid
}
return $ip
}
WPEval $export_vars {
# grok PATH_INFO for collection 'c' and folder 'f' uid 'u' and part 'p'
if {!([info exists env(PATH_INFO)] && [string length $env(PATH_INFO)]
&& [regexp {^/([0-9]+)/(.*)$} $env(PATH_INFO) dummy c f])} {
WPCmd PEInfo statmsg "Invalid Detach: $env(SCRIPT_NAME)"
cgi_exit
}
# generate filenames to hold exported folder and control file
for {set n 0} {1} {incr n} {
set rhandle [WPCmd PESession random 64]
set cfile [file join $_wp(fileroot) $_wp(detachpath) detach.${rhandle}-control]
set dfile [file join $_wp(fileroot) $_wp(detachpath) detach.${rhandle}-data]
if {[file exists $cfile] == 0 && [file exists $dfile] == 0} {
if {[catch {open $cfile {RDWR CREAT EXCL} [cgi_tmpfile_permissions]} cfd]
|| [catch {open $dfile {RDWR CREAT EXCL} [cgi_tmpfile_permissions]} dfd]} {
if {[info exists dfd]} {
catch {close $cfd}
catch {file delete -force $cfile}
set errstr $dfd
} else {
set errstr $cfd
}
error [list _action Export "Cannot create command/control files: [cgi_quote_html $errstr]" "Please close this window"]
} else {
close $dfd
break
}
} elseif {$n > 4} {
error [list _action Export "Command file creation limit" "Please close this window"]
}
}
catch {file delete $dfile}
if {[catch {WPCmd PEFolder export $c $f $dfile} result]} {
WPCmd PEInfo statmsg $result
} else {
if {[set dfilesize [file size $dfile]] > 0
&& ([info exists _wp(uplim_bytes)] && $_wp(uplim_bytes) > 0)
&& $dfilesize > $_wp(uplim_bytes)} {
if {$_wp(uplim_bytes) > (1000000)} {
set dfs [format {%s.%.2s MB} [WPcomma [expr {$dfilesize / 1000000}]] [expr {$dfilesize % 1000000}]]
set esl [format {%s.%.2s MB} [WPcomma [expr {$_wp(uplim_bytes) / 1000000}]] [expr {$_wp(uplim_bytes) % 1000000}]]
} else {
set dfs "[WPcomma $dfs] KB"
set esl "[WPcomma $_wp(uplim_bytes)] KB"
}
WPCmd PEInfo statmsg "Exported folder size ($dfs) exceeds the maximum ($esl) size that can be imported.<br>If you wish to import this folder back into Web Alpine at a later time,<br>you should break it up into smaller folders"
}
if {[info exists export_via_ip_address]} {
if {[regsub {^(http[s]?://)[A-Za-z0-9\\-\\.]+(.*)$} "[cgi_root]/pub/getach.tcl" "\\1\[[WPServerIP]\]\\2" redirect] != 1} {
WPCmd PEInfo statmsg "Cannot determine server address"
catch {unset redirect}
}
} elseif {[info exists export_via_local_hostname]} {
if {[regsub {^(http[s]?://)[A-Za-z0-9\\-\\.]+(.*)$} "[cgi_root]/pub/getach.tcl" "\\1\[[info hostname]\]\\2" redirect] != 1} {
WPCmd PEInfo statmsg "Cannot determine server address"
catch {unset redirect}
}
} else {
set redirect "[cgi_root]/pub/getach.tcl"
}
set givenname "[file tail $f]${mailextension}"
set safegivenname $givenname
regsub -all {[/]} $safegivenname {-} safegivenname
regsub -all {[ ]} $safegivenname {_} safegivenname
regsub -all {[\?]} $safegivenname {X} safegivenname
regsub -all {[&]} $safegivenname {X} safegivenname
regsub -all {[#]} $safegivenname {X} safegivenname
regsub -all {[=]} $safegivenname {X} safegivenname
set safegivenname "/$safegivenname"
puts $cfd "Content-type: Application/X-Mail-Folder"
puts $cfd "Content-Disposition: attachment; filename=\"$givenname\""
# side-step the cgi_xxx stuff in this special case because
# we don't want to buffer up the downloading attachment...
puts $cfd "Content-Length: $dfilesize"
puts $cfd "Expires: [clock format [expr {[clock seconds] + 3600}] -f {%a, %d %b %Y %H:%M:%S GMT} -gmt true]"
puts $cfd "Cache-Control: max-age=3600"
puts $cfd ""
puts $cfd $dfile
# exec chmod [cgi_tmpfile_permissions] $dfile
close $cfd
exec /bin/chmod [cgi_tmpfile_permissions] $cfile
exec /bin/chmod [cgi_tmpfile_permissions] $dfile
}
# prepare to clean up if the brower never redirects
if {[info exists redirect]} {
set redirect "${redirect}${safegivenname}?h=${rhandle}"
} else {
set redirect "[cgi_root]/$_wp(appdir)/$_wp(ui2dir)/folders/"
}
cgi_http_head {
# redirect to the place we stuffed the export info. use the ip address
# to foil spilling any session cookies or the like
if {[info exists env(SERVER_PROTOCOL)] && [regexp {[Hh][Tt][Tt][PP]/([0-9]+)\.([0-9]+)} $env(SERVER_PROTOCOL) m vmaj vmin] && $vmaj >= 1 && $vmin >= 1} {
cgi_puts "Status: 303 Temporary Redirect"
} else {
cgi_puts "Status: 302 Redirected"
}
cgi_puts "URI: $redirect"
cgi_puts "Location: $redirect"
}
cgi_body {}
exec echo $rhandle | [file join $_wp(cgipath) [WPCmd PEInfo set wp_ver_dir] whackatch.tcl] >& /dev/null &
}
|
