#=============================================================================
# General Doloforge Mason service setup. This Perl script creates all needed
# stuff for Doloforge Perl/Mason back-end Apache server.
# This script is designed from HTML::Mason::Admin man page and samples.
#
# It must be linked from apache-perl config directory, as explained in
# /etc/doloforge/apache-perl.conf (which PerlRequire's this script)
#
# Testing this script can be done using:
#   apache-perlctl configtest
#=============================================================================


#=============================================================================
# Package name referenced in VirtualHost snippets, as in:
#   <LocationMatch "\.(phtml|mason|md|mc)$">
#       SetHandler  perl-script
#       PerlHandler Doloforge::Mason
#       DefaultType text/html
#   </LocationMatch>
#
package Doloforge::Mason;

use strict;

# Apache modules
use Apache::Status;
# Mason-related packages
use HTML::Mason;                # Main Mason package
#use Apache::Request;            # ApacheHandler and it's dependencies, necessary for mod_perl integration
#use Apache::Leak;               # 20090204/NH : Module for tracking memory leaks in mod_perl code / look in error_log for results
use CGI;
use HTML::Mason::ApacheHandler;
# HTML::Mason uses Exception::Class, which does not fit correctly with Error::Simple's syntactic sugar...
# From man Exception::Class :
# OTHER EXCEPTION MODULES (try/catch syntax)
#   If you are interested in adding try/catch/finally syntactic sugar to
#   your code then I recommend you check out U. Arun Kumar's "Error.pm"
#   module, which implements this syntax.  It also includes its own base
#   exception class, "Error::Simple".
#   If you would prefer to use the "Exception::Class::Base" class included
#   with this module, you'll have to add this to your code somewhere:
push (@Exception::Class::Base::ISA, 'Error::Simple')
    unless Exception::Class::Base->isa('Error::Simple');

# Doloforge-related packages
use Config::YAML;               # Main doloforge configuration file parser (/etc/doloforge/doloforge.yaml)
use Sys::Hostname;
use File::Path;

use MIME::QuotedPrint;


#=============================================================================
# Read full Doloforge config file and setup the running environment
my $doloforge = Config::YAML->new(config => '/etc/doloforge/doloforge.yaml');

# Read the include'd files defined in the main configuration under the "include:" array key
foreach my $file (@{$doloforge->{include}}) {
    # Read the file in a new hash object
    my $include = Config::YAML->new(config => "$doloforge->{dir}->{conf}/$file");

    # The included configuration keys take precedence over all previously defined configuration keys.
    # Ignore the Config::YAML system specific keys (starting with "_" : "_infile", "_outfile", etc.)
    map {$doloforge->{$_} = $include->{$_} unless ($_ =~ m/^_/)} keys(%$include);
}

# A little hack in the configuration : "host:" is set with the hostname,
# if not already set in the config file. This allows to set a fake hostname
# for testing purposes.
# hostname is exported by Sys::Hostname
$doloforge->{host} = hostname unless (exists($doloforge->{host}));

# Use cluster:[hostname]:stages and get an array of stages the host is involved in.
# While the config format allow for multiple stages per host, implementation
# details at the daemon level are picky, and practically leaves room for one
# stage per host only.
# Practically, we choose here the first stage declared in the configuration...
$doloforge->{stage} = $doloforge->{cluster}->{$doloforge->{host}}->{stages}->[0]
    unless (exists($doloforge->{stage}));


#=============================================================================
# Include path for client-related packages.
# FIXME get shared libs from the /srv/d/shared/client/lib/perl5 dirs...
#use lib '/home/ghs/_conf/perl';
# Require'd packages will be loaded from dynamically configured lib dir
#   ln -s /srv/doloforge/shared/edition/lib/perl5/[A-Z]* /etc/doloforge/lib/perl5
#   ln -s /srv/doloforge/shared/edition/lib/perl5/auto/[A-Z]* /etc/doloforge/lib/perl5/auto
# "use lib" won't work, since it's evaluated at compile-time, when $doloforge is undefined
use lib "/etc/doloforge/lib/perl";
#push(@INC, "$doloforge->{dir}->{conf}/lib/perl5");
#use lib "$doloforge->{dir}->{conf}/lib/perl5";
# FIXME : mettre tout ça dans /e/d/l/perl5/Apache-perl/Mason.pm et le charger
#   de manière à régler l'aspect runtime de "$doloforge->{dir}->{conf}/lib/perl5" et compile-time des use qui suivent...
#   voir si ça a un effet sur le chargement en mémoire partagée
#   http://www.unix.org.ua/orelly/perl/prog4/ch31_13.htm


