SVN::Web - Subversion repository web frontend

repo

package SVN::Web;

use strict;
use warnings;

use URI::Escape;
use SVN::Client;
use SVN::Ra;
use YAML ();
use Template;
use File::Spec;
use POSIX ();

use SVN::Web::X;
use FindBin;

use SVN::Web::I18N;

# Add the localisations that ship with SVN::Web as the default, and set
# the default language.  This will be overridden later, but ensures that
# any error messages generated *before* it's overridden are generated
# properly.
SVN::Web::I18N::add_directory(
    File::Spec->catdir(substr(__FILE__, 0, -3), 'I18N')
);
SVN::Web::I18N::loc_lang('en');

use constant mod_perl_2 =>
    (exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2);

our $VERSION = 0.53;

my $template;
my $config;

my %REPOS;

sub load_config {
    return if defined $config;
    my $file = shift || 'config.yaml';
    my $config = YAML::LoadFile($file);
    set_config($config);
}

sub canonicalise_config {
    # Catch missing / incorrect 'version' entries
    die "Config file does not define a 'version' key."
	unless exists $config->{version} and defined $config->{version};

    die "Configuration file version ($config->{version}) does not match SVN::Web version ($VERSION)"
	if $config->{version} != $VERSION;

    # Deal with possibly conflicting 'templatedir' and 'templatedirs' settings.

    # If neither of them are set, use 'templatedirs'
    if(!exists $config->{templatedir} and !exists $config->{templatedirs}) {
        $config->{templatedirs} = [File::Spec->catdir(qw(template trac))];
    }

    # If 'templatedir' is the only one set, use it.
    if(exists $config->{templatedir} and !exists $config->{templatedirs}) {
        $config->{templatedirs} = [$config->{templatedir}];
        delete $config->{templatedir};
    }

    # If they're both set then throw an error
    if(exists $config->{templatedir} and exists $config->{templatedirs}) {
        die "templatedir and templatedirs both defined in config.yaml";
    }

    # Handle tt_compile_dir.  If it doesn't exist then set it to undef.
    # If it does exist, and is defined, append a '.' and the current
    # real UID, to help ensure uniqueness.
    if(!exists $config->{tt_compile_dir}) {
        $config->{tt_compile_dir} = undef;    # undef == no compiling
    } else {
        if(defined $config->{tt_compile_dir}) {
            $config->{tt_compile_dir} .= '.' . $<;
        }
    }

    # Handle timedate_format
    if(! exists $config->{timedate_format}) {
	$config->{timedate_format} = '%Y/%m/%d %H:%M:%S';
    }

    # Set the timezone, if not already specified.
    $config->{timezone} = '' unless exists $config->{timezone};

    # If cache/opts/directory_umask is configured, and it has a leading
    # 0 then ensure it's treated as an octal number.
    $config->{cache}{opts}{directory_umask} =
      oct($config->{cache}{opts}{directory_umask})
	if exists $config->{cache}{opts}{directory_umask}
	  and $config->{cache}{opts}{directory_umask} =~ /^0/;;

    # Add any additional language directories
    if(defined $config->{language_dirs}) {
	foreach my $dir (@{ $config->{language_dirs} }) {
	    SVN::Web::I18N::add_directory($dir);
	}
    }

    return;
}

sub set_config {
    $config = shift;

    canonicalise_config();
}

sub get_config {
    return $config;
}

my $repospool = SVN::Pool->new();

sub get_repos {
    my($repos) = @_;

    SVN::Web::X->throw(
        error => '(unconfigured repository)',
        vars  => []
    ) unless exists $config->{repos}{$repos} || $config->{reposparent};

    my $repo_uri =
        $config->{reposparent}
	    ? File::Spec->catdir($config->{reposparent}, $repos)
		: $config->{repos}{$repos};

    SVN::Web::X->throw(
        error => '(no such repo %1 %2)',
        vars  => [$repos, $repo_uri]
    ) unless defined $repos and (exists $config->{repos}{$repos} or -e $repo_uri);

    $repo_uri =~ s{/$}{}g;	# Trim trailing '/', SVN::Repos::open fails
				# otherwise

    # If there's a leading '/' then tack 'file://' on to the start
    $repo_uri = "file://$repo_uri" if $repo_uri =~ m{^/};

    eval {
	$REPOS{$repos}{uri}    ||= $repo_uri;
	$REPOS{$repos}{ra}     ||= SVN::Ra->new(url  => $repo_uri,
						pool => $repospool);
    };

    if($@) {
        my $e = $@;
        SVN::Web::X->throw(
            error => '(SVN::Client->new() failed: %1 %2)',
            vars  => [$repo_uri, $e]
        );
    }

    if($config->{block}) {
        foreach my $blocked (@{ $config->{block} }) {
            delete $REPOS{$blocked};
        }
    }
}

