153 lines
4.3 KiB
Perl
153 lines
4.3 KiB
Perl
# Selima Website Content Management System
|
|
# AuthDig.pm: The mod_perl HTTP digest authentication handler.
|
|
|
|
# Copyright (c) 2004-2018 imacat.
|
|
#
|
|
# Licensed under the Apache License, Version 2.0 (the "License");
|
|
# you may not use this file except in compliance with the License.
|
|
# You may obtain a copy of the License at
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
|
|
# Author: imacat <imacat@mail.imacat.idv.tw>
|
|
# First written: 2004-09-12
|
|
|
|
package Selima::AuthDig;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Apache::AuthDigest::API qw();
|
|
use CGI qw();
|
|
use Fcntl qw(:flock);
|
|
use File::Spec::Functions qw(catfile);
|
|
|
|
use Selima::Checker::LogIn;
|
|
use Selima::DataVars qw($AUTHINFO $IS_MP2 :db :input);
|
|
use Selima::DBI;
|
|
use Selima::HTTP;
|
|
use Selima::Init;
|
|
use Selima::LogIn;
|
|
use Selima::Session;
|
|
|
|
BEGIN {
|
|
if ($IS_MP2) {
|
|
require Apache2::Const;
|
|
import Apache2::Const qw(OK AUTH_REQUIRED);
|
|
} else {
|
|
require Apache::Constants;
|
|
import Apache::Constants qw(OK AUTH_REQUIRED);
|
|
}
|
|
}
|
|
|
|
# Full HTTP Digest Authentication is specified in RFC 2617
|
|
|
|
# handler: Handle the HTTP digest authentication
|
|
sub handler {
|
|
local ($_, %_);
|
|
my ($r, $rd, $d, $status, $response, $pkg);
|
|
my ($form, $checker);
|
|
$r = $_[0];
|
|
$rd = Apache::AuthDigest::API->new($r);
|
|
$d = new Selima::AuthDig::Destroy($rd);
|
|
|
|
# Retrieve the authentication information
|
|
($status, $response) = $rd->get_digest_auth_response;
|
|
# No authentication information available
|
|
return $status unless $status == OK;
|
|
|
|
# Initialize the environemnt
|
|
$pkg = $r->dir_config("PACKAGE");
|
|
initvars($pkg);
|
|
|
|
# Logged out
|
|
if ( defined($_ = $GET->param("logout"))
|
|
&& -e ($_ = catfile($Selima::Session::DIR, "logout_$_"))) {
|
|
unlink $_;
|
|
$rd->note_digest_auth_failure;
|
|
return AUTH_REQUIRED;
|
|
}
|
|
|
|
# Connect to the database
|
|
$DBH = Selima::DBI->new($DBI_TYPE);
|
|
%_ = ("users" => LOCK_EX, "groups" => LOCK_SH, "usermem" => LOCK_SH);
|
|
$DBH->lock(%_);
|
|
|
|
# Check the password digest
|
|
$form = new CGI("");
|
|
$form->param("id", $rd->user);
|
|
$checker = new Selima::Checker::LogIn($form);
|
|
$checker->{"rd"} = $rd;
|
|
$checker->{"response"} = $response;
|
|
$checker->{"login"} = 1;
|
|
$_ = $checker->check(qw(id authdig));
|
|
|
|
# Failed
|
|
if (defined $_) {
|
|
$rd->note_digest_auth_failure;
|
|
return AUTH_REQUIRED;
|
|
}
|
|
|
|
# Let $d->DESTROY release the database lock
|
|
# We do not update user information here. Updating user information
|
|
# requires initiating the session and set the session cookie SID.
|
|
# But cookies cannot be set under HTTP 304 Not Modified. We are
|
|
# protecting the whole directory, where there are a lot of static
|
|
# contents, including the Magicat home index.html. HTTP 304 occurs
|
|
# all the time, from the beginning of Magicat home entrance.
|
|
# Failing to set session cookie SID causes new sessions be
|
|
# reinitialited for every request. The user visits accounting
|
|
# would become non-sense. That accounting is important!
|
|
# We update user information at the script executing phrase, where
|
|
# we have more control over the output, including the cookies
|
|
# and the HTTP 304 status.
|
|
$AUTHINFO = $checker->{"row"};
|
|
return OK;
|
|
}
|
|
|
|
# Selima::AuthDig::Destroy: Object to remove program data
|
|
package Selima::AuthDig::Destroy;
|
|
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Selima::DataVars qw($DBH);
|
|
|
|
# new: Initialize the destroyer
|
|
sub new : method {
|
|
local ($_, %_);
|
|
my ($class, $rd, $self);
|
|
($class, $rd) = @_;
|
|
$self = bless {}, $class;
|
|
$self->{"rd"} = $rd;
|
|
return $self;
|
|
}
|
|
|
|
# DESTROY: Release the acquired locks
|
|
sub DESTROY : method {
|
|
local ($_, %_);
|
|
my ($self, $rd, $headers);
|
|
$self = $_[0];
|
|
$rd = $self->{"rd"};
|
|
|
|
# Disconnect database handle
|
|
if (defined $DBH) {
|
|
$DBH->disconnect;
|
|
undef $DBH;
|
|
}
|
|
|
|
# Destroy myself
|
|
$self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
|
|
# I cannot really undefine myself ($_[0]) after all
|
|
return;
|
|
}
|
|
|
|
return 1;
|