path: root/perl-install/standalone/fileshareset

#!/usr/bin/perl -T
use strict;

########################################
# config files
$nfs_exports::default_options = '*(ro,all_squash,sync,no_subtree_check)';
$nfs_exports::conf_file = '/etc/exports';
$smb_exports::conf_file = '/etc/samba/smb.conf';
my $authorisation_file = '/etc/security/fileshare.conf';
my $authorisation_group = 'fileshare';


########################################
# fileshare utility $Id$
# Copyright (C) 2001-2008 Mandriva (pixel@mandriva.com)
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.


########################################
my $uid = $<;
my $username = getpwuid($uid);

########################################
# errors
my $usage =
"usage: fileshareset --add <dir>
       fileshareset --remove <dir>";

my $not_enabled =
qq(File sharing is not enabled.
To enable file sharing put 
"FILESHARING=yes" in $authorisation_file);
       
my $not_simple_enabled = 
qq(Simple file sharing is not enabled.
To enable simple file sharing put
"SHARINGMODE=simple" in $authorisation_file);

my $non_authorised =
qq(You are not authorised to use fileshare'ing
To grant you the rights:
- put "RESTRICT=no" in $authorisation_file
- or put user "$username" in group "$authorisation_group");
my $no_export_method = "can not export anything: no nfs, no smb";

my %exit_codes = reverse(
  1 => $non_authorised,
  2 => $usage,

# when adding
  3 => "already exported", 
  4 => "invalid mount point",

# when removing
  5 => "not exported",

  6 => $no_export_method,
  
  7 => $not_enabled,
  
  8 => $not_simple_enabled,

  255 => "various",
);

################################################################################
# correct PATH needed to call /etc/init.d/... ? seems not, but...
%ENV = ();#(PATH => '/bin:/sbin:/usr/bin:/usr/sbin');

my $modify = $0 =~ /fileshareset/;

authorisation::check($modify);

my @exports = (
	       -e $nfs_exports::conf_file ? nfs_exports::read() : (),
	       -e $smb_exports::conf_file ? smb_exports::read() : (),
	      );
@exports or error($no_export_method);

if ($modify) {
    my ($cmd, $dir) = @ARGV;
    $< = $>;
    @ARGV == 2 && ($cmd eq '--add' || $cmd eq '--remove') or error($usage);

    verify_mntpoint($dir);

    if ($cmd eq '--add') {
	my @errs = map { eval { $_->add($dir) }; $@ } @exports;
	grep { !$_ } @errs or error("already exported");
    } else {
	my @errs = map { eval { $_->remove($dir) }; $@ } @exports;
	grep { !$_ } @errs or error("not exported");
    }    
    foreach my $export (@exports) {
	$export->write;
	$export->update_server;
    }
}
my @mntpoints = grep { $_ } uniq(map { map { $_->{mntpoint} } @$_ } @exports);
print "$_\n" foreach grep { own($_) } @mntpoints;


sub own { $uid == 0 || (stat($_[0]))[4] == $uid }

sub verify_mntpoint {
    local ($_) = @_;
    my $ok = 1;
    $ok &&= m|^/|;
    $ok &&= !m|\Q/../|;
    $ok &&= !m|[\0\n\r]|;
    $ok &&= -d $_;
    $ok &&= own($_);
    $ok or error("invalid mount point");
}

sub error {
    my ($string) = @_;
    print STDERR "$string\n";
    exit($exit_codes{$string} || 255);
}
sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
sub uniq { my %l; $l{$_} = 1 foreach @_; grep { delete $l{$_} } @_ }


################################################################################
package authorisation;

my $F_lock;
sub read_conf {
    my ($exclusive_lock) = @_;
    open $F_lock, $authorisation_file; # do not care if it's missing
    flock($F_lock, $exclusive_lock ? 2 : 1) or die "can not lock";
    my %conf;
    foreach (<$F_lock>) {
	s/#.*//; # remove comments
	s/^\s+//; 
	s/\s+$//;
	/^$/ and next;
	my ($cmd, $value) = split('=', $_, 2);
	$conf{$cmd} = $value || warn qq(suspicious line "$_" in $authorisation_file\n);
    }
    # no close $F_lock, keep it locked
    \%conf
}

