10 use base
qw(Exporter);
11 our @EXPORT = qw(scrypt jailed_file sendmail_pipe mailer_pipe
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 url_server
16 projects_html_list parse_rfc2822_date parse_any_date);
22 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
28 $Girocco::Config
::chroot."/$filename";
37 use Fcntl
qw(O_WRONLY O_CREAT O_EXCL);
39 my $handle = new IO
::Handle
;
41 unless (sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
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";
49 # XXX: filedb-specific
50 chmod 0664, $path or die "$path g+w failed: $!";
56 return defined($_[0]) && $_[0] eq jailed_file
('/etc/passwd');
59 sub _run_update_pwd_db
{
60 my ($path, $updatearg) = @_;
61 my @cmd = ($Girocco::Config
::basedir
.'/bin/update-pwd-db', "$path");
62 push(@cmd, $updatearg) if $updatearg;
63 system(@cmd) == 0 or die "update-pwd-db failed: $?";
67 my ($path, $noreplace, $updatearg) = @_;
70 _run_update_pwd_db
("$path.lock", $updatearg)
71 if $Girocco::Config
::update_pwd_db
&& _is_passwd_file
($path);
72 rename "$path.lock", $path or die "$path unlock failed: $!";
74 unlink "$path.lock" or die "$path unlock failed: $!";
78 sub filedb_atomic_append
{
79 my ($file, $line, $updatearg) = @_;
82 open my $src, '<', $file or die "$file open for reading failed: $!";
83 my $dst = lock_file
($file);
86 my $aid = (split /:/)[2];
87 $id = $aid + 1 if ($aid >= $id);
89 print $dst $_ or die "$file(l) write failed: $!";
93 print $dst "$line\n" or die "$file(l) write failed: $!";
95 close $dst or die "$file(l) close failed: $!";
98 unlock_file
($file, 0, $updatearg);
103 sub filedb_atomic_edit
{
104 my ($file, $fn, $updatearg) = @_;
106 open my $src, '<', $file or die "$file open for reading failed: $!";
107 my $dst = lock_file
($file);
110 print $dst $fn->($_) or die "$file(l) write failed: $!";
113 close $dst or die "$file(l) close failed: $!";
116 unlock_file
($file, 0, $updatearg);
119 sub filedb_atomic_grep
{
120 my ($file, $fn) = @_;
123 open my $src, '<', $file or die "$file open for reading failed: $!";
124 my $dst = lock_file
($file);
127 my $result = $fn->($_);
128 push(@results, $result) if $result;
131 close $dst or die "$file(l) close failed: $!";
134 unlock_file
($file, 1);
139 my ($file, $fn) = @_;
142 open my $src, '<', $file or die "$file open for reading failed: $!";
145 my $result = $fn->($_);
146 push(@results, $result) if $result;
156 /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
158 sub valid_email_multi
{
160 # More relaxed, we just want to avoid too dangerous characters.
161 /^[a-zA-Z0-9+._, @-]+$/;
165 /^https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
169 /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/;
174 about
=>1, after
=>1, all
=>1, also
=>1, an
=>1, and=>1, another
=>1, any
=>1,
175 are
=>1, as
=>1, at
=>1, be
=>1, because
=>1, been
=>1, before
=>1, being
=>1,
176 between
=>1, both
=>1, but
=>1, by
=>1, came
=>1, can
=>1, come
=>1, could
=>1,
177 did
=>1, do=>1, each=>1, for=>1, from
=>1, get
=>1, got
=>1, had
=>1, has
=>1,
178 have
=>1, he
=>1, her
=>1, here
=>1, him
=>1, himself
=>1, his
=>1, how
=>1,
179 if=>1, in=>1, into
=>1, is
=>1, it
=>1, like
=>1, make
=>1, many
=>1, me
=>1,
180 might
=>1, more
=>1, most
=>1, much
=>1, must
=>1, my=>1, never
=>1, now
=>1,
181 of
=>1, on
=>1, only
=>1, or=>1, other
=>1, our=>1, out
=>1, over
=>1,
182 said
=>1, same
=>1, see
=>1, should
=>1, since
=>1, some
=>1, still
=>1,
183 such
=>1, take
=>1, than
=>1, that
=>1, the
=>1, their
=>1, them
=>1, then
=>1,
184 there
=>1, these
=>1, they
=>1, this
=>1, those
=>1, through
=>1, to
=>1,
185 too
=>1, under
=>1, up
=>1, very
=>1, was
=>1, way
=>1, we
=>1, well
=>1,
186 were
=>1, what
=>1, where
=>1, which
=>1, while=>1, who
=>1, with
=>1,
187 would
=>1, you
=>1, your
=>1
190 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
191 # letter, must not be a noise word and except for 'C' must be more than one
192 # character long and no more than 32 characters long.
194 local $_ = $_[0] || '';
195 return 1 if $_ eq 'C'; # Currently only allowed single letter tag
196 return 0 unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
197 return 0 if $_badtags{lc($_)};
198 return length($_) <= 32 ?
1 : 0;
201 # If the passed in argument looks like a URL, return only the stuff up through
202 # the host:port part otherwise return the entire argument.
204 my $url = shift || '';
206 $url = $1.$2.$3.$4 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
214 # If the passed in argument looks like a URL, return only the stuff following
215 # the host:port part otherwise return the entire argument.
217 my $url = shift || '';
219 $url = $1 if $url =~ m
,^(?
: [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
220 (?
: // ) # // separator
221 (?
: [^\@
]+\@
)?
# optional userinfo
222 (?
: [^/?
#]+ ) # host and port
223 ((?
:[/?#].*)?)$,x; # path and optional query string and/or anchor
227 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
228 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
229 # return it. If a something that doesn't look like it could be the start of a
230 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
231 # then just return the argument unchanged.
233 my $url = shift || '';
234 my $path = url_path
($url);
235 return $url unless $path eq '' || $path =~ m
|^[/?
#]|;
236 return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
237 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
238 return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
239 my $server = $ENV{'SERVER_NAME'};
240 # Deal with Apache bug where IPv6 literal server names do not include
241 # the required surrounding '[' and ']' characters
242 $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
243 my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
244 my $portnum = 0 + $ENV{'SERVER_PORT'};
246 if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
247 $port = ':' . $portnum;
249 return 'http' . ($ishttps ?
's' : '') . '://' . $server . $port . $path;
254 $str =~ s/\&/\&/gs;
255 $str =~ s/\</\</gs;
256 $str =~ s/\>/\>/gs;
257 $str =~ s/\"/\"/gs; #"
261 # create relative time string from passed in age in seconds
266 if ($age > 60*60*24*365*2) {
267 $age_str = (int $age/60/60/24/365);
268 $age_str .= " years ago";
269 } elsif ($age > 60*60*24*(365/12)*2) {
270 $age_str = int $age/60/60/24/(365/12);
271 $age_str .= " months ago";
272 } elsif ($age > 60*60*24*7*2) {
273 $age_str = int $age/60/60/24/7;
274 $age_str .= " weeks ago";
275 } elsif ($age > 60*60*24*2) {
276 $age_str = int $age/60/60/24;
277 $age_str .= " days ago";
278 } elsif ($age > 60*60*2) {
279 $age_str = int $age/60/60;
280 $age_str .= " hours ago";
281 } elsif ($age > 60*2) {
282 $age_str = int $age/60;
283 $age_str .= " mins ago";
286 $age_str .= " secs ago";
287 } elsif ($age >= 0) {
288 $age_str = "right now";
290 $age_str = "future time";
295 # create relative time string from passed in idle in seconds
297 my $idle_str = _rel_age
(shift);
298 $idle_str =~ s/ ago//;
299 $idle_str = "not at all" if $idle_str eq "right now";
304 use POSIX
qw(strftime);
305 my ($fmt, $secs, $zonesecs) = @_;
306 my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
307 $zonesecs = int($zonesecs / 60);
309 my $ans = strftime
($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
313 $zonesecs = -$zonesecs;
317 $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
322 # Take a list of project names and produce a nicely formated table that
323 # includes owner links and descriptions. If the list is empty returns ''.
324 # The first argument may be a hash ref that contains options. The following
325 # options are available:
326 # target -- sets the target value of the owner link
327 # emptyok -- if true returns an empty table rather than ''
328 # typecol -- if true include type column with hover info
329 # changed -- if true include a changed and idle column
330 sub projects_html_list
{
332 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
335 return '' unless @_ || (defined($options->{emptyok
}) && $options->{emptyok
});
336 require Girocco
::Project
;
339 $target = " target=\""._escapeHTML
($options->{target
})."\""
340 if defined($options->{target
});
341 my $withtype = defined($options->{typecol
}) && $options->{typecol
};
342 my $withchanged = defined($options->{changed
}) && $options->{changed
};
344 $typehead = '<th>Type</th>' if $withtype;
346 $chghead = substr(<<EOT, 0, -1) if $withchanged;
347 <th><span class="hover">Changed<span><span class="head">Changed</span
348 />The last time a ref change was received by this site.</span></span></th
349 ><th><span class="hover">Idle<span><span class="head">Idle</span
350 />The most recent committer time in <i>refs/heads</i>.</span></span></th
354 <table class='projectlist'><tr><th>Project</th>$typehead$chghead<th class="desc">Description</th></tr>
356 my $trclass = ' class="odd"';
357 foreach (sort({lc($a) cmp lc($b)} @_)) {
358 if (Girocco
::Project
::does_exist
($_, 1)) {
359 my $proj = Girocco
::Project
->load($_);
360 my $projname = $proj->{name
}.".git";
361 my $projdesc = $proj->{desc
}||'';
362 utf8
::decode
($projdesc) if utf8
::valid
($projdesc);
365 if ($proj->{mirror
}) {
366 $typecol = substr(<<EOT, 0, -1);
367 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
370 my $users = @
{$proj->{users
}};
372 $users .= 's' unless @
{$proj->{users
}} == 1;
373 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @
{$proj->{users
}}));
374 my $spncls = length($userlist) > 25 ?
'' : ' class="nowrap"';
375 $typecol = $userlist ?
substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
376 <td
class="type"><span
class="hover">$users<span
$spncls>$userlist</span></span
></td
>
378 <td
class="type">$users</td
>
385 my $changetime = $proj->{lastchange
};
387 $rel = "<span class=\"hover\">" .
388 _rel_age
(time - parse_rfc2822_date
($changetime)) .
389 "<span class=\"nowrap\">$changetime</span></span>";
393 $changecol = substr(<<EOT, 0, -1);
394 <td class="change">$rel</td>
396 my $idletime = $proj->{lastactivity
};
398 $idlesecs = parse_any_date
($idletime, \
$tz) if $idletime;
400 my $idle2822 = _strftime
("%a, %d %b %Y %T %z", $idlesecs, $tz);
401 $rel = "<span class=\"hover\">" .
402 _rel_idle
(time - $idlesecs) .
403 "<span class=\"nowrap\">$idle2822</span></span>";
407 $changecol .= substr(<<EOT, 0, -1);
408 <td class="idle">$rel</td>
412 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
413 >@{[_escapeHTML($projname)]}</td>$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
415 $trclass = $trclass ?
'' : ' class="odd"';
422 return ($count || (defined($options->{emptyok
}) && $options->{emptyok
})) ?
$html : '';
428 jan
=> 0, feb
=> 1, mar
=> 2, apr
=> 3, may
=> 4, jun
=> 5,
429 jul
=> 6, aug
=> 7, sep
=> 8, oct => 9, nov
=> 10, dec
=> 11
433 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
434 # The leading "%a, " is optional, returns undef if unrecognized date. This is also known as
435 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
436 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
437 sub parse_rfc2822_date
{
438 my $dstr = shift || '';
439 my $tzoff = shift || '';
440 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
441 return undef unless $dstr =~
442 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
443 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
444 my $m = $_month_names{lc($b)};
445 return undef unless defined($m);
446 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
447 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
448 $offset = -$offset if substr($z,0,1) eq '-';
449 $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
450 return $seconds - $offset;
453 # Will parse any supported date format. Actually there are three formats
454 # currently supported:
455 # 1. RFC 2822 (uses parse_rfc2822_date)
456 # 2. RFC 3339 / ISO 8601 (T may be ' ', 'Z' is optional, ':' optional in TZ)
457 # 3. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
458 # Returns undef if unsupported date.
459 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
461 my $dstr = shift || '';
462 my $tzoff = shift || '';
463 if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
469 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
470 $off = -$off if substr($z,0,1) eq '-';
472 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
475 if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt ](\d{2}):(\d{2}):(\d{2})(?:[ ]([Zz]|(?:[-+]\d{2}:?\d{2})))?\s*$/) {
476 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
477 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
481 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
482 $off = -$off if substr($z,0,1) eq '-';
484 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
485 return $seconds - $off;
487 return parse_rfc2822_date
($dstr, $tzoff);
490 # Input is a number such as a minute interval
491 # Return value is a random number between the input and 1.25*input
492 # This can be used to randomize the update and gc operations a bit to avoid
493 # having them all end up all clustered together
495 my $input = shift || 0;
496 return $input unless $input;
497 return $input + int(rand(0.25 * $input));
500 # Open a pipe to a new sendmail process. The '-i' option is always passed to
501 # the new process followed by any addtional arguments passed in. Note that
502 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
503 # options. Using any other options via this function is not guaranteed to work.
504 # A list of recipients may follow the options. Combining a list of recipients
505 # with the '-t' option is not recommended.
507 return undef unless @_;
508 die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
509 unless $Girocco::Config
::sendmail_bin
&& -x
$Girocco::Config
::sendmail_bin
;
510 my $result = open(my $pipe, '|-', $Girocco::Config
::sendmail_bin
, '-i', @_);
511 return $result ?
$pipe : undef;
514 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
515 # if the first argument is '-s', a subject line will be automatically added
516 # (using the second argument as the subject). Any remaining arguments are
517 # expected to be recipient addresses that will be added to an explicit To:
518 # line as well as passed on to sendmail_pipe. In addition an
519 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
523 if (@_ >= 2 && $_[0] eq '-s') {
527 my $tolist = join(", ", @_);
528 unshift(@_, '-f', $Girocco::Config
::sender
) if $Girocco::Config
::sender
;
529 my $pipe = sendmail_pipe
(@_);
531 print $pipe "From: \"$Girocco::Config::name\" ",
532 "($Girocco::Config::title) ",
533 "<$Girocco::Config::admin>\n";
534 print $pipe "To: $tolist\n";
535 print $pipe "Subject: $subject\n" if defined($subject);
536 print $pipe "Auto-Submitted: auto-generated\n";