reguser.cgi: error instead of die on bad user name
[girocco.git] / Girocco / Util.pm
blobd0dde00c467b5af3cba48fbbf14280d869df3cd6
1 package Girocco::Util;
3 use strict;
4 use warnings;
6 use Girocco::Config;
7 use Time::Local;
9 BEGIN {
10 use base qw(Exporter);
11 our @EXPORT = qw(scrypt jailed_file
12 lock_file unlock_file valid_tag rand_adjust
13 filedb_atomic_append filedb_atomic_edit filedb_grep
14 filedb_atomic_grep valid_email valid_email_multi
15 valid_repo_url valid_web_url url_base url_path
16 projects_html_list parse_rfc2822_date parse_any_date);
20 sub scrypt {
21 my ($pwd) = @_;
22 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
25 sub jailed_file {
26 my ($filename) = @_;
27 $filename =~ s,^/,,;
28 $Girocco::Config::chroot."/$filename";
31 sub lock_file {
32 my ($path) = @_;
34 $path .= '.lock';
36 use Errno qw(EEXIST);
37 use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
38 use IO::Handle;
39 my $handle = new IO::Handle;
41 unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
42 my $cnt = 0;
43 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
44 ($! == EEXIST) or die "$path open failed: $!";
45 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
46 sleep(1);
49 # XXX: filedb-specific
50 chmod 0664, $path or die "$path g+w failed: $!";
52 $handle;
55 sub unlock_file {
56 my ($path, $noreplace) = @_;
58 if (!$noreplace) {
59 rename "$path.lock", $path or die "$path unlock failed: $!";
60 } else {
61 unlink "$path.lock" or die "$path unlock failed: $!";
65 sub filedb_atomic_append {
66 my ($file, $line) = @_;
67 my $id = 65536;
69 open my $src, '<', $file or die "$file open for reading failed: $!";
70 my $dst = lock_file($file);
72 while (<$src>) {
73 my $aid = (split /:/)[2];
74 $id = $aid + 1 if ($aid >= $id);
76 print $dst $_ or die "$file(l) write failed: $!";
79 $line =~ s/\\i/$id/g;
80 print $dst "$line\n" or die "$file(l) write failed: $!";
82 close $dst or die "$file(l) close failed: $!";
83 close $src;
85 unlock_file($file);
87 $id;
90 sub filedb_atomic_edit {
91 my ($file, $fn) = @_;
93 open my $src, '<', $file or die "$file open for reading failed: $!";
94 my $dst = lock_file($file);
96 while (<$src>) {
97 print $dst $fn->($_) or die "$file(l) write failed: $!";
100 close $dst or die "$file(l) close failed: $!";
101 close $src;
103 unlock_file($file);
106 sub filedb_atomic_grep {
107 my ($file, $fn) = @_;
108 my @results = ();
110 open my $src, '<', $file or die "$file open for reading failed: $!";
111 my $dst = lock_file($file);
113 while (<$src>) {
114 my $result = $fn->($_);
115 push(@results, $result) if $result;
118 close $dst or die "$file(l) close failed: $!";
119 close $src;
121 unlock_file($file, 1);
122 return @results;
125 sub filedb_grep {
126 my ($file, $fn) = @_;
127 my @results = ();
129 open my $src, '<', $file or die "$file open for reading failed: $!";
131 while (<$src>) {
132 my $result = $fn->($_);
133 push(@results, $result) if $result;
136 close $src;
138 return @results;
141 sub valid_email {
142 local $_ = $_[0];
143 /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
145 sub valid_email_multi {
146 local $_ = $_[0];
147 # More relaxed, we just want to avoid too dangerous characters.
148 /^[a-zA-Z0-9+._, @-]+$/;
150 sub valid_web_url {
151 local $_ = $_[0];
152 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
154 sub valid_repo_url {
155 local $_ = $_[0];
156 /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
158 my %_badtags;
159 BEGIN {
160 %_badtags = (
161 about=>1, after=>1, all=>1, also=>1, an=>1, and=>1, another=>1, any=>1,
162 are=>1, as=>1, at=>1, be=>1, because=>1, been=>1, before=>1, being=>1,
163 between=>1, both=>1, but=>1, by=>1, came=>1, can=>1, come=>1, could=>1,
164 did=>1, do=>1, each=>1, for=>1, from=>1, get=>1, got=>1, had=>1, has=>1,
165 have=>1, he=>1, her=>1, here=>1, him=>1, himself=>1, his=>1, how=>1,
166 if=>1, in=>1, into=>1, is=>1, it=>1, like=>1, make=>1, many=>1, me=>1,
167 might=>1, more=>1, most=>1, much=>1, must=>1, my=>1, never=>1, now=>1,
168 of=>1, on=>1, only=>1, or=>1, other=>1, our=>1, out=>1, over=>1,
169 said=>1, same=>1, see=>1, should=>1, since=>1, some=>1, still=>1,
170 such=>1, take=>1, than=>1, that=>1, the=>1, their=>1, them=>1, then=>1,
171 there=>1, these=>1, they=>1, this=>1, those=>1, through=>1, to=>1,
172 too=>1, under=>1, up=>1, very=>1, was=>1, way=>1, we=>1, well=>1,
173 were=>1, what=>1, where=>1, which=>1, while=>1, who=>1, with=>1,
174 would=>1, you=>1, your=>1
177 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
178 # letter, must not be a noise word and except for 'C' must be more than one
179 # character long and no more than 32 characters long.
180 sub valid_tag {
181 local $_ = $_[0] || '';
182 return 1 if $_ eq 'C'; # Currently only allowed single letter tag
183 return 0 unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
184 return 0 if $_badtags{lc($_)};
185 return length($_) <= 32 ? 1 : 0;
188 # If the passed in argument looks like a URL, return only the stuff up through
189 # the host:port part otherwise return the entire argument.
190 sub url_base {
191 my $url = shift || '';
192 # See RFC 3968
193 $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
194 ( // ) # // separator
195 ((?:[^\@]+\@)?) # optional userinfo
196 ( [^/?#]+ ) # host and port
197 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
198 return $url;
201 # If the passed in argument looks like a URL, return only the stuff following
202 # the host:port part otherwise return the entire argument.
203 sub url_path {
204 my $url = shift || '';
205 # See RFC 3968
206 $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
207 (?: // ) # // separator
208 (?: [^\@]+\@ )? # optional userinfo
209 (?: [^/?#]+ ) # host and port
210 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
211 return $url;
214 sub _escapeHTML {
215 my $str = shift;
216 $str =~ s/\&/\&amp;/gs;
217 $str =~ s/\</\&lt;/gs;
218 $str =~ s/\>/\&gt;/gs;
219 $str =~ s/\"/\&quot;/gs; #"
220 return $str;
223 # create relative time string from passed in age in seconds
224 sub _rel_age {
225 my $age = shift;
226 my $age_str;
228 if ($age > 60*60*24*365*2) {
229 $age_str = (int $age/60/60/24/365);
230 $age_str .= " years ago";
231 } elsif ($age > 60*60*24*(365/12)*2) {
232 $age_str = int $age/60/60/24/(365/12);
233 $age_str .= " months ago";
234 } elsif ($age > 60*60*24*7*2) {
235 $age_str = int $age/60/60/24/7;
236 $age_str .= " weeks ago";
237 } elsif ($age > 60*60*24*2) {
238 $age_str = int $age/60/60/24;
239 $age_str .= " days ago";
240 } elsif ($age > 60*60*2) {
241 $age_str = int $age/60/60;
242 $age_str .= " hours ago";
243 } elsif ($age > 60*2) {
244 $age_str = int $age/60;
245 $age_str .= " mins ago";
246 } elsif ($age > 2) {
247 $age_str = int $age;
248 $age_str .= " secs ago";
249 } elsif ($age >= 0) {
250 $age_str = "right now";
251 } else {
252 $age_str = "future time";
254 return $age_str;
257 # create relative time string from passed in idle in seconds
258 sub _rel_idle {
259 my $idle_str = _rel_age(shift);
260 $idle_str =~ s/ ago//;
261 $idle_str = "not at all" if $idle_str eq "right now";
262 return $idle_str;
265 sub _strftime {
266 use POSIX qw(strftime);
267 my ($fmt, $secs, $zonesecs) = @_;
268 my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
269 $zonesecs = int($zonesecs / 60);
270 $fmt =~ s/%z/\$z/g;
271 my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
272 my $z;
273 if ($zonesecs < 0) {
274 $z = "-";
275 $zonesecs = -$zonesecs;
276 } else {
277 $z = "+";
279 $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
280 $ans =~ s/\$z/$z/g;
281 return $ans;
284 # Take a list of project names and produce a nicely formated table that
285 # includes owner links and descriptions. If the list is empty returns ''.
286 # The first argument may be a hash ref that contains options. The following
287 # options are available:
288 # target -- sets the target value of the owner link
289 # emptyok -- if true returns an empty table rather than ''
290 # typecol -- if true include type column with hover info
291 # changed -- if true include a changed and idle column
292 sub projects_html_list {
293 my $options = {};
294 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
295 $options = shift;
297 return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
298 require Girocco::Project;
299 my $count = 0;
300 my $target = '';
301 $target = " target=\""._escapeHTML($options->{target})."\""
302 if defined($options->{target});
303 my $withtype = defined($options->{typecol}) && $options->{typecol};
304 my $withchanged = defined($options->{changed}) && $options->{changed};
305 my $typehead = '';
306 $typehead = '<th>Type</th>' if $withtype;
307 my $chghead = '';
308 $chghead = substr(<<EOT, 0, -1) if $withchanged;
309 <th><span class="hover">Changed<span><span class="head">Changed</span
310 />The last time a ref change was received by this site.</span></span></th
311 ><th><span class="hover">Idle<span><span class="head">Idle</span
312 />The most recent committer time in <i>refs/heads</i>.</span></span></th
315 my $html = <<EOT;
316 <table class='projectlist'><tr><th>Project</th>$typehead$chghead<th class="desc">Description</th></tr>
318 my $trclass = ' class="odd"';
319 foreach (sort({lc($a) cmp lc($b)} @_)) {
320 if (Girocco::Project::does_exist($_, 1)) {
321 my $proj = Girocco::Project->load($_);
322 my $projname = $proj->{name}.".git";
323 my $projdesc = $proj->{desc}||'';
324 utf8::decode($projdesc) if utf8::valid($projdesc);
325 my $typecol = '';
326 if ($withtype) {
327 if ($proj->{mirror}) {
328 $typecol = substr(<<EOT, 0, -1);
329 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
331 } else {
332 my $users = @{$proj->{users}};
333 $users .= ' user';
334 $users .= 's' unless @{$proj->{users}} == 1;
335 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
336 my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
337 $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
338 <td class="type"><span class="hover">$users<span$spncls>$userlist</span></span></td>
340 <td class="type">$users</td>
344 my $changecol = '';
345 if ($withchanged) {
346 my $rel = '';
347 my $changetime = $proj->{lastchange};
348 if ($changetime) {
349 $rel = "<span class=\"hover\">" .
350 _rel_age(time - parse_rfc2822_date($changetime)) .
351 "<span class=\"nowrap\">$changetime</span></span>";
352 } else {
353 $rel = "no commits";
355 $changecol = substr(<<EOT, 0, -1);
356 <td class="change">$rel</td>
358 my $idletime = $proj->{lastactivity};
359 my ($idlesecs, $tz);
360 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
361 if ($idlesecs) {
362 my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
363 $rel = "<span class=\"hover\">" .
364 _rel_idle(time - $idlesecs) .
365 "<span class=\"nowrap\">$idle2822</span></span>";
366 } else {
367 $rel = "no commits";
369 $changecol .= substr(<<EOT, 0, -1);
370 <td class="idle">$rel</td>
373 $html .= <<EOT;
374 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
375 >@{[_escapeHTML($projname)]}</td>$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
377 $trclass = $trclass ? '' : ' class="odd"';
378 ++$count;
381 $html .= <<EOT;
382 </table>
384 return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
387 my %_month_names;
388 BEGIN {
389 %_month_names = (
390 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
391 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
395 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
396 # The leading "%a, " is optional, returns undef if unrecognized date. This is also known as
397 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
398 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
399 sub parse_rfc2822_date {
400 my $dstr = shift || '';
401 my $tzoff = shift || '';
402 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
403 return undef unless $dstr =~
404 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
405 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
406 my $m = $_month_names{lc($b)};
407 return undef unless defined($m);
408 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
409 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
410 $offset = -$offset if substr($z,0,1) eq '-';
411 $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
412 return $seconds - $offset;
415 # Will parse any supported date format. Actually there are three formats
416 # currently supported:
417 # 1. RFC 2822 (uses parse_rfc2822_date)
418 # 2. RFC 3339 / ISO 8601 (T may be ' ', 'Z' is optional, ':' optional in TZ)
419 # 3. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
420 # Returns undef if unsupported date.
421 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
422 sub parse_any_date {
423 my $dstr = shift || '';
424 my $tzoff = shift || '';
425 if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
426 # Unix timestamp
427 my $ts = 0 + $1;
428 my $off = 0;
429 if ($2) {
430 my $z = $2;
431 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
432 $off = -$off if substr($z,0,1) eq '-';
434 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
435 return $ts;
437 if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt ](\d{2}):(\d{2}):(\d{2})(?:[ ]([Zz]|(?:[-+]\d{2}:?\d{2})))?\s*$/) {
438 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
439 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
440 $z =~ s/://;
441 my $off = 0;
442 if (uc($z) ne 'Z') {
443 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
444 $off = -$off if substr($z,0,1) eq '-';
446 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
447 return $seconds - $off;
449 return parse_rfc2822_date($dstr, $tzoff);
452 # Input is a number such as a minute interval
453 # Return value is a random number between the input and 1.25*input
454 # This can be used to randomize the update and gc operations a bit to avoid
455 # having them all end up all clustered together
456 sub rand_adjust {
457 my $input = shift || 0;
458 return $input unless $input;
459 return $input + int(rand(0.25 * $input));