#!../../bin/https/perl/perl
#
# Convert Netscape Dynamic Configurate Files (.nsconfig) to .htaccess files
#
# Execute from the config directory of your instance like this:
#   ../../bin/https/perl/perl ../../plugins/htaccess/htconvert server.xml
#

BEGIN {
    @INC = ( '../../bin/https/perl' );
}

use ObjConf;

$| = 1;

die "Usage: $0 server.xml\n" unless scalar( @ARGV ) == 1;

if ( $ARGV[0] eq '-t' ) {
    &cvtNSconfig( '/u/flc/play/htaccess/.nsconfig',
                  '/u/flc/play/htaccess/.htaccess' );
    exit 0;
}

#
# Main
#
# This isn't meant to be a full-blown XML parser, we are just interested
# in a few elements, so keep it simple.
#

open( XML, $ARGV[0] ) || die "Can't read $src: $!\n";
while ( <XML> ) {
    chomp;
    if (/<VSCLASS (.*)>/) {
	foreach $entry (split/[>,\s+]/) {
            my($var, $value) = split(/=/, $entry);
            $vars{$var} = &stripQuotes( $value );
        }

        print "Converting VS Class $vars{'id'}\n";
        print "obj.conf is $vars{'objectfile'}\n";
    }
    if (/name=\"docroot\" value=\"(.*)\"/) {
        $docroot = $1;
	if  ( $vars{'id'} ) { 
            &parse_doc_dirs($vars{'objectfile'}, $docroot);
	}
    }
}

sub parse_doc_dirs {
    my($dir) = shift;
    my($docroot) = shift;

    $obj = new ObjConf( $dir ) || die "Can't read $dir: $!\n";

    foreach $directive ( @{$obj->{'names'}->{'default'}->{'directives'}} ) {
        if ( $directive->{'type'} eq 'NameTrans' ) {
            if ( $directive->{'name'} eq 'pfx2dir' ) {
                &cvt( $directive->{'params'}->{'dir'} );
            } elsif ( $directive->{'name'} eq 'document-root' ) {
                    &cvt( $docroot );
            }
        }
    }
}

# Find .nsconfig files, and convert them to .htaccess files, recursively.
# Keep track of dirs already done, and don't redo them.
sub cvt {
    my        $dir = shift;
    my        $file;
    my        @dirs = ();
    my        $subDir;

    return if $doneDirs{$dir};
    $doneDirs{$dir} = 1;
    print "Going to convert $dir\n";
    if ( opendir( DIR, $dir ) ) {
      while ( $file = readdir( DIR ) ) {
        next if $file =~ /^\.\.?$/;        # skip this and parent directory
        &cvtNSconfig( "$dir/$file", "$dir/.htaccess" ) if $file eq '.nsconfig';
        push( @dirs, $file ) if -d "$dir/$file";
      }
      closedir( DIR );
      foreach $subDir ( @dirs ) {
        &cvt( "$dir/$subDir" );        # recurse
      }
    }
    else {
        print "Can't open $dir: $!\n";
    }
}

sub cvtNSconfig {
    my        $src = shift;
    my        $dest = shift;
    my        %curFiles;

    print "Converting $src to $dest\n";
    open( SRC, $src ) || die "Couldn't read $src: $!\n";
    while ( -f $dest ) {
        print "Not overwriting $dest, consider moving $dest.new to $dest\n";
        $dest .= '.new';
    }
    open( DEST, ">$dest" ) || die "Can't create $dest: $!\n";
    while ( <SRC> ) {
        chomp;
        if ( m'^#' || /^$/ ) {
            print DEST $_, "\n";
            next;
        } elsif ( /^<Files\s*/i ) {
            my        $remainder = $';

            die "Nested <Files> directives: $src: $..  Can't handle it\n"
                if defined( %curFiles );
            $remainder =~ s/>\s*$//;
            if ( $remainder ne '*' ) {
                print "Non-global $_ specification ignored, check $src: $.\n";
            }
            $curFiles{'active'} = 1;
        } elsif ( m'^</Files>'i ) {
            die "Unexpected $_: $src: $.\n" unless defined( %curFiles );
            delete $curFiles{'active'};
            &processDirectives( \%curFiles );
            undef( %curFiles );
        } else {
            my        $directive;
            my        $data;

            ( $directive, $data ) = /^(\w+)\s*(.*)/;
            push( @{$curFiles{$directive}}, $data );
        }
    }
    print DEST "<Limit POST PUT>\n";
    print DEST "order deny,allow\n";
    print DEST "deny from all\n";
    print DEST "</Limit>\n";

    close( SRC );
    close( DEST );
}

