File Coverage

blib/lib/WE/Util/Htaccess.pm

Criterion	Covered	Total	%
statement	6	98	6.1
branch	0	34	0.0
condition	0	12	0.0
subroutine	2	7	28.5
pod	0	1	0.0
total	8	152	5.2

# -*- perl -*-

#
# $Id: Htaccess.pm,v 1.7 2004/04/08 14:26:23 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2002 Online Office Berlin. All rights reserved.
# Copyright (C) 2002, 2003 Slaven Rezic.
# This is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License, see the file COPYING.

#
# Mail: [e-mail]
# WWW:  http://we-framework.sourceforge.net
#

package WE::Util::Htaccess;

use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);

=head1 NAME

WE::Util::Htaccess - create apache .htaccess files

=head1 SYNOPSIS

    use WE::Util::Htaccess;
    WE::Util::Htaccess::create("/var/www/htdocs/.htaccess", $obj_db
                               -authname => "sample",
                               -authuserfile => "/var/www/.htpasswd",
                               -authgroupfile => "/var/www/.htgroup",
			       -inherit => 1,
			       -add => "ErrorDocument 401 /index.html",
                              );


=head1 DESCRIPTION

This module is used to create Apache C<.htaccess> files from a
C database. All objects in the database are traversed (or
restricted by a filter) and if the object contains a C
attribute, an entry for the C<.htaccess> file is created.

The C attribute should be a string with the following syntax:

    "[user=|group=]id1,[user=|group=]id2..."

If netither "user=" nor "group=" is specified, then a user id is
assumed. Example:

    "bla,group=foo,user=bar"

means: the users C and C and the group C.

The files C<.htpasswd>, C<.htgroup> and C<.htaccess> are always
protected from WWW access, so you can use these names for the
user/group files, if you have to store these files in a WWW readable
directory.

The C function expects the following arguments:

=over 4

=item -authname => $name

The name of the authorization realm. By default it is "WE Authentication".

=item -authtype => $type

The type of user authentication. By default it is "Basic".

=item -authuserfile => $file

The path to the .htpasswd file (see L). This is
required unless set by an entry in the global C.

=item -authgroupfile => $file

The path to the groups file (see L). This is
required if there are any group authentifications in the object
database and no entry from the global C can be used.

=item -inherit => $bool

If set to true (default) then inherit folder rights to their children
and subfolders.

=item -filter => sub { my($obj) = @_; ... }

A filter callback for restricting an object or sub-tree. The callback
will get the current object as parameter and should return a boolean
value. If the returned value is false, then the object is not
processed; if it is a folder then the descendants of the folder are
not processed either.

=item -add => $string

A C<$string> to be added to the .htaccess file. An example would be to
add an C directive (see
L).

=item -addfile => $file

Like C<-add>, but read the contents from the named file. It is
possible to use C<-add> and C<-addfile> together.

=item -restrict => $restrict

Alternative restriction scheme. If set, then no access to the
C database is done. C<-inherit> and C<-filter> are
ignored. The C<$restrict> string should be of the form:

    type1 value1 value2 value3; type2 value4 value5 ...

where I is either C or C and I a group or
user name.

=item -getaliases => sub { my($id) = @_; ... }

This should be a code reference which receives the object id as
parameter and returns a list of alias names for this page (excluding
the supplied id).

=cut

sub create {
    my($dest_file, $obj_db, %args) = @_;

    my $s = _create($obj_db, %args);

    open(D, ">$dest_file") or die "Can't write to $dest_file: $!";
    print D $s;
    close D;
}

