17 # |
18 # |
18 # Eventuell in der Apache-Config sowas wie |
19 # Eventuell in der Apache-Config sowas wie |
19 # ScriptAlias /ud /home/ud/XXX/upload.pl |
20 # ScriptAlias /ud /home/ud/XXX/upload.pl |
20 # Alias /d /home/ud/XXX/d/ |
21 # Alias /d /home/ud/XXX/d/ |
21 # gesetzt werden. |
22 # gesetzt werden. |
|
23 # |
|
24 # }} |
|
25 # |
|
26 |
|
27 # STATUS: Proof of Concept! |
22 |
28 |
23 use 5.014; |
29 use 5.014; |
24 use strict; |
30 use strict; |
25 use warnings; |
31 use warnings; |
26 use CGI qw(:all *table); |
32 use CGI qw(:all *table); |
27 use CGI::Carp qw(fatalsToBrowser); |
33 use CGI::Carp qw(fatalsToBrowser); |
28 use CGI::Pretty; |
34 use CGI::Pretty; |
29 use IO::File; |
35 use IO::File; |
30 use File::Basename; |
36 use File::Basename; |
|
37 use File::Path qw(remove_tree make_path); |
|
38 use File::Spec::Functions; |
31 use File::MimeInfo qw(mimetype); |
39 use File::MimeInfo qw(mimetype); |
32 use Cwd qw(getcwd realpath); |
40 use Cwd qw(getcwd realpath); |
33 use Digest::MD5 qw(md5_hex); |
41 use Digest::MD5 qw(md5_hex); |
34 use OSSP::uuid; |
42 use OSSP::uuid; |
35 |
43 |
36 my $DIR = "d"; |
44 |
37 my $DIR_URI = "/once/$DIR"; |
45 sub human; # convert numbers to human readable format |
38 |
46 sub deletedir; # safely delete directories |
39 sub human($); |
47 sub confirm; # ask for user confirmation (HTML) |
40 sub deletedir(@); |
48 sub deslash; # cleanup a path name |
41 sub confirm; |
49 |
42 |
50 my $uuid = qr/[[:xdigit:]-]{36}/; |
43 delete @ENV{ grep /PATH/, keys %ENV }; |
51 my $hash = qr/[[:xdigit:]]{32}/; |
44 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin"; |
52 |
45 |
53 umask 077; |
46 $_ = dirname $DIR; |
54 |
47 -d or mkdir $_ => 0750 |
55 # The working (var) directory gets passed to us via ONCE_VAR environment |
48 or die "Can't mkdir $_: $!\n"; |
56 # FIXME: Should we allow the current directory as an alternative? |
|
57 |
|
58 my $ONCE_VAR = do { |
|
59 $ENV{ONCE_VAR} =~ /^(\/\S+)/; |
|
60 die "Please define (correct) env ONCE_VAR\n" |
|
61 if not defined $1; |
|
62 $1; |
|
63 }; |
|
64 |
49 |
65 |
50 my @footer = (hr, |
66 my @footer = (hr, |
51 div( |
67 div( |
52 { -align => "right" }, |
68 { -align => "right" }, |
53 a( |
69 a( |
54 { |
70 { |
55 -href => |
71 -href => |
56 "https://ssl.schlittermann.de/hg/anon-upload/file/once/" |
72 "https://ssl.schlittermann.de/hg/anon-upload/file/once/" |
57 } => "Scripting" |
73 } => "Scripting" |
58 ), |
74 ), |
59 " © 2010,2011 ", |
75 " © 2010,2011,2015 ", |
60 a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"), |
76 a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"), |
61 " © 2014 ", |
77 " © 2014 ", |
62 a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste") |
78 a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste") |
63 ) |
79 ) |
64 ); |
80 ); |
65 |
81 |
66 MAIN: { |
82 MAIN: { |
67 |
83 |
68 # assuming download request |
84 # Download? |
69 if (request_uri =~ m|^\Q$DIR_URI\E/(.+)$|) { |
85 if ($ENV{PATH_INFO} =~ m{(?<path>(?<store>(?<view>/$hash|$uuid)/$uuid-\d+-.)/(?<base>.*))}) { |
70 |
86 my $view = deslash realpath catfile $ONCE_VAR, $+{view}; |
71 # assuming $DIR relative to cwd |
87 my $store = deslash realpath catfile $ONCE_VAR, $+{store}; |
72 my $relative = $1; |
88 my $file = deslash realpath catfile $ONCE_VAR, $+{path}; |
73 my $base = getcwd; |
89 my $base = $+{base}; |
74 my $absolute; |
90 |
75 unless ($absolute = realpath "$base/$DIR/$relative") { |
91 unless (-f $file) { |
76 die "Can't realpath '$base/$DIR/$relative': $!" |
|
77 unless exists $!{ENOENT} and $!{ENOENT}; |
|
78 print header('text/plain', '404 Not found'), 'Not found'; |
92 print header('text/plain', '404 Not found'), 'Not found'; |
79 exit 0; |
93 exit 0; |
80 } |
94 } |
81 $absolute =~ m|^\Q$base/$DIR\E| or die "invalid path: [$absolute]"; |
95 |
82 |
96 my $mimetype = mimetype($file); |
83 (my $dir = $relative) =~ s|/[^/]+$||; |
97 confirm $base, $mimetype if $store =~ /-d$/ and not defined param('confirmed'); |
84 my $delete = $dir =~ /-d$/; |
98 |
85 |
99 open my $f, '<', $file or die "Can't open <`$file`: $!\n"; |
86 confirm if ($delete and not defined param('confirmed')); |
100 remove_tree $1 if $store =~ m(^(/.*-d)$); |
87 |
101 rmdir $1 if $view =~ m(^(/.*)); |
88 open F, '<', $absolute or die "Can't open '<', '$absolute': $!"; |
102 |
89 print header(-type => mimetype($absolute), -charset => 'UTF-8'); |
103 print header(-type => $mimetype, -charset => 'UTF-8'); |
90 if (request_method() ~~ [qw(GET POST)]) { |
104 if (request_method() ~~ [qw(GET POST)]) { |
91 my ($buf, $res); |
105 local $/ = \do{1 * 2**20}; # 1 MB Buffer |
92 print $buf while $res = read F, $buf, 32 * 2**10; |
106 print while <$f>; |
93 defined $res or die "Can't read: $!"; |
|
94 |
|
95 deletedir $dir if $delete; |
|
96 } |
107 } |
97 exit 0; |
108 exit 0; |
98 |
109 |
99 } |
110 } |
100 |
111 |
101 # per view we have an own directory |
112 # UPLOAD / VIEW request |
102 |
113 # per view (user) we have an own directory |
103 $ENV{REMOTE_USER} =~ /(.*)/; |
114 |
104 $_ = md5_hex($1); |
115 # pre condition checks |
105 $DIR .= "/$_"; |
116 -d $ONCE_VAR or mkdir $ONCE_VAR => 0777 |
106 $DIR_URI .= "/$_"; |
117 or die "Can't mkdir $ONCE_VAR: $! (your admin should have created it)\n"; |
107 -d $DIR |
118 |
108 or mkdir $DIR => 0750 |
119 -x -w $ONCE_VAR or |
109 or die "Can't mkdir $DIR: $!\n"; |
120 die "Can't write to $ONCE_VAR: $!\n"; |
110 |
121 |
111 if (param("delete") =~ /([-a-z\d]+-\d+-.)/i) { |
122 my ($view, $user_dir) = do { |
112 deletedir $1; |
123 my ($v, $d); |
|
124 if ($ENV{REMOTE_USER} =~ /^\s*(.+)\s*$/) { |
|
125 $v = $1; |
|
126 $d = md5_hex($1); |
|
127 } |
|
128 else { |
|
129 tie $d => 'OSSP::uuid::tie', 'v4'; |
|
130 $v = 'anonymous'; |
|
131 } |
|
132 $v, deslash catfile($ONCE_VAR, $d); |
|
133 }; |
|
134 |
|
135 if (param('delete') =~ m{(?<store>(?<view>$uuid|$hash)/$uuid-\d+-./?)}) { |
|
136 # FIXME: sanitization |
|
137 my $store = deslash catfile $ONCE_VAR, $+{store}; |
|
138 my $view = deslash catfile $ONCE_VAR, $+{view}; |
|
139 remove_tree $1 if $store =~ m(^(/.*)); |
|
140 rmdir $1 if $view =~ m(^(/.*)); |
113 print redirect(-uri => url(-path_info => 1)); |
141 print redirect(-uri => url(-path_info => 1)); |
114 exit 0; |
142 exit 0; |
115 } |
143 } |
116 |
144 |
117 print header(-charset => "UTF-8"), |
145 print header(-charset => "UTF-8"), |
118 start_html(-title => "once"), |
146 start_html(-title => "once"), |
119 h1 "Ansicht: $ENV{REMOTE_USER}"; |
147 h1 "Ansicht: $view"; |
120 |
148 |
121 # print Dump; |
149 # print Dump; |
122 |
150 |
123 if (length(my $file = param("upload"))) { |
151 if (length(my $file = param('upload'))) { |
124 my $days = param("expires"); |
152 my $days = param('expires'); |
125 my ($delete, $expires); |
153 my ($delete, $expires); |
126 tie my $uuid => "OSSP::uuid::tie", "v4"; |
154 tie my $uuid => 'OSSP::uuid::tie', 'v4'; |
127 |
155 |
128 # sanitize expires |
156 # sanitize expires |
129 $days =~ /.*?([+-]?\d+).*/; |
157 $days =~ /.*?([+-]?\d+).*/; |
130 $days = defined $1 ? $1 : 10; |
158 $days = defined $1 ? $1 : 10; |
131 |
159 |
160 } |
188 } |
161 |
189 |
162 } |
190 } |
163 print hr; |
191 print hr; |
164 |
192 |
165 if (my @files = glob "$DIR/*-*/*") { |
193 # List the current content |
166 |
194 if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") { |
167 #print "<pre>", |
|
168 #(map { "$_: $ENV{$_}\n" } sort keys %ENV), |
|
169 #"</pre>"; |
|
170 |
195 |
171 print p <<__; |
196 print p <<__; |
172 Der gültige Download-Link ist die Link-Adresse, die sich hinter |
197 <@files> |
173 dem Datei-Namen verbirgt. (Firefox: Rechte Maustaste, Link-Location). |
198 Der gültige Download-Link ist die Link-Adresse, die sich hinter |
174 Nach Ablauf des <a href="http://de.wikipedia.org/wiki/Mindesthaltbarkeitsdatum">MHD</a> |
199 dem Datei-Namen verbirgt. (Firefox: Rechte Maustaste, Link-Location). |
175 wird die Datei automatisch gelöscht. |
200 Nach Ablauf des <a href="http://de.wikipedia.org/wiki/Mindesthaltbarkeitsdatum">MHD</a> |
|
201 wird die Datei automatisch gelöscht. |
176 __ |
202 __ |
177 |
203 |
178 print start_table, |
204 print start_table, |
179 Tr(th { align => "left" }, [qw/Name Größe Hochgeladen Löschung/]); |
205 Tr(th { align => "left" }, [qw/Name Größe Hochgeladen Löschung/]); |
180 |
206 |
181 foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$DIR/*-*/*") { |
207 foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) { |
182 my ($file, $dir) = fileparse($_); |
208 my ($file, $dir) = fileparse($_); |
183 $dir = basename $dir; |
209 $dir = substr $dir, length $ONCE_VAR; # make it relative to $ONCE_VAR |
184 |
210 |
185 # $dir =~ /(?<hash>\S+)-(?<expires>\d+)$/ or next; |
211 $dir =~ /(\S+)-(\d+)-(.)\/?$/ or next; |
186 $dir =~ /(\S+)-(\d+)-(.)$/ or next; |
|
187 my ($hash, $expires, $delete) = ($1, $2, $3); |
212 my ($hash, $expires, $delete) = ($1, $2, $3); |
188 if (${expires} <= time and $delete eq 'l') { |
213 if (${expires} <= time and $delete eq 'l') { |
189 /(.*)/; |
214 /(.*)/; |
190 unlink $_ or die "Can't unlik $_: $!\n"; |
215 unlink $_ or die "Can't unlik $_: $!\n"; |
191 rmdir $dir or die "Can't rmdir $dir: $!\n"; |
216 rmdir $dir or die "Can't rmdir $dir: $!\n"; |
251 croak "filesize is too big (can't convert to human readable number)" |
272 croak "filesize is too big (can't convert to human readable number)" |
252 if !@units; |
273 if !@units; |
253 return "$_$units[0]"; |
274 return "$_$units[0]"; |
254 } |
275 } |
255 |
276 |
|
277 sub deslash { $_[0] =~ s{/+}{/}gr } |
|
278 |
256 sub confirm { |
279 sub confirm { |
|
280 my ($base, $mimetype) = @_; |
257 print header(-charset => "UTF-8"), |
281 print header(-charset => "UTF-8"), |
258 start_html(-title => "once"), |
282 start_html(-title => "once"), |
259 h1 "Download bestätigen"; |
283 h1 "Download bestätigen"; |
260 print hr, p <<__; |
284 print hr, p <<__; |
261 Die Datei, die Sie herunterladen möchten, wird nach Abschluß des |
285 Die Datei `$base' ($mimetype), die Sie herunterladen möchten, wird nach Abschluß des |
262 Downloads gelöscht. Virenscanner oder andere Programme, die den Link |
286 Downloads gelöscht. Virenscanner oder andere Programme, die den Link |
263 möglicherweise automatisiert aufrufen, könnten eine versehentliche |
287 möglicherweise automatisiert aufrufen, könnten eine versehentliche |
264 Löschung der Datei auslösen. Bestätigen Sie deshalb bitte den Download |
288 Löschung der Datei auslösen. Bestätigen Sie deshalb bitte den Download |
265 per Knopfdruck. |
289 per Knopfdruck. |
266 __ |
290 __ |