260 lines
8.5 KiB
Perl
260 lines
8.5 KiB
Perl
# Selima Website Content Management System
|
|
# Session.pm: The custom session 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-10-03
|
|
|
|
package Selima::Session;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
BEGIN {
|
|
sub sorter($);
|
|
}
|
|
|
|
use CGI::Cookie qw();
|
|
use Data::Dumper qw();
|
|
use Digest::MD5 qw(md5_hex);
|
|
use Fcntl qw(:flock :seek);
|
|
use File::Spec::Functions qw(catfile tmpdir);
|
|
use IO::File; # To use IO::Handle->flush
|
|
|
|
BEGIN {
|
|
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
|
|
require Apache2::Connection;
|
|
}
|
|
}
|
|
|
|
use Selima::DataVars qw(:env :input :output :proctime);
|
|
use Selima::FormFunc;
|
|
use Selima::HTTP;
|
|
use Selima::Logging;
|
|
|
|
use vars qw($DIR $NAME $META_SESSION);
|
|
use constant DEFAULT_DIR => "/dev/shm/cgi";
|
|
$DIR = DEFAULT_DIR;
|
|
if (!-e $DIR) {
|
|
mkdir $DIR or http_500 "$DIR: $!";
|
|
chmod 0700, $DIR or http_500 "$DIR: $!";
|
|
} elsif (!(-d $DIR && -w $DIR)) {
|
|
$DIR = $ENV{"HOME"} . "/tmp";
|
|
$DIR = tmpdir if !(-d $DIR && -w $DIR);
|
|
}
|
|
$NAME = "SID";
|
|
|
|
# This is much simpler than CGI::Session and Apache::Session
|
|
# And the most important, it is working, but they are not. :p
|
|
# CGI::Session use several storage engines. Session data
|
|
# are not locked throughout the session, but only on
|
|
# initialization, flush and close, in order to meet different
|
|
# capability on different storage engine.
|
|
# Apache::Session creates a seperate session lock file in order
|
|
# to meet different capability of different storage engine.
|
|
# This is doomed to fail. :p
|
|
# I'm not using different storage engine. That's not useful to
|
|
# me at all. Besides, using Data::Dumper make things very
|
|
# easy, easier than working around the problems of them.
|
|
# It is easier to work on myself.
|
|
# I am not using Apache mod_perl memory to store the session data
|
|
# anymore. Using share memory file system /dev/shm to store
|
|
# the session data if needed, to get rid of disk I/O overhead.
|
|
# Having multiple copies of session data in memory, in Apache
|
|
# and /dev/shm, is non-sense. It is a nightmare to decide the
|
|
# one to use and synchronize the other, too.
|
|
|
|
# import: Set the session directory
|
|
sub import : method { $DIR = $_[1] if defined $_[1]; };
|
|
|
|
# init: Initialize the session
|
|
sub init : method {
|
|
local ($_, %_);
|
|
my ($class, $DH, $id, $is_old, $file, $remote);
|
|
my ($newcookie, $origumask, $FH, $meta);
|
|
$class = $_[0];
|
|
|
|
# Do not initialize twice
|
|
return $$META_SESSION{"data"} if defined $META_SESSION;
|
|
|
|
# Expire old sessions from disk
|
|
if ($DIR eq DEFAULT_DIR) {
|
|
opendir $DH, $DIR or http_500 "$DIR: $!";
|
|
while (defined($_ = readdir $DH)) {
|
|
next if /^\./;
|
|
$file = catfile($DIR, $_);
|
|
next unless -f $file;
|
|
next if $T_START - (stat $file)[8] < 9000;
|
|
unlink $file;
|
|
}
|
|
closedir $DH or http_500 "$DIR: $!";
|
|
}
|
|
|
|
# Get the remote IP
|
|
$remote = $IS_MODPERL? ($IS_MP2?
|
|
Apache2::RequestUtil->request->connection->remote_ip:
|
|
Apache->request->connection->remote_ip):
|
|
$ENV{"REMOTE_ADDR"};
|
|
|
|
# Obtain the session ID
|
|
$is_old = 0;
|
|
$_ = get_or_post;
|
|
$id = defined $_->param($NAME)? $_->param($NAME):
|
|
exists $COOKIES{$NAME}? $COOKIES{$NAME}->value: undef;
|
|
if (defined $id) {
|
|
$file = catfile($DIR, "sess_" . $id);
|
|
# Get the session from the disk file, mod_perl or not.
|
|
# Store on share memory file system /dev/shm to get rid
|
|
# of disk I/O instead.
|
|
if (-e $file) {
|
|
open $FH, "+<$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
read $FH, $_, (stat $file)[7] or http_500 "$file: $!";
|
|
$META_SESSION = eval $_;
|
|
# Not from the same host -- reject it
|
|
if ($$META_SESSION{"remote"} ne $remote) {
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
$FH->close or http_500 "$file: $!";
|
|
undef $FH;
|
|
undef $META_SESSION;
|
|
undef $id;
|
|
} else {
|
|
$$META_SESSION{"mtime"} = (stat $file)[9];
|
|
$$META_SESSION{"atime"} = time;
|
|
$$META_SESSION{"fh"} = $FH;
|
|
${$$META_SESSION{"data"}}{".meta"} = $META_SESSION;
|
|
$$META_SESSION{"dump"} = $$META_SESSION{"data"}->dump;
|
|
$is_old = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Create a new session
|
|
if (!$is_old) {
|
|
# Generate a new session ID
|
|
if (!defined $id) {
|
|
do {
|
|
$_ = "";
|
|
$_ .= chr int rand 256 while length $_ < 32;
|
|
$id = md5_hex($_);
|
|
$file = catfile($DIR, "sess_" . $id);
|
|
} until !-e $file;
|
|
}
|
|
$META_SESSION = {
|
|
"mtime" => time,
|
|
"atime" => time,
|
|
"id" => $id,
|
|
"name" => $NAME,
|
|
"remote" => $remote,
|
|
"data" => bless({}, $class),
|
|
"file" => $file,
|
|
};
|
|
# Self-referring, so that we can find ourself later.
|
|
${$$META_SESSION{"data"}}{".meta"} = $META_SESSION;
|
|
# Create the session file
|
|
$origumask = umask 0077;
|
|
open $FH, "+>$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
umask $origumask;
|
|
$$META_SESSION{"fh"} = $FH;
|
|
# Dump the session
|
|
$_ = $$META_SESSION{"data"}->dump;
|
|
$$META_SESSION{"dump"} = $_;
|
|
print $FH $_ or http_500 "$file: $!";
|
|
$FH->flush or http_500 "$file: $!";
|
|
}
|
|
|
|
# Set the cookie
|
|
if (!exists $COOKIES{$NAME} || $COOKIES{$NAME}->value ne $id) {
|
|
$newcookie = new CGI::Cookie(-name=>$NAME, -value=>$id);
|
|
$COOKIES{$NAME} = $newcookie;
|
|
$NEWCOOKIES{$NAME} = $newcookie;
|
|
}
|
|
|
|
return $$META_SESSION{"data"};
|
|
}
|
|
|
|
# sorter: Dump the session
|
|
sub sorter($) {
|
|
local ($_, %_);
|
|
%_ = map { $_ => 1 } keys %{$_[0]};
|
|
delete $_{"mtime"};
|
|
delete $_{"atime"};
|
|
delete $_{"fh"};
|
|
delete $_{"dump"};
|
|
return [sort keys %_];
|
|
}
|
|
|
|
# dump: Dump the session
|
|
sub dump : method {
|
|
local ($_, %_);
|
|
my ($self, $meta, $dumper);
|
|
$self = $_[0];
|
|
$meta = $$self{".meta"};
|
|
# Clone the meta-session
|
|
$dumper = new Data::Dumper([$meta], [qw($_)]);
|
|
$dumper->Indent(1);
|
|
$dumper->Sortkeys(\&sorter);
|
|
return $dumper->Dump;
|
|
}
|
|
|
|
# flush: Flush the session data to the hard disk
|
|
sub flush : method {
|
|
local ($_, %_);
|
|
my ($self, $meta, $FH);
|
|
$self = $_[0];
|
|
$meta = $$self{".meta"};
|
|
# Return if session content not updated
|
|
return if ($_ = $self->dump) eq $$meta{"dump"};
|
|
$$meta{"dump"} = $_;
|
|
# Update the mtime
|
|
$$meta{"mtime"} = time;
|
|
# Output and flush the data
|
|
$FH = $$meta{"fh"};
|
|
seek $FH, 0, SEEK_SET or http_500 $$meta{"file"} . ": $!";
|
|
truncate $FH, 0 or http_500 $$meta{"file"} . ": $!";
|
|
print $FH $$meta{"dump"} or http_500 $$meta{"file"} . ": $!";
|
|
$FH->flush or http_500 $$meta{"file"} . ": $!";
|
|
return;
|
|
}
|
|
|
|
# close: Close the session
|
|
sub close : method {
|
|
local ($_, %_);
|
|
my ($self, $meta, $FH);
|
|
# Only close for once
|
|
return unless defined $META_SESSION;
|
|
$self = $_[0];
|
|
$meta = $$self{".meta"};
|
|
# Flush the session data
|
|
$self->flush;
|
|
# Close the data file
|
|
$FH = $$meta{"fh"};
|
|
flock $FH, LOCK_UN or http_500 $$meta{"file"} . ": $!";
|
|
$FH->close or http_500 $$meta{"file"} . ": $!";
|
|
# Undefine the session variables
|
|
# This is not DESTROY. $META_SESSION will not be cleaned automatically.
|
|
undef $META_SESSION;
|
|
return;
|
|
}
|
|
|
|
# DESTROY: Flush and close the session before everything ends
|
|
sub DESTROY : method {
|
|
$_[0]->close;
|
|
$_[0]->SUPER::DESTROY if $_[0]->can("SUPER::DESTROY");
|
|
}
|
|
|
|
return 1;
|