#!C:\Perl\bin\perl.exe -w
#
#    $Id: fs2htaccess.pl 138 2005-03-31 09:26:35Z  $
#
#    fs2htaccess Version 0.1.1 - this perl script transports windows file 
#    and directory permissions to apache per-directory configs.
#
#    Copyright (C) 2005  Markus Siebeneicher <siebeneicher@oaklett.org>
#
#    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 of the License, 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. 
#
#################################################################################

=pod

=pod SCRIPT CATEGORIES

Win32

=pod OSNAMES

Win32

=pod README

fs2htaccess transports windows file and directory permissions to apache per-directory configs.

=head1 NAME

B<fs2htaccess> - this perl script transports windows file and directory permissions to apache per-directory config.

=head1 SYNOPSIS

    # simple process one directory and write .htaccess config file
    perl c:\programms\fs2htaccess.pl s:\path
    
    # recurse all sub-directories, set HIDDEN attribute to config file and process current working directory
    cd d:\data
    perl c:\programms\fs2htaccess.pl -rs .
    
    # ignore all files beginning with a dot and write config file named: httpd.conf
    perl c:\programms\fs2htaccess.pl -c httpd.conf -i ^\. d:
    
    # print help page
    perl c:\programms\fs2htaccess.pl -h
    
    # ...
    perl fs2htaccess.pl -vsr -i ^\. s:\

    # example of generated apache per-directory config
    require user Administrator admin Siebeneicher
    require group Domänen-Admins
    <Files p_zukunftsatlas_karte_1.gif>
    require user Administrator admin Siebeneicher
    require group Domänen-Admins
    </Files>
    <Files echo-headers2.php>
    require user Administrator admin Siebeneicher
    require group Domänen-Admins
    </Files>
    <Files echo-headers.php>
    require user Administrator admin Siebeneicher
    require group Domänen-Admins
    </Files>

=head1 PREREQUISITES

=begin html

This script depends on the <a href="http://www.roth.net/perl/perms/">Win32::Perms</a> module which is maintained by the <a href="http://www.roth.net">Roth Consultings</a>.

=end html

=head1 DESCRIPTION

fs2htaccess.pl is a simple perl script for win32 systems and was developed under a w2k system using  ActivePerl 5.8.6. fs2htaccess.pl scan's a given directory for files. for each file it looks which windows system account have READ(FILE_READ_DATA STANDARD_RIGHTS_ALL READ_CONTROL) permission, than all of these accounts will be transported -- user or group account -- to the apache per-directory config. if a file have permission restrictions the entry in your config could look like:

    <Files private-picture.jpg>
        require user dude
        require group personal admins
    </Files>

if there are only permission restrictions to a user or group account, only that user or group will be transported.

if the config file is empty after processing a directory, that comes if all folks can read the folder and files, the config file will be deleted. if there was also an previous defined config in the folder all included apache directives, without "require ..." will be kept in it.

if the argument B<-r> was given all sub-directories will be process too.

under different locale windows has pre-defined a group called 'Everyone' which gives all users and group same permission. see argument B<-m>.

=head2 PRACTICAL NOTES

=over

=item

- you should be admin or a user who have read/write permission to the folder and config file you want to process.

=item

- you want to hide the config file after transporting accounts? no problem: set the B<-s> argument and all config files get the HIDDEN flag by default.

=item

- by default that config file is named ".htaccess". you can change the name: see OPTIONS.

=back

=head1 USAGE

    perl fs2htaccess.pl [OPTIONS] DIRECTORY

=head2 OPTIONS

        -a              set READONLY flag to config files [default: off]
        -c CONFIG-FILE  config filename [default: .htaccess]
        -d              debug mode [default: off]
        -i FILE-REGEX   ignore all files which match against this
                        regular expression
        -s              shadow config files; set hide attribute [default: off]
        -h              print this help page
        -m MESSIAH      messiah account(s) separated by '|' [default: Everyone|Jeder]
        -r              process all sub-directories in DIRECTORY
        -v              verbose mode

