aboutsummaryrefslogtreecommitdiff
blob: 7a52f4b8c222da42deabc628ebef1135a7daa1a6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
package Gitolite::Common;

# common (non-gitolite-specific) functions
# ----------------------------------------------------------------------

#<<<
@EXPORT = qw(
  print2  dbg     _mkdir  _open   ln_sf     tsh_rc      sort_u
  say     _warn   _chdir  _print            tsh_text    list_phy_repos
  say2    _die    _system slurp             tsh_lines
          trace           cleanup_conf_line tsh_try
          usage                             tsh_run
          gen_lfn
          gl_log

          dd
          t_start
          t_lap

          ssh_fingerprint_file
          ssh_fingerprint_line
);
#>>>
use Exporter 'import';
use File::Path qw(mkpath);
use File::Temp qw(tempfile);
use Carp qw(carp cluck croak confess);

use strict;
use warnings;

# ----------------------------------------------------------------------

sub print2 {
    local $/ = "\n";
    print STDERR @_;
}

sub say {
    local $/ = "\n";
    print @_, "\n";
}

sub say2 {
    local $/ = "\n";
    print STDERR @_, "\n";
}

sub trace {
    gl_log( "\t" . join( ",", @_[ 1 .. $#_ ] ) ) if $_[0] <= 1 and defined $Gitolite::Rc::rc{LOG_EXTRA};

    return unless defined( $ENV{D} );

    my $level = shift; return if $ENV{D} < $level;
    my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://;
    if ( not $sub ) {
        $sub = (caller)[1];
        $sub =~ s(.*/(.*))(($1));
    }
    $sub .= ' ' x ( 31 - length($sub) );
    say2 "$level\t$sub\t", join( "\t", @_ );
}

sub dbg {
    use Data::Dumper;
    return unless defined( $ENV{D} );
    for my $i (@_) {
        print STDERR "DBG: " . Dumper($i);
    }
}

sub dd {
    local $ENV{D} = 1;
    dbg(@_);
}

{
    my %start_times;

    eval "require Time::HiRes";
    # we just ignore any errors from this; nothing needs to be done as long as
    # no code *calls* either of the next two functions.

    sub t_start {
        my $name = shift || 'default';
        $start_times{$name} = [ Time::HiRes::gettimeofday() ];
    }

    sub t_lap {
        my $name = shift || 'default';
        return Time::HiRes::tv_interval( $start_times{$name} );
    }
}

sub _warn {
    gl_log( 'warn', @_ );
    if ( $ENV{D} and $ENV{D} >= 3 ) {
        cluck "WARNING: ", @_, "\n";
    } elsif ( defined( $ENV{D} ) ) {
        carp "WARNING: ", @_, "\n";
    } else {
        warn "WARNING: ", @_, "\n";
    }
}
$SIG{__WARN__} = \&_warn;

sub _die {
    gl_log( 'die', @_ );
    if ( $ENV{D} and $ENV{D} >= 3 ) {
        confess "FATAL: " . join( ",", @_ ) . "\n" if defined( $ENV{D} );
    } elsif ( defined( $ENV{D} ) ) {
        croak "FATAL: " . join( ",", @_ ) . "\n";
    } else {
        die "FATAL: " . join( ",", @_ ) . "\n";
    }
}
$SIG{__DIE__} = \&_die;

sub usage {
    my $script = (caller)[1];
    my $function = shift if @_ and $_[0] =~ /^[\w-]+$/;
    $function ||= ( ( ( caller(1) )[3] ) || ( ( caller(0) )[3] ) );
    $function =~ s/.*:://;
    my $code = slurp($script);
    $code =~ /^=for $function\b(.*?)^=cut/sm;
    say( $1 ? $1 : "...no usage message for '$function' in $script" );
    exit 1;
}

sub _mkdir {
    # It's not an error if the directory exists, but it is an error if it
    # doesn't exist and we can't create it. This includes not guaranteeing
    # dead symlinks or if mkpath traversal is blocked by a file.
    my $dir  = shift;
    my $perm = shift;    # optional
    return if -d $dir;
    mkpath($dir);
    chmod $perm, $dir if $perm;
    return 1;
}

sub _chdir {
    chdir( $_[0] || $ENV{HOME} ) or _die "chdir $_[0] failed: $!\n";
}

sub _system {
    # run system(), catch errors.  Be verbose only if $ENV{D} exists.  If not,
    # exit with <rc of system()> if it applies, else just "exit 1".
    trace( 1, 'system', @_ );
    if ( system(@_) != 0 ) {
        trace( 1, "system() failed", @_, "-> $?" );
        if ( $? == -1 ) {
            die "failed to execute: $!\n" if $ENV{D};
        } elsif ( $? & 127 ) {
            die "child died with signal " . ( $? & 127 ) . "\n" if $ENV{D};
        } else {
            die "child exited with value " . ( $? >> 8 ) . "\n" if $ENV{D};
            exit( $? >> 8 );
        }
        exit 1;
    }
}

sub _open {
    open( my $fh, $_[0], $_[1] ) or _die "open $_[1] failed: $!\n";
    return $fh;
}

sub _print {
    my ( $file, @text ) = @_;
    my $fh = _open( ">", "$file.$$" );
    print $fh @text;
    close($fh) or _die "close $file failed: $! at ", (caller)[1], " line ", (caller)[2], "\n";
    my $oldmode = ( ( stat $file )[2] );
    rename "$file.$$", $file;
    chmod $oldmode, $file if $oldmode;
}

sub slurp {
    return unless defined wantarray;
    local $/ = undef unless wantarray;
    my $fh = _open( "<", $_[0] );
    return <$fh>;
}

sub dos2unix {
    # WARNING: when calling this, make sure you supply a list context
    s/\r\n/\n/g for @_;
    return @_;
}

sub ln_sf {
    trace( 3, @_ );
    my ( $srcdir, $glob, $dstdir ) = @_;
    for my $hook ( glob("$srcdir/$glob") ) {
        $hook =~ s/$srcdir\///;
        unlink "$dstdir/$hook";
        symlink "$srcdir/$hook", "$dstdir/$hook" or croak "could not symlink $srcdir/$hook to $dstdir\n";
    }
}

sub sort_u {
    my %uniq;
    my $listref = shift;
    return [] unless @{$listref};
    undef @uniq{ @{$listref} };    # expect a listref
    my @sort_u = sort keys %uniq;
    return \@sort_u;
}

sub cleanup_conf_line {
    my $line = shift;
    return $line if $line =~ /^# \S+ \d+$/;

    # kill comments, but take care of "#" inside *simple* strings
    $line =~ s/^((".*?"|[^#"])*)#.*/$1/;
    # normalise whitespace; keeps later regexes very simple
    $line =~ s/=/ = /;
    $line =~ s/\s+/ /g;
    $line =~ s/^ //;
    $line =~ s/ $//;
    return $line;
}

{
    my @phy_repos = ();

    sub list_phy_repos {
        # use cached value only if it exists *and* no arg was received (i.e.,
        # receiving *any* arg invalidates cache)
        return \@phy_repos if ( @phy_repos and not @_ );

        my $cmd = 'find . ' . ($Gitolite::Rc::rc{REPO_SYMLINKS} || '') . ' -name "*.git" -prune';
        for my $repo (`$cmd`) {
            chomp($repo);
            $repo =~ s/\.git$//;
            $repo =~ s(^\./)();
            push @phy_repos, $repo unless $repo =~ m(/$);
                # tolerate bare repos within ~/repositories but silently ignore them
        }
        trace( 3, scalar(@phy_repos) . " physical repos found" );
        return sort_u( \@phy_repos );
    }
}

# generate a timestamp
sub gen_ts {
    my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
    $y += 1900; $m++;    # usual adjustments
    for ( $s, $min, $h, $d, $m ) {
        $_ = "0$_" if $_ < 10;
    }
    my $ts = "$y-$m-$d.$h:$min:$s";

    return $ts;
}

# generate a log file name
sub gen_lfn {
    my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
    $y += 1900; $m++;    # usual adjustments
    for ( $s, $min, $h, $d, $m ) {
        $_ = "0$_" if $_ < 10;
    }

    my ($template) = shift;
    # substitute template parameters and set the logfile name
    $template =~ s/%y/$y/g;
    $template =~ s/%m/$m/g;
    $template =~ s/%d/$d/g;

    return $template;
}

my $log_dest;
my $syslog_opened = 0;
END { closelog() if $syslog_opened; }
sub gl_log {
    # the log filename and the timestamp come from the environment.  If we get
    # called even before they are set, we have no choice but to dump to STDERR
    # (and probably call "logger").

    # tab sep if there's more than one field
    my $msg = join( "\t", @_ );
    $msg =~ s/[\n\r]+/<<newline>>/g;

    my $ts = gen_ts();
    my $tid = $ENV{GL_TID} ||= $$;

    $log_dest = $Gitolite::Rc::rc{LOG_DEST} || '' if not defined $log_dest;

    # log (update records only) to "gl-log" in the bare repo dir; this is to
    # make 'who-pushed' more efficient.  Since this is only for the update
    # records, it is not a replacement for the other two types of logging.
    if ($log_dest =~ /repo-log/ and $_[0] eq 'update') {
        # if the log line is 'update', we're already in the bare repo dir
        open my $lfh, ">>", "gl-log" or _die "open gl-log failed: $!";
        print $lfh "$ts\t$tid\t$msg\n";
        close $lfh;
    }

    # syslog
    if ($log_dest =~ /syslog/) {            # log_dest *includes* syslog
        if ($syslog_opened == 0) {
            require Sys::Syslog;
            Sys::Syslog->import(qw(:standard));

            openlog("gitolite" . ( $ENV{GL_TID} ? "[$ENV{GL_TID}]" : "" ), "pid", $Gitolite::Rc::rc{LOG_FACILITY} || 'local0');
            $syslog_opened = 1;
        }

        # gl_log is called either directly, or, if the rc variable LOG_EXTRA
        # is set, from trace(1, ...).  The latter use is considered additional
        # info for troubleshooting.  Trace prefixes a tab to the arguments
        # before calling gl_log, to visually set off such lines in the log
        # file.  Although syslog eats up that leading tab, we use it to decide
        # the priority/level of the syslog message.
        syslog( ( $msg =~ /^\t/ ? 'debug' : 'info' ), "%s", $msg);

        return if $log_dest !~ /normal/;
    }

    my $fh;
    logger_plus_stderr( "errors found before logging could be setup", "$msg" ) if not $ENV{GL_LOGFILE};
    open my $lfh, ">>", $ENV{GL_LOGFILE}
      or logger_plus_stderr( "errors found but logfile could not be created", "$ENV{GL_LOGFILE}: $!", "$msg" );
    print $lfh "$ts\t$tid\t$msg\n";
    close $lfh;
}

sub logger_plus_stderr {
    open my $fh, "|-", "logger" or confess "it's really not my day is it...?\n";
    for (@_) {
        print STDERR "FATAL: $_\n";
        print $fh "FATAL: $_\n";
    }
    exit 1;
}

# ----------------------------------------------------------------------
# Get the SSH fingerprint of a file
# If the fingerprint cannot be parsed, it will be undef
# In a scalar context, returns the fingerprint
# In a list context, returns (fingerprint, output) where output
# is the raw output of the ssh-keygen command
sub ssh_fingerprint_file {
    my $in = shift;
    -f $in or die "file not found: $in\n";
    my $fh;
    open( $fh, "ssh-keygen -l -f $in |" ) or die "could not fork: $!\n";
    my $output = <$fh>;
    chomp $output;
    # dbg("fp = $fp");
    close $fh;
    # Return a valid fingerprint or undef
    my $fp = undef;
    if($output =~ /((?:MD5:)?(?:[0-9a-f]{2}:){15}[0-9a-f]{2})/i or
       $output =~ m{((?:RIPEMD|SHA)\d+:[A-Za-z0-9+/=]+)}i) {
        $fp = $1;
    }
    return wantarray ? ($fp, $output) : $fp;
}

# Get the SSH fingerprint of a line of text
# If the fingerprint cannot be parsed, it will be undef
# In a scalar context, returns the fingerprint
# In a list context, returns (fingerprint, output) where output
# is the raw output of the ssh-keygen command
sub ssh_fingerprint_line {
    my ( $fh, $fn ) = tempfile();
    print $fh shift() . "\n";
    close $fh;
    my ($fp,$output) = ssh_fingerprint_file($fn);
    unlink $fn;
    return wantarray ? ($fp,$output) : $fp;
}

# ----------------------------------------------------------------------

# bare-minimum subset of 'Tsh' (see github.com/sitaramc/tsh)
{
    my ( $rc, $text );
    sub tsh_rc   { return $rc   || 0; }
    sub tsh_text { return $text || ''; }
    sub tsh_lines { return split /\n/, $text; }

    sub tsh_try {
        my $cmd = shift; die "try: expects only one argument" if @_;
        $text = `( $cmd ) 2>&1; printf RC=\$?`;
        if ( $text =~ s/RC=(\d+)$// ) {
            $rc = $1;
            trace( 3, $text );
            return ( not $rc );
        }
        die "couldnt find RC= in result; this should not happen:\n$text\n\n...\n";
    }

    sub tsh_run {
        open( my $fh, "-|", @_ ) or die "popen failed: $!";
        local $/ = undef; $text = <$fh>;
        close $fh; warn "pclose failed: $!" if $!;
        $rc = ( $? >> 8 );
        trace( 3, $text );
        return $text;
    }
}

1;