sub get_action {
    my $cfg = shift;
    my $action_pkg;

    if(exists $config->{actions}{ $cfg->{action} }) {
        if(ref($config->{actions}{ $cfg->{action} }) eq 'HASH') {
            if(exists $config->{actions}{ $cfg->{action} }{class}) {
                $action_pkg = $config->{actions}{ $cfg->{action} }{class};
            }
        }
    }

    unless($action_pkg) {
        $action_pkg = $cfg->{action};
        $action_pkg =~ s{^(\w)}{\U$1};
        $action_pkg = __PACKAGE__ . "::$action_pkg";
    }

    eval "require $action_pkg && $action_pkg->can('run')"
        or SVN::Web::X->throw(
        error => '(missing package %1 for action %2: %3)',
        vars  => [$action_pkg, $cfg->{action}, $@]
    );

    my $repos = $cfg->{repos} ? $REPOS{ $cfg->{repos} } : undef;

    return $action_pkg->new(
        %$cfg,
        reposname => $cfg->{repos},
        repos     => $repos,
        config    => $config
    );
}

sub run {
    my $cfg = shift;

    my $action;
    my $html;
    my $cache;

    if(defined $config->{cache}{class}) {
	eval "require $config->{cache}{class}"
	  or SVN::Web::X->throw(error => '(require %1 failed: %2)',
				vars  => [$config->{cache}{class}, $@]
			       );

	$config->{cache}{opts} = {}  unless exists $config->{cache}{opts};
	$config->{cache}{opts}{namespace} = $cfg->{repos};
	$cache = $config->{cache}{class}->new($config->{cache}{opts});
    }

    if(defined $cfg->{repos} && length $cfg->{repos}) {
        get_repos($cfg->{repos});
    }

    if($cfg->{repos} && $REPOS{ $cfg->{repos} }) {
        @{ $cfg->{navpaths} } = File::Spec::Unix->splitdir($cfg->{path});
        shift @{ $cfg->{navpaths} };

        # should use attribute or things alike
        $action = get_action({
	    %$cfg,
	    opts => exists $config->{actions}{ $cfg->{action} }{opts}
                ? $config->{actions}{ $cfg->{action} }{opts}
		    : {},
	});
    } else {
        $cfg->{action} = 'list';
        $action = get_action({
	    %$cfg,
	    opts => exists $config->{actions}{ $cfg->{action} }{opts}
                ? $config->{actions}{ $cfg->{action} }{opts}
		    : {},
	});
    }

    # Determine the language to use
    my $lang = get_language($cfg->{cgi}, $config->{languages},
			    $config->{default_language});

    $cfg->{lang} = $lang;	# Note the preference, stored in a cookie
				# later

    SVN::Web::I18N::loc_lang($lang); # Set the localisation language

    # Generate output, from the cache if necessary.

    # Does the action support caching?  If so, get the cache key
    my $cache_key;
    if(defined $cache and $action->can('cache_key')) {
	$cache_key = join(':', $cfg->{action}, $lang) . ':' . $action->cache_key();
    }

    # If there's a key, retrieve the data from the cache
    $html = $cache->get($cache_key) if defined $cache_key;

    # No data?  Get the action to generate it, then cache it
    if(! defined $html) {
	# Create a default pool for the action's allocation
	my $pool = SVN::Pool->new_default();

	$REPOS{$cfg->{repos}}{client}   = SVN::Client->new(config => {});

	$html = $action->run();

	$pool->clear();

	if(defined $cache_key) {
	    $cache->set($cache_key, $html, $cfg->{cache}{expires_in});
	}
    }

    return $html;
}

