Girocco/Util.pm

   1 package Girocco::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Girocco::Config;
   7 use Time::Local;
   8
   9 BEGIN {
  10         use base qw(Exporter);
  11         our @EXPORT = qw(scrypt jailed_file
  12                          lock_file unlock_file
  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_path rand_adjust
  16                          projects_html_list parse_rfc2822_date parse_any_date);
  17 }
  18
  19
  20 sub scrypt {
  21         my ($pwd) = @_;
  22         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  23 }
  24
  25 sub jailed_file {
  26         my ($filename) = @_;
  27         $filename =~ s,^/,,;
  28         $Girocco::Config::chroot."/$filename";
  29 }
  30
  31 sub lock_file {
  32         my ($path) = @_;
  33
  34         $path .= '.lock';
  35
  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;
  40
  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);
  47                 }
  48         }
  49         # XXX: filedb-specific
  50         chmod 0664, $path or die "$path g+w failed: $!";
  51
  52         $handle;
  53 }
  54
  55 sub unlock_file {
  56         my ($path, $noreplace) = @_;
  57
  58         if (!$noreplace) {
  59                 rename "$path.lock", $path or die "$path unlock failed: $!";
  60         } else {
  61                 unlink "$path.lock" or die "$path unlock failed: $!";
  62         }
  63 }
  64
  65 sub filedb_atomic_append {
  66         my ($file, $line) = @_;
  67         my $id = 65536;
  68
  69         open my $src, '<', $file or die "$file open for reading failed: $!";
  70         my $dst = lock_file($file);
  71
  72         while (<$src>) {
  73                 my $aid = (split /:/)[2];
  74                 $id = $aid + 1 if ($aid >= $id);
  75
  76                 print $dst $_ or die "$file(l) write failed: $!";
  77         }
  78
  79         $line =~ s/\\i/$id/g;
  80         print $dst "$line\n" or die "$file(l) write failed: $!";
  81
  82         close $dst or die "$file(l) close failed: $!";
  83         close $src;
  84
  85         unlock_file($file);
  86
  87         $id;
  88 }
  89
  90 sub filedb_atomic_edit {
  91         my ($file, $fn) = @_;
  92
  93         open my $src, '<', $file or die "$file open for reading failed: $!";
  94         my $dst = lock_file($file);
  95
  96         while (<$src>) {
  97                 print $dst $fn->($_) or die "$file(l) write failed: $!";
  98         }
  99
 100         close $dst or die "$file(l) close failed: $!";
 101         close $src;
 102
 103         unlock_file($file);
 104 }
 105
 106 sub filedb_atomic_grep {
 107         my ($file, $fn) = @_;
 108         my @results = ();
 109
 110         open my $src, '<', $file or die "$file open for reading failed: $!";
 111         my $dst = lock_file($file);
 112
 113         while (<$src>) {
 114                 my $result = $fn->($_);
 115                 push(@results, $result) if $result;
 116         }
 117
 118         close $dst or die "$file(l) close failed: $!";
 119         close $src;
 120
 121         unlock_file($file, 1);
 122         return @results;
 123 }
 124
 125 sub filedb_grep {
 126         my ($file, $fn) = @_;
 127         my @results = ();
 128
 129         open my $src, '<', $file or die "$file open for reading failed: $!";
 130
 131         while (<$src>) {
 132                 my $result = $fn->($_);
 133                 push(@results, $result) if $result;
 134         }
 135
 136         close $src;
 137
 138         return @results;
 139 }
 140
 141 sub valid_email {
 142         $_ = $_[0];
 143         /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 144 }
 145 sub valid_email_multi {
 146         $_ = $_[0];
 147         # More relaxed, we just want to avoid too dangerous characters.
 148         /^[a-zA-Z0-9+._, @-]+$/;
 149 }
 150 sub valid_web_url {
 151         $_ = $_[0];
 152         /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 153 }
 154 sub valid_repo_url {
 155         $_ = $_[0];
 156         /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 157 }
 158
 159 # If the passed in argument looks like a URL, return only the stuff following
 160 # the host:port part otherwise return the entire argument.
 161 sub url_path {
 162         my $url = shift || '';
 163         # See RFC 3968
 164         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 165                 (?: // )        # // separator
 166                 (?: [^\@]+\@ )? # optional userinfo
 167                 (?: [^/?#]+ )   # host and port
 168                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 169         return $url;
 170 }
 171
 172 sub _escapeHTML {
 173         my $str = shift;
 174         $str =~ s/\&/\&amp;/gs;
 175         $str =~ s/\</\&lt;/gs;
 176         $str =~ s/\>/\&gt;/gs;
 177         $str =~ s/\"/\&quot;/gs; #"
 178         return $str;
 179 }
 180
 181 # create relative time string from passed in age in seconds
 182 sub _rel_age {
 183         my $age = shift;
 184         my $age_str;
 185
 186         if ($age > 60*60*24*365*2) {
 187                 $age_str = (int $age/60/60/24/365);
 188                 $age_str .= " years ago";
 189         } elsif ($age > 60*60*24*(365/12)*2) {
 190                 $age_str = int $age/60/60/24/(365/12);
 191                 $age_str .= " months ago";
 192         } elsif ($age > 60*60*24*7*2) {
 193                 $age_str = int $age/60/60/24/7;
 194                 $age_str .= " weeks ago";
 195         } elsif ($age > 60*60*24*2) {
 196                 $age_str = int $age/60/60/24;
 197                 $age_str .= " days ago";
 198         } elsif ($age > 60*60*2) {
 199                 $age_str = int $age/60/60;
 200                 $age_str .= " hours ago";
 201         } elsif ($age > 60*2) {
 202                 $age_str = int $age/60;
 203                 $age_str .= " mins ago";
 204         } elsif ($age > 2) {
 205                 $age_str = int $age;
 206                 $age_str .= " secs ago";
 207         } elsif ($age >= 0) {
 208                 $age_str = "right now";
 209         } else {
 210                 $age_str = "future time";
 211         }
 212         return $age_str;
 213 }
 214
 215 # create relative time string from passed in idle in seconds
 216 sub _rel_idle {
 217         my $idle_str = _rel_age(shift);
 218         $idle_str =~ s/ ago//;
 219         $idle_str = "not at all" if $idle_str eq "right now";
 220         return $idle_str;
 221 }
 222
 223 sub _strftime {
 224         use POSIX qw(strftime);
 225         my ($fmt, $secs, $zonesecs) = @_;
 226         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 227         $zonesecs = int($zonesecs / 60);
 228         $fmt =~ s/%z/\$z/g;
 229         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 230         my $z;
 231         if ($zonesecs < 0) {
 232                 $z = "-";
 233                 $zonesecs = -$zonesecs;
 234         } else {
 235                 $z = "+";
 236         }
 237         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 238         $ans =~ s/\$z/$z/g;
 239         return $ans;
 240 }
 241
 242 # Take a list of project names and produce a nicely formated table that
 243 # includes owner links and descriptions.  If the list is empty returns ''.
 244 # The first argument may be a hash ref that contains options.  The following
 245 # options are available:
 246 #   target  -- sets the target value of the owner link
 247 #   emptyok -- if true returns an empty table rather than ''
 248 #   typecol -- if true include type column with hover info
 249 #   changed -- if true include a changed and idle column
 250 sub projects_html_list {
 251         my $options = {};
 252         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 253                 $options = shift;
 254         }
 255         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 256         require Girocco::Project;
 257         my $count = 0;
 258         my $target = '';
 259         $target = " target=\""._escapeHTML($options->{target})."\""
 260                 if defined($options->{target});
 261         my $withtype = defined($options->{typecol}) && $options->{typecol};
 262         my $withchanged = defined($options->{changed}) && $options->{changed};
 263         my $typehead = '';
 264         $typehead = '<th>Type</th>' if $withtype;
 265         my $chghead = '';
 266         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 267 <th><span class="hover">Changed<span><span class="head">Changed</span
 268 />The last time a ref change was received by this site.</span></span></th
 269 ><th><span class="hover">Idle<span><span class="head">Idle</span
 270 />The most recent committer time in <i>refs/heads</i>.</span></span></th
 271 >
 272 EOT
 273         my $html = <<EOT;
 274 <table class='projectlist'><tr><th>Project</th>$typehead$chghead<th class="desc">Description</th></tr>
 275 EOT
 276         my $trclass = ' class="odd"';
 277         foreach (sort({lc($a) cmp lc($b)} @_)) {
 278                 if (Girocco::Project::does_exist($_)) {
 279                         my $proj = Girocco::Project->load($_);
 280                         my $projname = $proj->{name}.".git";
 281                         my $projdesc = $proj->{desc}||'';
 282                         utf8::decode($projdesc) if utf8::valid($projdesc);
 283                         my $typecol = '';
 284                         if ($withtype) {
 285                                 if ($proj->{mirror}) {
 286                                         $typecol = substr(<<EOT, 0, -1);
 287 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
 288 EOT
 289                                 } else {
 290                                         my $users = @{$proj->{users}};
 291                                         $users .= ' user';
 292                                         $users .= 's' unless @{$proj->{users}} == 1;
 293                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 294                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 295                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 296 <td class="type"><span class="hover">$users<span$spncls>$userlist</span></span></td>
 297 EOT
 298 <td class="type">$users</td>
 299 EOT
 300                                 }
 301                         }
 302                         my $changecol = '';
 303                         if ($withchanged) {
 304                                 my $rel = '';
 305                                 my $changetime = $proj->{lastchange};
 306                                 if ($changetime) {
 307                                         $rel = "<span class=\"hover\">" .
 308                                                 _rel_age(time - parse_rfc2822_date($changetime)) .
 309                                                 "<span class=\"nowrap\">$changetime</span></span>";
 310                                 } else {
 311                                         $rel = "no commits";
 312                                 }
 313                                 $changecol = substr(<<EOT, 0, -1);
 314 <td class="change">$rel</td>
 315 EOT
 316                                 my $idletime = $proj->{lastactivity};
 317                                 my ($idlesecs, $tz);
 318                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 319                                 if ($idlesecs) {
 320                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 321                                         $rel = "<span class=\"hover\">" .
 322                                                 _rel_idle(time - $idlesecs) .
 323                                                 "<span class=\"nowrap\">$idle2822</span></span>";
 324                                 } else {
 325                                         $rel = "no commits";
 326                                 }
 327                                 $changecol .= substr(<<EOT, 0, -1);
 328 <td class="idle">$rel</td>
 329 EOT
 330                         }
 331                         $html .= <<EOT;
 332 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 333 >@{[_escapeHTML($projname)]}</td>$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 334 EOT
 335                         $trclass = $trclass ? '' : ' class="odd"';
 336                         ++$count;
 337                 }
 338         }
 339         $html .= <<EOT;
 340 </table>
 341 EOT
 342         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 343 }
 344
 345 my %_month_names;
 346 BEGIN {
 347         %_month_names = (
 348                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 349                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 350         );
 351 }
 352
 353 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 354 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 355 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 356 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 357 sub parse_rfc2822_date {
 358         my $dstr = shift || '';
 359         my $tzoff = shift || '';
 360         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 361         return undef unless $dstr =~
 362                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 363         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 364         my $m = $_month_names{lc($b)};
 365         return undef unless defined($m);
 366         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
 367         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 368         $offset = -$offset if substr($z,0,1) eq '-';
 369         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 370         return $seconds - $offset;
 371 }
 372
 373 # Will parse any supported date format.  Actually there are three formats
 374 # currently supported:
 375 #   1. RFC 2822 (uses parse_rfc2822_date)
 376 #   2. RFC 3339 / ISO 8601 (T may be ' ', 'Z' is optional, ':' optional in TZ)
 377 #   3. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 378 # Returns undef if unsupported date.
 379 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 380 sub parse_any_date {
 381         my $dstr = shift || '';
 382         my $tzoff = shift || '';
 383         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 384                 # Unix timestamp
 385                 my $ts = 0 + $1;
 386                 my $off = 0;
 387                 if ($2) {
 388                         my $z = $2;
 389                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 390                         $off = -$off if substr($z,0,1) eq '-';
 391                 }
 392                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 393                 return $ts;
 394         }
 395         if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt ](\d{2}):(\d{2}):(\d{2})(?:[ ]([Zz]|(?:[-+]\d{2}:?\d{2})))?\s*$/) {
 396                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 397                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
 398                 $z =~ s/://;
 399                 my $off = 0;
 400                 if (uc($z) ne 'Z') {
 401                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 402                         $off = -$off if substr($z,0,1) eq '-';
 403                 }
 404                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 405                 return $seconds - $off;
 406         }
 407         return parse_rfc2822_date($dstr, $tzoff);
 408 }
 409
 410 # Input is a number such as a minute interval
 411 # Return value is a random number between the input and 1.25*input
 412 # This can be used to randomize the update and gc operations a bit to avoid
 413 # having them all end up all clustered together
 414 sub rand_adjust {
 415         my $input = shift || 0;
 416         return $input unless $input;
 417         return $input + int(rand(0.25 * $input));
 418 }
 419
 420 1;