summaryrefslogtreecommitdiffstats
path: root/perl-install/run_program.pm
blob: b3a65d13a9745eb81db48e0dd47c72caac142678 (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
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
package run_program;

use diagnostics;
use strict;
use c;

use MDK::Common;
use common; # for get_parent_uid()
use log;
use Time::HiRes qw(ualarm);

=head1 SYNOPSYS

B<run_program> enables to:

=over 4

=item * run programs in foreground or in background,

=item * to retrieve their stdout or stderr

=item * ...

=back

Most functions exits in a normal form & a rooted one. e.g.:

=over 4

=item * C<run()> & C<rooted()>

=item * C<get_stdout()> & C<rooted_get_stdout()>

=back

Most functions exits in a normal form & one that die. e.g.:

=over 4

=item * C<run()> & C<run_or_die()>

=item * C<rooted()> & C<rooted_or_die()>

=back

=head1 Functions

=over

=cut

1;

my $default_timeout = 10 * 60;

=item set_default_timeout($seconds)

Alters defaults timeout (eg for harddrake service)

=cut

sub set_default_timeout {
    my ($seconds) = @_;
    $default_timeout = $seconds;
}

my $callback_routine;
my $callback_interval = 1 * 1000;

=item set_wait_loop_callback($routine, $o_interval)

Sets a callback routine that will be called at regular intervals whilst
waiting for a program being run in the foreground. Optionally sets the
interval in milliseconds between callbacks. If not set, the interval is
1 second.

The callback routine will be passed one argument which is the pid of
the program being run.

The callback routine should not call sleep() or abort(), as that may
prevent it being called again.

=cut

sub set_wait_loop_callback {
    my ($routine, $o_interval) = @_;
    $callback_routine = $routine;
    $callback_interval = $o_interval if $o_interval;
}

=item run_or_die($name, @args)

Runs $name with @args parameterXs. Dies if it exit code is not 0.

=cut

sub run_or_die {
    my ($name, @args) = @_;
    run($name, @args) or die "$name failed\n";
}

=item rooted_or_die($root, $name, @args)

Similar to run_or_die() but runs in chroot in $root

=cut

sub rooted_or_die {
    my ($root, $name, @args) = @_;
    rooted($root, $name, @args) or die "$name failed\n";
}

=item get_stdout($name, @args)

Similar to run_or_die() but return stdout of program:

=over 4

=item * a list of lines in list context

=item * a string of concatenated lines in scalar context

=back

=cut

sub get_stdout {
    my ($name, @args) = @_;
    my @r;
    run($name, '>', \@r, @args) or return;
    wantarray() ? @r : join('', @r);
}

=item get_stdout_raw($options, $name, @args)

Similar to get_stdout() but allow to pass options to raw()

=cut

sub get_stdout_raw {
    my ($options, $name, @args) = @_;
    my @r;
    raw($options, $name, '>', \@r, @args) or return;
    wantarray() ? @r : join('', @r);
}

=item rooted_get_stdout($root, $name, @args)

Similar to get_stdout() but runs in chroot in $root

=cut

sub rooted_get_stdout {
    my ($root, $name, @args) = @_;
    my @r;
    rooted($root, $name, '>', \@r, @args) or return;
    wantarray() ? @r : join('', @r);
}

=item run($name, @args)

Runs $name with @args parameters.

=cut

sub run { raw({}, @_) }

=item rooted($root, $name, @args)

Similar to run() but runs in chroot in $root

=cut

sub rooted {
    my ($root, $name, @args) = @_;
    raw({ root => $root }, $name, @args);
}

=item raw($options, $name, @args)

The function used by all the other, making every combination possible.
Runs $name with @args parameters. $options is a hash ref that can contains:

=over 4

=item * B<root>: $name will be chrooted in $root prior to run

=item * B<as_user>: $name will be run as $ENV{PKEXEC_UID} or with the UID of parent process. Implies I<setuid>

=item * B<sensitive_arguments>: parameters will be hidden in logs (b/c eg there's a password)

=item * B<detach>: $name will be run in the background. Default is foreground

=item * B<chdir>: $name will be run in a different default directory

=item * B<setuid>: a UID; $name will be with droped privileges ;
make sure environment is set right and keep a copy of the X11 cookie

=item * B<timeout>: execution of $name will be aborted after C<timeout> seconds

=back

eg:

=over 4

=item * C<< run_program::raw({ root => $::prefix, sensitive_arguments => 1 }, "echo -e $user->{password} | cryptsetup luksFormat $device"); >>

=item * C<< run_program::raw({ detach => 1 }, '/etc/rc.d/init.d/dm', '>', '/dev/null', '2>', '/dev/null', 'restart'); >>

=back

=cut

sub raw {
    my ($options, $name, @args) = @_;
    my $root = $options->{root} || '';
    my $real_name = ref($name) ? $name->[0] : $name;

    my ($stdout_raw, $stdout_mode, $stderr_raw, $stderr_mode);
    ($stdout_mode, $stdout_raw, @args) = @args if $args[0] =~ /^>>?$/;
    ($stderr_mode, $stderr_raw, @args) = @args if $args[0] =~ /^2>>?$/;

    my $home;
    if ($options->{as_user}) {
        $options->{setuid} = $ENV{PKEXEC_UID} ||= common::get_parent_uid();;
    }

    my $args = $options->{sensitive_arguments} ? '<hidden arguments>' : join(' ', @args);
    log::explanations("running: $real_name $args" . ($root ? " with root $root" : ""));

    return if $root && $<;

    $root ? ($root .= '/') : ($root = '');
    
    my $tmpdir = sub {
	my $dir = $< != 0 ? "$ENV{HOME}/tmp" : -d '/root' ? '/root/tmp' : '/tmp';
	-d $dir or mkdir($dir, 0700);
	$dir;
    };
    my $stdout = $stdout_raw && (ref($stdout_raw) ? $tmpdir->() . "/.drakx-stdout.$$" : "$root$stdout_raw");
    my $stderr = $stderr_raw && (ref($stderr_raw) ? $tmpdir->() . "/.drakx-stderr.$$" : "$root$stderr_raw");

    #- checking if binary exist to avoid clobbering stdout file
    my $rname = $real_name =~ /(.*?)[\s\|]/ ? $1 : $real_name;    
    if (! ($rname =~ m!^/! 
	     ? -x "$root$rname" || $root && -l "$root$rname" #- handle non-relative symlink which can be broken when non-rooted
	     : whereis_binary($rname, $root))) {
	log::l("program not found: $real_name");
	return;
    }

    if (my $pid = fork()) {
	if ($options->{detach}) {
	    $pid;
	} else {
	    my $ok;
	    add2hash_($options, { timeout => $default_timeout });

            my $remaining = $options->{timeout} if $options->{timeout} ne 'never';
            #- We count in milliseconds when using a callback routine.
            $remaining *= 1000 if $remaining && $callback_routine;

            #- Preserve any pre-existing alarm.
            my $old_remaining = alarm(0) if $remaining;

            wait_again:

	    eval {
		local $SIG{ALRM} = sub { die "ALARM" };
		if ($callback_routine) {
                    ualarm($callback_interval * 1000);
                } elsif ($remaining) {
                    alarm($remaining);
                }
		waitpid $pid, 0;
		$ok = $? == -1 || ($? >> 8) == 0;
		if ($callback_routine) {
                    ualarm(0);
                } elsif ($remaining) {
                    alarm(0);
                }
	    };
	    if ($@) {
                if ($@ =~ /^ALARM/ && $callback_routine) {
                    $callback_routine->($pid);
                    $remaining -= $callback_interval if $remaining;
                    goto wait_again if !defined $remaining || $remaining > 0;
                }
		log::l("ERROR: killing runaway process (process=$real_name, pid=$pid, args=@args, error=$@)");
		kill 9, $pid;
                #- Restore any pre-existing alarm.
                alarm($old_remaining) if $old_remaining;
		return;
	    }

            #- Restore any pre-existing alarm.
            alarm($old_remaining) if $old_remaining;

	    if ($stdout_raw && ref($stdout_raw)) {	    
		if (ref($stdout_raw) eq 'ARRAY') { 
		    @$stdout_raw = cat_($stdout);
		} else { 
		    $$stdout_raw = cat_($stdout);
		}
		unlink $stdout;
	    }
	    if ($stderr_raw && ref($stderr_raw)) {
		if (ref($stderr_raw) eq 'ARRAY') { 
		    @$stderr_raw = cat_($stderr);
		} else { 
		    $$stderr_raw = cat_($stderr);
		}
		unlink $stderr;
	    }
	    $ok;
	}
    } else {
        if ($options->{setuid}) {
            require POSIX;
            my ($logname, $home) = (getpwuid($options->{setuid}))[0,7];
            $ENV{LOGNAME} = $logname if $logname;
            $ENV{HOME} = $home if $home;

            # if we were root and are going to drop privilege, keep a copy of the X11 cookie:
            if (!$> && $home) {
                # FIXME: it would be better to remove this but most callers are using 'detach => 1'...
                my $xauth = chomp_(`mktemp $home/.Xauthority.XXXXX`);
                system('cp', '-a', $ENV{XAUTHORITY}, $xauth);
                system('chown', $logname, $xauth);
                $ENV{XAUTHORITY} = $xauth;
            }

            # drop privileges:
            POSIX::setuid($options->{setuid});
        }

	sub die_exit {
	    log::l($_[0]);
	    c::_exit(128);
	}
	if ($stderr && $stderr eq 'STDERR') {
	} elsif ($stderr) {
	    $stderr_mode =~ s/2//;
	    open STDERR, "$stderr_mode $stderr" or die_exit("run_program cannot output in $stderr (mode `$stderr_mode')");
	} elsif ($::isInstall) {
	    open STDERR, ">> /tmp/ddebug.log" or open STDOUT, ">> /dev/tty7" or die_exit("run_program cannot log, give me access to /tmp/ddebug.log");
	}
	if ($stdout && $stdout eq 'STDOUT') {
	} elsif ($stdout) {
	    open STDOUT, "$stdout_mode $stdout" or die_exit("run_program cannot output in $stdout (mode `$stdout_mode')");
	} elsif ($::isInstall) {
	    open STDOUT, ">> /tmp/ddebug.log" or open STDOUT, ">> /dev/tty7" or die_exit("run_program cannot log, give me access to /tmp/ddebug.log");
	}

	$root and chroot $root;
	chdir($options->{chdir} || "/");

	my $ok = ref $name ? do {
	    exec { $name->[0] } $name->[1], @args;
	} : do {
	    exec $name, @args;
	};
	if (!$ok) {
	    die_exit("exec of $real_name failed: $!");
	}
    }

}

=item terminate($pid, $o_timeout)

Sends the TERM signal to the process identified by $pid and waits for it
to terminate. If it hasn't terminated in $o_timeout seconds, sends the
KILL signal and returns without waiting. If $o_timeout is not specified,
the default timeout is 5 seconds. If $o_timeout is less than or equal to
zero, the TERM signal is not sent and the process is killed immediately.

=cut

sub terminate {
    my ($pid, $o_timeout) = @_;

    if (!defined $o_timeout || $o_timeout > 0) {
        kill 'TERM', $pid;
        eval {
            local $SIG{ALRM} = sub { die "ALARM" };
            my $old_remaining = alarm($o_timeout || 5);
            waitpid $pid, 0;
            alarm($old_remaining);
        };
        return if !$@;
        log::l("ERROR: killing runaway process (pid=$pid, error=$@)");
    }
    kill 'KILL', $pid;
}

package bg_command;

=item bg_command::new($class, $sub)

Runs in background a sub that give back data through STDOUT a la run_program::get_stdout
but w/ arbitrary perl code instead of external program

=cut

sub new {
    my ($class, $sub) = @_;
    my $o = bless {}, $class;
    if ($o->{pid} = open(my $fd, "-|")) {
        $o->{fd} = $fd;
        $o;
    } else {
        $sub->();
        c::_exit(0);
    }
}

=item bg_command::DESTROY($o)

When undefined (either explicitly or at end of lexical scope), close the fd and wait for the child process.

=cut

sub DESTROY {
    my ($o) = @_;
    close $o->{fd} or warn "kid exited $?";
    waitpid $o->{pid}, 0;
}

=back

=cut

1;

#- Local Variables:
#- mode:cperl
#- tab-width:8
#- End: