SoundSoftware Code Site

package Apache::Authn::SoundSoftware;

=head1 Apache::Authn::SoundSoftware

SoundSoftware - a mod_perl module for Apache authentication against a

Redmine database and optional LDAP implementing the access control

rules required for the SoundSoftware.ac.uk repository site.

=head1 SYNOPSIS

This module is closely based on the Redmine.pm authentication module

provided with Redmine.  It is intended to be used for authentication

in front of a repository service such as hgwebdir.

Requirements:

1. Clone/pull from repo for public project: Any user, no

authentication required

2. Clone/pull from repo for private project: Project members only

3. Push to repo for public project: "Permitted" users only (this

probably means project members who are also identified in the hgrc web

section for the repository and so will be approved by hgwebdir?)

4. Push to repo for private project: "Permitted" users only (as above)

5. Push to any repo that is tracking an external repo: Refused always

=head1 INSTALLATION

Debian/ubuntu:

  apt-get install libapache-dbi-perl libapache2-mod-perl2 \

    libdbd-mysql-perl libauthen-simple-ldap-perl libio-socket-ssl-perl

Note that LDAP support is hardcoded "on" in this script (it is

optional in the original Redmine.pm).

=head1 CONFIGURATION

   ## This module has to be in your perl path

   ## eg:  /usr/local/lib/site_perl/Apache/Authn/SoundSoftware.pm

   PerlLoadModule Apache::Authn::SoundSoftware

   # Example when using hgwebdir

   ScriptAlias / "/var/hg/hgwebdir.cgi/"

   <Location />

       AuthName "Mercurial"

       AuthType Basic

       Require valid-user

       PerlAccessHandler Apache::Authn::SoundSoftware::access_handler

       PerlAuthenHandler Apache::Authn::SoundSoftware::authen_handler

       SoundSoftwareDSN "DBI:mysql:database=redmine;host=localhost"

       SoundSoftwareDbUser "redmine"

       SoundSoftwareDbPass "password"

       Options +ExecCGI

       AddHandler cgi-script .cgi

       ## Optional where clause (fulltext search would be slow and

       ## database dependant).

       # SoundSoftwareDbWhereClause "and members.role_id IN (1,2)"

       ## Optional prefix for local repository URLs

       # SoundSoftwareRepoPrefix "/var/hg/"

  </Location>

See the original Redmine.pm for further configuration notes.

=cut

use strict;

use warnings FATAL => 'all', NONFATAL => 'redefine';

use DBI;

use Digest::SHA1;

use Authen::Simple::LDAP;

use Apache2::Module;

use Apache2::Access;

use Apache2::ServerRec qw();

use Apache2::RequestRec qw();

use Apache2::RequestUtil qw();

use Apache2::Const qw(:common :override :cmd_how);

use APR::Pool ();

use APR::Table ();

my @directives = (

  {

    name => 'SoundSoftwareDSN',

    req_override => OR_AUTHCFG,

    args_how => TAKE1,

    errmsg => 'Dsn in format used by Perl DBI. eg: "DBI:Pg:dbname=databasename;host=my.db.server"',

  },

  {

    name => 'SoundSoftwareDbUser',

    req_override => OR_AUTHCFG,

    args_how => TAKE1,

  },

  {

    name => 'SoundSoftwareDbPass',

    req_override => OR_AUTHCFG,

    args_how => TAKE1,

  },

  {

    name => 'SoundSoftwareDbWhereClause',

    req_override => OR_AUTHCFG,

    args_how => TAKE1,

  },

  {

    name => 'SoundSoftwareRepoPrefix',

    req_override => OR_AUTHCFG,

    args_how => TAKE1,

  },

);

sub SoundSoftwareDSN { 

    my ($self, $parms, $arg) = @_;

    $self->{SoundSoftwareDSN} = $arg;

    my $query = "SELECT 

                 hashed_password, auth_source_id, permissions

              FROM members, projects, users, roles, member_roles

              WHERE 

                projects.id=members.project_id

                AND member_roles.member_id=members.id

                AND users.id=members.user_id 

                AND roles.id=member_roles.role_id

                AND users.status=1 

                AND login=? 

                AND identifier=? ";

    $self->{SoundSoftwareQuery} = trim($query);

}

sub SoundSoftwareDbUser { set_val('SoundSoftwareDbUser', @_); }

sub SoundSoftwareDbPass { set_val('SoundSoftwareDbPass', @_); }

sub SoundSoftwareDbWhereClause { 

    my ($self, $parms, $arg) = @_;

    $self->{SoundSoftwareQuery} = trim($self->{SoundSoftwareQuery}.($arg ? $arg : "")." ");

}

sub SoundSoftwareRepoPrefix { 

    my ($self, $parms, $arg) = @_;

    if ($arg) {

	$self->{SoundSoftwareRepoPrefix} = $arg;

    }

}

sub trim {

    my $string = shift;

    $string =~ s/\s{2,}/ /g;

    return $string;

}

