package Lemonldap::NG::Handler::Main::Reload;

use strict;
use Lemonldap::NG::Common::Conf::Constants;    #inherits
use Lemonldap::NG::Common::Crypto;
use Lemonldap::NG::Common::Safelib;            #link protected safe Safe object
use Lemonldap::NG::Handler::Main::Jail;
use Scalar::Util qw(weaken);

use constant UNPROTECT => 1;
use constant SKIP      => 2;

our $VERSION = '2.0.0';

our @_onReload;

sub onReload {
    my ( $class, $obj, $sub ) = @_;
    weaken($obj);
    push @_onReload, [ $obj, $sub ];
}

# CONFIGURATION UPDATE

## @rmethod protected int checkConf(boolean force)
# Check if configuration is up to date, and reload it if needed.
# If the optional boolean $force is set to true,
# * cached configuration is ignored
# * and checkConf returns false if it fails to load remote config
# @param $force boolean
# @return true if config is up to date or if reload config succeeded
sub checkConf {
    my ( $class, $force ) = @_;
    my $conf = $class->confAcc->getConf( { local => !$force } );

    unless ( ref($conf) ) {
        $class->lmLog(
"$class: Unable to load configuration: $Lemonldap::NG::Common::Conf::msg",
            'error'
        );
        return $force ? 0 : $class->cfgNum ? 1 : 0;
    }

    if ( !$class->cfgNum or $class->cfgNum != $conf->{cfgNum} ) {
        $class->lmLog(
"Get configuration $conf->{cfgNum} ($Lemonldap::NG::Common::Conf::msg)",
            'debug'
        );
        $class->lastCheck( time() );
        unless ( $class->cfgNum( $conf->{cfgNum} ) ) {
            $class->lmLog( 'No configuration available', 'error' );
            return 0;
        }
        $conf->{$_} = $class->localConfig->{$_}
          foreach ( keys %{ $class->localConfig } );
        $class->configReload($conf);
    }
    $class->lmLog( "$class: configuration is up to date", 'debug' );
    foreach (@_onReload) {
        my ( $obj, $sub ) = @$_;
        if ($obj) {
            $class->lmLog( 'Launching ' . ref($obj) . "->$sub(conf)", 'debug' );
            unless ( $obj->$sub($conf) ) {
                $class->lmLog(
                    "Underlying object can't load conf ("
                      . ref($obj)
                      . "->$sub)",
                    'error'
                );
            }
        }
    }
    return 1;
}

# RELOAD SYSTEM

## @rmethod int reload
# Launch checkConf() with $local=0, so remote configuration is tested.
# Then build a simple HTTP response that just returns "200 OK" or
# "500 Server Error".
# @return Apache constant ($class->OK or $class->SERVER_ERROR)
sub reload {
    my $class = shift;
    $class->lmLog( "Request for configuration reload", 'notice' );
    return $class->checkConf(1) ? $class->DONE : $class->SERVER_ERROR;
}

*refresh = *reload;

# INTERNAL METHODS

## @imethod void configReload(hashRef conf, hashRef tsv)
# Given a Lemonldap::NG configuration $conf, computes values used to
# handle requests and store them in a thread shared object called $tsv
#
# methods called by configReload, and thread shared values computed, are:
# - jailInit():
#      - jail
# - defaultValuesInit():
#      (scalars for global options)
#      - cda
#      - cookieExpiration  # warning: absent from default Conf
#      - cookieName
#      - securedCookie,
#      - httpOnly
#      - whatToTrace
#      - customFunctions
#      - timeoutActivity
#      - useRedirectOnError
#      - useRedirectOnForbidden
#      - useSafeJail
#      (objects)
#      - cipher  # Lemonldap::NG::Common::Crypto object
#      (hashrefs for vhost options)
#      - https
#      - port
#      - maintenance
# - portalInit():
#      - portal (functions that returns portal URL)
# - locationRulesInit():
#      - locationCount
#      - defaultCondition
#      - defaultProtection
#      - locationCondition
#      - locationProtection
#      - locationRegexp
#      - locationConditionText
# - sessionStorageInit():
#      - sessionStorageModule
#      - sessionStorageOptions
#      - sessionCacheModule
#      - sessionCacheOptions
# - headersInit():
#      - headerList
#      - forgeHeaders
# - postUrlInit():
#      - inputPostData
#      - outputPostData
# - aliasInit():
#      - vhostAlias
#
# The *Init() methods can be run in any order,
# but jailInit must be run first because $tsv->{jail}
# is used by locationRulesInit, headersInit and postUrlInit.

