annotate extra/svn/SoundSoftware.pm @ 36:de76cd3e8c8e cc-branches

* Probably abortive experiments in extracting the branch from Hg
author Chris Cannam <chris.cannam@soundsoftware.ac.uk>
date Wed, 20 Oct 2010 10:07:29 +0100
parents 8100616a9904
children a389c77da9fd
rev   line source
Chris@7 1 package Apache::Authn::SoundSoftware;
Chris@7 2
Chris@7 3 =head1 Apache::Authn::SoundSoftware
Chris@7 4
Chris@7 5 SoundSoftware - a mod_perl module for Apache authentication against a
Chris@7 6 Redmine database and optional LDAP implementing the access control
Chris@7 7 rules required for the SoundSoftware.ac.uk repository site.
Chris@7 8
Chris@7 9 =head1 SYNOPSIS
Chris@7 10
Chris@7 11 This module is closely based on the Redmine.pm authentication module
Chris@7 12 provided with Redmine. It is intended to be used for authentication
Chris@7 13 in front of a repository service such as hgwebdir.
Chris@7 14
Chris@7 15 Requirements:
Chris@7 16
Chris@7 17 1. Clone/pull from repo for public project: Any user, no
Chris@7 18 authentication required
Chris@7 19
Chris@7 20 2. Clone/pull from repo for private project: Project members only
Chris@7 21
Chris@7 22 3. Push to repo for public project: "Permitted" users only (this
Chris@8 23 probably means project members who are also identified in the hgrc web
Chris@8 24 section for the repository and so will be approved by hgwebdir?)
Chris@7 25
Chris@8 26 4. Push to repo for private project: "Permitted" users only (as above)
Chris@7 27
Chris@7 28 =head1 INSTALLATION
Chris@7 29
Chris@7 30 Debian/ubuntu:
Chris@7 31
Chris@7 32 apt-get install libapache-dbi-perl libapache2-mod-perl2 \
Chris@7 33 libdbd-mysql-perl libauthen-simple-ldap-perl libio-socket-ssl-perl
Chris@7 34
Chris@7 35 Note that LDAP support is hardcoded "on" in this script (it is
Chris@7 36 optional in the original Redmine.pm).
Chris@7 37
Chris@7 38 =head1 CONFIGURATION
Chris@7 39
Chris@7 40 ## This module has to be in your perl path
Chris@7 41 ## eg: /usr/local/lib/site_perl/Apache/Authn/SoundSoftware.pm
Chris@7 42 PerlLoadModule Apache::Authn::SoundSoftware
Chris@7 43
Chris@7 44 # Example when using hgwebdir
Chris@7 45 ScriptAlias / "/var/hg/hgwebdir.cgi/"
Chris@7 46
Chris@7 47 <Location />
Chris@7 48 AuthName "Mercurial"
Chris@7 49 AuthType Basic
Chris@7 50 Require valid-user
Chris@7 51 PerlAccessHandler Apache::Authn::SoundSoftware::access_handler
Chris@7 52 PerlAuthenHandler Apache::Authn::SoundSoftware::authen_handler
Chris@7 53 SoundSoftwareDSN "DBI:mysql:database=redmine;host=localhost"
Chris@7 54 SoundSoftwareDbUser "redmine"
Chris@7 55 SoundSoftwareDbPass "password"
Chris@7 56 Options +ExecCGI
Chris@7 57 AddHandler cgi-script .cgi
Chris@7 58 ## Optional where clause (fulltext search would be slow and
Chris@7 59 ## database dependant).
Chris@7 60 # SoundSoftwareDbWhereClause "and members.role_id IN (1,2)"
Chris@8 61 ## Optional prefix for local repository URLs
Chris@8 62 # SoundSoftwareRepoPrefix "/var/hg/"
Chris@7 63 </Location>
Chris@7 64
Chris@7 65 See the original Redmine.pm for further configuration notes.
Chris@7 66
Chris@7 67 =cut
Chris@7 68
Chris@7 69 use strict;
Chris@7 70 use warnings FATAL => 'all', NONFATAL => 'redefine';
Chris@7 71
Chris@7 72 use DBI;
Chris@7 73 use Digest::SHA1;
Chris@7 74 use Authen::Simple::LDAP;
Chris@7 75 use Apache2::Module;
Chris@7 76 use Apache2::Access;
Chris@7 77 use Apache2::ServerRec qw();
Chris@7 78 use Apache2::RequestRec qw();
Chris@7 79 use Apache2::RequestUtil qw();
Chris@7 80 use Apache2::Const qw(:common :override :cmd_how);
Chris@7 81 use APR::Pool ();
Chris@7 82 use APR::Table ();
Chris@7 83
Chris@7 84 my @directives = (
Chris@7 85 {
Chris@7 86 name => 'SoundSoftwareDSN',
Chris@7 87 req_override => OR_AUTHCFG,
Chris@7 88 args_how => TAKE1,
Chris@7 89 errmsg => 'Dsn in format used by Perl DBI. eg: "DBI:Pg:dbname=databasename;host=my.db.server"',
Chris@7 90 },
Chris@7 91 {
Chris@7 92 name => 'SoundSoftwareDbUser',
Chris@7 93 req_override => OR_AUTHCFG,
Chris@7 94 args_how => TAKE1,
Chris@7 95 },
Chris@7 96 {
Chris@7 97 name => 'SoundSoftwareDbPass',
Chris@7 98 req_override => OR_AUTHCFG,
Chris@7 99 args_how => TAKE1,
Chris@7 100 },
Chris@7 101 {
Chris@7 102 name => 'SoundSoftwareDbWhereClause',
Chris@7 103 req_override => OR_AUTHCFG,
Chris@7 104 args_how => TAKE1,
Chris@7 105 },
Chris@7 106 {
Chris@8 107 name => 'SoundSoftwareRepoPrefix',
Chris@7 108 req_override => OR_AUTHCFG,
Chris@7 109 args_how => TAKE1,
Chris@7 110 },
Chris@7 111 );
Chris@7 112
Chris@7 113 sub SoundSoftwareDSN {
Chris@8 114 my ($self, $parms, $arg) = @_;
Chris@8 115 $self->{SoundSoftwareDSN} = $arg;
Chris@8 116 my $query = "SELECT
Chris@7 117 hashed_password, auth_source_id, permissions
Chris@7 118 FROM members, projects, users, roles, member_roles
Chris@7 119 WHERE
Chris@7 120 projects.id=members.project_id
Chris@7 121 AND member_roles.member_id=members.id
Chris@7 122 AND users.id=members.user_id
Chris@7 123 AND roles.id=member_roles.role_id
Chris@7 124 AND users.status=1
Chris@7 125 AND login=?
Chris@7 126 AND identifier=? ";
Chris@8 127 $self->{SoundSoftwareQuery} = trim($query);
Chris@7 128 }
Chris@7 129
Chris@7 130 sub SoundSoftwareDbUser { set_val('SoundSoftwareDbUser', @_); }
Chris@7 131 sub SoundSoftwareDbPass { set_val('SoundSoftwareDbPass', @_); }
Chris@7 132 sub SoundSoftwareDbWhereClause {
Chris@8 133 my ($self, $parms, $arg) = @_;
Chris@8 134 $self->{SoundSoftwareQuery} = trim($self->{SoundSoftwareQuery}.($arg ? $arg : "")." ");
Chris@7 135 }
Chris@7 136
Chris@8 137 sub SoundSoftwareRepoPrefix {
Chris@8 138 my ($self, $parms, $arg) = @_;
Chris@8 139 if ($arg) {
Chris@8 140 $self->{SoundSoftwareRepoPrefix} = $arg;
Chris@8 141 }
Chris@7 142 }
Chris@7 143
Chris@7 144 sub trim {
Chris@8 145 my $string = shift;
Chris@8 146 $string =~ s/\s{2,}/ /g;
Chris@8 147 return $string;
Chris@7 148 }
Chris@7 149
Chris@7 150 sub set_val {
Chris@8 151 my ($key, $self, $parms, $arg) = @_;
Chris@8 152 $self->{$key} = $arg;
Chris@7 153 }
Chris@7 154
Chris@7 155 Apache2::Module::add(__PACKAGE__, \@directives);
Chris@7 156
Chris@7 157
Chris@7 158 my %read_only_methods = map { $_ => 1 } qw/GET PROPFIND REPORT OPTIONS/;
Chris@7 159
Chris@7 160 sub access_handler {
Chris@8 161 my $r = shift;
Chris@7 162
Chris@8 163 print STDERR "SoundSoftware.pm: In access handler\n";
Chris@7 164
Chris@8 165 unless ($r->some_auth_required) {
Chris@8 166 $r->log_reason("No authentication has been configured");
Chris@8 167 return FORBIDDEN;
Chris@8 168 }
Chris@7 169
Chris@8 170 my $method = $r->method;
Chris@7 171
Chris@8 172 print STDERR "SoundSoftware.pm: Method: $method, uri " . $r->uri . ", location " . $r->location . "\n";
Chris@8 173 print STDERR "SoundSoftware.pm: Accept: " . $r->headers_in->{Accept} . "\n";
Chris@7 174
Chris@8 175 if (!defined $read_only_methods{$method}) {
Chris@8 176 print STDERR "SoundSoftware.pm: Method is not read-only, authentication handler required\n";
Chris@8 177 return OK;
Chris@8 178 }
Chris@7 179
Chris@8 180 my $dbh = connect_database($r);
Chris@7 181
Chris@8 182 my $project_id = get_project_identifier($dbh, $r);
Chris@8 183 my $status = get_project_status($dbh, $project_id, $r);
Chris@7 184
Chris@8 185 $dbh->disconnect();
Chris@8 186 undef $dbh;
Chris@7 187
Chris@8 188 if ($status == 0) { # nonexistent
Chris@8 189 print STDERR "SoundSoftware.pm: Project does not exist, refusing access\n";
Chris@8 190 return FORBIDDEN;
Chris@8 191 } elsif ($status == 1) { # public
Chris@8 192 print STDERR "SoundSoftware.pm: Project is public, no restriction here\n";
Chris@8 193 $r->set_handlers(PerlAuthenHandler => [\&OK])
Chris@8 194 } else { # private
Chris@8 195 print STDERR "SoundSoftware.pm: Project is private, authentication handler required\n";
Chris@8 196 }
Chris@7 197
Chris@8 198 return OK
Chris@7 199 }
Chris@7 200
Chris@7 201 sub authen_handler {
Chris@8 202 my $r = shift;
Chris@8 203
Chris@8 204 print STDERR "SoundSoftware.pm: In authentication handler\n";
Chris@7 205
Chris@8 206 my $dbh = connect_database($r);
Chris@8 207
Chris@8 208 my $project_id = get_project_identifier($dbh, $r);
Chris@8 209 my $realm = get_realm($dbh, $project_id, $r);
Chris@8 210 $r->auth_name($realm);
Chris@8 211
Chris@8 212 my ($res, $redmine_pass) = $r->get_basic_auth_pw();
Chris@8 213 unless ($res == OK) {
Chris@8 214 $dbh->disconnect();
Chris@8 215 undef $dbh;
Chris@8 216 return $res;
Chris@8 217 }
Chris@8 218
Chris@8 219 print STDERR "SoundSoftware.pm: User is " . $r->user . ", got password\n";
Chris@8 220
Chris@8 221 my $permitted = is_permitted($dbh, $project_id, $r->user, $redmine_pass, $r);
Chris@8 222
Chris@8 223 $dbh->disconnect();
Chris@8 224 undef $dbh;
Chris@8 225
Chris@8 226 if ($permitted) {
Chris@8 227 return OK;
Chris@8 228 } else {
Chris@8 229 print STDERR "SoundSoftware.pm: Not permitted\n";
Chris@8 230 $r->note_auth_failure();
Chris@8 231 return AUTH_REQUIRED;
Chris@8 232 }
Chris@7 233 }
Chris@7 234
Chris@7 235 sub get_project_status {
Chris@8 236 my $dbh = shift;
Chris@7 237 my $project_id = shift;
Chris@7 238 my $r = shift;
Chris@8 239
Chris@8 240 if (!defined $project_id or $project_id eq '') {
Chris@8 241 return 0; # nonexistent
Chris@8 242 }
Chris@7 243
Chris@7 244 my $sth = $dbh->prepare(
Chris@7 245 "SELECT is_public FROM projects WHERE projects.identifier = ?;"
Chris@7 246 );
Chris@7 247
Chris@7 248 $sth->execute($project_id);
Chris@8 249 my $ret = 0; # nonexistent
Chris@7 250 if (my @row = $sth->fetchrow_array) {
Chris@7 251 if ($row[0] eq "1" || $row[0] eq "t") {
Chris@7 252 $ret = 1; # public
Chris@7 253 } else {
Chris@8 254 $ret = 2; # private
Chris@7 255 }
Chris@7 256 }
Chris@7 257 $sth->finish();
Chris@7 258 undef $sth;
Chris@7 259
Chris@7 260 $ret;
Chris@7 261 }
Chris@7 262
Chris@8 263 sub is_permitted {
Chris@8 264 my $dbh = shift;
Chris@8 265 my $project_id = shift;
Chris@8 266 my $redmine_user = shift;
Chris@8 267 my $redmine_pass = shift;
Chris@8 268 my $r = shift;
Chris@7 269
Chris@8 270 my $pass_digest = Digest::SHA1::sha1_hex($redmine_pass);
Chris@7 271
Chris@8 272 my $cfg = Apache2::Module::get_config
Chris@8 273 (__PACKAGE__, $r->server, $r->per_dir_config);
Chris@7 274
Chris@8 275 my $query = $cfg->{SoundSoftwareQuery};
Chris@8 276 my $sth = $dbh->prepare($query);
Chris@8 277 $sth->execute($redmine_user, $project_id);
Chris@7 278
Chris@8 279 my $ret;
Chris@8 280 while (my ($hashed_password, $auth_source_id, $permissions) = $sth->fetchrow_array) {
Chris@7 281
Chris@8 282 # Test permissions for this user before we verify credentials
Chris@8 283 # -- if the user is not permitted this action anyway, there's
Chris@8 284 # not much point in e.g. contacting the LDAP
Chris@7 285
Chris@8 286 my $method = $r->method;
Chris@7 287
Chris@8 288 if ((defined $read_only_methods{$method} && $permissions =~ /:browse_repository/)
Chris@8 289 || $permissions =~ /:commit_access/) {
Chris@8 290
Chris@8 291 # User would be permitted this action, if their
Chris@8 292 # credentials checked out -- test those now
Chris@8 293
Chris@8 294 print STDERR "SoundSoftware.pm: User $redmine_user has required role, checking credentials\n";
Chris@8 295
Chris@8 296 unless ($auth_source_id) {
Chris@8 297 if ($hashed_password eq $pass_digest) {
Chris@8 298 print STDERR "SoundSoftware.pm: User $redmine_user authenticated via password\n";
Chris@8 299 $ret = 1;
Chris@8 300 last;
Chris@8 301 }
Chris@8 302 } else {
Chris@8 303 my $sthldap = $dbh->prepare(
Chris@8 304 "SELECT host,port,tls,account,account_password,base_dn,attr_login FROM auth_sources WHERE id = ?;"
Chris@8 305 );
Chris@8 306 $sthldap->execute($auth_source_id);
Chris@8 307 while (my @rowldap = $sthldap->fetchrow_array) {
Chris@8 308 my $ldap = Authen::Simple::LDAP->new(
Chris@8 309 host => ($rowldap[2] eq "1" || $rowldap[2] eq "t") ? "ldaps://$rowldap[0]" : $rowldap[0],
Chris@8 310 port => $rowldap[1],
Chris@8 311 basedn => $rowldap[5],
Chris@8 312 binddn => $rowldap[3] ? $rowldap[3] : "",
Chris@8 313 bindpw => $rowldap[4] ? $rowldap[4] : "",
Chris@8 314 filter => "(".$rowldap[6]."=%s)"
Chris@8 315 );
Chris@8 316 if ($ldap->authenticate($redmine_user, $redmine_pass)) {
Chris@8 317 print STDERR "SoundSoftware.pm: User $redmine_user authenticated via LDAP\n";
Chris@8 318 $ret = 1;
Chris@8 319 }
Chris@8 320 }
Chris@8 321 $sthldap->finish();
Chris@8 322 undef $sthldap;
Chris@8 323 }
Chris@8 324 } else {
Chris@8 325 print STDERR "SoundSoftware.pm: User $redmine_user lacks required role for this project\n";
Chris@8 326 }
Chris@7 327 }
Chris@7 328
Chris@8 329 $sth->finish();
Chris@8 330 undef $sth;
Chris@8 331
Chris@8 332 $ret;
Chris@7 333 }
Chris@7 334
Chris@7 335 sub get_project_identifier {
Chris@8 336 my $dbh = shift;
Chris@7 337 my $r = shift;
Chris@7 338
Chris@7 339 my $location = $r->location;
Chris@7 340 my ($repo) = $r->uri =~ m{$location/*([^/]+)};
Chris@10 341
Chris@10 342 return $repo if (!$repo);
Chris@10 343
Chris@7 344 $repo =~ s/[^a-zA-Z0-9\._-]//g;
Chris@7 345
Chris@8 346 # The original Redmine.pm returns the string just calculated as
Chris@8 347 # the project identifier. That won't do for us -- we may have
Chris@8 348 # (and in fact already do have, in our test instance) projects
Chris@8 349 # whose repository names differ from the project identifiers.
Chris@8 350
Chris@8 351 # This is a rather fundamental change because it means that almost
Chris@8 352 # every request needs more than one database query -- which
Chris@8 353 # prompts us to start passing around $dbh instead of connecting
Chris@8 354 # locally within each function as is done in Redmine.pm.
Chris@8 355
Chris@7 356 my $sth = $dbh->prepare(
Chris@7 357 "SELECT projects.identifier FROM projects, repositories WHERE repositories.project_id = projects.id AND repositories.url LIKE ?;"
Chris@7 358 );
Chris@7 359
Chris@8 360 my $cfg = Apache2::Module::get_config
Chris@8 361 (__PACKAGE__, $r->server, $r->per_dir_config);
Chris@8 362
Chris@8 363 my $prefix = $cfg->{SoundSoftwareRepoPrefix};
Chris@8 364 if (!defined $prefix) { $prefix = '%/'; }
Chris@8 365
Chris@7 366 my $identifier = '';
Chris@7 367
Chris@8 368 $sth->execute($prefix . $repo);
Chris@7 369 my $ret = 0;
Chris@7 370 if (my @row = $sth->fetchrow_array) {
Chris@7 371 $identifier = $row[0];
Chris@7 372 }
Chris@7 373 $sth->finish();
Chris@7 374 undef $sth;
Chris@7 375
Chris@8 376 print STDERR "SoundSoftware.pm: Repository '$repo' belongs to project '$identifier'\n";
Chris@7 377
Chris@7 378 $identifier;
Chris@7 379 }
Chris@7 380
Chris@8 381 sub get_realm {
Chris@8 382 my $dbh = shift;
Chris@8 383 my $project_id = shift;
Chris@8 384 my $r = shift;
Chris@8 385
Chris@8 386 my $sth = $dbh->prepare(
Chris@8 387 "SELECT projects.name FROM projects WHERE projects.identifier = ?;"
Chris@8 388 );
Chris@8 389
Chris@8 390 my $name = $project_id;
Chris@8 391
Chris@8 392 $sth->execute($project_id);
Chris@8 393 my $ret = 0;
Chris@8 394 if (my @row = $sth->fetchrow_array) {
Chris@8 395 $name = $row[0];
Chris@8 396 }
Chris@8 397 $sth->finish();
Chris@8 398 undef $sth;
Chris@8 399
Chris@8 400 # be timid about characters not permitted in auth realm and revert
Chris@8 401 # to project identifier if any are found
Chris@8 402 if ($name =~ m/[^\w\d\s\._-]/) {
Chris@8 403 $name = $project_id;
Chris@8 404 }
Chris@8 405
Chris@8 406 my $realm = '"Mercurial repository for ' . "'$name'" . '"';
Chris@8 407
Chris@8 408 $realm;
Chris@8 409 }
Chris@8 410
Chris@7 411 sub connect_database {
Chris@7 412 my $r = shift;
Chris@7 413
Chris@8 414 my $cfg = Apache2::Module::get_config
Chris@8 415 (__PACKAGE__, $r->server, $r->per_dir_config);
Chris@8 416
Chris@8 417 return DBI->connect($cfg->{SoundSoftwareDSN},
Chris@8 418 $cfg->{SoundSoftwareDbUser},
Chris@8 419 $cfg->{SoundSoftwareDbPass});
Chris@7 420 }
Chris@7 421
Chris@7 422 1;