# 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;