Girocco/Util.pm

   1 package Girocco::Util;
   2
   3 use 5.008;
   4 use strict;
   5 use warnings;
   6
   7 use Girocco::Config;
   8 use Girocco::ConfigUtil;
   9 use Girocco::TimedToken;
  10 use Girocco::ValidUtil;
  11 use Time::Local;
  12 use Scalar::Util qw(looks_like_number);
  13 use Encode ();
  14
  15 BEGIN {
  16         use base qw(Exporter);
  17         our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
  18                          lock_file unlock_file valid_tag rand_adjust
  19                          filedb_atomic_append filedb_atomic_edit filedb_grep
  20                          filedb_atomic_grep valid_email valid_email_multi
  21                          valid_repo_url valid_web_url url_base url_path url_server
  22                          projects_html_list parse_rfc2822_date parse_any_date
  23                          extract_url_hostname is_dns_hostname is_our_hostname
  24                          get_cmd online_cpus sys_pagesize sys_memsize
  25                          calc_windowmemory to_utf8 capture_command human_size
  26                          calc_bigfilethreshold has_reserved_suffix human_duration
  27                          noFatalsToBrowser calc_redeltathreshold
  28                          clean_email_multi read_HEAD_symref read_config_file
  29                          read_config_file_hash is_git_dir git_bool util_path
  30                          is_shellish read_HEAD_ref git_add_config to_json
  31                          json_bool from_json ref_indicator get_token_key
  32                          get_timed_token get_token_field check_timed_token
  33                          valid_branch_name);
  34 }
  35
  36 BEGIN {require "Girocco/extra/capture_command.pl"}
  37
  38 # Return the entire output sent to stdout from running a command
  39 # Any output the command sends to stderr is discarded
  40 # Returns undef if there was an error running the command (see $!)
  41 sub get_cmd {
  42         my ($status, $result) = capture_command(1, undef, @_);
  43         return defined($status) && $status == 0 ? $result : undef;
  44 }
  45
  46 # Same as get_cmd except configured git binary is automatically provided
  47 # as the first argument to get_cmd
  48 sub get_git {
  49         return get_cmd($Girocco::Config::git_bin, @_);
  50 }
  51
  52 sub scrypt {
  53         my ($pwd) = @_;
  54         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  55 }
  56
  57 sub jailed_file {
  58         my ($filename) = @_;
  59         $filename =~ s,^/,,;
  60         $Girocco::Config::chroot."/$filename";
  61 }
  62
  63 sub lock_file {
  64         my ($path) = @_;
  65
  66         $path .= '.lock';
  67
  68         use Errno qw(EEXIST);
  69         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
  70         use IO::Handle;
  71         my $handle = new IO::Handle;
  72
  73         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  74                 my $cnt = 0;
  75                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  76                         ($! == EEXIST) or die "$path open failed: $!";
  77                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
  78                         sleep(1);
  79                 }
  80         }
  81         # XXX: filedb-specific
  82         chmod 0664, $path or die "$path g+w failed: $!";
  83
  84         $handle;
  85 }
  86
  87 sub _is_passwd_file {
  88         return defined($_[0]) && $_[0] eq jailed_file('/etc/passwd');
  89 }
  90
  91 sub _run_update_pwd_db {
  92         my ($path, $updatearg) = @_;
  93         my @cmd = ($Girocco::Config::basedir.'/bin/update-pwd-db', "$path");
  94         push(@cmd, $updatearg) if $updatearg;
  95         system(@cmd) == 0 or die "update-pwd-db failed: $?";
  96 }
  97
  98 sub unlock_file {
  99         my ($path, $noreplace, $updatearg) = @_;
 100
 101         if (!$noreplace) {
 102                 _run_update_pwd_db("$path.lock", $updatearg)
 103                         if $Girocco::Config::update_pwd_db && _is_passwd_file($path);
 104                 rename "$path.lock", $path or die "$path unlock failed: $!";
 105         } else {
 106                 unlink "$path.lock" or die "$path unlock failed: $!";
 107         }
 108 }
 109
 110 sub filedb_atomic_append {
 111         my ($file, $line, $updatearg) = @_;
 112         my $id = 65536;
 113
 114         open my $src, '<', $file or die "$file open for reading failed: $!";
 115         my $dst = lock_file($file);
 116
 117         while (<$src>) {
 118                 my $aid = (split /:/)[2];
 119                 $id = $aid + 1 if ($aid >= $id);
 120
 121                 print $dst $_ or die "$file(l) write failed: $!";
 122         }
 123
 124         $line =~ s/\\i/$id/g;
 125         print $dst "$line\n" or die "$file(l) write failed: $!";
 126
 127         close $dst or die "$file(l) close failed: $!";
 128         close $src;
 129
 130         unlock_file($file, 0, $updatearg);
 131
 132         $id;
 133 }
 134
 135 sub filedb_atomic_edit {
 136         my ($file, $fn, $updatearg) = @_;
 137
 138         open my $src, '<', $file or die "$file open for reading failed: $!";
 139         my $dst = lock_file($file);
 140
 141         while (<$src>) {
 142                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 143         }
 144
 145         close $dst or die "$file(l) close failed: $!";
 146         close $src;
 147
 148         unlock_file($file, 0, $updatearg);
 149 }
 150
 151 sub filedb_atomic_grep {
 152         my ($file, $fn) = @_;
 153         my @results = ();
 154
 155         open my $src, '<', $file or die "$file open for reading failed: $!";
 156         my $dst = lock_file($file);
 157
 158         while (<$src>) {
 159                 my $result = $fn->($_);
 160                 push(@results, $result) if $result;
 161         }
 162
 163         close $dst or die "$file(l) close failed: $!";
 164         close $src;
 165
 166         unlock_file($file, 1);
 167         return @results;
 168 }
 169
 170 sub filedb_grep {
 171         my ($file, $fn) = @_;
 172         my @results = ();
 173
 174         open my $src, '<', $file or die "$file open for reading failed: $!";
 175
 176         while (<$src>) {
 177                 my $result = $fn->($_);
 178                 push(@results, $result) if $result;
 179         }
 180
 181         close $src;
 182
 183         return @results;
 184 }
 185
 186 sub valid_email {
 187         my $email = shift;
 188         defined($email) or $email = '';
 189         return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 190 }
 191
 192 sub clean_email_multi {
 193         my $input = shift;
 194         defined($input) or $input = '';
 195         $input =~ s/^\s+//; $input =~ s/\s+$//;
 196         my %seen = ();
 197         my @newlist = ();
 198         foreach (split(/\s*,\s*/, $input)) {
 199                 next if $_ eq "";
 200                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 201         }
 202         return join(",", @newlist);
 203 }
 204
 205 sub valid_email_multi {
 206         # each email address must be a valid_email but we silently
 207         # ignore extra spaces at the beginning/end and around any comma(s)
 208         foreach (split(/,/, clean_email_multi(shift))) {
 209                 return 0 unless valid_email($_);
 210         }
 211         return 1;
 212 }
 213
 214 sub valid_web_url {
 215         my $url = shift;
 216         defined($url) or $url = '';
 217         return $url =~
 218                 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 219 }
 220
 221 sub valid_repo_url {
 222         my $url = shift || '';
 223         # Currently neither username nor password is allowed in the URL (except for svn)
 224         # and IPv6 literal addresses are not accepted either.
 225         $Girocco::Config::mirror_svn &&
 226                 $url =~ /^svn(\+https?)?:\/\/([^\@\/\s]+\@)?[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 227                 and return 1;
 228         $Girocco::Config::mirror_darcs &&
 229                 $url =~ /^darcs(?:\+https?)?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 230                 and return 1;
 231         $Girocco::Config::mirror_bzr &&
 232                 $url =~ /^bzr:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 233                 and return 1;
 234         $Girocco::Config::mirror_hg &&
 235                 $url =~ /^hg\+https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 236                 and return 1;
 237         return $url =~  /^(https?|git):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/;
 238 }
 239
 240 sub extract_url_hostname {
 241         my $url = shift || '';
 242         if ($url =~ m,^bzr://,) {
 243                 $url =~ s,^bzr://,,;
 244                 return 'launchpad.net' if $url =~ /^lp:/;
 245         }
 246         return undef unless $url =~ m,^[A-Za-z0-9+.-]+://[^/],;
 247         $url =~ s,^[A-Za-z0-9+.-]+://,,;
 248         $url =~ s,^([^/]+).*$,$1,;
 249         $url =~ s/:[0-9]*$//;
 250         $url =~ s/^[^\@]*[\@]//;
 251         return $url ? $url : undef;
 252 }
 253
 254 # See these RFCs:
 255 #   RFC 1034 section 3.5
 256 #   RFC 1123 section 2.1
 257 #   RFC 1738 section 3.1
 258 #   RFC 2606 sections 2 & 3
 259 #   RFC 3986 section 3.2.2
 260 sub is_dns_hostname {
 261         my $host = shift;
 262         defined($host) or $host = '';
 263         return 0 if $host eq '' || $host =~ /\s/;
 264         # first remove a trailing '.'
 265         $host =~ s/\.$//;
 266         return 0 if length($host) > 255;
 267         my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
 268         return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
 269         my @labels = split(/[.]/, $host, -1);
 270         return 0 unless @labels && @labels >= $Girocco::Config::min_dns_labels;
 271         # now check each label
 272         foreach my $label (@labels) {
 273                 return 0 unless length($label) > 0 && length($label) <= 63;
 274                 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
 275         }
 276         # disallow RFC 2606 names provided at least two labels are present
 277         if (@labels >= 2) {
 278                 my $tld = lc($labels[-1]);
 279                 return 0 if
 280                     $tld eq 'test' ||
 281                     $tld eq 'example' ||
 282                     $tld eq 'invalid' ||
 283                     $tld eq 'localhost';
 284                 my $sld = lc($labels[-2]);
 285                 return 0 if $sld eq 'example' &&
 286                     ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
 287         }
 288         return 1;
 289 }
 290
 291 sub is_our_hostname {
 292         my $test = shift || '';
 293         $test =~ s/\.$//;
 294         my %names = ();
 295         my @urls = (
 296                 $Girocco::Config::gitweburl,
 297                 $Girocco::Config::gitwebfiles,
 298                 $Girocco::Config::webadmurl,
 299                 $Girocco::Config::bundlesurl,
 300                 $Girocco::Config::htmlurl,
 301                 $Girocco::Config::httppullurl,
 302                 $Girocco::Config::httpbundleurl,
 303                 $Girocco::Config::httpspushurl,
 304                 $Girocco::Config::gitpullurl,
 305                 $Girocco::Config::pushurl
 306         );
 307         foreach my $url (@urls) {
 308                 if ($url) {
 309                         my $host = extract_url_hostname($url);
 310                         if (defined($host)) {
 311                                 $host =~ s/\.$//;
 312                                 $names{lc($host)} = 1;
 313                         }
 314                 }
 315         }
 316         return $names{lc($test)} ? 1 : 0;
 317 }
 318
 319 my (%_oktags, %_badtags, %_canontags, $_canontagscreated, @_whitetags);
 320 BEGIN {
 321         # These are always okay (a "whitelist") even if they would
 322         # otherwise not be allowed
 323         @_whitetags = (qw(
 324                 .net 2d 3d 6502 68000 68008 68010 68020 68030 68040 68060
 325                 8086 80286 80386 80486 80586 c cc make www x
 326         ));
 327         map({$_oktags{lc($_)}=1} @_whitetags, @Girocco::Config::allowed_tags);
 328         # entries MUST be all lowercase to be effective
 329         %_badtags = (
 330         # These are "nonsense" or pointless tags
 331         about=>1, after=>1, all=>1, also=>1, an=>1, and=>1, another=>1, any=>1,
 332         are=>1, as=>1, at=>1, be=>1, because=>1, been=>1, before=>1, being=>1,
 333         between=>1, both=>1, but=>1, by=>1, came=>1, can=>1, come=>1, could=>1,
 334         did=>1, do=>1, each=>1, for=>1, from=>1, get=>1, got=>1, had=>1, has=>1,
 335         have=>1, he=>1, her=>1, here=>1, him=>1, himself=>1, his=>1, how=>1,
 336         if=>1, in=>1, into=>1, is=>1, it=>1, like=>1, make=>1, many=>1, me=>1,
 337         might=>1, more=>1, most=>1, much=>1, must=>1, my=>1, never=>1, now=>1,
 338         of=>1, oh=>1, on=>1, only=>1, or=>1, other=>1, our=>1, out=>1, over=>1,
 339         said=>1, same=>1, see=>1, should=>1, since=>1, some=>1, still=>1,
 340         such=>1, take=>1, than=>1, that=>1, the=>1, their=>1, them=>1, then=>1,
 341         there=>1, these=>1, they=>1, this=>1, those=>1, through=>1, to=>1,
 342         too=>1, under=>1, up=>1, very=>1, was=>1, way=>1, we=>1, well=>1,
 343         were=>1, what=>1, where=>1, which=>1, while=>1, who=>1, with=>1,
 344         would=>1, yea=>1, yeah=>1, you=>1, your=>1, yup=>1
 345         );
 346         # These are "offensive" tags with at least one letter escaped to
 347         # avoid having this file trigger various safe-scan robots
 348         $_badtags{"a\x73\x73"} = 1;
 349         $_badtags{"a\x73\x73hole"} = 1;
 350         $_badtags{"b\x30\x30b"} = 1;
 351         $_badtags{"b\x30\x30bs"} = 1;
 352         $_badtags{"b\x6f\x6fb"} = 1;
 353         $_badtags{"b\x6f\x6fbs"} = 1;
 354         $_badtags{"b\x75tt"} = 1;
 355         $_badtags{"b\x75ttd\x69\x63k"} = 1;
 356         $_badtags{"c\x6f\x63k"} = 1;
 357         $_badtags{"c\x75\x6e\x74"} = 1;
 358         $_badtags{"d\x69\x63k"} = 1;
 359         $_badtags{"d\x69\x63kb\x75tt"} = 1;
 360         $_badtags{"f\x75\x63k"} = 1;
 361         $_badtags{"in\x63\x65st"} = 1;
 362         $_badtags{"ph\x75\x63k"} = 1;
 363         $_badtags{"p\x6f\x72n"} = 1;
 364         $_badtags{"p\x6f\x72no"} = 1;
 365         $_badtags{"p\x6f\x72nographic"} = 1;
 366         $_badtags{"p\x72\x30n"} = 1;
 367         $_badtags{"p\x72\x6fn"} = 1;
 368         $_badtags{"r\x61\x70e"} = 1;
 369         $_badtags{"s\x65\x78"} = 1;
 370         map({$_badtags{lc($_)}=1} @Girocco::Config::blocked_tags);
 371 }
 372
 373 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
 374 # letter, must not be a noise word, must be more than one character long,
 375 # must not be a repeated letter and must be no more than 32 characters long.
 376 # However, anything in %_oktags is explicitly allowed even if it otherwise
 377 # would violate the rules (except that none of [,\s\\\/] are allowed in tags).
 378 # Returns the canonical name for the tag if the tag is valid otherwise undef.
 379 sub valid_tag {
 380         local $_ = $_[0];
 381         return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
 382         my $fold = $Girocco::Config::foldtags;
 383         if ($fold && !$_canontagscreated) {
 384                 local $_;
 385                 %_canontags = ();
 386                 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config::allowed_tags);
 387                 $_canontagscreated = 1;
 388         }
 389         return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
 390         return ($fold ? lc($_) : $_) if $_oktags{lc($_)};
 391         return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
 392         return undef if $_badtags{lc($_)};
 393         return undef if /^(.)\1+$/;
 394         return length($_) <= 32 ? ($fold ? lc($_) : $_) : undef;
 395 }
 396
 397 # If the passed in argument looks like a URL, return only the stuff up through
 398 # the host:port part otherwise return the entire argument.
 399 sub url_base {
 400         my $url = shift || '';
 401         # See RFC 3968
 402         $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 403                 ( // )          # // separator
 404                 ((?:[^\@]+\@)?) # optional userinfo
 405                 ( [^/?#]+ )     # host and port
 406                 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
 407         return $url;
 408 }
 409
 410 # If the passed in argument looks like a URL, return only the stuff following
 411 # the host:port part otherwise return the entire argument.
 412 # If the optional second argument is true, the returned value will have '/'
 413 # appended if it does not already end in '/'.
 414 sub url_path {
 415         my $url = shift || '';
 416         my $add_slash = shift || 0;
 417         # See RFC 3968
 418         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 419                 (?: // )        # // separator
 420                 (?: [^\@]+\@ )? # optional userinfo
 421                 (?: [^/?#]+ )   # host and port
 422                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 423         $url .= '/' if $add_slash && $url !~ m|/$|;
 424         return $url;
 425 }
 426
 427 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
 428 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
 429 # return it.  If a something that doesn't look like it could be the start of a
 430 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
 431 # then just return the argument unchanged.
 432 sub url_server {
 433         my $url = shift || '';
 434         my $path = url_path($url);
 435         return $url unless $path eq '' || $path =~ m|^[/?#]|;
 436         return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
 437                 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
 438         return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
 439         my $server = $ENV{'SERVER_NAME'};
 440         # Deal with Apache bug where IPv6 literal server names do not include
 441         # the required surrounding '[' and ']' characters
 442         $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
 443         my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
 444         my $portnum = 0 + $ENV{'SERVER_PORT'};
 445         my $port = '';
 446         if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
 447                 $port = ':' . $portnum;
 448         }
 449         return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
 450 }
 451
 452 # Returns the number rounded to the nearest tenths.  The ".d" part will be
 453 # excluded if it's ".0" unless the optional second argument is true
 454 sub _tenths {
 455         my $v = shift;
 456         my $use0 = shift;
 457         $v *= 10;
 458         $v += 0.5;
 459         $v = int($v);
 460         return '' . int($v/10) unless $v % 10 || $use0;
 461         return '' . int($v/10) . '.' . ($v%10);
 462 }
 463
 464 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
 465 # (in bytes) passed in.  Returns '0' for undefined or 0 or not all digits.
 466 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
 467 # nearest tenths of a KiB, MiB or GiB.
 468 sub human_size {
 469         my $v = shift || 0;
 470         return "0" unless $v && $v =~ /^\d+$/;
 471         return "1 KiB" unless $v > 1024;
 472         $v /= 1024;
 473         return _tenths($v) . " KiB" if $v < 1024;
 474         $v /= 1024;
 475         return _tenths($v) . " MiB" if $v < 1024;
 476         $v /= 1024;
 477         return _tenths($v) . " GiB";
 478 }
 479
 480 # Returns a human duration string (e.g. 1h10m5s for the value (in secs)
 481 # passed in.  Returns the value unchanged if it's not defined or <= 0.
 482 sub human_duration {
 483         my $secs = shift;
 484         return $secs unless defined($secs) && $secs >= 0;
 485         $secs = int($secs);
 486         my $ans = ($secs % 60) . 's';
 487         return $ans if $secs < 60;
 488         $secs = int($secs / 60);
 489         $ans = ($secs % 60) . 'm' . $ans;
 490         return $ans if $secs < 60;
 491         $secs = int($secs / 60);
 492         $ans = ($secs % 24) . 'h' . $ans;
 493         return $ans if $secs < 24;
 494         $secs = int($secs / 24);
 495         return $secs . 'd' . $ans;
 496 }
 497
 498 sub _escapeHTML {
 499         my $str = shift;
 500         $str =~ s/\&/\&amp;/gs;
 501         $str =~ s/\</\&lt;/gs;
 502         $str =~ s/\>/\&gt;/gs;
 503         $str =~ s/\"/\&quot;/gs; #"
 504         return $str;
 505 }
 506
 507 # create relative time string from passed in age in seconds
 508 sub _rel_age {
 509         my $age = shift;
 510         my $age_str;
 511
 512         if ($age > 60*60*24*365*2) {
 513                 $age_str = (int $age/60/60/24/365);
 514                 $age_str .= " years ago";
 515         } elsif ($age > 60*60*24*(365/12)*2) {
 516                 $age_str = int $age/60/60/24/(365/12);
 517                 $age_str .= " months ago";
 518         } elsif ($age > 60*60*24*7*2) {
 519                 $age_str = int $age/60/60/24/7;
 520                 $age_str .= " weeks ago";
 521         } elsif ($age > 60*60*24*2) {
 522                 $age_str = int $age/60/60/24;
 523                 $age_str .= " days ago";
 524         } elsif ($age > 60*60*2) {
 525                 $age_str = int $age/60/60;
 526                 $age_str .= " hours ago";
 527         } elsif ($age > 60*2) {
 528                 $age_str = int $age/60;
 529                 $age_str .= " mins ago";
 530         } elsif ($age > 2) {
 531                 $age_str = int $age;
 532                 $age_str .= " secs ago";
 533         } elsif ($age >= 0) {
 534                 $age_str = "right now";
 535         } else {
 536                 $age_str = "future time";
 537         }
 538         return $age_str;
 539 }
 540
 541 # create relative time string from passed in idle in seconds
 542 sub _rel_idle {
 543         my $idle_str = _rel_age(shift);
 544         $idle_str =~ s/ ago//;
 545         $idle_str = "not at all" if $idle_str eq "right now";
 546         return $idle_str;
 547 }
 548
 549 sub _strftime {
 550         use POSIX qw(strftime);
 551         my ($fmt, $secs, $zonesecs) = @_;
 552         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 553         $zonesecs = int($zonesecs / 60);
 554         $fmt =~ s/%z/\$z/g;
 555         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 556         my $z;
 557         if ($zonesecs < 0) {
 558                 $z = "-";
 559                 $zonesecs = -$zonesecs;
 560         } else {
 561                 $z = "+";
 562         }
 563         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 564         $ans =~ s/\$z/$z/g;
 565         return $ans;
 566 }
 567
 568 # Take a list of project names and produce a nicely formated table that
 569 # includes owner links and descriptions.  If the list is empty returns ''.
 570 # The first argument may be a hash ref that contains options.  The following
 571 # options are available:
 572 #   target  -- sets the target value of the owner link
 573 #   emptyok -- if true returns an empty table rather than ''
 574 #   sizecol -- if true include a human-readable size column
 575 #   typecol -- if true include type column with hover info
 576 #   changed -- if true include a changed and idle column
 577 sub projects_html_list {
 578         my $options = {};
 579         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 580                 $options = shift;
 581         }
 582         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 583         require Girocco::Project;
 584         my $count = 0;
 585         my $target = '';
 586         $target = " target=\""._escapeHTML($options->{target})."\""
 587                 if defined($options->{target});
 588         my $withsize = defined($options->{sizecol}) && $options->{sizecol};
 589         my $withtype = defined($options->{typecol}) && $options->{typecol};
 590         my $withchanged = defined($options->{changed}) && $options->{changed};
 591         my $sizehead = '';
 592         $sizehead = substr(<<EOT, 0, -1) if $withsize;
 593 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
 594 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
 595 >
 596 EOT
 597         my $typehead = '';
 598         $typehead = '<th>Type</th>' if $withtype;
 599         my $chghead = '';
 600         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 601 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
 602 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
 603 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
 604 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
 605 >
 606 EOT
 607         my $html = <<EOT;
 608 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
 609 EOT
 610         my $trclass = ' class="odd"';
 611         foreach (sort({lc($a) cmp lc($b)} @_)) {
 612                 if (Girocco::Project::does_exist($_, 1)) {
 613                         my $proj = Girocco::Project->load($_);
 614                         my $projname = $proj->{name}.".git";
 615                         my $projdesc = $proj->{desc}||'';
 616                         utf8::decode($projdesc) if utf8::valid($projdesc);
 617                         my $sizecol = '';
 618                         if ($withsize) {
 619                                 my $psize = $proj->{reposizek};
 620                                 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
 621                                 $psize = 0 if !defined($psize) && $proj->is_empty;
 622                                 if (!defined($psize)) {
 623                                         $psize = 'unknown';
 624                                 } elsif (!$psize) {
 625                                         $psize = 'empty';
 626                                 } else {
 627                                         $psize = human_size($psize * 1024);
 628                                         $psize =~ s/ /\&#160;/g;
 629                                 }
 630                                 $sizecol = '<td class="sizecol">'.$psize.'</td>';
 631                         }
 632                         my $typecol = '';
 633                         if ($withtype) {
 634                                 if ($proj->{mirror}) {
 635                                         my $url = _escapeHTML($proj->{url});
 636                                         $typecol = substr(<<EOT, 0, -1);
 637 <td class="type"><span class="hover">mirror<span class="nowrap"><span class="before" _data="$url"><span class="none"> <a href="$url" rel="nofollow">(URL)</a></span></span></span></span></td>
 638 EOT
 639                                 } else {
 640                                         my $users = @{$proj->{users}};
 641                                         $users .= ' user';
 642                                         $users .= 's' unless @{$proj->{users}} == 1;
 643                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 644                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 645                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 646 <td class="type"><span class="hover">$users<span$spncls><br class="none" />$userlist</span></span></td>
 647 EOT
 648 <td class="type">$users</td>
 649 EOT
 650                                 }
 651                         }
 652                         my $changecol = '';
 653                         if ($withchanged) {
 654                                 my $rel = '';
 655                                 my $changetime = $proj->{lastchange};
 656                                 if ($changetime) {
 657                                         my ($ts, $tz);
 658                                         $ts = parse_rfc2822_date($changetime, \$tz);
 659                                         my $ct = _strftime("%Y-%m-%d %T %z", $ts, $tz);
 660                                         $rel = "<span class=\"hover\">" .
 661                                                 _rel_age(time - $ts) .
 662                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
 663                                 } else {
 664                                         $rel = "no commits";
 665                                 }
 666                                 $changecol = substr(<<EOT, 0, -1);
 667 <td class="change">$rel</td>
 668 EOT
 669                                 my $idletime = $proj->{lastactivity};
 670                                 my ($idlesecs, $tz);
 671                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 672                                 if ($idlesecs) {
 673                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 674                                         my $ct = _strftime("%Y-%m-%d %T %z", $idlesecs, $tz);
 675                                         $rel = "<span class=\"hover\">" .
 676                                                 _rel_idle(time - $idlesecs) .
 677                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
 678                                 } else {
 679                                         $rel = "no commits";
 680                                 }
 681                                 $changecol .= substr(<<EOT, 0, -1);
 682 <td class="idle">$rel</td>
 683 EOT
 684                         }
 685                         $html .= <<EOT;
 686 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 687 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 688 EOT
 689                         $trclass = $trclass ? '' : ' class="odd"';
 690                         ++$count;
 691                 }
 692         }
 693         $html .= <<EOT;
 694 </table>
 695 EOT
 696         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 697 }
 698
 699 my %_month_names;
 700 BEGIN {
 701         %_month_names = (
 702                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 703                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 704         );
 705 }
 706
 707 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 708 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 709 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 710 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 711 sub parse_rfc2822_date {
 712         my $dstr = shift || '';
 713         my $tzoff = shift || '';
 714         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 715         return undef unless $dstr =~
 716                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 717         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 718         my $m = $_month_names{lc($b)};
 719         return undef unless defined($m);
 720         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, 0+$Y);
 721         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 722         $offset = -$offset if substr($z,0,1) eq '-';
 723         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 724         return $seconds - $offset;
 725 }
 726
 727 # Will parse any supported date format.  Actually there are three formats
 728 # currently supported:
 729 #   1. RFC 2822 (uses parse_rfc2822_date)
 730 #   2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
 731 #   3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
 732 #   4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 733 # Returns undef if unsupported date.
 734 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 735 sub parse_any_date {
 736         my $dstr = shift || '';
 737         my $tzoff = shift || '';
 738         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 739                 # Unix timestamp
 740                 my $ts = 0 + $1;
 741                 my $off = 0;
 742                 if ($2) {
 743                         my $z = $2;
 744                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 745                         $off = -$off if substr($z,0,1) eq '-';
 746                 }
 747                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 748                 return $ts;
 749         }
 750         if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt _](\d{1,2}):(\d{2}):(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{1,2}:?\d{2})))?\s*$/ ||
 751             $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
 752                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 753                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, 0+$Y);
 754                 defined($z) && $z ne '' or $z = 'Z';
 755                 $z = uc($z);
 756                 $z =~ s/://;
 757                 substr($z,1,0) = '0' if length($z) == 4;
 758                 my $off = 0;
 759                 if ($z ne 'Z' && $z ne 'UTC') {
 760                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 761                         $off = -$off if substr($z,0,1) eq '-';
 762                 }
 763                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 764                 return $seconds - $off;
 765         }
 766         return parse_rfc2822_date($dstr, $tzoff);
 767 }
 768
 769 # Input is a number such as a minute interval
 770 # Return value is a random number between the input and 1.25*input
 771 # This can be used to randomize the update and gc operations a bit to avoid
 772 # having them all end up all clustered together
 773 sub rand_adjust {
 774         my $input = shift || 0;
 775         return $input unless $input;
 776         return $input + int(rand(0.25 * $input));
 777 }
 778
 779 # Open a pipe to a new sendmail process.  The '-i' option is always passed to
 780 # the new process followed by any addtional arguments passed in.  Note that
 781 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
 782 # options.  Using any other options via this function is not guaranteed to work.
 783 # A list of recipients may follow the options.  Combining a list of recipients
 784 # with the '-t' option is not recommended.
 785 sub sendmail_pipe {
 786         return undef unless @_;
 787         die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
 788                 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
 789         my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
 790         return $result ? $pipe : undef;
 791 }
 792
 793 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
 794 # if the first argument is '-s', a subject line will be automatically added
 795 # (using the second argument as the subject).  Any remaining arguments are
 796 # expected to be recipient addresses that will be added to an explicit To:
 797 # line as well as passed on to sendmail_pipe.  In addition an
 798 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
 799 # "From:" header.
 800 sub mailer_pipe {
 801         my $subject = undef;
 802         if (@_ >= 2 && $_[0] eq '-s') {
 803                 shift;
 804                 $subject = shift;
 805         }
 806         my $tolist = join(", ", @_);
 807         unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
 808         my $pipe = sendmail_pipe(@_);
 809         if ($pipe) {
 810                 print $pipe "From: \"$Girocco::Config::name\" ",
 811                         "($Girocco::Config::title) ",
 812                         "<$Girocco::Config::admin>\n";
 813                 print $pipe "To: $tolist\n";
 814                 print $pipe "Subject: $subject\n" if defined($subject);
 815                 print $pipe "MIME-Version: 1.0\n";
 816                 print $pipe "Content-Type: text/plain; charset=utf-8; format=fixed\n";
 817                 print $pipe "Content-Transfer-Encoding: 8bit\n";
 818                 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
 819                         unless $Girocco::Config::suppress_x_girocco;
 820                 print $pipe "Auto-Submitted: auto-generated\n";
 821                 print $pipe "\n";
 822         }
 823         return $pipe;
 824 }
 825
 826 sub _goodval {
 827         my $val = shift;
 828         return undef unless defined($val);
 829         $val =~ s/[\r\n]+$//s;
 830         return undef unless $val =~ /^\d+$/;
 831         $val = 0 + $val;
 832         return undef unless $val >= 1;
 833         return $val;
 834 }
 835
 836 # Returns the number of "online" cpus or undef if undetermined
 837 sub online_cpus {
 838         my @confcpus = $^O eq "linux" ?
 839                 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
 840                 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
 841         my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
 842         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 843         $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
 844         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 845         if ($^O ne "linux") {
 846                 my @sysctls = qw(hw.ncpu);
 847                 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
 848                 foreach my $mib (@sysctls) {
 849                         $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
 850                         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 851                 }
 852         }
 853         return undef;
 854 }
 855
 856 # Returns the system page size in bytes or undef if undetermined
 857 # This should never fail on a POSIX system
 858 sub sys_pagesize {
 859         use POSIX ":unistd_h";
 860         my $pagesize = sysconf(_SC_PAGESIZE);
 861         return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
 862         $pagesize = 0 + $pagesize;
 863         return undef unless $pagesize >= 256;
 864         return $pagesize;
 865 }
 866
 867 # Returns the amount of available physical memory in bytes
 868 # This may differ from the actual amount of physical memory installed
 869 # Returns undef if this cannot be determined
 870 sub sys_memsize {
 871         my $pagesize = sys_pagesize;
 872         if ($pagesize && $^O eq "linux") {
 873                 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
 874                 return $pagesize * $pages if $pages;
 875         }
 876         if ($^O ne "linux") {
 877                 my @sysctls = qw(hw.physmem64);
 878                 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
 879                 foreach my $mib (@sysctls) {
 880                         my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
 881                         return $memsize if $memsize;
 882                 }
 883                 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
 884                 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
 885                 if ($pagesize) {
 886                         my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
 887                         return $pagesize * $pages if $pages;
 888                 }
 889                 return 2147483647 + 1 if $memsize32;
 890         }
 891         return undef;
 892 }
 893
 894 sub _get_max_conf_suffixed_size {
 895         my $conf = shift;
 896         return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
 897         my ($val, $suffix) = (0+$1, lc($2));
 898         $val *= 1024 if $suffix eq 'k';
 899         $val *= 1024 * 1024 if $suffix eq 'm';
 900         $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
 901         return $val;
 902 }
 903
 904 sub _make_suffixed_size {
 905         my $size = shift;
 906         return $size if $size % 1024;
 907         $size /= 1024;
 908         return "${size}k" if $size % 1024;
 909         $size /= 1024;
 910         return "${size}m" if $size % 1024;
 911         $size /= 1024;
 912         return "${size}g";
 913 }
 914
 915 # Return the value to pass to --window-memory= for git repack
 916 # If the system memory or number of CPUs cannot be determined, returns "1g"
 917 # Otherwise returns one third the available memory divided by the number of CPUs
 918 # but never more than 1 gigabyte or max_gc_window_memory_size.
 919 sub calc_windowmemory {
 920         my $cpus = online_cpus;
 921         my $memsize = sys_memsize;
 922         my $max = 1024 * 1024 * 1024;
 923         if ($cpus && $memsize) {
 924                 $max = int($memsize / 3 / $cpus);
 925                 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
 926         }
 927         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
 928         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 929         return _make_suffixed_size($max);
 930 }
 931
 932 # Return the value to set as core.bigFileThreshold for git repack
 933 # If the system memory cannot be determined, returns "256m"
 934 # Otherwise returns the available memory divided by 16
 935 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
 936 sub calc_bigfilethreshold {
 937         my $memsize = sys_memsize;
 938         my $max = 256 * 1024 * 1024;
 939         if ($memsize) {
 940                 $max = int($memsize / 16);
 941                 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
 942         }
 943         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
 944         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 945         return _make_suffixed_size($max);
 946 }
 947
 948 # Return the value to use when deciding whether or not to re-calculate object deltas
 949 # If there are no more than this many objects then deltas will be recomputed in
 950 # order to create more efficient pack files.  The new_delta_threshold value
 951 # is constrained to be at least 1000 * cpu cores and no more than 100000.
 952 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
 953 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
 954 # more than 100000 or less than 1000 * cpu cores.
 955 sub calc_redeltathreshold {
 956         my $cpus = online_cpus || 1;
 957         if (defined($Girocco::Config::new_delta_threshold) &&
 958             $Girocco::Config::new_delta_threshold =~ /^\d+/) {
 959                 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
 960                 if ($ndt >= $cpus * 1000) {
 961                         return $ndt <= 100000 ? $ndt : 100000;
 962                 }
 963         }
 964         my $calcval = 50000;
 965         my $memsize = sys_memsize;
 966         if ($memsize) {
 967                 my $quantum = 256 * 1024 * 1024;
 968                 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
 969                 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
 970                 $calcval = 100000 if $calcval > 100000;
 971         }
 972         return $calcval;
 973 }
 974
 975 # $1 => thing to test
 976 # $2 => optional directory, if given and -e "$2/$1$3", then return false
 977 # $3 => optional, defaults to ''
 978 sub has_reserved_suffix {
 979         no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
 980         my ($name, $dir, $ext) = @_;
 981         $ext = '' unless defined $ext;
 982         return 0 unless defined $name && $name =~ /\.([^.]+)$/;
 983         return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
 984         return 0 if defined $dir && -e "$dir/$name$ext";
 985         return 1;
 986 }
 987
 988 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
 989 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
 990 sub noFatalsToBrowser {
 991         delete $SIG{__DIE__};
 992         delete $SIG{__WARN__};
 993         undef *CORE::GLOBAL::die;
 994         *CORE::GLOBAL::die = sub {
 995                 no warnings;
 996                 my $ec = (0+$!) || ($? >> 8) || 255;
 997                 $ec != ($ec & 0xff) and $ec = 255;
 998                 $ec |= 128 if !(0+$!) && ($? & 0xff);
 999                 my (undef, $fn, $li) = caller(0);
1000                 my $loc = " at " . $fn . " line " . $li . ".\n";
1001                 my $msg = "";
1002                 $msg = join("", @_) if @_;
1003                 $msg = "Died" if $msg eq "";
1004                 $msg .= $loc unless $msg =~ /\n$/;
1005                 die $msg if $^S;
1006                 printf STDERR "%s", $msg;
1007                 exit($ec);
1008         };
1009         undef *CORE::GLOBAL::warn;
1010         *CORE::GLOBAL::warn = sub {
1011                 no warnings;
1012                 my (undef, $fn, $li) = caller(0);
1013                 my $loc = " at " . $fn . " line " . $li . ".\n";
1014                 my $msg = "";
1015                 $msg = join("", @_) if @_;
1016                 $msg = "Warning: something's wrong" if $msg eq "";
1017                 $msg .= $loc unless $msg =~ /\n$/;
1018                 printf STDERR "%s", $msg;
1019         };
1020 }
1021
1022 # mimics Git's symref reading but only for HEAD
1023 # returns undef on failure otherwise an string that is
1024 # either an all-hex (lowercase) value or starts with "refs/"
1025 sub read_HEAD_ref {
1026         my $headpath = $_[0] . "/HEAD";
1027         if (-l $headpath) {
1028                 my $rl = readlink($headpath);
1029                 return defined($rl) && $rl =~ m,^refs/[^\x00-\x1f \x7f~^:\\*?[]+$, ? $rl : undef;
1030         }
1031         open my $fd, '<', $headpath or return undef;
1032         my $hv;
1033         {
1034                 local $/ = undef;
1035                 $hv = <$fd>;
1036         }
1037         close $fd;
1038         defined($hv) or return undef;
1039         chomp $hv;
1040         $hv =~ m,^ref:\s*(refs/[^\x00-\x1f \x7f~^:\\*?[]+)$, and return $1;
1041         $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1042         return undef;
1043 }
1044
1045 # same as read_HEAD_ref but returns undef
1046 # unless the result starts with "refs/"
1047 sub read_HEAD_symref {
1048         my $hv = read_HEAD_ref(@_);
1049         return defined($hv) && $hv =~ m,^refs/., ? $hv : undef;
1050 }
1051
1052 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1053 sub is_git_dir {
1054         my $gd = shift;
1055         defined($gd) && $gd ne "" && -d $gd or return undef;
1056         -d "$gd/objects" && -x "$gd/objects" or return 0;
1057         -d "$gd/refs" && -x "$gd/refs" or return 0;
1058         if (-l "$gd/HEAD") {
1059                 my $rl = readlink("$gd/HEAD");
1060                 defined($rl) && $rl =~ m,^refs/., or return 0;
1061                 -e "$gd/HEAD" or return 1;
1062         }
1063         open my $fd, '<', "$gd/HEAD" or return 0;
1064         my $hv;
1065         {
1066                 local $/;
1067                 $hv = <$fd>;
1068         }
1069         close $fd;
1070         defined $hv or return 0;
1071         chomp $hv;
1072         $hv =~ m,^ref:\s*refs/., and return 1;
1073         return $hv =~ /^[0-9a-f]{40}/;
1074 }
1075
1076 # Returns a PATH properly prefixed which guarantees that Git is found and the
1077 # basedir/bin utilities are found as intended.  $ENV{PATH} is LEFT UNCHANGED!
1078 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1079 # arranging for it to be used.  If $ENV{PATH} already has the proper prefix
1080 # then it's returned as-is (making this function idempotent).
1081 # Will die if it cannot determine a suitable full PATH.
1082 # Result is cached so all calls after the first are practically free.
1083 my $var_git_exec_path;
1084 sub util_path {
1085         defined($Girocco::Config::var_git_exec_path) && $Girocco::Config::var_git_exec_path ne "" and
1086                 $var_git_exec_path = $Girocco::Config::var_git_exec_path;
1087         if (!defined($var_git_exec_path) || $var_git_exec_path eq "") {
1088                 defined($Girocco::Config::basedir) && $Girocco::Config::basedir ne "" &&
1089                 -d $Girocco::Config::basedir && -r _ && -x _ or
1090                         die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1091                 my $varsfile = $Girocco::Config::basedir . "/shlib_vars.sh";
1092                 if (-f $varsfile && -r _) {
1093                         my $vars;
1094                         if (open $vars, '<', $varsfile) {
1095                                 # last value for var_git_exec_path wins
1096                                 while (<$vars>) {
1097                                         chomp;
1098                                         substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1099                                         substr($_, -1, 1) eq "\"" or next;
1100                                         my $xd = substr($_, 19, -1);
1101                                         $var_git_exec_path = $xd if -d $xd && -r _ && -x _;
1102                                 }
1103                                 close $vars;
1104                         }
1105                 }
1106                 if (!defined($var_git_exec_path)) {
1107                         my $xd = get_git("--exec-path");
1108                         $var_git_exec_path = $xd if defined($xd) &&
1109                                 (chomp $xd, $xd) ne "" && -d $xd && -r _ && -x _;
1110                 }
1111                 defined($var_git_exec_path) && $var_git_exec_path ne "" or
1112                         die "could not determine \$(git --exec-path) value\n";
1113                 $var_git_exec_path = $1 if $var_git_exec_path =~ m|^(/.+)$|;
1114         }
1115         my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1116         if (substr($ENV{PATH}, 0, length($prefix)) eq $prefix) {
1117                 return $ENV{PATH};
1118         } else {
1119                 return $prefix . $ENV{PATH};
1120         }
1121 }
1122
1123 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1124 # but it has slightly different semantics in that whitespace does not automatically
1125 # make something "shellish".  The semantics used here more closely match Git's
1126 # semantics so that Girocco will provide an interpretation more similar to Git's.
1127 sub is_shellish {
1128         return unless defined(local $_ = shift);
1129         return 1 if m#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1130         return 0; # probably not shellish
1131 }
1132
1133 # Works just like the shlib.sh function git_add_config
1134 # except it takes two arguments, first the variable name, second the value
1135 # For example: git_add_config("gc.auto", "0")
1136 # No extra quoting is performed!
1137 # If the name or value requires special quoting, it must be provided by the caller!
1138 # Note this function will only be effective when running Git 1.7.3 or later
1139 sub git_add_config {
1140         my ($name, $val) = @_;
1141         defined($name) && defined($val) or return;
1142         $name ne "" or return;
1143         my $gcp = $ENV{GIT_CONFIG_PARAMETERS};
1144         defined($gcp) or $gcp = '';
1145         $gcp eq "" or $gcp = $gcp . " ";
1146         $gcp .= "'" . $name . '=' . $val . "'";
1147         $ENV{GIT_CONFIG_PARAMETERS} = $gcp;
1148 }
1149
1150 {
1151         package Girocco::Util::JSON::Boolean;
1152         use overload '""' => \&strval;
1153         sub new {
1154                 my $class = shift || __PACKAGE__;
1155                 my $val = shift;
1156                 return bless \$val, $class;
1157         }
1158         sub strval {
1159                 return ${$_[0]};
1160         }
1161 }
1162
1163 # returns a reference to a suitable object that will
1164 # encode to "true" or "false" when passed to to_json
1165 # based on the value passed to this function
1166 # For example, `print to_json(json_bool(1))` prints `true`.
1167 sub json_bool {
1168         return Girocco::Util::JSON::Boolean->new($_[0]);
1169 }
1170
1171 # returns a utf8 encoded result that strictly conforms to
1172 # the JSON standard aka RFC 8259.
1173 # first argument is a scalar or a ref to a SCALAR, ARRAY or HASH
1174 # second argument, if true, requests a "pretty" result
1175 sub to_json {
1176         my ($val, $prt) = @_;
1177         $prt = 1 if $prt && !looks_like_number($prt);
1178         $prt = 0 unless $prt;
1179         return _json_value($val, 0+$prt, "");
1180 }
1181
1182 sub _json_value {
1183         my ($val, $prt, $ndt) = @_;
1184         defined($val) or return "null";
1185         $val = $$val if ref($val) eq 'SCALAR';
1186         my $r = ref($val);
1187         $r eq 'HASH' and return _json_hash($val, $prt, $ndt);
1188         $r eq 'ARRAY' and return _json_array($val, $prt, $ndt);
1189         $r eq 'Girocco::Util::JSON::Boolean' and
1190                 return $val ? "true" : "false";
1191         $r ne '' and $val = "".$val;
1192         looks_like_number($val) and return "".(0+$val);
1193         return _json_str("".$val);
1194 }
1195
1196 my %json_esc; BEGIN {%json_esc=(
1197         '\\' => '\\\\',
1198         '"'  => '\"',
1199         "\b" => '\b',
1200         "\t" => '\t',
1201         "\n" => '\n',
1202         "\f" => '\f',
1203         "\r" => '\r'
1204 )}
1205
1206 sub _json_str {
1207         my $val = shift;
1208         Encode::is_utf8($val) and utf8::encode($val);
1209         $val =~ s/([\\\042\b\t\n\f\r])/$json_esc{$1}/go;
1210         $val =~ s/([\x00-\x1f])/sprintf("\\u%04X",ord($1))/goe;
1211         return '"'.$val.'"';
1212 }
1213
1214 sub _json_array {
1215         my ($val, $prt, $ndt) = @_;
1216         return '[]' unless @{$val};
1217         my $ans = "[";
1218         $ans .= "\n" if $prt;
1219         my $odt = $ndt;
1220         $ndt .= "  ";
1221         for (my $i = 0; $i <= $#{$val}; ++$i) {
1222                 $ans .= $ndt if $prt;
1223                 $ans .= _json_value(${$val}[$i], $prt, $ndt);
1224                 $ans .= "," if $i < $#{$val};
1225                 $ans .= "\n" if $prt;
1226         }
1227         $ndt = $odt;
1228         $ans .= $ndt if $prt;
1229         $ans .= "]";
1230         return $ans;
1231 }
1232
1233 sub _json_hash {
1234         my ($val, $prt, $ndt) = @_;
1235         return '{}' unless %{$val};
1236         my $ans = "{";
1237         $ans .= "\n" if $prt;
1238         my $odt = $ndt;
1239         $ndt .= "  ";
1240         my @keys = sort(keys(%{$val}));
1241         for (my $i = 0; $i <= $#keys; ++$i) {
1242                 $ans .= $ndt if $prt;
1243                 $ans .= _json_str("".$keys[$i]).":";
1244                 $ans .= " " if $prt;
1245                 $ans .= _json_value(${$val}{$keys[$i]}, $prt, $ndt);
1246                 $ans .= "," if $i < $#keys;
1247                 $ans .= "\n" if $prt;
1248         }
1249         $ndt = $odt;
1250         $ans .= $ndt if $prt;
1251         $ans .= "}";
1252         return $ans;
1253 }
1254
1255 # returns undef on error and sets $@ (otherwise $@ cleared)
1256 # if the JSON string to decode is "null" then undef is returned and $@ eq ""
1257 # $_[0] -> string value to decode from JSON
1258 # $_[1] -> if true return integers instead of json_bool for true/false
1259 # $_[2] -> if true strings are utf8::encode'd (i.e. they're bytes not chars)
1260 # returns scalar which will be an ARRAY or HASH ref for JSON array or hash values
1261 # using to_json(from_json($json_value)) will somewhat "normalize" $json_value
1262 # (and optionally pretty it up) and always recombine valid surrogate pairs
1263 sub from_json {
1264         my $ans = undef;
1265         eval {$ans = _from_jsonx(@_)};
1266         return $ans;
1267 }
1268
1269 # will die on bad input
1270 sub _from_jsonx {
1271         my ($val, $nobool, $enc) = @_;
1272         defined($val) or return undef;
1273         my $l = length($val);
1274         pos($val) = 0;
1275         my $atom = _from_json_value(\$val, $l, $nobool, $enc);
1276         $val =~ /\G\s+/gc;
1277         pos($val) >= $l or
1278                 die "garbage found at offset ".pos($val);
1279         return $atom;
1280 }
1281
1282 sub _from_json_value {
1283         my ($val, $l, $nobool, $enc) = @_;
1284         $$val =~ /\G\s+/gc;
1285         my $c = substr($$val, pos($$val), 1);
1286         $c eq "" and die "unexpected end of input at offset ".pos($$val);
1287         $c eq "{" and return _from_json_hash($val, $l, $nobool, $enc);
1288         $c eq "[" and return _from_json_array($val, $l, $nobool, $enc);
1289         $c eq '"' and return _from_json_str($val, $enc);
1290         index("-0123456789", $c) >= 0 and do {
1291                 $$val =~ /\G(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)/gc and
1292                         return int($1) == $1 ? int($1) : $1;
1293                 die "invalid JSON number at offset ".pos($$val);
1294         };
1295         $$val =~ /\Gnull\b/gc and return undef;
1296         $$val =~ /\Gtrue\b/gc and return $nobool?1:json_bool(1);
1297         $$val =~ /\Gfalse\b/gc and return $nobool?0:json_bool(0);
1298         die "invalid JSON value at offset ".pos($$val);
1299 }
1300
1301 my %json_unesc; BEGIN {%json_unesc=(
1302         '\\' => "\\",
1303         '"'  => '"',
1304         'b'  => "\b",
1305         't'  => "\t",
1306         'n'  => "\n",
1307         'f'  => "\f",
1308         'r'  => "\r"
1309 )}
1310
1311 sub _from_json_str {
1312         my ($val, $enc) = @_;
1313         my $opos = pos($$val);
1314         $$val =~ /\G\042((?:[^\\\042]|\\.)*)\042/gsc and
1315                 return _from_json_strval($1, $opos+1, $enc);
1316         die "invalid JSON string starting at offset $opos";
1317 }
1318
1319 sub _from_json_strval {
1320         my ($val, $pos, $enc) = @_;
1321         Encode::is_utf8($val) || utf8::decode($val) or
1322                 die "invalid UTF-8 string starting at offset $pos";
1323         $val =~ s{\\([\\\042btnfr]|u[0-9a-fA-F]{4})}{
1324                 substr($1,0,1) eq "u" ? &{sub{
1325                         my $c = hex(substr($1,1,4));
1326                         0xD800 <= $c && $c <= 0xDFFF ?
1327                                 "\\" . $1 :
1328                                 chr(hex(substr($1,1,4)))
1329                 }} : $json_unesc{$1}
1330         }goxe;
1331         $val =~ s{\\u([Dd][89AaBb][0-9a-fA-F]{2})\\u([Dd][CcDdEeFf][0-9a-fA-F]{2})}{
1332                 chr(( ((hex($1)&0x03FF)<<10) | (hex($2)&0x03FF) ) + 0x10000)
1333         }goxe;
1334         !Encode::is_utf8($val) || utf8::encode($val) if $enc;
1335         return $val;
1336 }
1337
1338 sub _from_json_array {
1339         my ($val, $l, $nobool, $enc) = @_;
1340         my @a = ();
1341         $$val =~ /\G\[/gc or die "expected '[' at offset ".pos($$val);
1342         my $wantcomma = 0;
1343         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "]") {
1344                 $$val =~ /\G\s+/gc and next;
1345                 !$wantcomma && substr($$val, pos($$val), 1) eq "," and
1346                         die "unexpected comma (,) in JSON array at offset ".pos($$val);
1347                 $wantcomma && !($$val =~ /\G,/gc) and
1348                         die "expected comma (,) or right-bracket (]) in JSON array at offset ".pos($$val);
1349                 push(@a, _from_json_value($val, $l, $nobool, $enc));
1350                 $wantcomma = 1;
1351         }
1352         $$val =~ /\G\]/gc or die "expected ']' at offset ".pos($$val);
1353         return \@a;
1354 }
1355
1356 sub _from_json_hash {
1357         my ($val, $l, $nobool, $enc) = @_;
1358         my %h = ();
1359         $$val =~ /\G\{/gc or die "expected '{' at offset ".pos($$val);
1360         my $wantc = "";
1361         my $k = undef;
1362         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "}") {
1363                 $$val =~ /\G\s+/gc and next;
1364                 !$wantc && index(":,", substr($$val, pos($$val), 1)) >= 0 and
1365                         die "unexpected colon (:) or comma (,) in JSON hash at offset ".pos($$val);
1366                 $wantc eq ":" && !($$val =~ /\G:/gc) and
1367                         die "expected colon (:) in JSON hash at offset ".pos($$val);
1368                 $wantc eq "," && !($$val =~ /\G,/gc) and
1369                         die "expected comma (,) or right-brace (}) in JSON hash at offset ".pos($$val);
1370                 $wantc and $$val =~ /\G\s+/gc;
1371                 $wantc eq "," and $wantc = "";
1372                 !$wantc && substr($$val, pos($$val), 1) ne '"' and
1373                         die "expected double-quote (\") in JSON hash at offset ".pos($$val);
1374                 !$wantc and do {
1375                         $k = _from_json_str($val, $enc);
1376                         $wantc = ":";
1377                         next;
1378                 };
1379                 $h{$k} = _from_json_value($val, $l, $nobool, $enc);
1380                 $wantc = ",";
1381         }
1382         $wantc ne ":" or die "expected ':' at offset ".pos($$val);
1383         $$val =~ /\G\}/gc or die "expected '}' at offset ".pos($$val);
1384         return \%h;
1385 }
1386
1387 # $_[0] -> full absolute path to a git ".git" directory
1388 # $_[1] -> "old" ref hash value
1389 # $_[2] -> "new" ref hash value
1390 # returns:
1391 #   scalar context: "..." -- if forced ref update detected (i.e. NOT a fast-forward)
1392 #                   ".."  -- any other condition (i.e. fast-forward/creation/deletion/no change/etc.)
1393 #   array context: [0] -> scalar context result
1394 #                  [1] -> true value if a git command had to be run
1395 sub ref_indicator {
1396         return '..' unless defined($_[0]);
1397         my ($git_dir, $old, $new) = @_;
1398         return '..' unless defined($old) && defined($new) && $old !~ /^0+$/ && $new !~ /^0+$/ && $old ne $new;
1399         # In many cases `git merge-base` is slower than this even if using the
1400         # `--is-ancestor` option available since Git 1.8.0, but it's never faster
1401         my $ans = get_git("--git-dir=$git_dir", "rev-list", "-n", "1", "^$new^0", "$old^0", "--") ? '...' : '..';
1402         return wantarray ? ($ans, 1) : $ans;
1403 }
1404
1405 # return the token key to use for the passed in category
1406 # if there is no such token or it cannot be read or is invalid
1407 # then silently return undef
1408 # category names must currently be 32 or fewer alphanumeric
1409 # characters where the first must be an alpha char
1410 # $_[0] -> category name
1411 sub get_token_key {
1412         my $cname = shift;
1413         defined($cname) or return undef;
1414         $cname = lc($cname);
1415         $cname =~ /^([a-z][a-z0-9]{0,31})$/ or return undef;
1416         $cname = $1;
1417         my $tf = $Girocco::Config::certsdir . "/tokenkeys/$cname.tky";
1418         -e $tf && -f _ && -r _ && -s _ or return undef;
1419         my $fh;
1420         open $fh, '<', $tf or return undef;
1421         my $tk = <$fh>;
1422         close $fh;
1423         defined($tk) or return undef;
1424         chomp($tk);
1425         $tk =~ /^([A-Za-z0-9_-]{48})$/ or return undef;
1426         return $1;
1427 }
1428
1429 # just like create_timed_token except that
1430 # the first argument is a category name instead of
1431 # the actual HMAC "secret"
1432 # $_[0] -> category name to pass to get_token_key
1433 # $_[1] -> optional instance info to include in "text"
1434 # $_[2] -> duration of validity in seconds (5..2147483647)
1435 # $_[3] -> optional time stamp (secs since unix Epoch)
1436 #          if not provided, current time is used
1437 # Returns a base64_url token (no trailing '='s) that is
1438 # valid starting at $_[3] and expires $_[2] seconds after $_[3].
1439 # Unless get_token_key fails in which case it returns undef.
1440 #
1441 sub get_timed_token {
1442         my ($catg, $extra, $duration, $start) = @_;
1443         my $tk = get_token_key($catg);
1444         defined($tk) && $tk ne "" or return undef;
1445         return create_timed_token($tk, $extra, $duration, $start);
1446 }
1447
1448 # return a hidden "token" <input /> field if the token ($_[0])
1449 # can be read, otherwise the empty string "".
1450 # $_[0] -> the token category (passed to get_token_key)
1451 # $_[1] -> the optional instance info (passed to create_timed_token)
1452 # $_[2] -> the duration of validity (passed to create_timed_token)
1453 # $_[3] -> optional name of field (defaults to "token")
1454 # returns a "hidden" XHTML input element or the empty string if
1455 # get_timed_token fails.  The token starting time will be the
1456 # current time.
1457 #
1458 sub get_token_field {
1459         my ($catg, $extra, $duration, $name) = @_;
1460         defined($name) && $name ne "" or $name = "token";
1461         my $tt = get_timed_token($catg, $extra, $duration);
1462         defined($tt) && $tt ne "" or return "";
1463         return "<input type=\"hidden\" name=\"$name\" value=\"$tt\" />";
1464 }
1465
1466 # just like verify_timed_token except that
1467 # the second argument is a category name instead of
1468 # the actual HMAC "secret"
1469 # $_[0] -> a create_timed_token/get_timed_token to check
1470 # $_[1] -> category name to pass to get_token_key
1471 # $_[2] -> optional instance info to include in "text"
1472 # $_[3] -> duration of validity in seconds (5..2147483647)
1473 # $_[4] -> optional time stamp (secs since unix Epoch)
1474 #          if not provided, current time is used
1475 # Returns true if $_[4] falls within the token's validity range
1476 # Returns false for a bad or expired token
1477 sub check_timed_token {
1478         my ($token, $catg, $extra, $duration, $start) = @_;
1479         my $tk = get_token_key($catg);
1480         defined($tk) && $tk ne "" or return undef;
1481         return verify_timed_token($token, $tk, $extra, $duration, $start);
1482 }
1483
1484 1;