sub check {
    my ($exclusive_lock) = @_;
    my $conf = read_conf($exclusive_lock);

    if (lc($conf->{FILESHARING}) eq 'no') {
      ::error($not_enabled);
    } elsif (lc($conf->{SHARINGMODE}) eq 'advanced') {
      ::error($not_simple_enabled);
    } elsif ($conf->{FILESHAREGROUP}) {
      $authorisation_group = $conf->{FILESHAREGROUP};
    } elsif (lc($conf->{RESTRICT}) eq 'no') {
	# ok, access granted for everybody
    } else {
	my @l;
	while (@l = getgrent) {
	    last if $l[0] eq $authorisation_group;
	}
	::member($username, split(' ', $l[3])) or ::error($non_authorised);
    }
}

################################################################################
package exports;

sub find {
    my ($exports, $mntpoint) = @_;
    foreach (@$exports) {
	$_->{mntpoint} eq $mntpoint and return $_;
    }
    undef;
}

sub add {
    my ($exports, $mntpoint) = @_;
    find($exports, $mntpoint) and die 'add';
    push @$exports, my $e = { mntpoint => $mntpoint };
    $e;
}

sub remove {
    my ($exports, $mntpoint) = @_;
    my @l = grep { $_->{mntpoint} ne $mntpoint } @$exports;
    @l < @$exports or die 'remove';
    @$exports = @l;  
}


################################################################################
package nfs_exports;

use vars qw(@ISA $conf_file $default_options);
BEGIN { @ISA = 'exports' }

sub read() {
    my $file = $conf_file;
    open(my $F, $file) or return [];

    my ($prev_raw, $prev_line, @l);
    my $line_nb = 0;
    foreach my $raw (<$F>) {
	$line_nb++;
	local $_ = $raw;
	$raw .= "\n" if !/\n/;

	s/#.*//; # remove comments

	s/^\s+//; 
	s/\s+$//; # remove unuseful spaces to help regexps

	if (/^$/) {
	    # blank lines ignored
	    $prev_raw .= $raw;
	    next;
	}

	if (/\\$/) {
	    # line continue across lines
	    chop; # remove the backslash
	    $prev_line .= "$_ ";
	    $prev_raw .= $raw;
	    next;
	}
	my $line = $prev_line . $_;
	my $raw_line = $prev_raw . $raw;
	($prev_line, $prev_raw) = ('', '');

	my ($mntpoint, $options) = $line =~ /("[^"]*"|\S+)\s+(.*)/ or die "$file:$line_nb: bad line $line\n";

	# You can also specify spaces or any other unusual characters in the
	# export path name using a backslash followed by the character code as
	# 3 octal digits.
	$mntpoint =~ s/\\(\d{3})/chr(oct $1)/ge;

	# not accepting weird characters that would break the output
	$mntpoint =~ m/[\0\n\r]/ and die "i will not handle this";
	push @l, { mntpoint => $mntpoint, option => $options, raw => $raw_line };
    }
    bless \@l, 'nfs_exports';
}

sub write {
    my ($nfs_exports) = @_;
    foreach (@$nfs_exports) {
	if (!exists $_->{options}) {
	    $_->{options} = $default_options;
	}
	if (!exists $_->{raw}) {	    
	    my $mntpoint = $_->{mntpoint} =~ /\s/ ? qq("$_->{mntpoint}") : $_->{mntpoint};
	    $_->{raw} = sprintf("%s %s\n", $mntpoint, $_->{options});
	}
    }
    open(my $F, ">$conf_file") or die "can not write $conf_file";
    print $F $_->{raw} foreach @$nfs_exports;
}

sub update_server() {
    if (fork()) {
	system('/usr/sbin/exportfs', '-r');
	if (system('PATH=/bin:/sbin pidof rpc.mountd >/dev/null') != 0 ||
	    system('PATH=/bin:/sbin pidof nfsd >/dev/null') != 0) {
	    # trying to start the server...
	    system('/etc/init.d/portmap start') if system('/etc/init.d/portmap status >/dev/null') != 0;
	    system('/etc/init.d/nfs', $_) foreach 'stop', 'start';
	}
	exit 0;
    }
}

