Initial commit.

lib/perl5/Selima/AuthDig.pm

@@ -0,0 +1,152 @@
+# 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;