=head2 DIRECTORY

directory which will be processed. if recurse processing is on, which is by default off, all sub-directories will be processed too. 

    s:\my\pretty\absolute\path
    .\relative\to\cwd

=head2 CONFIG-FILE

set this filename equal to the value of the AccessFileName directive in your apache config. by default this is set to '.htaccess'.

    per-dir-httpd.conf

=head2 FILE-REGEX

all files on disk matched against this regular expression will be ignored. the regular expression is processed without modificators.

    meta.xml
    ^\.
    .* (all files will be ignored)

=head2 MESSIAH

the windows system's pre-defined group 'Everyone' has different names under different locales. if that group has permission, all the folk have exactly that permission too. so the account is like a messiah cos it opens all the doors to the folks. change the MESSIAH to what ever you want, if you have more messiah than one, separete them by '|'. messiah will processed case-insensitive.

    example: everyone|jeder [default]

=head1 SEE ALSO

=begin html

<a href="http://www.roth.net/perl/perms">Win32::Perms</a>

=end html

This script is only usefull if you have same user/group accounts on both, webserver and filesever. Its common to use a Domain Controller to store your user/group accounts only once. if you have a linux or unix webserver you could manage to sync the accounts from the DC with the winbind package. also you could use mod_auth_pam for your apache webserver to auth against the winbind accounts through PAM authentication. good luck...

=head1 KNOWS BUGS

=over 4

=item

if there was an <Files> directive in an old config with other directives in side than 'require ...', these directives will bex lost when B<-i regex> matches that specific file. in short: old directives in side <Files> except 'require ...' fly away if that file should be ignored.

=item

script could set permission to admins on all config files. permissions could be pre-defined or given by argument -p. accounts should be given by argument B<-a>.

=back

please report bugs to <siebeneicher@oaklett.org>

=head1 CHANGELOG

=over 4

=item  from version 0.1.0 to 0.1.1

+ filenames regular expressions meta chars +.()${}[]^ became escaped

=back

=head1 LICENSE

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 of the License, 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. 

=head1 Author

Copyright (C) 2005 - Markus Siebeneicher <siebeneicher@oaklett.org>

=cut

#######################################################################


use strict;
use warnings;

use Win32;
use Win32::Perms;
use Win32::File;

use Getopt::Std;
use Benchmark;

my %opts;
getopts("ahvrsi:c:d", \%opts);

if(defined($opts{h})) {
    print "USAGE: fs2htaccess.pl [OPTIONS] DIRECTORY\n";
    print "\n";
    print "OPTIONS:\n";
    print "\t-a\t\tset READONLY flag to config files [default: off]\n";
    print "\t-c CONFIG-FILE\tconfig filename [default: .htaccess]\n";
    print "\t-d\t\tdebug mode [default: off]\n";
    print "\t-i FILE-REGEX\tignore all files which match against this\n";
    print "\t\t\tregular expression\n";
    print "\t-s\t\tshadow config files; set hide attribute [default: off]\n";
    print "\t-h\t\tprint this help page\n";
    print "\t-m MESSIAH\tmessiah account(s) separated by '|'\n";
    print "\t\t\t[default: Everyone|Jeder]\n";
    print "\t-r\t\tprocess all sub-directories in DIRECTORY\n";
    print "\t-v\t\tverbose mode\n";
    print "\n";
    print "DIRECTORY\n";
    print "\tdirectory which will be processed.\n";
    print "\tif recurse processing is on, which is by default off,\n";
    print "\tall sub-directories will be processed too.\n";
    print "\texample: s:\\my\\pretty\\absolute\\path\n";
    print "\texample: .\\relative\\to\\cwd\n";
    print "\n";
    print "CONFIG-FILE\n";
    print "\tset this filename equal to the value of the AccessFileName directive in\n";
    print "\tyour apache config. by default this is set to '.htaccess'.\n";
    print "\texample: per-dir-httpd.conf\n";
    print "\n";
    print "FILE-REGEX\n";
    print "\tall files on disk matched against this regular expression will be\n";
    print "\tignored. the regular expression is processed without modificators.\n";
    print "\texample: meta.xml\n";
    print "\texample: ^\\.\n";
    print "\texample: .* (all files will be ignored)\n";
    print "\n";
    print "MESSIAH\n";
    print "\tthe windows system's pre-defined group 'Everyone' has different\n";
    print "\tnames under different locales. if that group has permission, all the\n";
    print "\tfolk have exactly that permission too. so the account is like a messiah\n";
    print "\tcos it opens doors to the folks. change the MESSIAH to what\n";
    print "\tever you want, if you have more MESSIAH than one, separete them by '|'.\n";
    print "\tMESSIAH will processed as regular expression(case-insensitive).\n";
    print "\texample: Everyone|Jeder\n";
    print "\n";
    print "Copyright (C) 2005 Markus Siebeneicher\n";
    print "This script is distributed under the General Public License.\n";
    print "please report bugs to <siebeneicher\@oaklett.org>\n";
    exit 0;
}


