Chris@7: package Apache::Authn::SoundSoftware;
Chris@7: 
Chris@7: =head1 Apache::Authn::SoundSoftware
Chris@7: 
Chris@7: SoundSoftware - a mod_perl module for Apache authentication against a
Chris@7: Redmine database and optional LDAP implementing the access control
Chris@7: rules required for the SoundSoftware.ac.uk repository site.
Chris@7: 
Chris@7: =head1 SYNOPSIS
Chris@7: 
Chris@7: This module is closely based on the Redmine.pm authentication module
Chris@7: provided with Redmine.  It is intended to be used for authentication
Chris@7: in front of a repository service such as hgwebdir.
Chris@7: 
Chris@7: Requirements:
Chris@7: 
Chris@7: 1. Clone/pull from repo for public project: Any user, no
Chris@7: authentication required
Chris@7: 
Chris@7: 2. Clone/pull from repo for private project: Project members only
Chris@7: 
Chris@7: 3. Push to repo for public project: "Permitted" users only (this
Chris@8: probably means project members who are also identified in the hgrc web
Chris@8: section for the repository and so will be approved by hgwebdir?)
Chris@7: 
Chris@8: 4. Push to repo for private project: "Permitted" users only (as above)
Chris@7: 
chris@300: 5. Push to any repo that is tracking an external repo: Refused always
chris@300: 
Chris@7: =head1 INSTALLATION
Chris@7: 
Chris@7: Debian/ubuntu:
Chris@7: 
Chris@7:   apt-get install libapache-dbi-perl libapache2-mod-perl2 \
Chris@1575:     libdbd-mysql-perl libdbd-pg-perl libio-socket-ssl-perl \
Chris@1575:     libauthen-simple-ldap-perl
Chris@7: 
Chris@7: Note that LDAP support is hardcoded "on" in this script (it is
Chris@7: optional in the original Redmine.pm).
Chris@7: 
Chris@7: =head1 CONFIGURATION
Chris@7: 
Chris@7:    ## This module has to be in your perl path
Chris@7:    ## eg:  /usr/local/lib/site_perl/Apache/Authn/SoundSoftware.pm
Chris@7:    PerlLoadModule Apache::Authn::SoundSoftware
Chris@7: 
Chris@7:    # Example when using hgwebdir
Chris@7:    ScriptAlias / "/var/hg/hgwebdir.cgi/"
Chris@7: 
Chris@7:    <Location />
Chris@7:        AuthName "Mercurial"
Chris@7:        AuthType Basic
Chris@7:        Require valid-user
Chris@7:        PerlAccessHandler Apache::Authn::SoundSoftware::access_handler
Chris@7:        PerlAuthenHandler Apache::Authn::SoundSoftware::authen_handler
Chris@7:        SoundSoftwareDSN "DBI:mysql:database=redmine;host=localhost"
Chris@7:        SoundSoftwareDbUser "redmine"
Chris@7:        SoundSoftwareDbPass "password"
Chris@7:        Options +ExecCGI
Chris@7:        AddHandler cgi-script .cgi
Chris@7:        ## Optional where clause (fulltext search would be slow and
Chris@7:        ## database dependant).
Chris@7:        # SoundSoftwareDbWhereClause "and members.role_id IN (1,2)"
Chris@8:        ## Optional prefix for local repository URLs
Chris@8:        # SoundSoftwareRepoPrefix "/var/hg/"
Chris@7:   </Location>
Chris@7: 
Chris@7: See the original Redmine.pm for further configuration notes.
Chris@7: 
Chris@7: =cut
Chris@7: 
Chris@7: use strict;
Chris@7: use warnings FATAL => 'all', NONFATAL => 'redefine';
Chris@7: 
Chris@7: use DBI;
Chris@1331: use Digest::SHA;
Chris@7: use Authen::Simple::LDAP;
Chris@7: use Apache2::Module;
Chris@7: use Apache2::Access;
Chris@7: use Apache2::ServerRec qw();
Chris@7: use Apache2::RequestRec qw();
Chris@7: use Apache2::RequestUtil qw();
Chris@7: use Apache2::Const qw(:common :override :cmd_how);
Chris@7: use APR::Pool ();
Chris@7: use APR::Table ();
Chris@7: 
Chris@7: my @directives = (
Chris@7:   {
Chris@7:     name => 'SoundSoftwareDSN',
Chris@7:     req_override => OR_AUTHCFG,
Chris@7:     args_how => TAKE1,
Chris@7:     errmsg => 'Dsn in format used by Perl DBI. eg: "DBI:Pg:dbname=databasename;host=my.db.server"',
Chris@7:   },
Chris@7:   {
Chris@7:     name => 'SoundSoftwareDbUser',
Chris@7:     req_override => OR_AUTHCFG,
Chris@7:     args_how => TAKE1,
Chris@7:   },
Chris@7:   {
Chris@7:     name => 'SoundSoftwareDbPass',
Chris@7:     req_override => OR_AUTHCFG,
Chris@7:     args_how => TAKE1,
Chris@7:   },
Chris@7:   {
Chris@7:     name => 'SoundSoftwareDbWhereClause',
Chris@7:     req_override => OR_AUTHCFG,
Chris@7:     args_how => TAKE1,
Chris@7:   },
Chris@7:   {
Chris@8:     name => 'SoundSoftwareRepoPrefix',
Chris@7:     req_override => OR_AUTHCFG,
Chris@7:     args_how => TAKE1,
Chris@7:   },
Chris@732:   {
Chris@732:     name => 'SoundSoftwareSslRequired',
Chris@732:     req_override => OR_AUTHCFG,
Chris@732:     args_how => TAKE1,
Chris@732:   },
Chris@7: );
Chris@7: 
Chris@7: sub SoundSoftwareDSN { 
Chris@8:     my ($self, $parms, $arg) = @_;
Chris@8:     $self->{SoundSoftwareDSN} = $arg;
Chris@8:     my $query = "SELECT 
chris@301:                  hashed_password, salt, auth_source_id, permissions
Chris@7:               FROM members, projects, users, roles, member_roles
Chris@7:               WHERE 
Chris@7:                 projects.id=members.project_id
Chris@7:                 AND member_roles.member_id=members.id
Chris@7:                 AND users.id=members.user_id 
Chris@7:                 AND roles.id=member_roles.role_id
Chris@7:                 AND users.status=1 
Chris@7:                 AND login=? 
Chris@7:                 AND identifier=? ";
Chris@8:     $self->{SoundSoftwareQuery} = trim($query);
Chris@7: }
Chris@7: 
Chris@7: sub SoundSoftwareDbUser { set_val('SoundSoftwareDbUser', @_); }
Chris@7: sub SoundSoftwareDbPass { set_val('SoundSoftwareDbPass', @_); }
Chris@7: sub SoundSoftwareDbWhereClause { 
Chris@8:     my ($self, $parms, $arg) = @_;
Chris@8:     $self->{SoundSoftwareQuery} = trim($self->{SoundSoftwareQuery}.($arg ? $arg : "")." ");
Chris@7: }
Chris@7: 
Chris@8: sub SoundSoftwareRepoPrefix { 
Chris@8:     my ($self, $parms, $arg) = @_;
Chris@8:     if ($arg) {
Chris@8: 	$self->{SoundSoftwareRepoPrefix} = $arg;
Chris@8:     }
Chris@7: }
Chris@7: 
Chris@732: sub SoundSoftwareSslRequired { set_val('SoundSoftwareSslRequired', @_); }
Chris@732: 
Chris@7: sub trim {
Chris@8:     my $string = shift;
Chris@8:     $string =~ s/\s{2,}/ /g;
Chris@8:     return $string;
Chris@7: }
Chris@7: 
Chris@7: sub set_val {
Chris@8:     my ($key, $self, $parms, $arg) = @_;
Chris@8:     $self->{$key} = $arg;
Chris@7: }
Chris@7: 
Chris@7: Apache2::Module::add(__PACKAGE__, \@directives);
Chris@7: 
Chris@7: 
Chris@7: my %read_only_methods = map { $_ => 1 } qw/GET PROPFIND REPORT OPTIONS/;
Chris@7: 
Chris@7: sub access_handler {
Chris@8:     my $r = shift;
Chris@7: 
Chris@517:     print STDERR "SoundSoftware.pm:$$: In access handler at " . scalar localtime() . "\n";
Chris@7: 
Chris@8:     unless ($r->some_auth_required) {
Chris@8: 	$r->log_reason("No authentication has been configured");
Chris@8: 	return FORBIDDEN;
Chris@8:     }
Chris@7: 
Chris@8:     my $method = $r->method;
Chris@7: 
Chris@517:     print STDERR "SoundSoftware.pm:$$: Method: $method, uri " . $r->uri . ", location " . $r->location . "\n";
Chris@1585: #    print STDERR "SoundSoftware.pm:$$: Accept: " . $r->headers_in->{Accept} . "\n";
Chris@7: 
Chris@8:     my $dbh = connect_database($r);
Chris@152:     unless ($dbh) {
Chris@517: 	print STDERR "SoundSoftware.pm:$$: Database connection failed!: " . $DBI::errstr . "\n";
Chris@152: 	return FORBIDDEN;
Chris@152:     }
Chris@152: 
chris@300:     print STDERR "Connected to db, dbh is " . $dbh . "\n";
Chris@7: 
Chris@8:     my $project_id = get_project_identifier($dbh, $r);
chris@300: 
Chris@732:     # We want to delegate most of the work to the authentication
Chris@732:     # handler (to ensure that user is asked to login even for 
Chris@732:     # nonexistent projects -- so they can't tell whether a private
Chris@732:     # project exists or not without authenticating). So 
Chris@732:     # 
Chris@732:     # * if the project is public
Chris@732:     #   - if the method is read-only
Chris@732:     #     + set handler to OK, no auth needed
Chris@732:     #   - if the method is not read-only
Chris@732:     #     + if the repo is read-only, return forbidden
Chris@732:     #     + else require auth
Chris@732:     # * if the project is not public or does not exist
Chris@732:     #     + require auth
Chris@732:     #
Chris@732:     # If we are requiring auth and are not currently https, and
Chris@732:     # https is required, then we must return a redirect to https
Chris@732:     # instead of an OK.
chris@300: 
Chris@8:     my $status = get_project_status($dbh, $project_id, $r);
Chris@732:     my $readonly = project_repo_is_readonly($dbh, $project_id, $r);
Chris@7: 
Chris@8:     $dbh->disconnect();
Chris@8:     undef $dbh;
Chris@7: 
Chris@734:     my $auth_ssl_reqd = will_require_ssl_auth($r);
Chris@734: 
Chris@732:     if ($status == 1) { # public
Chris@732: 
Chris@732: 	print STDERR "SoundSoftware.pm:$$: Project is public\n";
Chris@732: 
Chris@732: 	if (!defined $read_only_methods{$method}) {
Chris@732: 
Chris@732: 	    print STDERR "SoundSoftware.pm:$$: Method is not read-only\n";
Chris@732: 
Chris@732: 	    if ($readonly) {
Chris@732: 		print STDERR "SoundSoftware.pm:$$: Project repo is read-only, refusing access\n";
Chris@732: 		return FORBIDDEN;
Chris@732: 	    } else {
Chris@732: 		print STDERR "SoundSoftware.pm:$$: Project repo is read-write, auth required\n";
Chris@732: 		# fall through, this is the normal case
Chris@732: 	    }
Chris@732: 
Chris@734:         } elsif ($auth_ssl_reqd and $r->unparsed_uri =~ m/cmd=branchmap/) {
Chris@734: 
Chris@734:             # A hac^H^H^Hspecial case. We want to ensure we switch to
Chris@734:             # https (if it will be necessarily for authentication) 
Chris@734:             # before the first POST request, and this is what I think
Chris@734:             # will give us suitable warning for Mercurial.
Chris@734: 
Chris@734:             print STDERR "SoundSoftware.pm:$$: Switching to HTTPS in preparation\n";
Chris@734:             # fall through, this is the normal case
Chris@734: 
Chris@732: 	} else {
Chris@732: 	    # Public project, read-only method -- this is the only
Chris@732: 	    # case we can decide for certain to accept in this function
Chris@732: 	    print STDERR "SoundSoftware.pm:$$: Method is read-only, no restriction here\n";
Chris@732: 	    $r->set_handlers(PerlAuthenHandler => [\&OK]);
Chris@1612:             if (!defined $r->user or $r->user eq '') {
Chris@1612:                 # Apache 2.4+ requires auth module to set user if no
Chris@1612:                 # auth was needed. Note that this actually tells
Chris@1612:                 # apache that user has been identified, so authen
Chris@1612:                 # handler will never be called (i.e. we must not do
Chris@1612:                 # this unless we are actually approving the auth-free
Chris@1612:                 # access). If we don't do this, we get a 500 error
Chris@1612:                 # here after the set_handlers call above
Chris@1612:                 $r->user('*anon*');
Chris@1612:             }
Chris@732: 	    return OK;
Chris@732: 	}
Chris@732: 
Chris@732:     } else { # status != 1, i.e. nonexistent or private -- equivalent here
Chris@732: 
Chris@732: 	print STDERR "SoundSoftware.pm:$$: Project is private or nonexistent, auth required\n";
Chris@732: 	# fall through
Chris@8:     }
Chris@7: 
Chris@734:     if ($auth_ssl_reqd) {
Chris@734:         my $redir_to = "https://" . $r->hostname() . $r->unparsed_uri();
Chris@734:         print STDERR "SoundSoftware.pm:$$: Need to switch to HTTPS, redirecting to $redir_to\n";
Chris@734:         $r->headers_out->add('Location' => $redir_to);
Chris@734:         return REDIRECT;
Chris@732:     } else {
Chris@734:         return OK;
Chris@732:     }
Chris@7: }
Chris@7: 
Chris@7: sub authen_handler {
Chris@8:     my $r = shift;
Chris@8:     
Chris@517:     print STDERR "SoundSoftware.pm:$$: In authentication handler at " . scalar localtime() . "\n";
Chris@7: 
Chris@8:     my $dbh = connect_database($r);
Chris@152:     unless ($dbh) {
Chris@517:         print STDERR "SoundSoftware.pm:$$: Database connection failed!: " . $DBI::errstr . "\n";
Chris@152:         return AUTH_REQUIRED;
Chris@152:     }
Chris@8:     
Chris@8:     my $project_id = get_project_identifier($dbh, $r);
Chris@8:     my $realm = get_realm($dbh, $project_id, $r);
Chris@8:     $r->auth_name($realm);
Chris@8: 
Chris@8:     my ($res, $redmine_pass) =  $r->get_basic_auth_pw();
Chris@8:     unless ($res == OK) {
Chris@8: 	$dbh->disconnect();
Chris@8: 	undef $dbh;
Chris@8: 	return $res;
Chris@8:     }
Chris@8:     
Chris@517:     print STDERR "SoundSoftware.pm:$$: User is " . $r->user . ", got password\n";
Chris@8: 
Chris@732:     my $status = get_project_status($dbh, $project_id, $r);
Chris@732:     if ($status == 0) {
Chris@732: 	# nonexistent, behave like private project you aren't a member of
Chris@732: 	print STDERR "SoundSoftware.pm:$$: Project doesn't exist, not permitted\n";
Chris@732: 	$dbh->disconnect();
Chris@732: 	undef $dbh;
Chris@732: 	$r->note_auth_failure();
Chris@732: 	return AUTH_REQUIRED;
Chris@732:     }
Chris@732: 
Chris@8:     my $permitted = is_permitted($dbh, $project_id, $r->user, $redmine_pass, $r);
Chris@8:     
Chris@8:     $dbh->disconnect();
Chris@8:     undef $dbh;
Chris@8: 
Chris@8:     if ($permitted) {
Chris@8: 	return OK;
Chris@8:     } else {
Chris@517: 	print STDERR "SoundSoftware.pm:$$: Not permitted\n";
Chris@8: 	$r->note_auth_failure();
Chris@8: 	return AUTH_REQUIRED;
Chris@8:     }
Chris@7: }
Chris@7: 
Chris@7: sub get_project_status {
Chris@8:     my $dbh = shift;
Chris@7:     my $project_id = shift;
Chris@7:     my $r = shift;
Chris@8: 
Chris@8:     if (!defined $project_id or $project_id eq '') {
Chris@8: 	return 0; # nonexistent
Chris@8:     }
Chris@7:     
Chris@7:     my $sth = $dbh->prepare(
Chris@7:         "SELECT is_public FROM projects WHERE projects.identifier = ?;"
Chris@7:     );
Chris@7: 
Chris@7:     $sth->execute($project_id);
Chris@8:     my $ret = 0; # nonexistent
Chris@7:     if (my @row = $sth->fetchrow_array) {
Chris@7:     	if ($row[0] eq "1" || $row[0] eq "t") {
Chris@7: 	    $ret = 1; # public
Chris@7:     	} else {
Chris@8: 	    $ret = 2; # private
Chris@7: 	}
Chris@7:     }
Chris@7:     $sth->finish();
Chris@7:     undef $sth;
Chris@7: 
Chris@7:     $ret;
Chris@7: }
Chris@7: 
Chris@734: sub will_require_ssl_auth {
Chris@734:     my $r = shift;
Chris@734: 
Chris@734:     my $cfg = Apache2::Module::get_config
Chris@734:         (__PACKAGE__, $r->server, $r->per_dir_config);
Chris@734: 
Chris@734:     if ($cfg->{SoundSoftwareSslRequired} eq "on") {
Chris@734:         if ($r->dir_config('HTTPS') eq "on") {
Chris@734:             # already have ssl
Chris@734:             return 0;
Chris@734:         } else {
Chris@734:             # require ssl for auth, don't have it yet
Chris@734:             return 1;
Chris@734:         }
Chris@734:     } elsif ($cfg->{SoundSoftwareSslRequired} eq "off") {
Chris@734:         # don't require ssl for auth
Chris@734:         return 0;
Chris@734:     } else {
Chris@734:         print STDERR "WARNING: SoundSoftware.pm:$$: SoundSoftwareSslRequired should be either 'on' or 'off'\n";
Chris@734:         # this is safer
Chris@734:         return 1;
Chris@734:     }
Chris@734: }
Chris@734: 
chris@300: sub project_repo_is_readonly {
chris@300:     my $dbh = shift;
chris@300:     my $project_id = shift;
chris@300:     my $r = shift;
chris@300: 
chris@300:     if (!defined $project_id or $project_id eq '') {
chris@300:         return 0; # nonexistent
chris@300:     }
chris@300: 
chris@300:     my $sth = $dbh->prepare(
chris@300:         "SELECT repositories.is_external FROM repositories, projects WHERE projects.identifier = ? AND repositories.project_id = projects.id;"
chris@300:     );
chris@300: 
chris@300:     $sth->execute($project_id);
chris@300:     my $ret = 0; # nonexistent
chris@300:     if (my @row = $sth->fetchrow_array) {
chris@301:         if (defined($row[0]) && ($row[0] eq "1" || $row[0] eq "t")) {
chris@300:             $ret = 1; # read-only (i.e. external)
chris@300:         } else {
chris@300:             $ret = 0; # read-write
chris@300:         }
chris@300:     }
chris@300:     $sth->finish();
chris@300:     undef $sth;
chris@300: 
chris@300:     $ret;
chris@300: }
chris@300: 
Chris@8: sub is_permitted {
Chris@8:     my $dbh = shift;
Chris@8:     my $project_id = shift;
Chris@8:     my $redmine_user = shift;
Chris@8:     my $redmine_pass = shift;
Chris@8:     my $r = shift;
Chris@7: 
Chris@1331:     my $pass_digest = Digest::SHA::sha1_hex($redmine_pass);
Chris@7: 
Chris@8:     my $cfg = Apache2::Module::get_config
Chris@8: 	(__PACKAGE__, $r->server, $r->per_dir_config);
Chris@7: 
Chris@8:     my $query = $cfg->{SoundSoftwareQuery};
Chris@8:     my $sth = $dbh->prepare($query);
Chris@8:     $sth->execute($redmine_user, $project_id);
Chris@7: 
Chris@8:     my $ret;
chris@301:     while (my ($hashed_password, $salt, $auth_source_id, $permissions) = $sth->fetchrow_array) {
Chris@7: 
Chris@8: 	# Test permissions for this user before we verify credentials
Chris@8: 	# -- if the user is not permitted this action anyway, there's
Chris@8: 	# not much point in e.g. contacting the LDAP
Chris@7: 
Chris@8: 	my $method = $r->method;
Chris@7: 
Chris@8: 	if ((defined $read_only_methods{$method} && $permissions =~ /:browse_repository/)
Chris@8: 	    || $permissions =~ /:commit_access/) {
Chris@8: 
Chris@8: 	    # User would be permitted this action, if their
Chris@8: 	    # credentials checked out -- test those now
Chris@8: 
Chris@8: 	    print STDERR "SoundSoftware.pm: User $redmine_user has required role, checking credentials\n";
Chris@8: 
Chris@8: 	    unless ($auth_source_id) {
Chris@1331:                 my $salted_password = Digest::SHA::sha1_hex($salt.$pass_digest);
chris@301: 		if ($hashed_password eq $salted_password) {
Chris@8: 		    print STDERR "SoundSoftware.pm: User $redmine_user authenticated via password\n";
Chris@8: 		    $ret = 1;
Chris@8: 		    last;
Chris@8: 		}
Chris@8: 	    } else {
Chris@8: 		my $sthldap = $dbh->prepare(
Chris@8: 		    "SELECT host,port,tls,account,account_password,base_dn,attr_login FROM auth_sources WHERE id = ?;"
Chris@8: 		    );
Chris@8: 		$sthldap->execute($auth_source_id);
Chris@8: 		while (my @rowldap = $sthldap->fetchrow_array) {
Chris@8: 		    my $ldap = Authen::Simple::LDAP->new(
Chris@8: 			host    => ($rowldap[2] eq "1" || $rowldap[2] eq "t") ? "ldaps://$rowldap[0]" : $rowldap[0],
Chris@8: 			port    => $rowldap[1],
Chris@8: 			basedn  => $rowldap[5],
Chris@8: 			binddn  => $rowldap[3] ? $rowldap[3] : "",
Chris@8: 			bindpw  => $rowldap[4] ? $rowldap[4] : "",
Chris@8: 			filter  => "(".$rowldap[6]."=%s)"
Chris@8: 			);
Chris@8: 		    if ($ldap->authenticate($redmine_user, $redmine_pass)) {
Chris@517: 			print STDERR "SoundSoftware.pm:$$: User $redmine_user authenticated via LDAP\n";
Chris@8: 			$ret = 1;
Chris@8: 		    }
Chris@8: 		}
Chris@8: 		$sthldap->finish();
Chris@8: 		undef $sthldap;
Chris@735:                 last if ($ret);
Chris@8: 	    }
Chris@8: 	} else {
Chris@517: 	    print STDERR "SoundSoftware.pm:$$: User $redmine_user lacks required role for this project\n";
Chris@8: 	}
Chris@7:     }
Chris@7: 
Chris@8:     $sth->finish();
Chris@8:     undef $sth;
Chris@8: 
Chris@8:     $ret;
Chris@7: }
Chris@7: 
Chris@7: sub get_project_identifier {
Chris@8:     my $dbh = shift;
Chris@7:     my $r = shift;
Chris@7:     my $location = $r->location;
Chris@737:     my ($repo) = $r->uri =~ m{$location/*([^/]*)};
Chris@10: 
Chris@10:     return $repo if (!$repo);
Chris@10: 
Chris@7:     $repo =~ s/[^a-zA-Z0-9\._-]//g;
Chris@736:     
Chris@8:     # The original Redmine.pm returns the string just calculated as
Chris@8:     # the project identifier.  That won't do for us -- we may have
Chris@8:     # (and in fact already do have, in our test instance) projects
Chris@8:     # whose repository names differ from the project identifiers.
Chris@8: 
Chris@8:     # This is a rather fundamental change because it means that almost
Chris@8:     # every request needs more than one database query -- which
Chris@8:     # prompts us to start passing around $dbh instead of connecting
Chris@8:     # locally within each function as is done in Redmine.pm.
Chris@8: 
Chris@7:     my $sth = $dbh->prepare(
Chris@7:         "SELECT projects.identifier FROM projects, repositories WHERE repositories.project_id = projects.id AND repositories.url LIKE ?;"
Chris@7:     );
Chris@7: 
Chris@8:     my $cfg = Apache2::Module::get_config
Chris@8: 	(__PACKAGE__, $r->server, $r->per_dir_config);
Chris@8: 
Chris@8:     my $prefix = $cfg->{SoundSoftwareRepoPrefix};
Chris@8:     if (!defined $prefix) { $prefix = '%/'; }
Chris@7:     my $identifier = '';
Chris@7: 
Chris@8:     $sth->execute($prefix . $repo);
Chris@7:     my $ret = 0;
Chris@7:     if (my @row = $sth->fetchrow_array) {
Chris@7: 	$identifier = $row[0];
Chris@7:     }
Chris@7:     $sth->finish();
Chris@7:     undef $sth;
Chris@7: 
Chris@517:     print STDERR "SoundSoftware.pm:$$: Repository '$repo' belongs to project '$identifier'\n";
Chris@7: 
Chris@7:     $identifier;
Chris@7: }
Chris@7: 
Chris@8: sub get_realm {
Chris@8:     my $dbh = shift;
Chris@8:     my $project_id = shift;
Chris@8:     my $r = shift;
Chris@8: 
Chris@8:     my $sth = $dbh->prepare(
Chris@8:         "SELECT projects.name FROM projects WHERE projects.identifier = ?;"
Chris@8:     );
Chris@8: 
Chris@8:     my $name = $project_id;
Chris@8: 
Chris@8:     $sth->execute($project_id);
Chris@8:     my $ret = 0;
Chris@8:     if (my @row = $sth->fetchrow_array) {
Chris@8: 	$name = $row[0];
Chris@8:     }
Chris@8:     $sth->finish();
Chris@8:     undef $sth;
Chris@8: 
Chris@8:     # be timid about characters not permitted in auth realm and revert
Chris@8:     # to project identifier if any are found
Chris@8:     if ($name =~ m/[^\w\d\s\._-]/) {
Chris@8: 	$name = $project_id;
Chris@733:     } elsif ($name =~ m/^\s*$/) {
Chris@733: 	# empty or whitespace
Chris@733: 	$name = $project_id;
Chris@733:     }
Chris@733:     
Chris@733:     if ($name =~ m/^\s*$/) {
Chris@733:         # nothing even in $project_id -- probably a nonexistent project.
Chris@733:         # use repo name instead (don't want to admit to user that project
Chris@733:         # doesn't exist)
Chris@733:         my $location = $r->location;
Chris@737:         my ($repo) = $r->uri =~ m{$location/*([^/]*)};
Chris@733:         $name = $repo;
Chris@8:     }
Chris@8: 
Chris@1271: #    my $realm = '"Mercurial repository for ' . "'$name'" . '"';
Chris@1271: # see #577:
Chris@1271:     my $realm = '"Mercurial repository for ' . "$name" . '"';
Chris@8: 
Chris@8:     $realm;
Chris@8: }
Chris@8: 
Chris@7: sub connect_database {
Chris@7:     my $r = shift;
Chris@7:     
Chris@8:     my $cfg = Apache2::Module::get_config
Chris@8: 	(__PACKAGE__, $r->server, $r->per_dir_config);
Chris@8: 
Chris@8:     return DBI->connect($cfg->{SoundSoftwareDSN},
Chris@152: 	                $cfg->{SoundSoftwareDbUser},
Chris@152: 		        $cfg->{SoundSoftwareDbPass});
Chris@7: }
Chris@7: 
Chris@7: 1;