#!/usr/pubsw/bin/perl -w
$ID = q$Id: cleanmtpts,v 1.5 2004/03/11 01:15:58 eagle Exp $;
#
# cleanmtpts -- Clean out stale information in mount point database.
#
# Written by Neil Crellin <neilc@stanford.edu>
# Extensively updated by Russ Allbery <rra@stanford.edu>
# Copyright 1999, 2003, 2004 Board of Trustees, Leland Stanford Jr. University
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.

##############################################################################
# Site configuration
##############################################################################

# The path to the mount point database.  Note that you need to make sure that
# all versions of Perl that you use to run this script use the same version of
# the Berkeley DB database format.
$DB = '/afs/ir/service/afs/data/mountpoints/mountpoints.db';

# The full path to fs and vos.  Allow for Linux where the preferred location
# may be on local disk.
($FS)  = grep { -x $_ } qw(/usr/bin/fs /usr/afsws/bin/fs /usr/pubsw/bin/fs);
$FS ||= '/usr/afsws/bin/fs';

# The following function is used to convert paths to a canonical form.  You
# will almost certainly want to change this for your site.
sub canonify_path {
    my ($path) = @_;
    $path =~ s%^/chroot/afs/%/afs%;
    $path =~ s%^/afs/\.?ir(?:\.stanford\.edu)?/%/afs/.ir/%;
    return unless ($path =~ m%^/afs/\.ir/% || $path eq '/afs');
    return $path;
}

# You will probably also need to modify the path to Perl at the top of this
# script.

##############################################################################
# Modules and declarations
##############################################################################

use strict;
use vars qw($DB $ID $FS $VOS);

use DB_File ();
use Getopt::Long qw(GetOptions);

##############################################################################
# Mount point checking
##############################################################################