#=============================================================================
# This is the package HTML::Mason components will run inside: load any modules
# here. These modules are loaded once for all, and share memory between Apache
# children processes. No need to reload them in each component or script...
# FIXME : store this (or GHS:: Edition::) in /srv/doloforge/shared/lpsystem/lib/ ?
#
{
    package HTML::Mason::Commands;

    # Variables globales.
    # "use vars" in order to have those variables imported in component execution scope.
    # "my" won't do it automagically.
    use vars qw(%session $dbh $app);

    # Deux modules nécessaires à la gestion des sessions.
    # L'initialisation se fait plus bas.
    use CGI; # Pour les upload de fichiers
    use CGI::Util qw(expires);
    use CGI::Cookie;
    $CGI::POST_MAX = 1024 * 1024;
    use Apache::Session::File;

    # Pour accéder aux bases de données/fichier plats SQL
    use Apache::DBI;
    #$Apache::DBI::DEBUG = 2;
    use DBD::Pg;
    use DBD::AnyData;

    use Apache::AuthDBI;
    Apache::AuthDBI->setCacheTime(180);
    Apache::AuthDBI->setCleanupTime(180);
    Apache::AuthDBI->initIPC(50000);
    #$Apache::AuthDBI::DEBUG = 2;

    use GHS::AuthDBI;
    GHS::AuthDBI->setCacheTime(180);
    GHS::AuthDBI->setCleanupTime(180);
    GHS::AuthDBI->initIPC(25000);
    #$GHS::AuthDBI::DEBUG = 2;

    # Le serveur d'application GHS et la gestion d'erreurs
#    use Error;
    use Error qw(:try);
    $Error::Debug = 1;
    use GHS::AppServ;
    use GHS::AppObj;
    use GHS::Mailer;
    use GHS::Panier;

    # Divers use standards chargés usuellement.
    use Data::Dumper;

    use POSIX;
    use File::Path;
    use File::Temp qw(tempfile tempdir);
    use IPC::Open2;
    use Search::OpenFTS::Index;
    use GHS::FTS::OpenFTS;

    use HTTP::Headers;
    use HTTP::Request;
    use HTTP::Response;
    use LWP::UserAgent;
    use MIME::QuotedPrint;

    use IO::Scalar;
    use Spreadsheet::WriteExcel;

    # FIXME : import all symbols from each module
    use Unicode::String qw(utf8 latin1 utf16);
}


