view extra/soundsoftware/SoundSoftware-salted.pm @ 868:e203d95588cd feature_135

Close obsolete branch feature_135

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, salt, 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, $salt, $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) {
                my $salted_password = Digest::SHA1::sha1_hex($salt.$pass_digest);
		if ($hashed_password eq $salted_password) {
		    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;