sub get_language {
    my $obj          = shift;	# CGI or Apache instance
    my $languages    = shift;	# Hash ref of valid langauges
    my $default_lang = shift;	# Default language

    my $lang = $obj->param('lang');

    # If lang was included in the query string then delete it now we've
    # got it.  This stops it showing up in from calls to self_url().  Have
    # to do this in three different ways, depending on whether this is an
    # Apache::Request, Apache2::Request, or a CGI object.
    if(defined $lang) {
	if(ref($obj) eq 'Apache::Request') {
	    my $table = $obj->parms();
	    delete $table->{lang};
	} elsif(ref($obj) eq 'Apache2::Request') {
	    # Get the query string, remove lang param, replace queue string
	    my $args = $obj->args();
	    $args =~ s/lang = $lang (?:&|;)?//xms;
	    $obj->args($args);
	} else {
	    $obj->delete('lang'); # Remove from self_url() invocations
	}
    }

    # If no valid lang=.. param was found then check the user's cookies
    if(! defined $lang) {
	if(ref($obj) eq 'Apache::Request') {
	    my $cookies = Apache::Cookie->fetch();
	    if(defined $cookies->{'svnweb-lang'}) {
		$lang = $cookies->{'svnweb-lang'}->value();
	    }
	} elsif(ref($obj) eq 'Apache2::Request') {
	    my $jar            = Apache2::Cookie::Jar->new($obj);
	    my $lang_in_cookie = $jar->cookies('svnweb-lang');
	    if(defined $lang_in_cookie) {
		$lang = $lang_in_cookie->value();;
	    }
	} else {
	    $lang = $obj->cookie('svnweb-lang');
	}
    }

    # If $lang is not defined, or if it's not in the hash of valid languages
    # then use the default configured language, falling back to English as
    # a last resort.
    if(! defined $lang or ! exists $languages->{$lang}) {
	$lang = $default_lang;
	$lang = 'en' unless defined $lang;
    }

    die "lang is not defined" unless defined $lang;

    return $lang;
}

sub cgi_output {
    my($cfg, $html) = @_;

    return unless defined $html;

    my @cookies = ();
    push @cookies, $cfg->{cgi}->cookie(-name  => 'svnweb-lang',
				       -value => $cfg->{lang},
				      );

    if(ref($html)) {
        print $cfg->{cgi}->header(
            -charset => $html->{charset}  || 'UTF-8',
            -type    => $html->{mimetype} || 'text/html',
	    -cookie  => \@cookies,
        );

	$cfg->{path} = encode_path($cfg->{path});
        if($html->{template}) {
            $template->process($html->{template}, {
		c => $cfg,
		%{ $html->{data} }
	    }) or die "Template::process() error: " . $template->error;
        } else {
            print $html->{body};
        }
    } else {
        print $cfg->{cgi}->header(
            -charset => 'UTF-8',
            -type    => 'text/html',
	    -cookie  => \@cookies,
        );
        print $html;
    }
}

sub mod_perl_output {
    my($cfg, $html) = @_;

    my @cookies = ();

    if(mod_perl_2) {
	push @cookies, Apache2::Cookie->new($cfg->{request},
					    -name  => 'svnweb-lang',
					    -value => $cfg->{lang},
					);
	$_->bake($cfg->{request}) foreach @cookies;
    } else {
	push @cookies, Apache::Cookie->new($cfg->{request},
					   -name  => 'svnweb-lang',
					   -value => $cfg->{lang},
				       );
	$_->bake() foreach @cookies;
    }

    if(ref($html)) {
        my $content_type = $html->{mimetype} || 'text/html';
        $content_type .= '; charset=';
        $content_type .= $html->{charset} || 'UTF-8';
        $cfg->{request}->content_type($content_type);

	if(mod_perl_2) {
	    $cfg->{request}->headers_out();
	} else {
	    $cfg->{request}->send_http_header();
	}

        if($html->{template}) {
            $template ||= get_template();
	    $cfg->{path} = encode_path($cfg->{path});
            $template->process($html->{template},
                { c => $cfg, %{ $html->{data} } },
                $cfg->{request})
                or die $template->error;
        } else {
            $cfg->{request}->print($html->{body});
        }
    } else {
        $cfg->{request}->content_type('text/html; charset=UTF-8');

	if(mod_perl_2) {
	    $cfg->{request}->headers_out();
	} else {
	    $cfg->{request}->send_http_header();
	}

        $cfg->{request}->print($html);
    }
}

