# Selima Website Content Management System
# Init.pm: The script initializer.

#  Copyright (c) 2003-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: 2003-03-23

package Selima::Init;
use 5.008;
use utf8;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(initvars initenv);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub initvars($);
sub initenv(%);
sub check_spambots();
sub block_spam($);
}

use Fcntl qw(:flock);
use File::Basename qw(basename);
use File::Spec::Functions qw(splitpath splitdir catpath catdir catfile);
use IO::NestedCapture qw(CAPTURE_STDOUT);
use POSIX qw(setlocale LC_ALL);
use Sys::Hostname qw(hostname);
use Time::HiRes qw();
use URI qw();
use URI::Escape qw(uri_unescape);

BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
    require Apache2::RequestRec;
}
}

use Selima::Cache qw();
use Selima::CallForm;
use Selima::DataVars qw(:all);
use Selima::DBI;
use Selima::DecForm;
use Selima::FormFunc;
use Selima::HTTP;
use Selima::LastModf;
use Selima::ListPref;
use Selima::LogIn;
use Selima::Logging;
use Selima::ReqURI;
use Selima::ScptPriv;
use Selima::SetL10N;
use Selima::ShortCut;
use Selima::Session;
use Selima::Unauth;

# initvars: Initialize the data variables
sub initvars($) {
    local ($_, %_);
    my ($pkg, $r);
    $pkg = $_[0];
    
    # Only run once for mod_perl
    if ($IS_MODPERL) {
        $r = $IS_MP2? Apache2::RequestUtil->request:
            Apache->request;
        # Bounce if already initialized under mod_perl
        return if defined $r->headers_in->get("X-Selima-Initialized");
        $r->headers_in->set("X-Selima-Initialized", "yes");
        # Clean-up before initialization, only for mod_perl
        Selima::DataVars::clear;
        Selima::Cache::clear;
        # Cear the site data variables
        if (defined $pkg) {
            $_ = "Selima::" . $pkg . "::DataVars";
            &$_ if defined($_ = $_->can("clear"));
        }
    }
    
    # Set the default values of some variables
    # By default we use PostgreSQL, unless changed by site configuration
    $DBI_TYPE = DBI_POSTGRESQL;
    
    # The script path
    %SCRIPTS = (
        FORM_USERS()    => "/magicat/cgi-bin/users.cgi",
        FORM_GROUPS()   => "/magicat/cgi-bin/groups.cgi",
        FORM_USERMEM()  => "/magicat/cgi-bin/usermem.cgi",
        FORM_GROUPMEM() => "/magicat/cgi-bin/groupmem.cgi",
        FORM_USERPREF() => "/magicat/cgi-bin/userpref.cgi",
        FORM_SCPTPRIV() => "/magicat/cgi-bin/scpptpriv.cgi",
        FORM_PIC()      => "/magicat/cgi-bin/pic.cgi",
        FORM_PAGES()    => "/magicat/cgi-bin/pages.cgi",
        FORM_NEWS()     => "/magicat/cgi-bin/news.cgi",
        FORM_LINKCAT()  => "/magicat/cgi-bin/linkcat.cgi",
        FORM_LINKS()    => "/magicat/cgi-bin/links.cgi",
        FORM_ACCTSUBJ() => "/magicat/cgi-bin/acctsubj.cgi",
        FORM_ACCTTRX() => "/magicat/cgi-bin/accttrx.cgi",
    );
    
    $NOLOGIN = 0;
    
    $DEFAULT_LANG = "zh-tw";
    
    $PAGEBAR_RANGE = 2;
    
    IO::NestedCapture->start(CAPTURE_STDOUT);
    binmode IO::NestedCapture->instance->{"STDOUT_current"}[-1], ":utf8";
    $NO_AUTO_OUTPUT = 0;
    
    $LOGTIME = 0;
    $T_START = Time::HiRes::time;
    
    # Load the site and host configuration
    if (defined $pkg) {
        # Load the site configuration
        $_ = "Selima::" . $pkg . "::Config";
        &$_ if defined($_ = $_->can("siteconf"));
        # Load the host-specific configuration
        $_ = "Selima::" . $pkg . "::HostConf";
        &$_ if defined($_ = $_->can("hostconf"));
    # Look for siteconf() and hostconf() imported to the caller
    } else {
        (caller 1)[0]->siteconf if (caller 1)[0]->can("siteconf");
        (caller 1)[0]->hostconf if (caller 1)[0]->can("hostconf");
    }
    
    # Set $0 of the non-CGI scripts
    if (!$IS_CGI) {
        # Deal with the relative path
        require FindBin;
        if ($FindBin::Script ne "-" && $FindBin::Script ne "-e") {
            @_ = splitpath($FindBin::Bin);
            $_[1] = catdir(splitdir($_[1]));
            $_ = catpath(@_);
            $0 = catfile($_, $FindBin::Script);
        }
    }
    
    # Emulate the CGI environment, if not
    if (!$IS_CGI) {
        $ENV{"GATEWAY_INTERFACE"} = "";
        $ENV{"QUERY_STRING"} = "" if !exists $ENV{"QUERY_STRING"};
        $ENV{"REMOTE_ADDR"} = "127.0.0.1" if !exists $ENV{"REMOTE_ADDR"};
        $ENV{"REMOTE_HOST"} = "localhost" if !exists $ENV{"REMOTE_HOST"};
        $ENV{"REQUEST_METHOD"} = "GET" if !exists $ENV{"REQUEST_METHOD"};
        $ENV{"SCRIPT_NAME"} = $0 if !exists $ENV{"SCRIPT_NAME"};
        $ENV{"SERVER_NAME"} = hostname if !exists $ENV{"SERVER_NAME"};
        $ENV{"SERVER_PORT"} = 80 if !exists $ENV{"SERVER_PORT"};
        $ENV{"SERVER_SOFTWARE"} = $^O if !exists $ENV{"SERVER_SOFTWARE"};
    }
    
    # Try to obtain the request information
    init_request_uri;
    # Scan the parameters
    %COOKIES = fetch CGI::Cookie;
    init_forms;
    # Initialize the localization framework (gettext/Maketext)
    # This runs gettext implicitly
    set_l10n;
    decode_forms;
    # Set the path of the this processing form
    $SCRIPTS{FORM_THIS()} = form_this;
    
    return;
}

