26 use CGI qw(:all *table); |
26 use CGI qw(:all *table); |
27 use CGI::Carp qw(fatalsToBrowser); |
27 use CGI::Carp qw(fatalsToBrowser); |
28 use CGI::Pretty; |
28 use CGI::Pretty; |
29 use IO::File; |
29 use IO::File; |
30 use File::Basename; |
30 use File::Basename; |
|
31 use File::MimeInfo qw(mimetype); |
|
32 use Cwd qw(getcwd realpath); |
31 use Digest::MD5 qw(md5_hex); |
33 use Digest::MD5 qw(md5_hex); |
32 use OSSP::uuid; |
34 use OSSP::uuid; |
33 |
35 |
34 my $DIR = "d/{view}"; |
36 my $DIR = "d"; |
35 my $DIR_URI = "/xfer/$DIR"; |
37 my $DIR_URI = "/xfer/$DIR"; |
36 |
38 |
37 sub human($); |
39 sub human($); |
|
40 sub deletedir(@); |
38 |
41 |
39 delete @ENV{ grep /PATH/, keys %ENV }; |
42 delete @ENV{ grep /PATH/, keys %ENV }; |
40 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin"; |
43 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin"; |
41 |
44 |
42 $_ = dirname $DIR; |
45 $_ = dirname $DIR; |
43 -d or mkdir $_ => 0750 |
46 -d or mkdir $_ => 0750 |
44 or die "Can't mkdir $_: $!\n"; |
47 or die "Can't mkdir $_: $!\n"; |
45 |
48 |
46 MAIN: { |
49 MAIN: { |
47 |
50 |
|
51 # assuming download request |
|
52 if (request_uri =~ m|^\Q$DIR_URI\E/(.+)$|) { |
|
53 # assuming $DIR relative to cwd |
|
54 my $relative = $1; |
|
55 my $base = getcwd; |
|
56 my $absolute; |
|
57 unless ($absolute = realpath "$base/$DIR/$relative") { |
|
58 die "Can't realpath '$base/$DIR/$relative': $!" unless exists $!{ENOENT} and $!{ENOENT}; |
|
59 print header('text/plain', '404 Not found'); |
|
60 print "Not found"; |
|
61 exit 0; |
|
62 } |
|
63 $absolute =~ m|^\Q$base/$DIR\E| or die "invalid path: [$absolute]"; |
|
64 |
|
65 open F, '<', $absolute or die "Can't open '<', '$absolute': $!"; |
|
66 print header(-type => mimetype($absolute)); |
|
67 my ($buf, $res); |
|
68 print $buf while $res = read F, $buf, 32*2**10; |
|
69 defined $res or die "Can't read: $!"; |
|
70 |
|
71 (my $dir = $relative) =~ s|/[^/]+$||; |
|
72 deletedir $dir if $dir =~ /-d$/; |
|
73 exit 0; |
|
74 |
|
75 } |
|
76 |
48 # per view we have an own directory |
77 # per view we have an own directory |
49 |
78 |
50 $ENV{REMOTE_USER} =~ /(.*)/; |
79 $ENV{REMOTE_USER} =~ /(.*)/; |
51 $_ = md5_hex($1); |
80 $_ = md5_hex($1); |
52 $DIR =~ s/{view}/$_/g; |
81 $DIR .= "/$_"; |
53 $DIR_URI =~ s/{view}/$_/g; |
82 $DIR_URI .= "/$_"; |
54 -d $DIR |
83 -d $DIR |
55 or mkdir $DIR => 0750 |
84 or mkdir $DIR => 0750 |
56 or die "Can't mkdir $DIR: $!\n"; |
85 or die "Can't mkdir $DIR: $!\n"; |
57 |
86 |
58 if (param("delete") =~ /([-a-z\d]+-\d+)/i) { |
87 if (param("delete") =~ /([-a-z\d]+-\d+-.)/i) { |
59 my $dir = $1; |
88 deletedir $1; |
60 if (-d "$DIR/$dir") { |
|
61 unlink map { /(.*)/ && $1 } glob("$DIR/$dir/*") |
|
62 or die "Can't unlink $DIR/$dir/*: $!\n"; |
|
63 rmdir "$DIR/$dir" or die "Can't rmdir $DIR/$dir: $!\n"; |
|
64 } |
|
65 print redirect(-uri => url(-path_info => 1)); |
89 print redirect(-uri => url(-path_info => 1)); |
66 exit 0; |
90 exit 0; |
67 } |
91 } |
68 |
92 |
69 print header(-charset => "UTF-8"), |
93 print header(-charset => "UTF-8"), |
72 |
96 |
73 # print Dump; |
97 # print Dump; |
74 |
98 |
75 if (length(my $file = param("upload"))) { |
99 if (length(my $file = param("upload"))) { |
76 my $days = param("expires"); |
100 my $days = param("expires"); |
77 my $expires; |
101 my ($delete, $expires); |
78 tie my $uuid => "OSSP::uuid::tie", "v4"; |
102 tie my $uuid => "OSSP::uuid::tie", "v4"; |
79 |
103 |
80 # sanitize expires |
104 # sanitize expires |
81 $days =~ /.*?(\d+).*/; |
105 $days =~ /.*?([+-]?\d+).*/; |
82 $days = defined $1 ? $1 : 10; |
106 $days = defined $1 ? $1 : 10; |
|
107 |
83 $expires = time + $days * 86400; |
108 $expires = time + $days * 86400; |
|
109 $delete = 'l'; # on file[l]ist |
|
110 if ($days == 0) { |
|
111 $delete = 'd'; # on first [d]ownload |
|
112 } elsif ($days == -1) { |
|
113 $delete = 'm'; # only [m]anually |
|
114 } |
84 |
115 |
85 # sanitizing the filename |
116 # sanitizing the filename |
86 (my $filename = $file) =~ tr /\\/\//; |
117 (my $filename = $file) =~ tr /\\/\//; |
87 $filename =~ /(.*)/; |
118 $filename =~ /(.*)/; |
88 $filename = $1; |
119 $filename = $1; |
89 |
120 |
90 my $dir = "$DIR/$uuid-$expires"; |
121 my $dir = "$DIR/$uuid-$expires-$delete"; |
91 mkdir $dir, 0750 or die "Can't mkdir $dir: $!\n"; |
122 mkdir $dir, 0750 or die "Can't mkdir $dir: $!\n"; |
92 my $outfh = new IO::File ">$dir/$filename" |
123 my $outfh = new IO::File ">$dir/$filename" |
93 or die "Can't create $dir/$filename: $!\n"; |
124 or die "Can't create $dir/$filename: $!\n"; |
94 print {$outfh} <$file>; |
125 print {$outfh} <$file>; |
95 |
126 |
123 foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$DIR/*-*/*") { |
154 foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$DIR/*-*/*") { |
124 my ($file, $dir) = fileparse($_); |
155 my ($file, $dir) = fileparse($_); |
125 $dir = basename $dir; |
156 $dir = basename $dir; |
126 |
157 |
127 # $dir =~ /(?<hash>\S+)-(?<expires>\d+)$/ or next; |
158 # $dir =~ /(?<hash>\S+)-(?<expires>\d+)$/ or next; |
128 $dir =~ /(\S+)-(\d+)$/ or next; |
159 $dir =~ /(\S+)-(\d+)-(.)$/ or next; |
129 my $hash = $1; |
160 my ($hash, $expires, $delete) = ($1, $2, $3); |
130 my $expires = $2; |
161 if (${expires} <= time and $delete eq 'l') { |
131 if (${expires} <= time) { |
|
132 /(.*)/; |
162 /(.*)/; |
133 unlink $_ or die "Can't unlik $_: $!\n"; |
163 unlink $_ or die "Can't unlik $_: $!\n"; |
134 rmdir $dir or die "Can't rmdir $dir: $!\n"; |
164 rmdir $dir or die "Can't rmdir $dir: $!\n"; |
135 next; |
165 next; |
136 } |
166 } |
137 |
167 |
138 print Tr( |
168 print Tr( |
139 td(a { href => "$DIR_URI/$dir/$file" }, $file), |
169 td(a { href => "$DIR_URI/$dir/$file" }, $file), |
140 td({ align => "right" }, human((stat $_)[7])), |
170 td({ align => "right" }, human((stat $_)[7])), |
141 td(scalar localtime +(stat $_)[9]), |
171 td(scalar localtime +(stat $_)[9]), |
142 td(scalar localtime ${expires}), |
172 td($delete eq 'l' ? scalar localtime ${expires} : 'nicht verfügbar'), |
143 td(a({ href => "?delete=$dir" }, "remove")) |
173 td(a({ href => "?delete=$dir" }, "remove")) |
144 ); |
174 ); |
145 } |
175 } |
146 |
176 |
147 print end_table, hr; |
177 print end_table, hr; |
150 print start_multipart_form, start_table, |
180 print start_multipart_form, start_table, |
151 Tr(td("Dateiname: "), |
181 Tr(td("Dateiname: "), |
152 td(filefield(-name => "upload", -default => "nothing")), |
182 td(filefield(-name => "upload", -default => "nothing")), |
153 ), |
183 ), |
154 Tr(td("Löschen in: "), td(textfield(-name => "expires", -default => 10)), |
184 Tr(td("Löschen in: "), td(textfield(-name => "expires", -default => 10)), |
155 td("Tagen")), |
185 td("Tagen (0: beim ersten Download; -1: nur manuell)")), |
156 Tr(td(), td(submit(-value => "Hochladen")),), |
186 Tr(td(), td(submit(-value => "Hochladen")),), |
157 end_table, |
187 end_table, |
158 end_multipart_form; |
188 end_multipart_form; |
159 |
189 |
160 print hr, |
190 print hr, |
168 a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann") |
198 a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann") |
169 ), |
199 ), |
170 end_html; |
200 end_html; |
171 } |
201 } |
172 |
202 |
|
203 sub deletedir(@) { |
|
204 for my $dir (@_) { |
|
205 if (-d "$DIR/$dir") { |
|
206 unlink map { /(.*)/ && $1 } glob("$DIR/$dir/*") |
|
207 or die "Can't unlink $DIR/$dir/*: $!\n"; |
|
208 rmdir "$DIR/$dir" or die "Can't rmdir $DIR/$dir: $!\n"; |
|
209 } |
|
210 } |
|
211 } |
|
212 |
173 sub human($) { |
213 sub human($) { |
174 my $_ = shift; |
214 my $_ = shift; |
175 my @units = qw(B K M G T); |
215 my @units = qw(B K M G T); |
176 while (length int > 3 and @units) { |
216 while (length int > 3 and @units) { |
177 $_ = sprintf "%.1f" => $_ / 1024; |
217 $_ = sprintf "%.1f" => $_ / 1024; |