sub set_val {

    my ($key, $self, $parms, $arg) = @_;

    $self->{$key} = $arg;

}

Apache2::Module::add(__PACKAGE__, \@directives);

my %read_only_methods = map { $_ => 1 } qw/GET PROPFIND REPORT OPTIONS/;

sub access_handler {

    my $r = shift;

    print STDERR "SoundSoftware.pm: In access handler at " . scalar localtime() . "\n";

    unless ($r->some_auth_required) {

	$r->log_reason("No authentication has been configured");

	return FORBIDDEN;

    }

    my $method = $r->method;

    print STDERR "SoundSoftware.pm: Method: $method, uri " . $r->uri . ", location " . $r->location . "\n";

    print STDERR "SoundSoftware.pm: Accept: " . $r->headers_in->{Accept} . "\n";

    my $dbh = connect_database($r);

    unless ($dbh) {

	print STDERR "SoundSoftware.pm: Database connection failed!: " . $DBI::errstr . "\n";

	return FORBIDDEN;

    }

    print STDERR "Connected to db, dbh is " . $dbh . "\n";

    my $project_id = get_project_identifier($dbh, $r);

    if (!defined $read_only_methods{$method}) {

        print STDERR "SoundSoftware.pm: Method is not read-only\n";

        if (project_repo_is_readonly($dbh, $project_id, $r)) {

            print STDERR "SoundSoftware.pm: Project repo is read-only, refusing access\n";

	    return FORBIDDEN;

        } else {

	    print STDERR "SoundSoftware.pm: Project repo is read-write, authentication handler required\n";

            return OK;

        }

    }

    my $status = get_project_status($dbh, $project_id, $r);

    $dbh->disconnect();

    undef $dbh;

    if ($status == 0) { # nonexistent

	print STDERR "SoundSoftware.pm: Project does not exist, refusing access\n";

	return FORBIDDEN;

    } elsif ($status == 1) { # public

	print STDERR "SoundSoftware.pm: Project is public, no restriction here\n";

	$r->set_handlers(PerlAuthenHandler => [\&OK])

    } else { # private

	print STDERR "SoundSoftware.pm: Project is private, authentication handler required\n";

    }

    return OK

}

sub authen_handler {

    my $r = shift;

    print STDERR "SoundSoftware.pm: In authentication handler at " . scalar localtime() . "\n";

    my $dbh = connect_database($r);

    unless ($dbh) {

        print STDERR "SoundSoftware.pm: Database connection failed!: " . $DBI::errstr . "\n";

        return AUTH_REQUIRED;

    }

    my $project_id = get_project_identifier($dbh, $r);

    my $realm = get_realm($dbh, $project_id, $r);

    $r->auth_name($realm);

    my ($res, $redmine_pass) =  $r->get_basic_auth_pw();

    unless ($res == OK) {

	$dbh->disconnect();

	undef $dbh;

	return $res;

    }

    print STDERR "SoundSoftware.pm: User is " . $r->user . ", got password\n";

    my $permitted = is_permitted($dbh, $project_id, $r->user, $redmine_pass, $r);

    $dbh->disconnect();

    undef $dbh;

    if ($permitted) {

	return OK;

    } else {

	print STDERR "SoundSoftware.pm: Not permitted\n";

	$r->note_auth_failure();

	return AUTH_REQUIRED;

    }

}

sub get_project_status {

    my $dbh = shift;

    my $project_id = shift;

    my $r = shift;

    if (!defined $project_id or $project_id eq '') {

	return 0; # nonexistent

    }

    my $sth = $dbh->prepare(

        "SELECT is_public FROM projects WHERE projects.identifier = ?;"

    );

    $sth->execute($project_id);

    my $ret = 0; # nonexistent

    if (my @row = $sth->fetchrow_array) {

    	if ($row[0] eq "1" || $row[0] eq "t") {

	    $ret = 1; # public

    	} else {

	    $ret = 2; # private

	}

    }

    $sth->finish();

    undef $sth;

    $ret;

}

sub project_repo_is_readonly {

    my $dbh = shift;

    my $project_id = shift;

    my $r = shift;

    if (!defined $project_id or $project_id eq '') {

        return 0; # nonexistent

    }

    my $sth = $dbh->prepare(

        "SELECT repositories.is_external FROM repositories, projects WHERE projects.identifier = ? AND repositories.project_id = projects.id;"

    );

    $sth->execute($project_id);

    my $ret = 0; # nonexistent

    if (my @row = $sth->fetchrow_array) {

        if (defined($row[0]) && ($row[0] eq "1" || $row[0] eq "t")) {

            $ret = 1; # read-only (i.e. external)

        } else {

            $ret = 0; # read-write

        }

    }

    $sth->finish();

    undef $sth;

    $ret;

}