# initenv: Initialize the script environment
sub initenv(%) {
    local ($_, %_);
    my (%param);
    my ($dbi, $session, $restricted, $lastmod);
    %param = @_;
    
    # Initialize the data variables and cache
    $MAIN = (caller)[0];
    &$_ if defined($_ = $MAIN->can("siteconf"));
    initvars $PACKAGE;
    decode_forms_delay;
    # Load the script configuration
    $THIS_FILE = basename($0);
    # $MAIN was cleaned-up in initvars(), so we need to obtain it again
    $MAIN = (caller)[0];
    &$_ if defined($_ = $MAIN->can("scptconf"));
    
    # Parse the arguments
    $dbi = exists $param{"-dbi"}? $param{"-dbi"}:
        defined $DBI_TYPE? $DBI_TYPE: DBI_NONE;
    $session = exists $param{"-session"}? $param{"-session"}: 1;
    $restricted = exists $param{"-restricted"}? $param{"-restricted"}: 0;
    $lastmod = exists $param{"-lastmod"}? $param{"-lastmod"}: 0;
    # Tag if we should log the processing time
    $LOGTIME = $param{"-logtime"} if exists $param{"-logtime"};
    if (exists $param{"-page_param"}) {
        $PAGE_PARAM = $param{"-page_param"};
        # Maketext now, since we have already set_l10n() in initvars()
        $$PAGE_PARAM{"keywords"} = __($$PAGE_PARAM{"keywords"})
            if exists $$PAGE_PARAM{"keywords"};
    }
    
    # Block FunWebProduct
    # See http://www.networkworld.com/newsletters/web/2003/1208web2.html
    http_403(N_("Sorry, browsers with FunWebProduct plugin (Smiley, PopSwatter, Spin4Dough, My Mail Signature, My Mail Stationery, My Mail Stamp, Cursor Mania, etc.) are are not welcome.  It duplicates your request and produces high load and even crashes to our server.  Please remove it first before you visit us."))
        if  exists $ENV{"HTTP_USER_AGENT"}
            && $ENV{"HTTP_USER_AGENT"} =~ /FunWebProduct/;
    # Block bad-behaved e-mail crawlers
    # Some bad-behaved e-mail crawlers cannot deal with the parent
    #   directory "/.." and ampersands, and attach them to the URI infinitely
    http_400(0) if $REQUEST_PATH =~ /\/\.\./ || $REQUEST_URI =~ /&amp;/;
    # Check the request method
    $_ = exists $param{"-allowed"}? $param{"-allowed"}: [qw(GET HEAD POST)];
    if (defined $_) {
        %_ = map { $_ => 1 } @$_;
        http_405 @$_ if !exists $_{$ENV{"REQUEST_METHOD"}};
    }
    # Check and block the spambots
    check_spambots;
    
    # Start the session
    $SESSION = Selima::Session->init if $session;
    
    # If client has not logged in on restricted area, we can
    #   bypass SQL connection to save our work
    if ($IS_CGI && $restricted) {
        if (exists $INC{"Apache/AuthDigest/API.pm"}) {
            unauth if !defined $AUTHINFO;
        } else {
            unauth if !exists $ENV{"REMOTE_USER"};
        }
    }
    
    # Initialize the database connection
    if ($dbi) {
        $DBH = Selima::DBI->new($dbi) ;
        # Set the current table
        $THIS_TABLE = $param{"-this_table"} if exists $param{"-this_table"};
    }
    
    # Prepare the SQL tables to lock
    if ($dbi && exists $param{"-dbi_lock"}) {
        # Read-only on non-POSTed forms
        if ($ENV{"REQUEST_METHOD"} ne "POST") {
            ${$param{"-dbi_lock"}}{$_} = LOCK_SH
                foreach keys %{$param{"-dbi_lock"}};
        }
        # Supply the default locks
        if (use_users) {
            ${$param{"-dbi_lock"}}{$_} = LOCK_SH
                foreach grep !exists ${$param{"-dbi_lock"}}{$_},
                    (qw(users groups scptpriv userpref),
                        "users AS createdby", "users AS updatedby");
        }
    }
    
    # Check the last modified
    if ($lastmod) {
        my (@tables, @files);
        # Set the database tables to check
        @tables = qw();
        push @tables, @{$param{"-lmtables"}} if exists $param{"-lmtables"};
        # Add the locked tables automatically
        push @tables, keys %{$param{"-dbi_lock"}} if exists $param{"-dbi_lock"};
        # Set the files to check
        @files = qw();
        push @files,  @{$param{"-lmfiles"}} if exists $param{"-lmfiles"};
        http_304 if not_modified @tables, @files;
    }
    
    # Lock the SQL tables
    $DBH->lock(%{$param{"-dbi_lock"}})
        if $dbi && exists $param{"-dbi_lock"};
    
    # Only available on systems with membership turned on
    if ($dbi && use_users && $session) {
        # Update the log-in information
        if (exists $INC{"Apache/AuthDigest/API.pm"}) {
            upd_login_info if defined $AUTHINFO;
        } else {
            upd_login_info if exists $ENV{"REMOTE_USER"};
            upd_login_info if !$IS_CGI;
        }
        # Check the client permission
        unauth if $restricted && !is_script_permitted;
    }
    
    # Process the list preference form
    if (form_type eq "listpref") {
        my $domain;
        if (    defined($domain = $POST->param("domain"))
                && $domain->can("new")) {
            $_ = $domain->new;
            $_->set_listpref;
        } else {
            $_ = new Selima::ListPref($POST);
            $_->main;
        }
    }
    
    return;
}

# check_spambots: Check and block spam bots
# This starts at an earlier phrase before the database initialization,
# to decrease the server load.
sub check_spambots() {
    local ($_, %_);
    my ($r, $method, $col);
    if ($IS_MODPERL) {
        $r = $IS_MP2? Apache2::RequestUtil->request:
            Apache->request;
        $method = $r->method;
    } else {
        $method = $ENV{"REQUEST_METHOD"};
    }
    $col = FORM_CAPTCHA;
    # Block the spam for POST forms
    if ($method eq "POST" && defined $POST->param($col)) {
        block_spam "check_spambots: captcha column \"$col\" should be empty but got \""
                . $POST->param($col) . "\"."
            if $POST->param($col) ne "";
    }
}

# block_spam: Block the spam message
sub block_spam($) {
    local ($_, %_);
    $_ = $_[0];
    spamlog $_;
    # Delay the spammer
    sleep 300;
    http_403(0);
    # No return
}

no utf8;
return 1;