# @param $conf reference to the configuration hash
# @param $tsv reference to the thread-shared parameters conf
sub configReload {
    my ( $class, $conf ) = @_;
    $class->lmLog( "Loading configuration $conf->{cfgNum} for process $$",
        "info" );

    foreach my $sub (
        qw( jailInit defaultValuesInit portalInit locationRulesInit
        sessionStorageInit headersInit postUrlInit aliasInit )
      )
    {
        $class->lmLog( "Process $$ calls $sub", "debug" );
        $class->$sub($conf);
    }
    return 1;
}

## @imethod protected void jailInit(hashRef args)
# Set default values for non-customized variables
# @param $args reference to the configuration hash
sub jailInit {
    my ( $class, $conf ) = @_;

    $class->tsv->{jail} = Lemonldap::NG::Handler::Main::Jail->new(
        'jail'            => $class->tsv->{jail},
        'useSafeJail'     => $conf->{useSafeJail},
        'customFunctions' => $conf->{customFunctions}
    );
    $class->tsv->{jail}->build_jail($class);
}

## @imethod protected void defaultValuesInit(hashRef args)
# Set default values for non-customized variables
# @param $args reference to the configuration hash
sub defaultValuesInit {
    my ( $class, $conf ) = @_;

    $class->tsv->{$_} = $conf->{$_} foreach (
        qw(
        cda                    cookieExpiration cookieName
        customFunctions        httpOnly         securedCookie
        timeout                timeoutActivity  useRedirectOnError
        useRedirectOnForbidden useSafeJail      whatToTrace
        )
    );

    $class->tsv->{cipher} = Lemonldap::NG::Common::Crypto->new( $conf->{key} );

    foreach my $opt (qw(https port maintenance)) {
        next unless defined $conf->{$opt};

        # Record default value in key '_'
        $class->tsv->{$opt} = { _ => $conf->{$opt} };

        # Override with vhost options
        if ( $conf->{vhostOptions} ) {
            my $name = 'vhost' . ucfirst($opt);
            foreach my $vhost ( keys %{ $conf->{vhostOptions} } ) {
                my $val = $conf->{vhostOptions}->{$vhost}->{$name};
                $class->lmLog( "Options $opt for vhost $vhost: $val", 'debug' );
                $class->tsv->{$opt}->{$vhost} = $val
                  if ( $val >= 0 );    # Keep default value if $val is negative
            }
        }
    }
    return 1;
}