sub is_permitted {

    my $dbh = shift;

    my $project_id = shift;

    my $redmine_user = shift;

    my $redmine_pass = shift;

    my $r = shift;

    my $pass_digest = Digest::SHA1::sha1_hex($redmine_pass);

    my $cfg = Apache2::Module::get_config

	(__PACKAGE__, $r->server, $r->per_dir_config);

    my $query = $cfg->{SoundSoftwareQuery};

    my $sth = $dbh->prepare($query);

    $sth->execute($redmine_user, $project_id);

    my $ret;

    while (my ($hashed_password, $auth_source_id, $permissions) = $sth->fetchrow_array) {

	# Test permissions for this user before we verify credentials

	# -- if the user is not permitted this action anyway, there's

	# not much point in e.g. contacting the LDAP

	my $method = $r->method;

	if ((defined $read_only_methods{$method} && $permissions =~ /:browse_repository/)

	    || $permissions =~ /:commit_access/) {

	    # User would be permitted this action, if their

	    # credentials checked out -- test those now

	    print STDERR "SoundSoftware.pm: User $redmine_user has required role, checking credentials\n";

	    unless ($auth_source_id) {

		if ($hashed_password eq $pass_digest) {

		    print STDERR "SoundSoftware.pm: User $redmine_user authenticated via password\n";

		    $ret = 1;

		    last;

		}

	    } else {

		my $sthldap = $dbh->prepare(

		    "SELECT host,port,tls,account,account_password,base_dn,attr_login FROM auth_sources WHERE id = ?;"

		    );

		$sthldap->execute($auth_source_id);

		while (my @rowldap = $sthldap->fetchrow_array) {

		    my $ldap = Authen::Simple::LDAP->new(

			host    => ($rowldap[2] eq "1" || $rowldap[2] eq "t") ? "ldaps://$rowldap[0]" : $rowldap[0],

			port    => $rowldap[1],

			basedn  => $rowldap[5],

			binddn  => $rowldap[3] ? $rowldap[3] : "",

			bindpw  => $rowldap[4] ? $rowldap[4] : "",

			filter  => "(".$rowldap[6]."=%s)"

			);

		    if ($ldap->authenticate($redmine_user, $redmine_pass)) {

			print STDERR "SoundSoftware.pm: User $redmine_user authenticated via LDAP\n";

			$ret = 1;

		    }

		}

		$sthldap->finish();

		undef $sthldap;

	    }

	} else {

	    print STDERR "SoundSoftware.pm: User $redmine_user lacks required role for this project\n";

	}

    }

    $sth->finish();

    undef $sth;

    $ret;

}

sub get_project_identifier {

    my $dbh = shift;

    my $r = shift;

    my $location = $r->location;

    my ($repo) = $r->uri =~ m{$location/*([^/]+)};

    return $repo if (!$repo);

    $repo =~ s/[^a-zA-Z0-9\._-]//g;

    # The original Redmine.pm returns the string just calculated as

    # the project identifier.  That won't do for us -- we may have

    # (and in fact already do have, in our test instance) projects

    # whose repository names differ from the project identifiers.

    # This is a rather fundamental change because it means that almost

    # every request needs more than one database query -- which

    # prompts us to start passing around $dbh instead of connecting

    # locally within each function as is done in Redmine.pm.

    my $sth = $dbh->prepare(

        "SELECT projects.identifier FROM projects, repositories WHERE repositories.project_id = projects.id AND repositories.url LIKE ?;"

    );

    my $cfg = Apache2::Module::get_config

	(__PACKAGE__, $r->server, $r->per_dir_config);

    my $prefix = $cfg->{SoundSoftwareRepoPrefix};

    if (!defined $prefix) { $prefix = '%/'; }

    my $identifier = '';

    $sth->execute($prefix . $repo);

    my $ret = 0;

    if (my @row = $sth->fetchrow_array) {

	$identifier = $row[0];

    }

    $sth->finish();

    undef $sth;

    print STDERR "SoundSoftware.pm: Repository '$repo' belongs to project '$identifier'\n";

    $identifier;

}

sub get_realm {

    my $dbh = shift;

    my $project_id = shift;

    my $r = shift;

    my $sth = $dbh->prepare(

        "SELECT projects.name FROM projects WHERE projects.identifier = ?;"

    );

    my $name = $project_id;

    $sth->execute($project_id);

    my $ret = 0;

    if (my @row = $sth->fetchrow_array) {

	$name = $row[0];

    }

    $sth->finish();

    undef $sth;

    # be timid about characters not permitted in auth realm and revert

    # to project identifier if any are found

    if ($name =~ m/[^\w\d\s\._-]/) {

	$name = $project_id;

    }

    my $realm = '"Mercurial repository for ' . "'$name'" . '"';

    $realm;

}

sub connect_database {

    my $r = shift;

    my $cfg = Apache2::Module::get_config

	(__PACKAGE__, $r->server, $r->per_dir_config);

    return DBI->connect($cfg->{SoundSoftwareDSN},

	                $cfg->{SoundSoftwareDbUser},

		        $cfg->{SoundSoftwareDbPass});

}

1;