equal
deleted
inserted
replaced
27 # TODO: Security review! |
27 # TODO: Security review! |
28 |
28 |
29 use 5.018; |
29 use 5.018; |
30 use strict; |
30 use strict; |
31 use warnings; |
31 use warnings; |
32 use CGI qw(:all *table); |
32 use IO::File; |
|
33 use CGI qw(param upload); |
33 use CGI::Carp qw(fatalsToBrowser); |
34 use CGI::Carp qw(fatalsToBrowser); |
34 use CGI::Pretty; |
|
35 use IO::File; |
|
36 use FindBin qw($RealBin); |
35 use FindBin qw($RealBin); |
37 use File::Basename; |
36 use File::Basename; |
38 use File::Path qw(remove_tree make_path); |
37 use File::Path qw(remove_tree make_path); |
39 use File::Spec::Functions; |
38 use File::Spec::Functions; |
40 use File::MimeInfo qw(mimetype); |
39 use File::MimeInfo qw(mimetype); |
48 sub confirm; # ask for user confirmation (HTML) |
47 sub confirm; # ask for user confirmation (HTML) |
49 sub deslash; # cleanup a path name |
48 sub deslash; # cleanup a path name |
50 sub gen_uuid; # create a uniq identifier |
49 sub gen_uuid; # create a uniq identifier |
51 sub base62; |
50 sub base62; |
52 sub md5_base62 { ... } |
51 sub md5_base62 { ... } |
|
52 sub untaint; |
53 |
53 |
54 my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i; # date-userhash |
54 my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i; # date-userhash |
55 my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-./i; # date-filehash-deletemode |
55 my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-./i; # date-filehash-deletemode |
56 |
56 |
57 my $TT_CONFIG = |
57 my $TT_CONFIG = |
61 umask 077; |
61 umask 077; |
62 |
62 |
63 # The working (var) directory gets passed to us via ONCE_VAR environment |
63 # The working (var) directory gets passed to us via ONCE_VAR environment |
64 # FIXME: Should we allow the current directory as an alternative? |
64 # FIXME: Should we allow the current directory as an alternative? |
65 |
65 |
66 my $ONCE_VAR = do { |
66 die "Environment ONCE_VAR needs to be defined\n" |
67 $ENV{ONCE_VAR} =~ /^(\/\S+)/; |
67 if not defined $ENV{ONCE_VAR}; |
68 die "Please define (correct) env ONCE_VAR\n" |
68 my $ONCE_VAR = untaint($ENV{ONCE_VAR}, qr((^/.*)));; |
69 if not defined $1; |
|
70 $1; |
|
71 }; |
|
72 |
69 |
73 exit main() if not caller; |
70 exit main() if not caller; |
74 |
71 |
75 sub main { |
72 sub main { |
|
73 |
|
74 |
|
75 # Handle the UPLOAD / VIEW request |
|
76 # per view (user) we have an own directory |
|
77 |
|
78 # pre condition checks |
|
79 -d $ONCE_VAR |
|
80 or mkdir $ONCE_VAR => 0777 |
|
81 or die "Can't mkdir $ONCE_VAR: $! (your admin should have created it)\n"; |
|
82 |
|
83 -x -w $ONCE_VAR |
|
84 or die "Can't write to $ONCE_VAR: $!\n"; |
76 |
85 |
77 # Download? |
86 # Download? |
78 # PATH_INFO is something like |
87 # PATH_INFO is something like |
79 # /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot |
88 # /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot |
80 # |-VIEW-----| |-BASE-| |
89 # |-VIEW-----| |-BASE-| |
110 } |
119 } |
111 exit 0; |
120 exit 0; |
112 |
121 |
113 } |
122 } |
114 |
123 |
115 # Handle the UPLOAD / VIEW request |
124 # Setup the essentials: view and user_dir |
116 # per view (user) we have an own directory |
|
117 |
|
118 # pre condition checks |
|
119 -d $ONCE_VAR |
|
120 or mkdir $ONCE_VAR => 0777 |
|
121 or die "Can't mkdir $ONCE_VAR: $! (your admin should have created it)\n"; |
|
122 |
|
123 -x -w $ONCE_VAR |
|
124 or die "Can't write to $ONCE_VAR: $!\n"; |
|
125 |
|
126 my ($view, $user_dir) = do { |
125 my ($view, $user_dir) = do { |
127 |
126 |
128 # view: display name |
127 # view: display name |
129 # anonymous | hans | … |
128 # anonymous | hans | … |
130 # user_dir: the directory name, becomes part of the |
129 # user_dir: the directory name, becomes part of the |
155 $v = 'anonymous'; |
154 $v = 'anonymous'; |
156 } |
155 } |
157 $v, deslash catfile($ONCE_VAR, $d); |
156 $v, deslash catfile($ONCE_VAR, $d); |
158 }; |
157 }; |
159 |
158 |
|
159 # Handle the removal request and we're done |
160 if (param('delete') =~ m{(?<store>(?<view>$rxVIEW)/$rxFILE/?)}) { |
160 if (param('delete') =~ m{(?<store>(?<view>$rxVIEW)/$rxFILE/?)}) { |
161 |
161 |
162 # FIXME: sanitization |
162 # FIXME: sanitization |
163 my $store = deslash catfile $ONCE_VAR, $+{store}; |
163 my $store = deslash catfile $ONCE_VAR, $+{store}; |
164 my $view = deslash catfile $ONCE_VAR, $+{view}; |
164 my $view = deslash catfile $ONCE_VAR, $+{view}; |
169 } |
169 } |
170 |
170 |
171 # save the uploaded file |
171 # save the uploaded file |
172 |
172 |
173 if (length(my $file = param('upload'))) { |
173 if (length(my $file = param('upload'))) { |
|
174 my $upload_fh = upload('upload'); |
174 my $uuid = gen_uuid(); |
175 my $uuid = gen_uuid(); |
175 my ($delete, $expires, $days) = do { |
176 my ($delete, $expires, $days) = do { |
176 my ($d, $e); |
177 my ($d, $e); |
177 my $days = param('expires'); |
178 my $days = param('expires') // 0; |
178 |
179 |
179 # sanitize expires |
180 # sanitize expires |
180 $days =~ /.*?([+-]?\d+).*/; |
181 $days =~ /.*?([+-]?\d+).*/; |
181 $days = $1 // 10; |
182 $days = $1 // 10; |
182 $e = base62 time + $days * 86400; |
183 $e = base62 time + $days * 86400; |
194 $1; |
195 $1; |
195 }; |
196 }; |
196 |
197 |
197 my $dir = catfile($user_dir, "$expires-$uuid-$delete"); |
198 my $dir = catfile($user_dir, "$expires-$uuid-$delete"); |
198 make_path($dir); |
199 make_path($dir); |
199 my $outfh = new IO::File "$dir/$filename", 'w' |
200 { |
200 or die "Can't create $dir/$filename: $!\n"; |
201 my $outfh = new IO::File "$dir/$filename", 'w' |
201 print {$outfh} <$file>; |
202 or die "Can't create $dir/$filename: $!\n"; |
|
203 print {$outfh} <$upload_fh>; |
|
204 } |
202 |
205 |
203 if (not $delete ~~ [qw(d m)] |
206 if (not $delete ~~ [qw(d m)] |
204 and my $atfh = new IO::File("|at now + $days days")) |
207 and my $atfh = new IO::File("|at now + $days days")) |
205 { |
208 { |
206 print {$atfh} |
209 print {$atfh} |
334 } |
337 } |
335 unshift @result, $digits->[$n]; |
338 unshift @result, $digits->[$n]; |
336 join '', @result; |
339 join '', @result; |
337 } |
340 } |
338 |
341 |
|
342 sub untaint { |
|
343 my ($_, $rx) = (@_, qr((\w+))); |
|
344 /$rx/; |
|
345 die sprintf("%s:%s:%d: untaint('%s', %s): not defined\n", caller, $_, $rx) |
|
346 if not defined $1; |
|
347 return $1; |
|
348 } |
|
349 |
339 sub gen_uuid { |
350 sub gen_uuid { |
340 |
351 |
341 #open my $f, '/dev/urandom' or croak; |
352 #open my $f, '/dev/urandom' or croak; |
342 #read $f, my($_), 128/8; |
353 #read $f, my($_), 128/8; |
343 #/^(.*)$/; |
354 #/^(.*)$/; |