sub processDirectives {
    my        $directives = shift;
    my        $directive;
    my        $directiveData;
    my        $data;
    

    if ( defined( $directives->{'RestrictAccess'} ) ) {
        my        %params;
        my        $i;
        my        $currentPermission;
        my        $prefix = '';
        my        $currentMethods;

        for ( $i = 0 ; $i < scalar( @{$directives->{'RestrictAccess'}} ) ; ++$i ) {
            %params = &parseParams( $directives->{'RestrictAccess'}->[$i] );
            if ( defined( $params{'method'} ) ) {
                $params{'method'} =~ s/\|/ /g;
                $params{'method'} =~ s/[\(\)]|//g;
            } else {
                $params{'method'} = "GET";
            }
             
            if ($currentMethods ne $params{'method'}) {
                print DEST "</Limit>\n" if ($currentMethods ne '');
                print DEST "<Limit $params{'method'}>\n";
                print DEST "order deny,allow\n";
                print DEST "deny from all\n";        # default
                $currentMethods = $params{'method'};
            }

#            print DEST "$prefix$params{'type'} from ";
            if ( defined( $params{'ip'} ) ) {
                my        $ip = $params{'ip'};

                $ip =~ s/^\*\.\*\.\*\.\*$/all/;
                $ip =~ s/^\*$/all/;
                if($ip =~/(.*)\((.*)\)(.*)/){
                   my $counter1=0;
                   my $initialp=$1;
                   my $insidebr=$2;
                   my $tailp=$3;
                   @oredfields=split(/\|/, $insidebr);
                   for($counter1=0;$counter1<=$#oredfields;$counter1++){
                      if($oredfields[$counter1] =~/(.*)?(\[)([0-9]{1,3})\-([0-9]{1,3})(\])([0-9]{1,3})?/){
                         for($jk=$3;$jk<=$4;$jk++){
                             $ip = $initialp.$1.$jk.$6.$tailp;
                             $ip =~ s/\*$//;
                             print DEST "$prefix$params{'type'} from ".$ip, "\n";
                         }
                      } else {
                          $ip = $initialp.$oredfields[$counter1].$tailp;
                          $ip =~ s/\*$//;
                          print DEST "$prefix$params{'type'} from ".$ip, "\n";
                      }
                  }
                }else{
                      $ip =~ s/\*$//;
                      print DEST "$prefix$params{'type'} from ".$ip, "\n";
                }
            }

            if ( defined( $params{'dns'} ) ) {
                my        $dns = $params{'dns'};

                $dns =~ s/^\*$/all/;
                $dns =~ s/^\*//;
                if($dns =~/(.*)\((.*)\)(.*)/){
                   my $initialp=$1;
                   my $insidebr=$2;
                   my $tailp=$3;
                   @oredfields=split(/\|/, $insidebr);
                   for($counter1=0;$counter1<=$#oredfields;$counter1++){
                       $dns= $initialp.$oredfields[$counter1].$tailp;
                       $dns =~ s/\*$//;
                       print DEST "$prefix$params{'type'} from ".$dns, "\n";
                   }
                }else{
                    $dns =~ s/\*$//;
                    $dns =~ s/^(\.\*)+//g;
                    print DEST "$prefix$params{'type'} from ".$dns, "\n";
                }
            }
        }
        print DEST "</Limit>\n";
    }

    if ( defined( $directives->{'RequireAuth'} ) ) {
        my        %params;
        my        $i;
        my        $users;

        for ( $i = 0 ; $i < scalar( @{$directives->{'RequireAuth'}} ) ; ++$i ) {
            %params = &parseParams( $directives->{'RequireAuth'}->[$i] );
            if ( $params{'userlist'} ) {
                ( $users = $params{'userlist'} ) =~ s/,/ /g;
                $users = 'user ' . $users;
            } else {
                $users = 'valid-user';
            }
            #QQQQ If there is no userfile, we're hosed
            if ( defined( $params{'userfile'} ) ) {
                print DEST "AuthUserFile $params{'userfile'}\n";
                print DEST "require $users\n";
                print DEST "AuthType Basic\n";
                print DEST "AuthName $params{'realm'}\n";
            } else {
                print "You will need to separately enable DBM authentication support or switch to a text userfile, ignoring RequireAuth directive. $.\n";
            }
        }
    }

    if ( defined( $directives->{'ErrorFile'} ) ) {
        print "The ErrorFile directive is not supported in .htaccess files, you will need to configure this under Content Management in the admin server. $.\n";
    }

    if ( defined( $directives->{'AddType'} ) ) {
        print "The AddType directive is not supported in .htaccess files, you will need to configure this under Mime Types in the admin server. $.\n";
    }
}

sub parseParams {
    my        $line = shift;
    my        %params;
    my        $param;
    my        $partParam = '';
    my        $name;
    my        $data;
    my        @quotes;

    foreach $partParam ( split( /\s+/, $line ) ) {
        $param .= $partParam;
        # If quoted spaces, we have to remerge
        @quotes = $param =~ m'[^\\]"'g;
        if ( scalar( @quotes ) % 2 ) {        # odd number
            $param .= ' ';
            next;
        }
        $param =~ /=/;
        $params{$`} = &stripQuotes( $' );
        $param = '';
    }
    return %params;
}

sub stripQuotes {
    my        $string = shift;

    $string =~ s/^"//;
    $string =~ s/"$//;

    return $string;
}
