lemonldap-ng/lemonldap-ng-handler/lib/Lemonldap/NG/Handler/Main/Reload.pm

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

our $VERSION = '2.1.0';

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

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;
use constant MAYSKIP   => 3;

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 ) = @_;
    $class->logger->debug("Check configuration for $class");
    my $prm  = { local => !$force, localPrm => $class->localConfig };
    my $conf = $class->confAcc->getConf($prm);
    chomp $Lemonldap::NG::Common::Conf::msg;

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

    if ($Lemonldap::NG::Common::Conf::msg) {
        if ( $Lemonldap::NG::Common::Conf::msg =~ /Error:/ ) {
            $class->logger->error($Lemonldap::NG::Common::Conf::msg);
        }
        elsif ( $Lemonldap::NG::Common::Conf::msg =~ /Warn:/ ) {
            $class->logger->warn($Lemonldap::NG::Common::Conf::msg);
        }
        else {
            $class->logger->debug($Lemonldap::NG::Common::Conf::msg);
        }
    }
    $Lemonldap::NG::Common::Conf::msg = '';

    if (   $force
        or !$class->cfgNum
        or !$class->cfgDate
        or $class->cfgNum != $conf->{cfgNum}
        or $class->cfgDate != $conf->{cfgDate} )
    {
        $class->logger->debug("Get configuration $conf->{cfgNum}");
        unless ( $class->cfgNum( $conf->{cfgNum} )
            && $class->cfgDate( $conf->{cfgDate} ) )
        {
            $class->logger->error('No configuration available');
            return 0;
        }
        $class->configReload($conf);
        foreach (@_onReload) {
            my ( $obj, $sub ) = @$_;
            if ($obj) {
                $class->logger->debug(
                    'Launching ' . ref($obj) . "->$sub(conf)" );
                unless ( $obj->$sub($conf) ) {
                    $class->logger->error( "Underlying object can't load conf ("
                          . ref($obj)
                          . "->$sub)" );
                    return 0;
                }
            }
        }
    }
    $class->checkTime( $conf->{checkTime} ) if $conf->{checkTime};
    $class->lastCheck( time() );
    $class->logger->debug("$class: configuration is up to date");
    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->logger->notice("Request for configuration reload");
    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)
#      - cookieExpiration  # warning: absent from default Conf
#      - cookieName
#      - securedCookie,
#      - httpOnly
#      - whatToTrace
#      - customFunctions
#      - timeoutActivity
#      - timeoutActivityInterval
#      - 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->logger->info(
        "Loading configuration $conf->{cfgNum} for process $$");

    foreach my $sub (
        qw( defaultValuesInit jailInit portalInit locationRulesInit
        sessionStorageInit headersInit postUrlInit aliasInit oauth2Init )
      )
    {
        $class->logger->debug("Process $$ calls $sub");
        $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( {
            useSafeJail          => $conf->{useSafeJail},
            customFunctions      => $conf->{customFunctions},
            multiValuesSeparator => $conf->{multiValuesSeparator},
        }
    );
    $class->tsv->{jail}
      ->build_jail( $class, $conf->{require}, $conf->{requireDontDie} );
}

