1# Copyright (c) 2008-2013 Zmanda, Inc.  All Rights Reserved.
2#
3# This program is free software; you can redistribute it and/or
4# modify it under the terms of the GNU General Public License
5# as published by the Free Software Foundation; either version 2
6# of the License, or (at your option) any later version.
7#
8# This program is distributed in the hope that it will be useful, but
9# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
10# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
11# for more details.
12#
13# You should have received a copy of the GNU General Public License along
14# with this program; if not, write to the Free Software Foundation, Inc.,
15# 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
16#
17# Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
18# Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
19
20package Amanda::Changer::compat;
21
22use strict;
23use warnings;
24use vars qw( @ISA );
25@ISA = qw( Amanda::Changer );
26
27use Carp;
28use File::Glob qw( :glob );
29use File::Path;
30use Amanda::Paths;
31use Amanda::MainLoop qw( :GIOCondition );
32use Amanda::Config qw( :getconf );
33use Amanda::Debug qw( debug );
34use Amanda::Device qw( :constants );
35use Amanda::Changer;
36use Amanda::MainLoop;
37
38=head1 NAME
39
40Amanda::Changer::compat -- run "old" changer scripts
41
42=head1 DESCRIPTION
43
44This package calls through to old Changer API shell scripts using the new API.
45If necessary, it writes temporary configurations under C<$AMANDA_TMPDIR> and
46invokes the changer there, allowing multiple distinct changers to run within
47the same Amanda process.
48
49See the amanda-changers(7) manpage for usage information.
50
51=head2 NOTE
52
53In-process reservations are handled correctly - only one device may be used at
54a time.  However, the underlying scripts do not support reservations, so
55another application can easily run the script and change the current device.
56Caveat emptor.
57
58=cut
59
60# TODO
61# Clean out old changer temporary directories on object destruction.
62
63sub new {
64    my $class = shift;
65    my ($config, $tpchanger) = @_;
66    my ($script) = ($tpchanger =~ /chg-compat:(.*)/);
67
68    unless (-e $script) {
69	$script = "$amlibexecdir/$script";
70    }
71
72    if (! -x $script) {
73	return Amanda::Changer->make_error("fatal", undef,
74	    message => "'$script' is not executable");
75    }
76
77    my $self = {
78        script => $script,
79	config => $config,
80	reserved => 0,
81	nslots => undef,
82	backwards => undef,
83	searchable => undef,
84	lock => [],
85	got_info => 0,
86	info_lock => [],
87    };
88    bless ($self, $class);
89
90    $self->_make_cfg_dir($config);
91
92    debug("$class initialized with script $script, temporary directory $self->{cfg_dir}");
93
94    return $self;
95}
96
97sub load {
98    my $self = shift;
99    my %params = @_;
100
101    $self->validate_params('load', \%params);
102    return if $self->check_error($params{'res_cb'});
103
104    if ($self->{'reserved'}) {
105	return $self->make_error("failed", $params{'res_cb'},
106	    reason => "driveinuse",
107	    message => "Changer is already reserved: '" . $self->{'reserved'}->device_name . "'");
108    }
109
110    my $steps = define_steps
111	cb_ref => \$params{'res_cb'};
112
113    # make sure the info is loaded, and re-call load() if we have to wait
114    step get_info => sub {
115	$self->_get_info($steps->{'got_info'});
116    };
117
118    step got_info => sub {
119	my ($exitval, $message) = @_;
120	if (defined $exitval) { # error
121	    # this is always fatal - we can't load without info
122	    return $self->make_error("fatal", $params{'res_cb'},
123		message => $message);
124	}
125
126	$steps->{'start_load'}->();
127    };
128
129    step start_load => sub {
130	if (exists $params{'label'}) {
131	    if ($self->{'searchable'}) {
132		$self->_run_tpchanger($steps->{'load_run_done'}, "-search", $params{'label'});
133	    } else {
134		# not searchable -- run a manual scan
135		$self->_manual_scan(%params);
136	    }
137	} elsif (exists $params{'relative_slot'}) {
138	    # if there is an explicit $slot, then just hope it's the same as the current
139	    # slot, or we're in trouble.  We don't know what the current slot is, so we
140	    # can't verify, but the current slot is set on *every* load, so this works.
141
142	    # if we've already seen nslots slots, then the next slot is
143	    # certainly one of them, so the iteration should terminate.
144	    # However, not all changers will return nslots distinct slots
145	    # (chg-zd-mtx skips empty slots, for example), so we will need to
146	    # protect against except_slots in other ways, too.
147	    if (exists $params{'except_slots'} and (keys %{$params{'except_slots'}}) == $self->{'nslots'}) {
148		return $self->make_error("failed", $params{'res_cb'},
149		    reason => 'notfound',
150		    message => "all slots have been loaded");
151	    }
152
153	    $self->_run_tpchanger($steps->{'load_run_done'}, "-slot", $params{'relative_slot'});
154	} elsif (exists $params{'slot'}) {
155	    $self->_run_tpchanger($steps->{'load_run_done'}, "-slot", $params{'slot'});
156	}
157    };
158
159    step load_run_done => sub {
160	my ($exitval, $slot, $rest) = @_;
161	if ($exitval == 0) {
162	    if (!$rest) {
163		return $self->make_error("fatal", $params{'res_cb'},
164		    message => "changer script did not provide a device name");
165	    }
166	} elsif ($exitval >= 2) {
167		return $self->make_error("fatal", $params{'res_cb'},
168		    message => $rest);
169	} else {
170	    return $self->make_error("failed", $params{'res_cb'},
171		reason => "notfound",
172		message => $rest);
173	}
174
175	# re-check except_slots, and return 'notfound' if we've loaded a
176	# forbidden slot.  This will generally happen when scanning, and when
177	# the underlying changer script has "skipped" some slots and looped
178	# around earlier than we expected.
179	if (exists $params{'except_slots'} and exists $params{'except_slots'}{$slot}) {
180	    return $self->make_error("failed", $params{'res_cb'},
181		reason => 'notfound',
182		message => "all slots have been loaded");
183	}
184
185	return $self->_make_res($params{'res_cb'}, $slot, $rest, undef);
186    };
187}
188
189sub _manual_scan {
190    my $self = shift;
191    my %params = @_;
192    my $nchecked = 0;
193    my ($get_info, $got_info, $run_cb, $load_next);
194    my $first_scanned_slot = -1;
195
196    my $user_msg_fn = $params{'user_msg_fn'};
197    $user_msg_fn ||= sub { Amanda::Debug::info("chg-compat: " . $_[0]); };
198
199    # search manually, starting with "current" and proceeding through nslots-1
200    # loads of "next".  This doesn't use the except_slots iteration mechanism as
201    # that would just add extra layers of complexity with no benefit
202
203    $get_info = sub {
204	$self->_get_info($got_info);
205    };
206
207    $got_info = sub {
208	$user_msg_fn->("beginning manual scan of $self->{nslots} slots");
209	$self->_run_tpchanger($run_cb, "-slot", "current");
210    };
211    $run_cb = sub {
212        my ($exitval, $slot, $rest) = @_;
213
214	if ($slot == $first_scanned_slot) {
215	    $nchecked = $self->{'nslots'};
216	    return $load_next->();
217	}
218
219	$first_scanned_slot = $slot if $first_scanned_slot == -1;
220
221	$user_msg_fn->("updated slot $slot");
222	if ($exitval == 0) {
223	    # if we're looking for a label, check what we got
224	    if (defined $params{'label'}) {
225		my $device = Amanda::Device->new($rest);
226		if ($device and $device->configure(1)
227			    and $device->read_label() == $DEVICE_STATUS_SUCCESS
228			    and $device->volume_label() eq $params{'label'}) {
229		    # we found the correct slot
230		    $self->_make_res($params{'res_cb'}, $slot, $rest, $device);
231		    return;
232		}
233	    }
234
235	    return $load_next->();
236	} else {
237	    # don't continue scanning after a fatal error
238	    if ($exitval >= 2) {
239		return $self->make_error("fatal", $params{'res_cb'},
240		    message => $rest);
241	    }
242
243	    return $load_next->();
244	}
245    };
246
247    $load_next = sub {
248	# if we've scanned all nslots, we haven't found the label.
249        if (++$nchecked >= $self->{'nslots'}) {
250	    if (defined $params{'label'}) {
251		return $self->make_error("failed", $params{'res_cb'},
252		    reason => "notfound",
253		    message => "Volume '$params{label}' not found");
254	    } else {
255		return $params{'res_cb'}->(undef, undef);
256	    }
257	}
258
259	$self->_run_tpchanger($run_cb, "-slot", "next");
260    };
261
262    $get_info->();
263}
264
265# takes $res_cb, $slot and $rest; creates and configures the device, and calls
266# $res_cb with the results.
267sub _make_res {
268    my $self = shift;
269    my ($res_cb, $slot, $rest, $device) = @_;
270    my $res;
271
272    if (!defined $device) {
273	$device = Amanda::Device->new($rest);
274	if ($device->status != $DEVICE_STATUS_SUCCESS) {
275	    return $self->make_error("failed", $res_cb,
276		    reason => "device",
277		    message => "opening '$rest': " . $device->error_or_status());
278	}
279    }
280
281    if (my $err = $self->{'config'}->configure_device($device)) {
282	return $self->make_error("failed", $res_cb,
283		reason => "device",
284		message => $err);
285    }
286
287    $res = Amanda::Changer::compat::Reservation->new($self, $slot, $device);
288    $device->read_label();
289
290    $res_cb->(undef, $res);
291}
292
293sub info_setup {
294    my $self = shift;
295    my %params = @_;
296
297    $self->_get_info(sub {
298	my ($exitval, $message) = @_;
299	if (defined $exitval) { # error
300	    if ($exitval >= 2) {
301		return $self->make_error("fatal", $params{'finished_cb'},
302		    message => $message);
303	    } else {
304		return $self->make_error("failed", $params{'finished_cb'},
305		    reason => "notfound",
306		    message => $message);
307	    }
308	}
309
310	# no error, so we're done with setup
311	$params{'finished_cb'}->();
312    });
313}
314
315sub info_key {
316    my $self = shift;
317    my ($key, %params) = @_;
318    my %results;
319
320    if ($key eq 'num_slots') {
321	$results{$key} = $self->{'nslots'};
322    } elsif ($key eq 'fast_search') {
323	$results{$key} = $self->{'searchable'};
324    }
325
326    $params{'info_cb'}->(undef, %results) if $params{'info_cb'};
327}
328
329# run a simple op -- no arguments, no slot returned
330sub _simple_op {
331    my $self = shift;
332    my $op = shift;
333    my %params = @_;
334
335    my $run_cb = sub {
336	my ($exitval, $slot, $rest) = @_;
337	if ($exitval == 0) {
338	    if (exists $params{'finished_cb'}) {
339		$params{'finished_cb'}->(undef);
340	    }
341	} else {
342	    if ($exitval >= 2) {
343		return $self->make_error("fatal", $params{'finished_cb'},
344		    message => $rest);
345	    } else {
346		return $self->make_error("failed", $params{'finished_cb'},
347		    reason => "unknown",
348		    message => $rest);
349	    }
350	}
351    };
352    $self->_run_tpchanger($run_cb, "-$op");
353}
354
355sub reset {
356    my $self = shift;
357    my %params = @_;
358
359    $self->_simple_op("reset", %params);
360}
361
362sub clean {
363    my $self = shift;
364    my %params = @_;
365
366    # note: parameter 'drive' is ignored
367    $self->_simple_op("clean", %params);
368}
369
370sub eject {
371    my $self = shift;
372    my %params = @_;
373
374    # note: parameter 'drive' is ignored
375    $self->_simple_op("eject", %params);
376}
377
378sub update {
379    my $self = shift;
380    my %params = @_;
381
382    if ($params{'changed'}) {
383	return $self->make_error("failed", $params{'finished_cb'},
384	    reason => 'invalid',
385	    message => 'chg-compat does not support specifying what has changed');
386    }
387
388    my $scan_done_cb = make_cb(scan_done_cb => sub {
389	my ($err, $res) = @_;
390	if ($err) {
391	    return $params{'finished_cb'}->($err);
392	}
393
394	# we didn't search for a label, so we don't get a reservation
395	$params{'finished_cb'}->(undef);
396    });
397
398    # for compat changers, "update" just entails scanning the whole changer
399    $self->_manual_scan(
400	res_cb => $scan_done_cb,
401	label => undef, # search forever
402	user_msg_fn => $params{'user_msg_fn'},
403    );
404}
405
406# Internal function to call the script's -info and store the results in $self.
407# If this returns true, then the info is loaded; otherwise, got_info_cb will be
408# called either with no arguments (success) or ($exitval, $message) on error.
409sub _get_info {
410    my ($self, $got_info_cb) = @_;
411
412    Amanda::MainLoop::synchronized($self->{'info_lock'}, $got_info_cb, sub {
413	my ($got_info_cb) = @_;
414
415	# if we've already got info, just call back right away
416	if ($self->{'got_info'}) {
417	    return $got_info_cb->();
418	}
419
420	my $run_cb = sub {
421	    my ($exitval, $slot, $rest) = @_;
422	    if ($exitval == 0) {
423		# old, unsearchable changers don't return the third result, so it's
424		# optional in the regex
425		unless ($rest =~ /(\d+) (\d+) ?(\d+)?/) {
426		    return $got_info_cb->(2,
427			    "Malformed response from changer -info: $rest");
428		}
429
430		$self->{'nslots'} = $1;
431		$self->{'backward'} = $2;
432		$self->{'searchable'} = $3? 1:0;
433
434		$self->{'got_info'} = 1;
435		return $got_info_cb->(undef, undef);
436	    } else {
437		return $got_info_cb->($exitval, $rest);
438	    }
439	};
440
441	$self->_run_tpchanger($run_cb, "-info");
442    });
443}
444
445# Internal function to create a temporary configuration directory, which persists
446# for the duration of this changer's lifetime (and beyond, TODO)
447sub _make_cfg_dir {
448    my ($self, $config) = @_;
449
450    if ($config->{'is_global'}) {
451	# for the default changer, we don't need to invent a config..
452	$self->{'cfg_dir'} = Amanda::Config::get_config_dir();
453    } else {
454	my $cfg_name = Amanda::Config::get_config_name();
455	my $changer_name = $config->{'name'};
456	my $tapedev = $config->{'tapedev'};
457	my $tpchanger = $config->{'tpchanger'};
458	my $changerdev = $config->{'changerdev'};
459	my $changerfile = $config->{'changerfile'};
460
461	my $cfg_dir = "$AMANDA_TMPDIR/Amanda::Changer::compat/$cfg_name-$changer_name";
462
463	if (-d $cfg_dir) {
464	    rmtree($cfg_dir)
465		or die("Could not delete '$cfg_dir'");
466	}
467
468	mkpath($cfg_dir)
469	    or die("Could not create '$cfg_dir'");
470
471	# Write an amanda.conf
472	open(my $amconf, ">", "$cfg_dir/amanda.conf")
473	    or die ("Could not write '$cfg_dir/amanda.conf'");
474
475	print $amconf "# automatically generated by Amanda::Changer::compat\n";
476	print $amconf 'org "', getconf($CNF_ORG), "\"\n"
477	    if getconf_seen($CNF_ORG);
478	print $amconf 'mailto "', getconf($CNF_MAILTO), "\"\n"
479	    if getconf_seen($CNF_MAILTO);
480	print $amconf 'mailer "', getconf($CNF_MAILER), "\"\n"
481	    if getconf_seen($CNF_MAILER);
482	print $amconf "tapedev \"$tapedev\"\n"
483	    if defined($tapedev);
484	print $amconf "tpchanger \"$tpchanger\"\n"
485	    if defined($tpchanger);
486	print $amconf "changerdev \"$changerdev\"\n"
487	    if defined($changerdev);
488	print $amconf "changerfile \"",
489		Amanda::Config::config_dir_relative($changerfile),
490		"\"\n"
491	    if defined($changerfile);
492
493	# TODO: device_property, tapetype, and the tapetype def
494
495	close $amconf;
496
497	$self->{'cfg_dir'} = $cfg_dir;
498    }
499
500}
501
502# Internal-use function to actually invoke a changer script and parse
503# its output.
504#
505# @param $run_cb: called with ($exitval, $slot, $rest)
506# @params @args: command-line arguments to follow the name of the changer
507sub _run_tpchanger {
508    my ($self, $run_cb, @args) = @_;
509
510    Amanda::MainLoop::synchronized($self->{'lock'}, $run_cb, sub {
511	my ($run_cb) = @_;
512	debug("Amanda::Changer::compat: invoking $self->{script} with " . join(" ", @args));
513
514	my ($readfd, $writefd) = POSIX::pipe();
515	if (!defined($writefd)) {
516	    croak("Error creating pipe to run changer script: $!");
517	}
518
519	my $pid = fork();
520	if (!defined($pid) or $pid < 0) {
521	    croak("Can't fork to run changer script: $!");
522	}
523
524	if (!$pid) {
525	    ## child
526
527	    # get our file-handle house in order
528	    POSIX::close($readfd);
529	    POSIX::dup2($writefd, 1);
530	    POSIX::close($writefd);
531
532	    # cd into the config dir
533	    if (!chdir($self->{'cfg_dir'})) {
534		print "<error> Could not chdir to '" . $self->{cfg_dir} . "'\n";
535		exit(2);
536	    }
537
538	    %ENV = Amanda::Util::safe_env();
539
540	    my $script = $self->{'script'};
541	    { exec { $script } $script, @args; } # braces protect against warning
542
543	    my $err = "<error> Could not exec $script: $!\n";
544	    POSIX::write($writefd, $err, length($err));
545	    exit 2;
546	}
547
548	## parent
549
550	# clean up file descriptors from the fork
551	POSIX::close($writefd);
552
553	# the callbacks that follow share these lexical variables
554	my $child_eof = 0;
555	my $child_output = '';
556	my $child_dead = 0;
557	my $child_exit_status = 0;
558	my ($fdsrc, $cwsrc);
559	my ($maybe_finished, $fd_source_cb, $child_watch_source_cb);
560
561	# Perl note: we have to use anonymous subs here, as they are instantiated
562	# at runtime, rather than at compile time.
563
564	$maybe_finished = sub {
565	    return unless $child_eof;
566	    return unless $child_dead;
567
568	    # everything is finished -- process the results and invoke the callback
569	    chomp $child_output;
570
571	    # handle unexpected exit status as a fatal error
572	    if (!POSIX::WIFEXITED($child_exit_status) || POSIX::WEXITSTATUS($child_exit_status) > 2) {
573		$run_cb->(POSIX::WEXITSTATUS($child_exit_status), undef,
574		    "Fatal error from changer script: ".$child_output);
575		return;
576	    }
577
578	    # parse the child's output
579	    my @child_output = split '\n', $child_output;
580	    my $exitval = POSIX::WEXITSTATUS($child_exit_status);
581
582	    debug("Amanda::Changer::compat: Got response '$child_output' with exit status $exitval");
583	    if (@child_output < 1) {
584		$run_cb->(2, undef, "Malformed output from changer script -- no output");
585		return;
586	    }
587	    my $slotline = shift @child_output;
588	    if ($slotline !~ /\s*([^\s]+)(?:\s+(.+))?/) {
589		$run_cb->(2, undef, "Malformed output from changer script: '$slotline'");
590		return;
591	    }
592	    my ($slot, $rest) = ($1, $2);
593
594	    # append any additional lines to $rest
595	    if (@child_output) {
596		$rest .= "\n" . join("\n", @child_output);
597	    }
598
599	    # let the callback take care of any further interpretation
600	    $run_cb->($exitval, $slot, $rest);
601	};
602
603	$fd_source_cb = sub {
604	    my ($fdsrc) = @_;
605	    my ($len, $bytes);
606	    $len = POSIX::read($readfd, $bytes, 1024);
607
608	    # if we got an EOF, shut things down.
609	    if ($len == 0) {
610		$child_eof = 1;
611		POSIX::close($readfd);
612		$fdsrc->remove();
613		$fdsrc = undef; # break a reference loop
614		$maybe_finished->();
615	    } else {
616		# otherwise, just keep the bytes
617		$child_output .= $bytes;
618	    }
619	};
620	$fdsrc = Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP);
621	$fdsrc->set_callback($fd_source_cb);
622
623	$child_watch_source_cb = sub {
624	    my ($cwsrc, $got_pid, $got_status) = @_;
625	    $cwsrc->remove();
626	    $cwsrc = undef; # break a reference loop
627	    $child_dead = 1;
628	    $child_exit_status = $got_status;
629
630	    $maybe_finished->();
631	};
632	$cwsrc = Amanda::MainLoop::child_watch_source($pid);
633	$cwsrc->set_callback($child_watch_source_cb);
634    });
635}
636
637package Amanda::Changer::compat::Reservation;
638use vars qw( @ISA );
639use Amanda::Debug qw( debug );
640@ISA = qw( Amanda::Changer::Reservation );
641
642sub new {
643    my $class = shift;
644    my ($chg, $slot, $device) = @_;
645    my $self = Amanda::Changer::Reservation::new($class);
646
647    $self->{'chg'} = $chg;
648
649    $self->{'device'} = $device;
650    $self->{'this_slot'} = $slot;
651
652    # mark the changer as reserved
653    $self->{'chg'}->{'reserved'} = $device;
654
655    return $self;
656}
657
658sub do_release {
659    my $self = shift;
660    my %params = @_;
661
662    my $finished = sub {
663	my ($message) = @_;
664
665	$self->{'chg'}->{'reserved'} = 0;
666
667	# unref the device, for good measure
668	$self->{'device'} = undef;
669
670	$params{'finished_cb'}->($message) if $params{'finished_cb'};
671    };
672
673    if (exists $params{'eject'} && $params{'eject'}) {
674	$self->{'chg'}->eject(finished_cb => $finished);
675    } else {
676	$finished->(undef);
677    }
678}
679
680sub set_label {
681    my $self = shift;
682    my %params = @_;
683
684    # non-searchable changers don't get -label, except that chg-zd-mtx needs
685    # it to maintain its slotinfofile (this is a hack)
686    if (!$self->{'chg'}->{'searchable'}
687	&& $self->{'chg'}->{'script'} !~ /chg-zd-mtx$/) {
688	debug("Amanda::Changer::compat - changer script is not searchable, so not invoking -label for set_label");
689        $params{'finished_cb'}->(undef) if $params{'finished_cb'};
690        return;
691    }
692
693    if (!defined $params{'label'}) {
694        $params{'finished_cb'}->(undef) if $params{'finished_cb'};
695        return;
696    }
697
698    my $run_cb = sub {
699	my ($exitval, $slot, $rest) = @_;
700	if ($exitval == 0) {
701	    $params{'finished_cb'}->(undef) if $params{'finished_cb'};
702	} else {
703	    if ($exitval >= 2) {
704		return $self->{'chg'}->make_error("fatal", $params{'finished_cb'},
705		    message => $rest);
706	    } else {
707		return $self->{'chg'}->make_error("failed", $params{'finished_cb'},
708		    reason => "unknown",
709		    message => $rest);
710	    }
711	}
712    };
713    $self->{'chg'}->_run_tpchanger(
714        $run_cb, "-label", $params{'label'});
715}
716
7171;
718