## @imethod protected void portalInit(hashRef args)
# Verify that portal variable exists. Die unless
# @param $args reference to the configuration hash
sub portalInit {
    my ( $class, $conf ) = @_;
    unless ( $conf->{portal} ) {
        $class->lmLog( "portal parameter required", 'error' );
        return 0;
    }
    if ( $conf->{portal} =~ /[\$\(&\|"']/ ) {
        ( $class->tsv->{portal} ) =
          $class->conditionSub( $conf->{portal} );
    }
    else {
        $class->tsv->{portal} = sub { return $conf->{portal} };
    }
    return 1;
}

## @imethod void locationRulesInit(hashRef args)
# Compile rules.
# Rules are stored in $args->{locationRules}->{<virtualhost>} that contains
# regexp=>test expressions where :
# - regexp is used to test URIs
# - test contains an expression used to grant the user
#
# This function creates 2 hashRef containing :
# - one list of the compiled regular expressions for each virtual host
# - one list of the compiled functions (compiled with conditionSub()) for each
# virtual host
# @param $args reference to the configuration hash
sub locationRulesInit {
    my ( $class, $conf ) = @_;

    foreach my $vhost ( keys %{ $conf->{locationRules} } ) {
        my $rules = $conf->{locationRules}->{$vhost};
        foreach my $url ( sort keys %{$rules} ) {
            my ( $cond, $prot ) = $class->conditionSub( $rules->{$url} );
            unless ($cond) {
                $class->tsv->{maintenance}->{$vhost} = 1;
                $class->lmLog(
                    "Unable to build rule '$rules->{$url}': "
                      . $class->tsv->{jail}->error,
                    'error'
                );
                next;
            }

            if ( $url eq 'default' ) {
                $class->tsv->{defaultCondition}->{$vhost}  = $cond;
                $class->tsv->{defaultProtection}->{$vhost} = $prot;
            }
            else {
                push @{ $class->tsv->{locationCondition}->{$vhost} },  $cond;
                push @{ $class->tsv->{locationProtection}->{$vhost} }, $prot;
                push @{ $class->tsv->{locationRegexp}->{$vhost} },     qr/$url/;
                push @{ $class->tsv->{locationConditionText}->{$vhost} },
                    $cond =~ /^\(\?#(.*?)\)/ ? $1
                  : $cond =~ /^(.*?)##(.+)$/ ? $2
                  :                            $url;
                $class->tsv->{locationCount}->{$vhost}++;
            }
        }

        # Default policy set to 'accept'
        unless ( $class->tsv->{defaultCondition}->{$vhost} ) {
            $class->tsv->{defaultCondition}->{$vhost} = sub { 1 };
            $class->tsv->{defaultProtection}->{$vhost} = 0;
        }
    }
    return 1;
}

## @imethod protected void sessionStorageInit(hashRef args)
# Initialize the Apache::Session::* module choosed to share user's variables
# and the Cache::Cache module choosed to cache sessions
# @param $args reference to the configuration hash
sub sessionStorageInit {
    my ( $class, $conf ) = @_;
    unless ( $class->tsv->{sessionStorageModule} = $conf->{globalStorage} ) {
        $class->lmLog( "globalStorage required", 'error' );
        return 0;
    }
    eval "use " . $class->tsv->{sessionStorageModule};
    die($@) if ($@);
    $class->tsv->{sessionStorageOptions} = $conf->{globalStorageOptions};

    if ( $conf->{localSessionStorage} ) {
        $class->tsv->{sessionCacheModule} = $conf->{localSessionStorage};
        $class->tsv->{sessionCacheOptions} =
          $conf->{localSessionStorageOptions};
        $class->tsv->{sessionCacheOptions}->{default_expires_in} ||= 600;

        if ( $conf->{status} ) {
            my $params = "";
            if ( $class->tsv->{sessionCacheModule} ) {
                require Data::Dumper;
                $params = ' '
                  . $class->tsv->{sessionCacheModule} . ','
                  . Data::Dumper->new( [ $class->tsv->{sessionCacheOptions} ] )
                  ->Terse(1)->Indent(0)->Dump;    # To send params on one line
            }
            print { $class->tsv->{statusPipe} } "RELOADCACHE $params\n";
        }
    }
    return 1;
}

## @imethod void headersInit(hashRef args)
# Create the subroutines used to insert headers into the HTTP request.
# @param $args reference to the configuration hash
sub headersInit {
    my ( $class, $conf ) = @_;

    # Creation of the subroutine which will generate headers
    foreach my $vhost ( keys %{ $conf->{exportedHeaders} } ) {
        my %headers = %{ $conf->{exportedHeaders}->{$vhost} };
        $class->tsv->{headerList}->{$vhost} = [ keys %headers ];
        my $sub;
        foreach ( keys %headers ) {
            my $val = $class->substitute( $headers{$_} );
            $sub .= "'$_' => $val,";
        }

        unless ( $class->tsv->{forgeHeaders}->{$vhost} =
            $class->buildSub($sub) )
        {
            $class->tsv->{maintenance}->{$vhost} = 1;
            $class->lmLog(
                "$class Unable to forge headers: " . $class->tsv->{jail}->error,
                'error'
            );
        }
    }
    return 1;
}

## @imethod protected void postUrlInit()
# Prepare methods to post form attributes
sub postUrlInit {
    my ( $class, $conf ) = @_;
    return unless ( $conf->{post} );

    # Browse all vhost
    foreach my $vhost ( keys %{ $conf->{post} } ) {

        #  Browse all POST URI
        foreach my $url ( keys %{ $conf->{post}->{$vhost} } ) {
            my $d = $conf->{post}->{$vhost}->{$url};
            $class->lmLog( "Compiling POST data for $url", 'debug' );

            # Where to POST
            $d->{target} ||= $url;
            my $sub;
            $d->{vars} ||= [];
            foreach my $input ( @{ delete $d->{vars} } ) {
                $sub .=
                  "'$input->[0]' => " . $class->substitute( $input->[1] ) . ",";
            }
            unless (
                $class->tsv->{inputPostData}->{$vhost}->{ delete $d->{target} }
                = $class->tsv->{outputPostData}->{$vhost}->{$url} =
                $class->buildSub($sub) )
            {
                $class->tsv->{maintenance}->{$vhost} = 1;
                $class->lmLog(
                    "$class: Unable to build post datas: "
                      . $class->tsv->{jail}->error,
                    'error'
                );
            }

            $class->tsv->{postFormParams}->{$vhost}->{$url} = $d;
        }
    }
    return 1;
}

## @imethod protected codeRef conditionSub(string cond)
# Returns a compiled function used to grant users (used by
# locationRulesInit(). The second value returned is a non null
# constant if URL is not protected (by "unprotect" or "skip"), 0 else.
# @param $cond The boolean expression to use
# @param $mainClass  optional
# @return array (ref(sub), int)
sub conditionSub {
    my ( $class, $cond ) = @_;
    my ( $OK, $NOK ) = ( sub { 1 }, sub { 0 } );

    # Simple cases : accept and deny
    return ( $OK, 0 )
      if ( $cond =~ /^accept$/i );
    return ( $NOK, 0 )
      if ( $cond =~ /^deny$/i );

    # Cases unprotect and skip : 2nd value is 1 or 2
    return ( $OK, UNPROTECT )
      if ( $cond =~ /^unprotect$/i );
    return ( $OK, SKIP )
      if ( $cond =~ /^skip$/i );

    # Case logout
    if ( $cond =~ /^logout(?:_sso)?(?:\s+(.*))?$/i ) {
        my $url = $1;
        return (
            $url
            ? (
                sub {
                    $Lemonldap::NG::Handler::Main::datas->{_logout} = $url;
                    return 0;
                },
                0
              )
            : (
                sub {
                    $Lemonldap::NG::Handler::Main::datas->{_logout} =
                      &{ $class->tsv->{portal} }();
                    return 0;
                },
                0
            )
        );
    }

    # Since filter exists only with Apache>=2, logout_app and logout_app_sso
    # targets are available only for it.
    # This error can also appear with Manager configured as CGI script
    if ( $cond =~ /^logout_app/i
        and not $class->isa('Lemonldap::NG::Handler::ApacheMP2') )
    {
        $class->lmLog( "Rules logout_app and logout_app_sso require Apache>=2",
            'info' );
        return ( sub { 1 }, 0 );
    }

    # logout_app
    if ( $cond =~ /^logout_app(?:\s+(.*))?$/i ) {
        my $u = $1 || &{ $class->tsv->{portal} }();
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
        return (
            sub {
                $Lemonldap::NG::Handler::ApacheMP2::request->add_output_filter(
                    sub {
                        return $class->redirectFilter( $u, @_ );
                    }
                );
                1;
            },
            0
        );
    }
    elsif ( $cond =~ /^logout_app_sso(?:\s+(.*))?$/i ) {
        my $u = $1 || &{ $class->tsv->{portal} }();
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
        return (
            sub {

                #TODO: check this
                $class->localUnlog;
                $Lemonldap::NG::Handler::ApacheMP2::request->add_output_filter(
                    sub {
                        my $r = $_[0]->r;
                        return $class->redirectFilter(
                            &{ $class->tsv->{portal} }() . "?url="
                              . $class->encodeUrl($u)
                              . "&logout=1",
                            @_
                        );
                    }
                );
                1;
            },
            0
        );
    }

    # Replace some strings in condition
    $cond = $class->substitute($cond);
    my $sub;
    unless ( $sub = $class->buildSub($cond) ) {
        $class->lmLog(
            "$class: Unable to build condition ($cond): "
              . $class->tsv->{jail}->error,
            'error'
        );
    }

    # Return sub and protected flag
    return ( $sub, 0 );
}

## @method arrayref aliasInit
# @param options vhostOptions configuration item
# @return arrayref of vhost and aliases
sub aliasInit {
    my ( $class, $conf ) = @_;

    foreach my $vhost ( keys %{ $conf->{vhostOptions} } ) {
        if ( my $aliases = $conf->{vhostOptions}->{$vhost}->{vhostAliases} ) {
            foreach ( split /\s+/, $aliases ) {
                $class->tsv->{vhostAlias}->{$_} = $vhost;
                $class->lmLog( "Registering $_ as alias of $vhost", 'debug' );
            }
        }
    }
    return 1;
}

# TODO: support wildcards in aliases

sub substitute {
    my ( $class, $expr ) = @_;

    # substitute special vars, just for retro-compatibility
    $expr =~ s/\$date\b/&date/sg;
    $expr =~ s/\$vhost\b/&hostname/sg;
    $expr =~ s/\$ip\b/&remote_ip/sg;

    # substitute vars with session datas, excepts special vars $_ and $\d+
    $expr =~ s/\$(?!ENV)(_*[a-zA-Z]\w*)/\$session->{$1}/sg;

    return $expr;
}

sub buildSub {
    my ( $class, $val ) = @_;
    return $class->tsv->{jail}
      ->jail_reval("sub{my \$session=\$_[0];return($val)}");
}

1;