################################################################################
package smb_exports;

use vars qw(@ISA $conf_file);
BEGIN { @ISA = 'exports' }

sub read() {
    my ($s, @l);
    open(my $F, $conf_file);
    local $_;
    while (<$F>) {
	if (/^\s*\[.*\]/ || eof $F) {
	    #- first line in the category
	    my ($label) = $s =~ /^\s*\[(.*)\]/;
	    my ($mntpoint) = $s =~ /^\s*path\s*=\s*(.*)/m;
	    push @l, { mntpoint => $mntpoint, raw => $s, label => $label };
	    $s = '';
	}
	$s .= $_;
    }
    bless \@l, 'smb_exports';
}

sub write {
    my ($smb_exports) = @_;
    foreach (@$smb_exports) {
	if (!exists $_->{raw}) {
	    $_->{raw} = <<EOF;

[$_->{label}]
   path = $_->{mntpoint}
   comment = $_->{mntpoint}
   public = yes
   guest ok = yes
   writable = no
   wide links = no
EOF
	}
    }
    open(my $F, ">$conf_file") or die "can not write $conf_file";
    print $F $_->{raw} foreach @$smb_exports;
}

sub add {
    my ($exports, $mntpoint) = @_;
    my $e = $exports->exports::add($mntpoint);
    $e->{label} = name_mangle($mntpoint, map { $_->{label} } @$exports);
}

sub name_mangle {
    my ($input, @others) = @_;

    local $_ = $input;

    # 1. first only keep legal characters. "/" is also kept for the moment
    tr|a-z|A-Z|;
    s|[^A-Z0-9#\-_!/]|_|g; # "$" is allowed except at the end, remove it in any case
    
    # 2. removing non-interesting parts
    s|^/||;
    s|^home/||;
    s|_*/_*|/|g;
    s|_+|_|g;

    # 3. if size is too small (!), make it bigger
    $_ .= "_" while length($_) < 3;

    # 4. if size is too big, shorten it
    while (length > 12) {
	my ($s) = m|.*?/(.*)|;
	if (length($s) > 8 && !grep { /\Q$s/ } @others) {
	    # dropping leading directories when the resulting is still long and meaningful
	    $_ = $s;
	} else {
	    s|(.*)[0-9#\-_!/]|$1|
	      # inspired by "Christian Brolin" "Long names are doom" on comp.lang.functional
	      || s|(.+)[AEIOU]|$1|# allButFirstVowels
	      || s|(.*)(.)\2|$1$2| # adjacentDuplicates
	      || s|(.*).|$1|; # booh, :'-(
	}
    }

    # 5. remove "/"s still there
    s|/|_|g;

    # 6. resolving conflicts
    my $l = join("|", map { quotemeta } @others);
    my $conflicts = qr|^($l)$|;
    if (/$conflicts/) {
      A: while (1) {
	    for (my $nb = 1; length("$_$nb") <= 12; $nb++) {
		if ("$_$nb" !~ /$conflicts/) {
		    $_ = "$_$nb";
		    last A;
		}
	    }
	    $_ or die "can not find a unique name";
	    # can not find a unique name, dropping the last letter
	    s|(.*).|$1|;
	}
    }

    # 7. done
    $_;
}

sub update_server() {
    if (fork()) {
	system('/usr/bin/killall -HUP smbd 2>/dev/null');
	if (system('PATH=/bin:/sbin pidof smbd >/dev/null') != 0 ||
	    system('PATH=/bin:/sbin pidof nmbd >/dev/null') != 0) {
	    # trying to start the server...
	    my ($f) = grep { -f $_ } map { "/etc/init.d/$_" } 'smb', 'samba', 'rc.samba';
	    if ($f) {
		system($f, $_) foreach 'stop', 'start';
	    } else {
		print STDERR "Error: Can't find the samba init script \n";
	    }
	}
	exit 0;
    }
}