sub _create {
    my($obj_db, %args) = @_;

    my $authname = $args{-authname} || "WE Authentication";
    my $authtype = $args{-authtype} || "Basic";
    my $inherit  = defined $args{-inherit} ? $args{-inherit} : 1;
    my $filter   = delete $args{-filter};
    my $restrict = delete $args{-restrict} || "";
    my $get_aliases = delete $args{-getaliases};
    my $add = "";
    if (defined $args{-add}) {
	$add .= "\n" . delete($args{-add}) . "\n";
    }
    if (defined $args{-addfile}) {
	if (!open(ADDFILE, $args{-addfile})) {
	    warn "Can't open file specified in -addfile: $args{-addfile}: $!";
	} else {
	    local $/ = undef;
	    $add .= "\n" . scalar() . "\n";
	    close ADDFILE;
	}
    }

    # get all objects with restrictions
    my %restr_objs;
    if ($restrict eq '') {
	$obj_db->walk_preorder($obj_db->root_object, sub {
            my($id) = @_;
	    my($obj) = $obj_db->get_object($id);

	    return if ($filter && !$filter->($obj));

	    if ($inherit) {
		my(@parent_ids) = $obj_db->parent_ids($id);
		foreach my $p_id (@parent_ids) {
		    if (exists $restr_objs{$p_id}) {
			push @{ $restr_objs{$id} }, @{ $restr_objs{$p_id} };
		    }
		}
	    }

	    if (defined $obj->{WWWAuth} && $obj->{WWWAuth} ne "") {
		my(@auth_token) = split /,/, $obj->{WWWAuth};
		foreach my $auth_token (@auth_token) {
		    if ($auth_token =~ /^([^=]+)=(.*)$/) {
			push @{ $restr_objs{$id} }, [$1, $2];
		    } else {
			push @{ $restr_objs{$id} }, [user => $auth_token];
		    }
		}
	    }
	});
    }

    # norm requirements so it is easier to collect requirements
    my %restr_reqs; # require-string => [objid ...]
    while(my($objid, $reqs) = each %restr_objs) {
	my $require_string = _norm_requirements($objid, $reqs);
	push @{ $restr_reqs{$require_string} }, $objid;
    }

    # create auth/files sections
    my $s = "";
    if ($restrict ne '') {
	$s .= <
AuthName "$authname"
AuthType $authtype
EOF
        $s .= "AuthGroupFile $args{-authgroupfile}\n"
	    if $args{-authgroupfile};
	$s .= "AuthUserFile $args{-authuserfile}\n"
	    if $args{-authuserfile};
	my(@token1) = split /\s*;\s*/, $restrict;
	for my $token (@token1) {
	    my($type, @val) = split /\s+/, $token;
	    $s .= "require $type @val\n";
	}
	$s .= "\n";
    } else {
	while(my($restr_reqs, $ids) = each %restr_reqs) {
	    $s .= "
	    my @ids = @$ids;
	    my(%aliases, @aliases);
	    if ($get_aliases) {
		for my $id (@ids) {
		    my @new_aliases = $get_aliases->($id);
		    @aliases{@new_aliases} = (1) x @new_aliases;
		}
		@aliases = keys %aliases;
	    }
	    $s .= join("|", map { quotemeta($_) } @ids, @aliases);
	    $s .= ")\\.[^\\.]*\$\">\n";
	    $s .= "AuthName \"$authname\"\n";
	    $s .= "AuthType $authtype\n";
	    $s .= "AuthGroupFile $args{-authgroupfile}\n"
		if $args{-authgroupfile};
	    $s .= "AuthUserFile $args{-authuserfile}\n"
		if $args{-authuserfile};
	    $s .= $restr_reqs;
	    $s .= "\n\n";
	}
    }

    $s .= _protect_ourselves();

    $s .= $add;

    $s;
}

sub _protect_ourselves {
    <<'EOF'

Order deny,allow
Deny from all
Satisfy All


EOF
}

sub _norm_requirements {
    my($objid, $reqs) = @_;
    my %reqs_by_type;
    foreach my $req (@$reqs) {
	my($type, $name) = @$req;
	push @{ $reqs_by_type{$type} }, $name;
    }
    my $require_string = "";
    foreach my $type (sort keys %reqs_by_type) {
	# make unique
	my %values = map {($_=>1)} @{ $reqs_by_type{$type} };
	$require_string .= "require $type " . join(" ", sort keys %values) . "\n";
    }
    $require_string;
}

1;

__END__