#=============================================================================
# Escape functions
#
my %html_escape = ('&' => '&amp;', '>'=>'&gt;', '<'=>'&lt;', '"'=>'&quot;', "\n" => '<br>', "\r" => '');
my $html_escape = qr/([&<>"\n\r])/;
sub basic_html_escape_with_para
{
    return unless defined ${ $_[0] };
    ${ $_[0] } =~ s/$html_escape/$html_escape{$1}/mg;
}

sub javascript_escape
{
    return unless defined ${ $_[0] };
    # Encapsule le code HTML généré par le composant dans des instructions JavaScript
    ${ $_[0] } =~ s/\\/\\\\/go;             # Echappe les \ du texte HTML pour que le JS les laisse tels quels
    ${ $_[0] } =~ s/'/\\'/go;               # Echappe les ' du texte HTML pour ne pas clasher avec les ' encadrant les chaînes JS
    ${ $_[0] } =~ s/<\//<'+'\//go;          # Remplace les </ par une concaténation de chaînes JS, afin que les </script> éventuels ne soient pas considérés comme la fin de ce script-ci
    ${ $_[0] } =~ s/\r\n/'+"\\r\\n"+'/go;   # Remplace les \r\n par une concaténation de chaine pour que ces derniers apparaissent dans le code js
    ${ $_[0] } =~ s/\r/'+"\\r"+'/go;        # idem pour les \r...
    ${ $_[0] } =~ s/\n/'+"\\n"+'/go;        # ...et pour les \n seuls...
}

sub rich_text_escape
{
    return unless defined ${ $_[0] };
    # Encode le texte en HTML enrichi : les escapes HTML normaux sont appliqués, avec en plus des encodages *gras*, /ital/, etc.
    # FIXME : cf. libtext-wiki*-perl
    ${ $_[0] } =~ s/([<>&\n])/$html_escape{$1}/mgoe;
    ${ $_[0] } =~ s/( |^)\*(\S.*?\S)\*($|\W)/$1<b>$2<\/b>$3/mgo;   # Traitement des *gras*
    ${ $_[0] } =~ s/( |^)\/(\S.*?\S)\/($|\W)/$1<i>$2<\/i>$3/mgo;   # Traitement des /ital/
    ${ $_[0] } =~ s/( |^)\_(\S.*?\S)\_($|\W)/$1<u>$2<\/u>$3/mgo;   # Traitement des _souligné_
    ${ $_[0] } =~ s/( |^)(http:\/\/[\w|\.|\?|\=|\%|\/|\-]+)(\/|\w)($|\b| |\.)/$1<a href\=\"$2$3\">$2$3<\/a>$4/mgo;   # Crée un bon <a href> autour des liens http://...
    ${ $_[0] } =~ s/( |^)(mailto:)([\w|\.|\_|\-|\@]+)(\w)($|\b| |\.)/$1<a href\=\"$2$3$4\">$3$4<\/a>$5/mgo;          # Crée un bon <a href> autour des liens mailto://...
    ${ $_[0] } =~ s/\[\[([^<>\[\]]+?)\]\]/<$1>/mgo;                # Remplace les [[tag]] pas des <tag> HTML (tag ne doit pas contenir de [, ], <, >)
}

sub url_escape
{
    return unless defined ${ $_[0] };
    use bytes;
    ${ $_[0] } =~ s/([^a-zA-Z0-9 _.,:-])/uc sprintf("%%%02x",ord($1))/eg;
    ${ $_[0] } =~ s/ /+/g;
}

sub quotedprintable_escape
{
    return unless defined ${ $_[0] };
    ${ $_[0] } = substr(encode_qp(${ $_[0] }), 0, -2);
}

# FIXME : add quoted-printable, etc.


#=============================================================================
# Create Mason objects
#
#my $ah_prod = new HTML::Mason::ApacheHandler (
#    comp_root => '/home/mason/components',
#    data_dir => '/home/mason/data',
##    args_method => 'mod_perl',
#    args_method => 'CGI',
##    use_data_cache => 1,
#    data_cache_api => '1.0',
#    code_cache_max_size => 20*1024*1024, # Default = 10MB
#    error_mode => 'fatal',
#    escape_flags => {
#        h => \&HTML::Mason::Escapes::basic_html_escape, # h - html escape (basic 1.0x version)
#        p => \&basic_html_escape_with_para,             # p - html + \n escape
#        j => \&javascript_escape,                       # j - javascript escape (in the context of a '' string)
#        r => \&rich_text_escape,                        # r - rich-text escape (*bold*, /ital/, etc.)
#        },
#    );

# FIXME : if needed, create many $ah (in a hash) and select the right one at each request, based on project conf (PerlSetVar)
my $ah_devl = new HTML::Mason::ApacheHandler (
    comp_root => "$doloforge->{dir}->{shared}/.doloforge/mason/components",
    data_dir => "$doloforge->{dir}->{local}/.doloforge/mason/data",
#    args_method => 'mod_perl',
    args_method => 'CGI',
    data_cache_defaults => {
        # Mason caching behaviour is similar to Apache front-end caching (cf. skel/template/apache_httpd.conf.tmpl)
        cache_class => 'NullCache',
    },
    data_cache_api => '1.0',
    #code_cache_max_size => 20*1024*1024, # Default = unlimited
    # Error reporting is similar to Apache ErrordDocument handling (cf. skel/template/apache_httpd.conf.tmpl)
    error_mode => 'output',
    escape_flags => {
        h => \&HTML::Mason::Escapes::basic_html_escape, # h - html escape (basic 1.0x version)
        p => \&basic_html_escape_with_para,             # p - html + \n escape
        j => \&javascript_escape,                       # j - javascript escape (in the context of a '' string)
        r => \&rich_text_escape,                        # r - rich-text escape (*bold*, /ital/, etc.)
        u => \&url_escape,                              # u - replaces some characters with the URL-escaped equivalent, a percent sign (%) followed by the hexadecimal number, replaces space with '+'
        q => \&quotedprintable_escape,                  # q - quoted-printable escape, without \r\n at the end
    },
);

my $ah_prod = new HTML::Mason::ApacheHandler (
    comp_root => "$doloforge->{dir}->{shared}/.doloforge/mason/components",
    data_dir => "$doloforge->{dir}->{local}/.doloforge/mason/data",
    args_method => 'CGI',
    data_cache_defaults => {
        cache_class => 'FileCache',
    },
    data_cache_api => '1.0',
    error_mode => 'fatal',
    escape_flags => {
        h => \&HTML::Mason::Escapes::basic_html_escape, # h - html escape (basic 1.0x version)
        p => \&basic_html_escape_with_para,             # p - html + \n escape
        j => \&javascript_escape,                       # j - javascript escape (in the context of a '' string)
        r => \&rich_text_escape,                        # r - rich-text escape (*bold*, /ital/, etc.)
        u => \&url_escape,                              # u - replaces some characters with the URL-escaped equivalent, a percent sign (%) followed by the hexadecimal number, replaces space with '+'
        q => \&quotedprintable_escape,                  # q - quoted-printable escape, without \r\n at the end
    },
);


# Locate and create sessions and locks directories from the Doloforge configuration
my $sessions_dir = "$doloforge->{dir}->{shared}/.doloforge/mason/sessions";
my $sessions_lck = "$doloforge->{dir}->{local}/.doloforge/mason/sessions-lock";
# FIXME : mkdir /srv/doloforge/shared/.doloforge/mason/sessions: Permission denied / rootsquash !!!
mkpath $sessions_dir unless (-e $sessions_dir);
mkpath $sessions_lck unless (-e $sessions_lck);

# Activate the following if running httpd as root (the normal case).
# Resets ownership of all files created by Mason at startup.
chown (Apache->server->uid, Apache->server->gid, $ah_devl->interp()->files_written, $ah_prod->interp()->files_written, $sessions_dir, $sessions_lck);

# For group-writable files even when uploaded by apache-perl
# 20100603/NH : files are uploaded or created via Apache, thus from "the entire world", world-writable files make then sense.
#   We create an apache-perl writable directory by setting mode o+w (world-writable), making logical the subsenquent world-writable sub-dirs and files.
#umask 0002;
umask 0000;

# Cleanup environment inherited from the starting shell, for all critical variables
# used below.
delete $ENV{DBI_DSN};


#=============================================================================
# PerlInitHandler
# Use this to create the DBI_DSN env var for use by
# every handler (for Apache::AuthDBI to work).
#
sub init {
    my ($r) = @_;

    # 20070817/NH : ajout pour que le nom de la base et du répertoire spécifique ne soient pas "devinés" par le code des composants...
    # Ce code est identique à ce qui se trouve ci-dessous, et correspond à edition/admin/conf/mason_postgres7_httpd.conf.tmpl
    if (my $dbname = $r->dir_config("dbname")) {
        $dbname =~ s/(\{[^\}]+\})/eval($1)/eg;
        $r->dir_config->set("dbname", $dbname);
    }

    if (my $dsn = $r->dir_config("DBIDataSource")) {
# FIXME : translate
        # Le DSN trouvé dans le fichier de conf peut contenir des couples {}
        # contenant des expressions Perl évaluées. On peut par exemple placer
        #   PerlSetVar DBIDataSource "DBI:Pg:dbname={ $r->hostname =~ /^([^.]+)/; $1 };host=db-server"
        # Cette expression va utiliser $r->hostname (de la forme
        # vininfos.admin-edition.be) pour en extraire la première partie et
        # l'utiliser comme nom de base de données (ici vininfos).
        # Ceci n'est valable que son on ajoute le PerlInitHandler qui
        # utilise cette fonction, de manière à protéger les sites normaux.
        $dsn =~ s/(\{[^\}]+\})/eval($1)/eg;
        $ENV{'DBI_DSN'} = $dsn;
    }

    return 0; # Apache::Constants::OK
}