sub get_template {
    Template->new({
	INCLUDE_PATH => $config->{templatedirs},
	COMPILE_DIR  => $config->{tt_compile_dir},
	PRE_CHOMP    => 2,
	POST_CHOMP   => 2,
	FILTERS      => {
	    l       => ([\&loc_filter, 1]),
	}
    });
}

sub run_cgi {
    my %opts = @_;
    die $@ if $@;

    load_config('config.yaml');

    $config->{$_}             = $opts{$_} foreach keys %opts;
    $template               ||= get_template();

    # Pull in the configured CGI class.  Propogate any errors back, and
    # call the correct import() routine.
    #
    # This is more complicated than it should be.  If $config->{cgi_class}
    # is defined then use that.  If not, use CGI::Fast.  If that can't be
    # loaded then use CGI.
    #
    # There's a problem with (at least) CGI::Fast.  It's possible for the
    # require() to fail, but for CGI::Fast's entry in %INC to be populated.
    # This seems to happen when CGI::Fast loads, but its dependency (such
    # as FCGI) fails to load.  So if the require() fails for any reason
    # we explicitly remove the %INC entry.

    my $cgi_class;
    my $eval_result;

    if(exists $config->{cgi_class}) {
        $eval_result = eval "require $config->{cgi_class}";
        die $@ if $@;
        $cgi_class = $config->{cgi_class};
    } else {
        foreach('CGI::Fast', 'CGI') {
            $eval_result = eval "require $_";
            if($@) {
                my $path = $_;
		my @path_components = split('::', $path);
		$path = File::Spec->catfile(@path_components);
                $path .= '.pm';
                delete $INC{$path};
            } else {
                $cgi_class = $_;
                last;
            }
        }
    }

    die "Could not load a CGI class" unless $eval_result;
    $cgi_class->import();

    # Save the selected module so that future calls to this routine
    # don't waste time trying to find the correct class.
    $config->{cgi_class} = $cgi_class unless exists $config->{cgi_class};

    while(my $cgi = $cgi_class->new) {
        my($html, $cfg);

	$cfg = {
	    style     => $config->{style},
	    cgi       => $cgi,
	    languages => $config->{languages},
	};

        eval {
	    my($action, $base, $repo, $script, $path) = crack_url($cgi);

            SVN::Web::X->throw(
                error => '(action %1 not supported)',
                vars  => [$action]
	    ) unless exists $config->{actions}{ lc($action) };

            $cfg->{repos}    = $repo;
	    $cfg->{action}   = $action;
	    $cfg->{path}     = $path;
	    $cfg->{script}   = $script;
	    $cfg->{base_uri} = $base;
	    $cfg->{self_uri} = $cgi->self_url();
	    $cfg->{config}   = $config;

            $html = run($cfg);
        };

        my $e;
        if($e = SVN::Web::X->caught()) {
            $html->{template} = 'x';
            $html->{data}{error_msg} = SVN::Web::I18N::loc($e->error(), @{ $e->vars() });
        } else {
            if($@) {
                $html->{template} = 'x';
                $html->{data}{error_msg} = $@;
            }
        }

        cgi_output($cfg, $html);
        last if $cgi_class eq 'CGI';
    }
}

sub loc_filter {
    my $context = shift;
    my @args    = @_;
    return sub { SVN::Web::I18N::loc($_[0], @args) };
}