# Given a path, make sure it's fully qualified and doesn't contain any invalid
# characters.
sub fix_path {
    my ($path) = @_;
    return unless $path =~ m%^/afs%;
    $path = canonify_path ($path);
    return unless $path;
    return if $path =~ /[\\\';]/;
    $path =~ s%/+$%%;
    return $path;
}

# Given a path, return the volume mounted on that path or undef if it does not
# appear to be a mount point (or on any other failure).
sub path_to_volume {
    my ($path) = @_;
    my $volname;
    if ($path eq '/afs') {
        $volname = 'root.afs';
    } else {
        $volname = `$FS lsmount '$path' 2>&1`;
        my $ismtpt = ($? == 0);
        return unless $ismtpt;
        $volname =~ s/.*a mount point for volume \'\#(\S+)\'\s+$/$1/;
    }
    return $volname;
}

# Check a single mount point, canonifying if necessary and making sure that
# it's still valid.  Remove mount point mappings that are no longer valid.
# Special-case /afs and root.afs, since fs lsm may not return the right
# results there.  Returns the number of deletions done.
sub check_mount {
    my ($volume, $mtpts) = @_;
    my ($path) = split (';', $$mtpts{$volume});
    my $newpath = fix_path ($path);
    if (!$newpath) {
        print "REMOVING $volume => $path (bad path)\n";
        delete $$mtpts{$volume};
        return 1;
    } else {
        my $real = path_to_volume ($newpath);
        if (!$real || $real ne $volume) {
            print "REMOVING $volume => $path\n";
            delete $$mtpts{$volume};
            return 1;
        } elsif ($path ne $newpath) {
            print "CANONIFYING $volume => $newpath\n";
            my ($path, $volid, $canonical) = split (';', $$mtpts{$volume});
            $$mtpts{$volume} = "$newpath;$volid;$canonical";
        }
        return 0;
    }
}

##############################################################################
# Main routine
##############################################################################

# Trim extraneous garbage from the path.
my $fullpath = $0;
$0 =~ s%.*/%%;

# Parse command line options.
my ($help, $version);
Getopt::Long::config ('bundling', 'no_ignore_case');
GetOptions ('help|h'    => \$help,
            'version|v' => \$version) or exit 1;
if ($help) {
    print "Feeding myself to perldoc, please wait....\n";
    exec ('perldoc', '-t', $fullpath) or die "$0: cannot fork: $!\n";
} elsif ($version) {
    my $version = join (' ', (split (' ', $ID))[1..3]);
    $version =~ s/,v\b//;
    $version =~ s/(\S+)$/($1)/;
    $version =~ tr%/%-%;
    print $version, "\n";
    exit 0;
}

# Tie the database file.  Note that we do not do any locking here even though
# we probably should.  See the documentation.
my %mtpts;
tie (%mtpts, 'DB_File', $DB) or die "$0: unable to read $DB: $!\n";

# If we're given a list of volumes on the command line, process those.
# Otherwise, process every volume in the database.  The duplication of code is
# annoying here, but I don't see a good way to avoid it without reading all
# the volumes in the database into memory.
my ($count, $deletes) = (0, 0);
if (@ARGV) {
    for my $volume (@ARGV) {
        next unless exists $mtpts{$volume};
        $deletes += check_mount ($volume, \%mtpts);
    } continue {
        $count++;
        print "$count entries processed\n" if ($count % 1000 == 0);
    }
} else {
    for my $volume (keys %mtpts) {
        $deletes += check_mount ($volume, \%mtpts);
    } continue {
        $count++;
        print "$count entries processed\n" if ($count % 1000 == 0);
    }
}
print "$count entries total processed\n";
print "$deletes entries deleted\n";
exit 0;
__END__

##############################################################################
# Documentation
##############################################################################

=head1 NAME

cleanmtpts - Clean out stale information in mount point database

=head1 SYNOPSIS

cleanmtpts [B<-hv>] [I<volume> ...]

=head1 DESCRIPTION

B<cleanmtpts> either walks the entire mount point database or processes just
those volumes given on the command line if any are givenn.  For each volume,
it checks the recorded path and makes sure that it's in its canonical form.
It then makes sure that the path is still a mount point for that volume.

If the path is no longer a mount point, no longer exists, or is no longer a
mount point for the same volume, the entry is removed from the database.
Otherwise, if the canonical path doesn't match the current path, the path is
updated.  One line is printed out for each change, and a status line is
printed after every 1000 processed entries.  A total number of entries
processed is printed at the end.

Note that some process is needed to check the contents of the database
against the complete list of volumes in the cell and identify any volumes
that are missing mount point entries, since B<cleanmtpts> reacts to any
incorrect information by just deleting the entry, leaving no entry for that
volume at all.

This script should be run periodically against the database (probably
monthly).

=head1 OPTIONS

=over 4

=item B<-h>, B<--help>

Print out this documentation (which is done simply by feeding the script
to C<perldoc -t>).

=item B<-v>, B<--version>

Print out the version of B<cleanmtpts> and exit.

=back

=head1 EXAMPLES

Walk the entire database and check every entry:

    cleanmtpts

Check only the entries for user.rra and user.neilc:

    cleanmtpts user.rra user.neilc

=head1 FILES

=over 4

=item F</afs/ir/service/afs/data/mountpoints/mountpoints.db>

The default location of the mount point database where mount point mappings
are looked up.  This will use whatever database format that the DB_File that
comes with Perl uses.

=back

=head1 BUGS

This program doesn't lock the database, so running it at the same time as
B<loadmtpt> may corrupt the database (although in extensive use of this
program and related programs, I've never seen this happen).  The only reason
why this has not yet been done is that B<cleanmtpts> can take hours to run
and I want to be able to run it without locking all other users out of the
database in the meantime.

=head1 SEE ALSO

mtpt(1), loadmtpt(1)

The current version of this program and the B<mtpt> and B<loadmtpt>
utilities are available from their web page at
L<http://www.eyrie.org/~eagle/software/afs-mount/>.

=head1 AUTHORS

Neil Crellin <neilc@stanford.edu> and Russ Allbery <rra@stanford.edu>.

=head1 COPYRIGHT AND LICENSE

Copyright 1999, 2003, 2004 Board of Trustees, Leland Stanford
Jr. University.

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=cut