#!/usr/bin/perl -T

########################################
# 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: fileshareset 233183 2008-01-23 12:17:07Z tv $
# 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;

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;

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;
    }
}