my $rootDirectory;
if(0 > $#ARGV) {
    print "FATAL ERROR: missing root-directory, try with argument -h.\n";
    print "exit 1";
    exit 1;
} elsif(0 < $#ARGV) {
    print "FATAL ERROR: too much arguments given or in wrong order.\n";
    print "exit 1";
    exit 1;
} else {
    ($rootDirectory) = @ARGV;
    if($rootDirectory =~ m/[^\\]$/) { $rootDirectory.= '\\'; }   # if necessary append slash
}

my ($recursive) = (defined($opts{r})) ? 1 : 0;
our $readonly = (defined($opts{a})) ? 1 : 0;
our $rwConfigAccounts = (defined($opts{p})) ? $opts{p} : '';
our $hideConfigFile = (defined($opts{s})) ? 1 : 0;
our $configFilename = (defined($opts{c})) ? $opts{c} : '.htaccess';
our $ignoreFilePattern = (defined($opts{f})) ? $opts{f} : '';

our $allowedMasks = 'FILE_READ_DATA STANDARD_RIGHTS_ALL READ_CONTROL';
our $messiah = 'Everyone|Jeder';    # this string is part of a regular expression; separate messiahs by "|";  if any messiahs account has READ permission to an object all the folk will have permission to, than in fact: no permission restrictions are given


# statistic vars
our $countDirs = 0;
our $countFiles = 0;



my $t0 = new Benchmark;
dirWalk($rootDirectory, $recursive);
my $t1 = new Benchmark;



if($opts{v}) {
    print "files processed: $countFiles (" . $countFiles / $countDirs . ")\n";
    print "directories processed: $countDirs\n";
    print "processing took: " . timestr(timediff($t1, $t0));
}