#=============================================================================
# PerlHandler
# This is the fonction that is called by Apache to process
# the current request.
#
sub handler
{
    my ($r) = @_;

    my ($status);

    undef $HTML::Mason::Commands::dbh;
    # The my variable is NOT between parens in order to evaluate the
    # affectation in scalar context, that returns the affected value...
    if (my $dsn = $ENV{'DBI_DSN'} || $r->dir_config("DBIDataSource")) {
        $HTML::Mason::Commands::dbh = DBI->connect(
                $dsn,
                undef, # username
                undef, # password
                {
                  RaiseError => 1,
                  AutoCommit => 0,
                })
            or die("DBI connect error with [$dsn] : $DBI::errstr", $r->uri);
        # Start with a rollback to ignore all previous requests (... and reset 'now()')
        $HTML::Mason::Commands::dbh->rollback();
    }

    # Use the X-Forwarded-For header to identify the real client IP
    # instead of the front-end's IP... Only get the last IP, which is
    # set by the front-end Apache server, since every other may be
    # spoofed (each proxy adds the forwarded IP as ", xxx.yyy.zzz.ttt")
    # We force evaluation of the =~ operator in list context to retrieve
    # the value of $1 instead of the number of matches when =~ is in scalar
    # context... This is why the my variable is between parens...
    # In the HTTPS pre-front-end case, the last IP is 127.0.0.1 (apache-ssl),
    # we then need the previous IP address.
    #   'X-Forwarded-For' => '85.241.170.24, 127.0.0.1'
    if (my ($ip) = ($r->header_in('X-Forwarded-For') =~ /(\d+(\.\d+){3})(, 127(\.\d+){3})*$/)) {
        $r->connection->remote_ip($ip);
    }

    # Identify the session key, sent by the browser in a cookie
    my %cookies = parse CGI::Cookie($r->header_in('Cookie'));
    my $cookie = ($cookies{'DSID'} && $cookies{'DSID'}->value());

    # Expires values are set from MasonSessionCookieExpires :
    #   default : '+12h'
    #   allowed values from CGI::Cookie, ie. : '+15m'
    #   keep cookie in memory : 'memory'
    #   do not use cookies at all : 'no_session'
    # The my variable is NOT between parens in order to evaluate the
    # affectation in scalar context, that returns the affected value...
    my $expires = $r->dir_config('MasonSessionCookieExpires') || '+12h';

    # Try hard (but not loop forever) to create a tied session from the cookie,
    # but only if the cookie sent is not "no_session", in which case we don't
    # tie the session hash, and don't send back a new cookie.
    # The {{}} is for redo to work : it's bound to a loop, but do isn't a loop
    # From man perlsyn :
    #    the loop control statements described later will NOT work
    #    in this construct, because modifiers don't take loop
    #    labels.  Sorry.  You can always put another block inside
    #    of it (for "next") or around it (for "last") to do that
    #    sort of thing.  For "next", just double the braces:
    #    
    #       do {{
    #           next if $x == $y;
    #           # do something here
    #       }} until $x++ > $z;
    do {{
        eval {
            tie (%HTML::Mason::Commands::session,
                 'Apache::Session::File',
                 $cookie,
                 {
                   'Directory' => $sessions_dir,
                   'LockDirectory' => $sessions_lck,
                   'Transaction' => 1,
                 });
        };
        # If there is an error, whatever it is, log and redo once
        if ($@) {
            # This kind of error is effectively triggered by proxies and
            # so on, so we don't really log them.
            # Really interesting errors is when a browser loses it's
            # session ID and we create a new one. This event is seen in
            # the access_log, when session ID changes. There is no other
            # way to log it.
            #$r->log_error('tie \%HTML::Mason::Commands::session, DSID=' . (defined($cookie) ? "'$cookie'" : '(undef)') . " : $@");

            # Undefine $cookie and redo if it was not already undefined : redo once
            if ($cookie) {
                undef($cookie);
                redo;
            }
        }
    # FIXME : remove some, update others, to allow cron scripts to automate more things (+ checklinks with session)
    }} if (($expires ne 'no_session') and ($cookie ne 'no_session') and (defined($cookie) or ($ENV{'HTTP_USER_AGENT'} !~ m/(spider|crawl|bot|slurp|scooter|seek|publish|pompos|archiver|track|urllib|perl|wget|facebookexternalhit)/i)));

    # If there is a real tied session with it's _session_id, we can send back the cookie
    if ($HTML::Mason::Commands::session{'_session_id'}) {
        $HTML::Mason::Commands::session{'_count'}++;
        $HTML::Mason::Commands::session{'_ip'} = $r->connection->remote_ip();
        # If this is a newly created session, add some easy debugging info in it
        unless (exists($HTML::Mason::Commands::session{'_created'})) {
            $HTML::Mason::Commands::session{'_created'} = scalar(localtime);    # identify long-lasting sessions
            $HTML::Mason::Commands::session{'_hostname'} = $r->hostname();      # easily identify the project
        }

        # X-Forwarded-Host may contain the port number, if the site is accessed thru a tunnel (ssh -N devl.doloforge.net -L 8080:localhost:80 /  http://sandbox.internal.local.doloforge.com:8080/index.phtml)
        # In that case, the client complains about "Cookie coming from sandbox.internal.local.doloforge.com attempted to set domain to sandbox.internal.local.doloforge.com:8080"
        # FIXME : may contain a list of forwards (apache-ssl) : 'X-Forwarded-Host' => 'sandbox.internal.secure.doloforge.com, sandbox.internal.local.doloforge.net'
        #my $domain = $r->header_in('X-Forwarded-Host');
        #$domain =~ s/:\d+$//;

        # The cookie is resent on each request in order to replace its expiration date...
        $cookie = new CGI::Cookie(
                -name => 'DSID',
                -value => $HTML::Mason::Commands::session{'_session_id'},
                #-domain => $domain,
                -path => '/'
                );
        $cookie->expires($expires) unless ($expires eq 'memory');

        # On place le cookie même en cas d'erreur (redirect, etc)
        $r->err_header_out('Set-Cookie' => $cookie);
    }

    # Create the Application Server Object GHS::AppServ
    $HTML::Mason::Commands::app = new GHS::AppServ(\%HTML::Mason::Commands::session, $HTML::Mason::Commands::dbh);

    eval {
        # In order to avoid executions warnings, but inside components only
        no warnings;

        # If MasonDevlMode is set in the _conf/mason_httpd.conf file, then we're in development mode, ie. errors are output to the browser, there is no Mason cache, no ErrorDocument, etc.
        #$status = $ah->handle_request($r);
        if ($r->dir_config("MasonDevlMode")) {
            $status = $ah_devl->handle_request($r);
        } else {
            $status = $ah_prod->handle_request($r);
        }
    };
    if ($@) {
        $r->log_error($@);
    }

    # Log the login of the user in the Apache log.
    # Application may set '_login' session key to the actual name to magically populate the log file.
    $r->connection->user( $HTML::Mason::Commands::session{'_login'} ) if ($HTML::Mason::Commands::session{'_session_id'} && $HTML::Mason::Commands::session{'_login'});

    untie %HTML::Mason::Commands::session; # Save the session contents to persistent storage
    undef %HTML::Mason::Commands::session; # Forget the value in memory (may help reduce memory leak)
    $HTML::Mason::Commands::dbh->disconnect if ($HTML::Mason::Commands::dbh);

    return $status;
}



1;

#=============================================================================
__END__