# Crack a URL and determine the components we need.  Takes either a CGI
# or Apache object as the only argument, so this is misnamed.
sub crack_url {
    my $obj = shift;

#    warn "REF: ", ref($obj), "\n";

    my($location, $filename, $path_info, $uri);

    if(ref($obj) eq 'Apache' or ref($obj) eq 'Apache2::RequestRec') {
	$location  = $obj->location();
	$filename  = $obj->filename();
	$path_info = $obj->path_info();
	$uri       = $obj->uri();
    } else {
	# For compatibility with Apache::Request->filename():
	# 1. $location is the current working directory
	# 2. $filename is $location + the first component of path_info()
	$location  = POSIX::getcwd();
	
	# Split path_info, keeping trailing fields
	my @path = split('/', $obj->path_info(), -1);
	$filename = $location;
	if($#path) {
	    shift @path;	# Leading empty null field
	    if(defined $path[0]) {
		$filename .= '/' . shift @path;
	    }
	}

	$path_info = '/' . join('/', @path);
	$uri       = $obj->url(-relative => 1, -path_info => 1);
    }

#    warn "LOCATION: $location\n";
#    warn "FILENAME: $filename\n";
#    warn "PATH_INFO: $path_info\n";
#    warn "URI: $uri\n";

    my($action, $base, $repo, $script, $path);

    # Determine $repo.
    #
    # This is used as the key in to the hash of configured repositories.
    # It may be the empty string, in which case the action to run is
    # the 'list repositories' action.
    if($location eq $filename) {
	$repo   = '';		# No repo, show repo list
	$action = 'list';
    } else {
	# Start with $repo equal to $filename.  Then remove $location.
	# This needs to be quoted for systems where the path may include
	# backslashes.  There may also be a trailing directory separator
	# which needs removing.
	#
	# XXX In an ideal world File::Spec would tell us what the directory
	# separator is.  For the time being, punt, and use both forward and
	# backward slashes.
	$repo = $filename;
	my $quoted_location = quotemeta($location);
	$repo =~ s{^ $quoted_location [/\\]? }{}x;
	$repo = uri_unescape($repo);
    }

#    warn "REPO: $repo\n";

    # Determine $action
    #
    # This will be used as the key in to the hash of configured actions
    # and their classes.  If no action is included in the URL then the
    # default action is 'browse'.
    if(! defined $action) {
	if($path_info eq '/' or $path_info eq '') {
	    $action = 'browse';
	} else {
	    my @path = split('/', $path_info);
	    $action = $path[1];
	}
    }

#    warn "ACTION: $action\n";

    # Determine $path
    #
    # This is the path in the repository that we will be acting on.  Some
    # actions don't need this set.
    if($action eq 'list') {
	$path = '/';
    } else {
	if($path_info eq '' or $path_info eq '/') {
	    $path = '/';
	} else {
	    $path = $path_info;
	    $path =~ s{^/$action}{};
	    $path =~ s{/+$}{} unless $path eq '/';
	}
    }

    # Unescape it, as it will have been escaped on the web page
    $path = uri_unescape($path);

#    warn "PATH: $path\n";

    # Determine $script
    #
    # $script is the URI that points to the SVN::Web script.  If this
    # is CGI then it's something like 'http://host//svnweb/index.cgi'.
    # If it's an Apache handler then it will be a directory reference,
    # like '/svnweb', or possibly '/'.
    #
    # In the CGI case this is just the SCRIPT_NAME environment
    # variable.  There's no Apache equivalent, so for Apache 1 take
    # the URI, prepend the protocol, host, and port, then starting
    # from the right end, remove the path, the action, and the
    # repository name.  The result is the root URI for the handler.
    #
    # For Apache 2 use Apache2::URI::construct_url() to get the full
    # URL (without the query string), and then perform the same
    # substitutions as for the Apache 1 case.
    if(ref($obj) eq 'Apache') {
	my $port = $obj->server()->port();

	$script = sprintf('%s://%s:%s%s',
			  $port == 443 ? 'https' : 'http',
			  $obj->server()->server_hostname(),
			  $port,
			  $uri);
	$script =~ s{$path/?$}{};
	$script =~ s{/$action$}{};
	$script =~ s{/$repo$}{};
    } elsif(ref($obj) eq 'Apache2::RequestRec') {
	$script = $obj->construct_url();
	$script =~ s{$path/?$}{};
	$script =~ s{/$action$}{};
	$script =~ s{/$repo$}{};
    } else {
	$script = $ENV{SCRIPT_NAME};
    }

    $script =~ s{/$}{};		# Remove trailing slash

#    warn "SCRIPT: $script\n";

    # Determine $base
    #
    # $base is the URI that points to the directory that contains index.cgi,
    # config.yaml, css/, etc.  It's needed to generate links to the .css
    # files.

    # In all cases, $base is a substring of $script.  In the mod_perl and
    # svnweb-server cases it's identical
    $base = $script;		# Only in mod_perl case

    # If we're running as a CGI then SCRIPT_FILENAME will (or should)
    # be set in the environment.  If it is, find the filename component,
    # which should be the name of this script, and remove that component
    # from $base.
    #
    # This turns '/svnweb/index.cgi' into '/svnweb/'.  We go through these
    # shenanigans so that the script can be called something other than
    # index.cgi.
    if(ref($obj) ne 'Apache') {
	if(exists $ENV{SCRIPT_FILENAME}) {
	    my $path = $ENV{SCRIPT_FILENAME};
	    my(undef, undef, $file) = File::Spec->splitpath($path);
	    $base =~ s{$file$}{};
	} else {
#	    warn 'SCRIPT_FILENAME not set in environment, assuming script is called index.cgi';
	    $base =~ s{index.cgi$}{};
	}
    }
    $base =~ s{/$}{};		# Remove trailing slash

#    warn "BASE: $base\n";

    return($action, $base, $repo, $script, $path);
}