sub dirWalk {
    my ($dir, $recursive) = @_;
    my $configFile = $dir.$configFilename;

    if(!-d $dir) {
	print "ERROR: given directory '$dir' is no directory.\n";
	return 1;
    }

    $countDirs++;   # statistic

    my $data = '';                   # we need a defined $data string just now SOURCE is empty
    if(-e $configFile && !-f $configFile) {
	print "ERROR: config '$configFile' exists, but is not a file(-f).\n";
	return 1;
    } elsif(-e $configFile) {                              # r/w mode
	unHideFile($configFile);                           # cant open hidden files cos permission denied(ask bill!)
	unsetReadOnly($configFile);                           # cant write READONLY flagged files
	if(!open(SOURCE, "+<", $configFile)) {                                              # RDWR TRUNC CREAT
	    print "ERROR: could not open '$configFile' in R/W mode: $!\n";
	    return 1;
	}
	while(<SOURCE>) { $data.= $_; }
    } else {
	if(!open(SOURCE, ">", $configFile)) {                                         # only write mode
	    print "ERROR: could not open '$configFile' in WRONLY mode: $!\n";
	    return 1;
	}
    }
                                      # iterate through files on disk
    my (@dirs, %currentFiles);        # %currentFiles will be used for each found file on disk
    opendir(IN, $dir);                # value will be hash(keys: user, group)
    while(defined(my $in = readdir(IN))) {
	next if $in =~ m/^\.\.?$/;            # jump over "." and ".."

	# fill directory list
	if($recursive && -d $dir.$in) {
	    $dirs[$#dirs+1] = $dir.$in.'\\';
	}

	# fill files list
	if(-f $dir.$in && $dir.$in !~ m/$ignoreFilePattern/) {            # object must be file and dont 
	    my %rdyFileAccs = prepareAccounts(getReadAccounts($dir.$in));      # match ignore pattern
	    if($opts{d}) { 
		print $dir.$in . ' (user: ' . $rdyFileAccs{user} . ', group: ' . $rdyFileAccs{group} .  ")\n";
	    }
	    $currentFiles{$in} = { %rdyFileAccs };
	    $countFiles++;
	}
    }
    closedir(IN);



    my %rdyDirAccs = prepareAccounts(getReadAccounts($dir));
    if($opts{d}) { print $dir . '(user: '.$rdyDirAccs{user}.', group: '.$rdyDirAccs{group}.')' . "\n"; }


    my %foundFiles;                                              # store found <Files> Directives from old config
    for my $item ($data =~ m/<Files .+?>.*?<\/Files>/gsi) {      # get all named blocks of the <Files> directive
	my ($file, $tmp) = $item =~ m/<Files [\"\']?.+?[\"\']?>/gi;    # e.g. $file = "<Files xxx>";
	($tmp = $file) =~ s/([\.\(\)\+\$\{\}\[\]\^])/\\\1/g;           # we have to escape re meta-chars +.()${}[]^

	my $directives = join( '', $item =~ m/(?<=$tmp).*(?=<\/Files>)/gis );    
	$directives =~ s/^\s+//mg;         # remove whitespace
	$directives =~ s/\s+$//mg;

	my @directives = split( "\n", $directives );

	$file =~ s/<Files [\"\']?(.+?)[\"\']?>/$1/;           # strip filename from <Files filename> directive
	@{$foundFiles{$file}} = @directives;                  # but no panic: $file is free from escape chars "\"
    }

    # remove all named blocks of the <Files> Directive, next step we prebuild all current files
    $data =~ s/<Files .+?>.*?<\/Files>//gsi;

    for my $filename ((my %tmpHash = %currentFiles)) {     # iterate through %currentFiles
	                                               # to build the <Files..> directives with all nested directives
	my $directives = '';                           # the %currentFiles values will no more a hash, soon string
	if($currentFiles{$filename}{user}) { $directives.= "\trequire user $currentFiles{$filename}{user}\n"; }        # append if there are required accounts
	if($currentFiles{$filename}{group}) { $directives.= "\trequire group $currentFiles{$filename}{group}\n"; }


	if(defined($foundFiles{$filename})) {                           # check for nested directives in
	    for my $oldDirective (@{$foundFiles{$filename}}) {          # all found(old config) <Files> directives
		if($oldDirective !~ m/require/) {                   # and append them except: require directives
		    $directives.= "\t". $oldDirective . "\n";
		}
	    }
	}

	if($directives) {   
	    $currentFiles{$filename} = "<Files \"$filename\">\n$directives</Files>";
	} else {                                       # no nested directives: no <Files> directive
	    delete($currentFiles{$filename});
	}
    }


    # from this point the script presume that there could only be 'require' directives 
    # which arn't nested into other directives. in fact: now remove all 'require' directives
    # and append the fresh ones if required.
    $data =~ s/^.*require.*$//mig;


    # so we have cleaned up all that require shit, lets append new require shit again...
    if($rdyDirAccs{user}) { $data.= "require user $rdyDirAccs{user}\n"; }
    if($rdyDirAccs{group}) { $data.= "require group $rdyDirAccs{group}\n"; }

    while(my ($key, $value) = each(%currentFiles)) { $data.= "$value\n"; }


    $data =~ s/^\s+//mg;        # remove empty lines
    $data =~ s/\s+$//mg;       

    seek(SOURCE, 0, 0);
    print SOURCE $data;
    truncate(SOURCE, tell(SOURCE));
    close(SOURCE);


    if(-z $configFile) {                                 # remove empty config
	unlink($configFile);
    } else {
	($hideConfigFile) ? hideFile($configFile) : unHideFile($configFile);           # (un)hide config
	($readonly) ? setReadOnly($configFile) : unsetReadOnly($configFile);           # (un)set READONLY flag
# do: set permission to specific accounts
    }


    # walk through deeper dir's
    my $nextDir;
    foreach $nextDir (@dirs) {
	dirWalk($nextDir, $recursive);
    }
}


sub getReadAccounts {
    my ($location) = @_;
    my @accounts;

    my $perms = new Win32::Perms($location);
    my @acl;
    $perms->Dump(\@acl);


    foreach my $ace (@acl) {
	# DACL(Discretionary Access Control List) required; no need for SACL(System Access Control List)
	next if( !defined($ace->{Entry}) || $ace->{Entry} !~ /DACL/i);

	my @masks;
	Win32::Perms::DecodeMask($ace, \@masks);
	
	foreach my $mask ( @masks ) {
	    push( @accounts, $ace->{Account} ) if($allowedMasks  =~ /$mask/i );
	}
    }

    return @accounts;
}


# takes account-name and returns sidtype
# sidtype's: 1(user), 2(group), 3(domain), 4(alias), 5(sid predefined), 6(killed account), 7(non-valid), 8(unknown)
sub getAccountType {
    my ($account) = @_;

    my ($domain, $sid, $sidtype);
    Win32::LookupAccountName('', $account, $domain, $sid, $sidtype);
    return $sidtype;
}


# subroutine prepares an array of account-names in two groups: user and group 
# and returns a hash with these two elements(same name: 'user' and 'group').
# the values of the user and the group elements contain the assigned accounts
# seperated by space.
sub prepareAccounts {
    my (@preAccounts) = @_;
    my %accounts = (user => '',
		    group => '');

    for my $account (@preAccounts) {
	my $sidtype = getAccountType($account);

	# die guten ins töpchen, die schlechten ins kröpfchen
	if($sidtype == 1) {
	    $accounts{user} .= ($accounts{user} !~ m/$account/) ? $account . ' ' : '';
	} elsif($sidtype == 2) {
	    $accounts{group} .= ($accounts{group} !~ m/$account/) ? $account . ' ' : '';
# if users 'jeder' have read permission, all user/group have read permission...
# user 'jeder' is of sidtype 5(predefined)
	} elsif($account =~ /($messiah)/i) {  
	    $accounts{user} = '';
	    $accounts{group} = '';
	    last;
	}
    }

    $accounts{user} =~ s/ $//;                # remove last whitespace
    $accounts{group} =~ s/ $//;

    return %accounts;
}

sub hideFile {
    my ($file) = @_;
    if(!-f $file) { return 1; }
    my $fileAttr;
    Win32::File::GetAttributes($file, $fileAttr);
    return Win32::File::SetAttributes($file, $fileAttr | HIDDEN);
}

sub unHideFile {
    my ($file) = @_;
    if(!-f $file) { return 1; }
    my $fileAttr;
    Win32::File::GetAttributes($file, $fileAttr);
    return Win32::File::SetAttributes($file, ($fileAttr | HIDDEN) - HIDDEN);
}

sub setReadOnly {
    my ($file) = @_;
    if(!-f $file) { return 1; }
    my $fileAttr;
    Win32::File::GetAttributes($file, $fileAttr);
    return Win32::File::SetAttributes($file, $fileAttr | READONLY);
}

sub unsetReadOnly {
    my ($file) = @_;
    if(!-f $file) { return 1; }
    my $fileAttr;
    Win32::File::GetAttributes($file, $fileAttr);
    return Win32::File::SetAttributes($file, ($fileAttr | READONLY) - READONLY);
}


exit 0;