## @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(
        cookieExpiration        cookieName         customFunctions httpOnly
        securedCookie           timeout            timeoutActivity
        timeoutActivityInterval useRedirectOnError useRedirectOnForbidden
        useSafeJail             whatToTrace        handlerInternalCache
        handlerServiceTokenTTL  customToTrace      lwpOpts lwpSslOpts
        authChoiceAuthBasic     authChoiceParam    hiddenAttributes
        upgradeSession
        )
    );

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

    foreach my $opt (qw(https port maintenance)) {

        # 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 ( sort keys %{ $conf->{vhostOptions} } ) {
                $conf->{vhostOptions}->{$vhost} ||= {};
                my $val = $conf->{vhostOptions}->{$vhost}->{$name};

                # Keep global value if $val is negative
                if ( defined $val and $val >= 0 ) {
                    $class->logger->debug(
                        "Options $opt for vhost $vhost: $val");
                    $class->tsv->{$opt}->{$vhost} = $val;
                }
            }
        }
    }
    if ( $conf->{vhostOptions} ) {
        foreach my $vhost ( sort keys %{ $conf->{vhostOptions} } ) {
            $class->tsv->{type}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostType};
            $class->tsv->{authnLevel}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostAuthnLevel};
            $class->tsv->{serviceTokenTTL}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostServiceTokenTTL};
            $class->tsv->{accessToTrace}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostAccessToTrace};
        }
    }
    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->logger->error("portal parameter required");
        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, $orules ) = @_;

    $orules ||= $conf->{locationRules};
    $class->tsv->{vhostReg} = [];
    my @lastReg;

    foreach my $vhost ( keys %$orules ) {
        my $rules = $orules->{$vhost};
        if ( $vhost =~ /[\%\*]/ ) {
            my $expr = join '[^\.]*', map {
                my $elt = $_;
                join '.*', map { quotemeta $_ } split /\*/, $elt;
            } split /\%/, $vhost;
            if ($expr) {
                push @{ $class->tsv->{vhostReg} }, [ qr/^$expr$/, $vhost ];
            }
            else {
                push @lastReg, [ qr/.+/, $vhost ];
            }
        }
        $class->tsv->{locationCount}->{$vhost}         = 0;
        $class->tsv->{locationCondition}->{$vhost}     = [];
        $class->tsv->{locationProtection}->{$vhost}    = [];
        $class->tsv->{locationRegexp}->{$vhost}        = [];
        $class->tsv->{locationConditionText}->{$vhost} = [];
        $class->tsv->{locationAuthnLevel}->{$vhost}    = [];

        foreach my $url ( sort keys %{$rules} ) {
            my ( $cond, $prot ) = $class->conditionSub( $rules->{$url} );
            unless ($cond) {
                $class->tsv->{maintenance}->{$vhost} = 1;
                $class->logger->error(
                    "Unable to build rule '$rules->{$url}': "
                      . $class->tsv->{jail}->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->{locationAuthnLevel}->{$vhost} },
                  $url =~ /\(\?#AuthnLevel=(-?\d+)\)/
                  ? $1
                  : undef;
                push @{ $class->tsv->{locationConditionText}->{$vhost} },
                    $url =~ /^\(\?#(.*?)\)/ ? $1
                  : $url =~ /^(.*?)##(.+)$/ ? $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;
        }
    }
    @{ $class->tsv->{vhostReg} } = sort {
        my $av = $a->[1];
        my $bv = $b->[1];
        return 1  if $av =~ /^\*/ and $bv !~ /^\*/;
        return -1 if $bv =~ /^\*/ and $av !~ /^\*/;
        return 1  if $av =~ /^\%/ and $bv !~ /^\%/;
        return -1 if $bv =~ /^\%/ and $av !~ /^\%/;
        return length($bv) <=> length($av) || $av cmp $bv;
    } @{ $class->tsv->{vhostReg} } if @{ $class->tsv->{vhostReg} };
    push @{ $class->tsv->{vhostReg} }, @lastReg if @lastReg;
    return 1;
}

## @imethod protected void sessionStorageInit(hashRef args)
# Initialize the Apache::Session::* module choosed to share user's variables
# and the Cache::Cache module chosen to cache sessions
# @param $args reference to the configuration hash
sub sessionStorageInit {
    my ( $class, $conf ) = @_;

    # Global session storage
    unless ( $class->tsv->{sessionStorageModule} = $conf->{globalStorage} ) {
        $class->logger->error("globalStorage required");
        return 0;
    }
    eval "use " . $class->tsv->{sessionStorageModule};
    die($@) if ($@);
    $class->tsv->{sessionStorageOptions} = $conf->{globalStorageOptions};

    # OIDC session storage
    if ( $conf->{oidcStorage} ) {
        eval "use " . $conf->{oidcStorage};
        die($@) if ($@);
        $class->tsv->{oidcStorageModule}  = $conf->{oidcStorage};
        $class->tsv->{oidcStorageOptions} = $conf->{oidcStorageOptions};

    }
    else {
        $class->tsv->{oidcStorageModule}  = $conf->{globalStorage};
        $class->tsv->{oidcStorageOptions} = $conf->{globalStorageOptions};
    }

    # Local session storage
    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} ) {
                $params = $class->tsv->{sessionCacheModule} . ',{' . join(
                    ',',
                    map {
                        "$_ => '"
                          . $class->tsv->{sessionCacheOptions}->{$_} . "'"
                      }
                      keys %{ $class->tsv->{sessionCacheOptions} // {} }
                ) . '}';
            }
            $class->tsv->{statusPipe}->print("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, $headers ) = @_;
    $headers ||= $conf->{exportedHeaders};

    # Creation of the subroutine which will generate headers
    foreach my $vhost ( keys %{$headers} ) {
        unless ($vhost) {
            $class->logger->warn('Empty vhost in headers, skipping');
            next;
        }
        $headers->{$vhost} ||= {};
        my %headers = %{ $headers->{$vhost} };
        $class->tsv->{headerList}->{$vhost} = [ keys %headers ];
        my $sub = '';
        foreach ( keys %headers ) {
            $headers{$_} ||= "''";
            my $val = $class->substitute( $headers{$_} ) . " // ''";
            $sub .= "('$_' => $val),";
        }

        unless ( $class->tsv->{forgeHeaders}->{$vhost} =
            $class->buildSub($sub) )
        {
            $class->tsv->{maintenance}->{$vhost} = 1;
            $class->logger->error( "$class Unable to forge $vhost headers: "
                  . $class->tsv->{jail}->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->logger->debug("Compiling POST data for $url");

            # 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->logger->error( "$class: Unable to build post data: "
                      . $class->tsv->{jail}->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 ) = @_;
    $cond =~ s/\(\?#(\d+)\)$//;
    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 {
                    $_[1]->{_logout} = $url;
                    return 0;
                },
                0
              )
            : (
                sub {
                    $_[1]->{_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::Main') )
    {
        $class->logger->info(
            "Rules logout_app and logout_app_sso require Apache>=2");
        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 {
                $_[0]->{env}->{'psgi.r'}->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 {
                my ($req) = @_;
                $class->localUnlog( $req, @_ );
                $req->{env}->{'psgi.r'}->add_output_filter(
                    sub {
                        my $r = $_[0]->r;
                        return $class->redirectFilter(
                            &{ $class->tsv->{portal} }() . "?url="
                              . $class->encodeUrl( $req, $u )
                              . "&logout=1",
                            @_
                        );
                    }
                );
                1;
            },
            0
        );
    }

    my $mayskip = 0;
    $mayskip = MAYSKIP if $cond =~ /\bskip\b/;

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

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

## @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->logger->debug("Registering $_ as alias of $vhost");
            }
        }
    }
    return 1;
}

# TODO: support wildcards in aliases

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

    foreach my $rp ( keys %{ $conf->{oidcRPMetaDataOptions} || {} } ) {
        if (    $conf->{oidcRPMetaDataOptions}->{$rp}
            and $conf->{oidcRPMetaDataOptions}->{$rp}
            ->{oidcRPMetaDataOptionsClientID} )
        {
            $class->tsv->{oauth2Options}->{$rp}->{clientId} =
              $conf->{oidcRPMetaDataOptions}->{$rp}
              ->{oidcRPMetaDataOptionsClientID};
        }
    }
    return 1;
}

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

    # substitute special vars, just for retro-compatibility
    $expr =~ s/\$date\b/&date/sg;
    $expr =~ s/\$vhost\b/\$ENV{HTTP_HOST}/sg;
    $expr =~ s/\$ip\b/\$ENV{REMOTE_ADDR}/sg;

    # substitute vars with session data, excepts special vars $_ and $\d+
    $expr =~ s/\$(?!(?:ENV|env|_rulematch)\b)(_\w+|[a-zA-Z]\w*)/\$s->{$1}/sg;
    $expr =~ s/\$ENV\{/\$r->{env}->\{/g;
    $expr =~ s/\$env->\{/\$r->{env}->\{/g;
    $expr =~ s/\$_rulematch\[/\$m->\[/g;
    $expr =~ s/\bskip\b/q\{999_SKIP\}/g;

    # handle inGroup
    $expr =~ s/\binGroup\(([^)]*)\)/listMatch(\$s->{'hGroups'},$1,1)/g;

    # handle has2f
    $expr =~ s/\bhas2f\(([^),]*)\)/has2f(\$s,$1)/g;

    return $expr;
}

sub buildSub {
    my ( $class, $val ) = @_;
    my $res =
      $class->tsv->{jail}->jail_reval("sub{my (\$r,\$s,\$m)=\@_;return($val)}");
    unless ($res) {
        $class->logger->error( $class->tsv->{jail}->error );
    }
    return $res;
}

1;