#!/usr/bin/perl

use Cwd qw(abs_path);
use File::Spec;
use Getopt::Std qw(getopts);

# get options from command line
my %opt = ();
getopts( 'd:Ffhr:v', \%opt );
Usage() if ( $opt{h} );
my $VERBOSE = $opt{v};
my $RPTDIR  = $opt{d} || '/tmp';
my $REPORT  = $opt{r};
my $FIX     = $opt{F} ? 2 : $opt{f} ? 1 : undef;
Usage() if ( !@ARGV );

sub Usage {
    die <<EOF;
Usage: $0 [options] /path/to/doc/root
-d dir      where to write reports (default /tmp)
-f          fix htaccess files separately - as .htaccess.shib
-F          fix htaccess files in place - keeps backup as .htaccess.wrap
-h          show this help
-r filename write report to this filename (default last part of docroot)
-v          verbose messages
EOF
}

ROOT:
while (@ARGV) {
    my $docroot = shift;
    $docroot = abs_path($docroot);

    if ( !$opt{r} ) {
        my ($last) = ( $docroot =~ m{/([^/]+)/?\z} );
        $REPORT = "$RPTDIR/$last.txt";
    }

    # finds all files named '.htaccess'
    print STDERR "Spidering $docroot " if ($VERBOSE);
    my @htlist = dir_walk(
        $docroot,
        sub {
            my $top = shift;
            return $top if ( $top =~ m{/\.htaccess\z} );
            return;
        },
        sub {
            my ( $top, @res ) = (@_);
            print STDERR "." if ($VERBOSE);
            return @res;
        },
    );
    print STDERR "done\n" if ($VERBOSE);

    if (@htlist) {
        if ($VERBOSE) {
            print STDERR "Found htaccess files under $docroot:\n";
            foreach my $sub ( sort @htlist ) {
                my $rel = File::Spec->abs2rel( $sub, $docroot );
                print STDERR "  $rel\n";
            }
        }
    }
    else {
        print STDERR "No .htaccess files found in $docroot\n";
        next ROOT;
    }

    # parse the htaccess file for WRAP settings
    my $found   = 0;
    my $summary = '';
    foreach my $ht ( sort @htlist ) {
        my $rel = File::Spec->abs2rel( $ht, $docroot );
        my ( $haswrap, $report ) = parse_htaccess($ht);
        if ($haswrap) {
            $found++;
            $summary .= "$ht\n" . "$report\n";
            print STDERR "Found WRAP in $rel\n" if ($VERBOSE);
            if ($FIX) {
                rewrite_htaccess($ht);
                print STDERR "    ... fixed.\n" if ($VERBOSE);
            }
        }
    }
    print STDERR "Found $found files with WRAP rules\n" if ($VERBOSE);
    if ($found) {
        open( my $out, '>>', $REPORT );
        print $out $summary;
        print $out '-' x 70, "\n\n";
        close($out);
        print STDERR "Wrote report to $REPORT\n" if ($VERBOSE);
    }
    else {
        print STDERR "No .htaccess files with WRAP found\n";
        next ROOT;
    }
}

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

sub parse_htaccess {
    my $ht = shift;

    my $in;
    if ( !open( $in, '<', $ht ) ) {
        print STDERR "Failed to read $ht: $!\n";
        return 0, '';
    }

    my $found  = 0;
    my $report = '';
    my @block  = ();
    while ( my $lin = <$in> ) {
        $lin =~ s/\A\s+|\s+\z//g;
        if ( $lin =~ /\AAuthType\s+WRAP/ ) {
            $found = 1;
            $report .= join( ', ', @block, $lin ) . "\n";
        }
        elsif ( $lin =~ /\Arequire\s+(.*)/ ) {
            $report .= join( ', ', @block, $lin ) . "\n";
        }
        elsif ( $lin =~ m{\A</(\S+)>} ) {
            pop @block;
        }
        elsif ( $lin =~ m{\A<([^>]+)>} ) {
            push @block, $1;
        }
    }
    close($in);
    return $found, $report;
}

sub rewrite_htaccess {
    my $ht     = shift;
    my $htwrap = "$ht.wrap";
    my $htshib = "$ht.shib";

    my ( $in, $out );
    if ( !open( $in, '<', $ht ) ) {
        print STDERR "Failed to read $ht: $!\n";
        return;
    }
    if ( !open( $out, '>', $htshib ) ) {
        close($in);
        print STDERR "Failed to write $htshib: $!\n";
        return;
    }

    my $ignorereq = 0;
    my @block = ();
    while ( my $lin = <$in> ) {
        if ( $lin =~ /\A\s*AuthType\s+WRAP/ ) {
            $found = 1;

            # print $out "# ", $lin;
            print $out "AuthType shibboleth\n";
            print $out "ShibCompatWith24 On\n";
            if ( $lin =~ /WRAPOptional/ ) {
                print $out "ShibRequestSetting requireSession false\n";
                print $out "require Shibboleth\n";
                $ignorereq = 1;
            }
            else {
                print $out "ShibRequestSetting requireSession true\n";
                $ignorereq = 0;
            }
        }
        elsif ( $lin =~ /\A\s*require\s+(.*)/ ) {
            my $req = $1;

            # print $out "# ", $lin;
            if ( $ignorereq ) {

                # require lines ignored by lazy sessions
            }
            elsif ( $req =~ /valid-user/ ) {
                print $out "require shib-session\n";
            }
            elsif ( $req =~ /known-user/ ) {
                print $out "require shib-attr SHIB_AFFILIATION ",
                    'member@ncsu.edu', "\n";
                print $out "require shib-attr SHIB_AFFILIATION ",
                    'affiliate@ncsu.edu', "\n";
            }
            elsif ( $req =~ /affiliation/ ) {

                # ignore this
            }
            elsif ( $req =~ /\Auser\s+/ ) {
                my @users = split /\s+/, lc($req);
                shift @users;    # drop the 'user' directive
                while (@users) {
                    my @list = splice( @users, 0, 3 );    # group by 3 ids
                    print $out "require shib-user ",
                        join( ' ', map { $_ . '@ncsu.edu' } @list ),
                        "\n";
                }
            }
        }
        elsif ( $lin =~ m{\A\s*</(\S+)>} ) {
            pop @block;
            print $out $lin;
        }
        elsif ( $lin =~ m{\A\s*<([^>]+)>} ) {
            push @block, $1;
            print $out $lin;
        }
        else {
            print $out $lin;
        }
    }
    close($out);
    close($in);
    system 'chown', '--reference=' . $ht, $htshib;
    system 'chmod', '--reference=' . $ht, $htshib;
    if ( $FIX > 1 ) {
        system 'mv', $ht     => $htwrap;
        system 'mv', $htshib => $ht;
    }
}

## Higher Order Perl, by Mark Jason Dominus
## Chapter 1 section 5

sub dir_walk {
    my ( $top, $filefunc, $dirfunc ) = @_;
    my $DIR;

    if ( -d $top ) {
        my $file;
        unless ( opendir $DIR, $top ) {
            warn "Couldn't open directory top: $!; skipping.\n";
            return;
        }

        my @results;
        while ( $file = readdir $DIR ) {
            next if $file eq '.' || $file eq '..';
            next if ( -l "$top/$file" );
            push @results, dir_walk( "$top/$file", $filefunc, $dirfunc );
        }
        return $dirfunc ? $dirfunc->( $top, @results ) : ();
    }
    else {
        return $filefunc ? $filefunc->($top) : ();
    }
}