sub handler {
    my $ok;
    require CGI;

    eval {
        if(mod_perl_2) {
            require Apache2::RequestRec;
            require Apache2::RequestUtil;
            require Apache2::RequestIO;
            require Apache2::Response;
	    require Apache2::Request;
            require Apache2::Const;
	    require Apache2::Cookie;
	    require Apache2::URI;
            Apache2::Const->import(-compile => qw(OK DECLINED));
            $ok = &Apache2::Const::OK;
        } else {
            require Apache::Request;
            require Apache::Constants;
	    require Apache::Cookie;
            Apache::Constants->import(qw(OK DECLINED));
            $ok = &Apache::Constants::OK;
        }
    };

    die $@ if $@;		# Fail if the mod_perl imports failed

    my $r = shift;		# Apache or Apache2::RequestRec object

    my $apr = mod_perl_2 ? Apache2::Request->new($r)
                         : Apache::Request->new($r);

    my($action, $base, $repo, $script, $path) = crack_url($r);

    chdir($r->location());
    load_config('config.yaml');

    my($html, $cfg);

    $cfg = {
	style     => $config->{style},
	cgi       => $apr,
	languages => $config->{languages},
	request   => $r,
    };

    eval {
	SVN::Web::X->throw(
	    error => '(action %1 not supported)',
            vars  => [$action]
	) unless exists $config->{actions}{ lc($action) };

	$cfg->{repos}    = $repo;
	$cfg->{action}   = $action;
	$cfg->{path}     = $path;
	$cfg->{script}   = $script;
	$cfg->{base_uri} = $base;
	$cfg->{config}   = $config;

	$cfg->{self_uri} = $r->uri();
	my $args         = $r->args();
	if($args) {
	    $cfg->{self_uri} .= "?$args";
	}

        $html = run($cfg);
    };

    my $e;
    if($e = SVN::Web::X->caught()) {
        $html->{template} = 'x';
        $html->{data}{error_msg} = SVN::Web::I18N::loc($e->error(),
						       @{ $e->vars() });
    } else {
	if($@) {
	    $html->{template} = 'x';
	    $html->{data}{error_msg} = $@;
	}
    }

    mod_perl_output($cfg, $html);
    return $ok;
}

sub encode_path {
    my $path = shift;

    return unless defined $path;

    my @path = split('/', $path);

    $path = join('/', map { uri_escape($_) } @path);

    return $path;
}

1;

__END__

SVN::Web - Subversion repository web frontend

Index

Code Index:

NAME

SYNOPSIS

DESCRIPTION

CONFIGURATION

Version number

Repositories

Local and remote repositories

Local repositories under a single root

Templates

Languages

Localisation directories

Available languages

Default language

Data cache

Template cache

Log message filters

Time and date formatting

Actions, action classes, and action options

Action menu configuration

CGI class

ACTIONS, SUBCLASSES, AND URLS

WEB SERVERS

svnweb-server

Apache as CGI

Apache with mod_perl or mod_perl2

Apache with FastCGI

IIS

MAILING LIST

SEE ALSO

BUGS

AUTHORS

COPYRIGHT