File Coverage

blib/lib/Dancer2/ConfigReader.pm

Criterion	Covered	Total	%
statement	115	121	95.0
branch	36	54	66.6
condition	8	10	80.0
subroutine	19	21	90.4
pod			n/a
total	178	206	86.4

# ABSTRACT: Config reader for Dancer2 App
package Dancer2::ConfigReader;
$Dancer2::ConfigReader::VERSION = '2.1.0';
use Moo;

use Config::Any;
use Hash::Merge::Simple;
use Carp 'croak';
use Module::Runtime qw{ use_module };
use Ref::Util qw/ is_arrayref is_hashref /;
use Scalar::Util qw/ blessed /;
use Path::Tiny ();

use Dancer2::Core::Factory;
use Dancer2::Core;
use Dancer2::Core::Types;
use Dancer2::ConfigUtils 'normalize_config_entry';

our $MAX_CONFIGS = $ENV{DANCER_MAX_CONFIGS} || 100;

my %KNOWN_CORE_KEYS = map +( $_ => 1 ), qw(
    additional_config_readers
    appdir
    apphandler
    appname
    auto_page
    behind_proxy
    charset
    content_type
    default_mime_type
    engines
    environment
    error_template
    host
    layout
    layout_dir
    log
    logger
    no_default_middleware
    no_server_tokens
    plugins
    port
    public_dir
    route_handlers
    serializer
    session
    show_errors
    show_stacktrace
    startup_info
    static_handler
    template
    timeout
    traces
    type_library
    views
    strict_config
    strict_config_allow
);

my %KNOWN_ENGINE_CONFIG = (
    'logger' => {
        'base_keys' => {
            'app_name'              => 1,
            'auto_encoding_charset' => 1,
            'log_format'            => 1,
            'log_level'             => 1,
        },
        'engines' => {
            'capture' => { keys => {} },
            'console' => { keys => {} },
            'diag'    => { keys => {} },
            'file'    => {
                'keys' => {
                    'file_name' => 1,
                    'log_dir'   => 1,
                },
            },
            'note'    => { keys => {} },
            'null'    => { keys => {} },
        },
    },
    'serializer' => {
        'engines' => {
            'dumper' => { keys => {} },
            'json'   => { allow_any => 1 },
            'mutable' => {
                keys => {
                    mapping => 1,
                },
            },
            'yaml' => { keys => {} },
        },
    },
    'session' => {
        'base_keys' => {
            'cookie_domain'    => 1,
            'cookie_duration'  => 1,
            'cookie_name'      => 1,
            'cookie_path'      => 1,
            'cookie_same_site' => 1,
            'is_http_only'     => 1,
            'is_secure'        => 1,
            'session_duration' => 1,
        },
        'engines' => {
            'simple' => { keys => {} },
            'yaml'   => {
                'keys' => {
                    'session_dir' => 1,
                },
            },
        },
    },
    'template' => {
        'engines' => {
            'templatetoolkit' => { allow_any => 1 },
            'tiny'            => { allow_any => 1 },
        },
    },
);

has location => (
    is       => 'ro',
    isa      => Str,
    required => 1,
);

has default_config => (
    is      => 'ro',
    isa     => HashRef,
    required => 1,
);

has config_location => (
    is      => 'ro',
    isa     => ReadableFilePath,
    lazy    => 1,
    default => sub { $_[0]->location },
);

# The type for this attribute is Str because we don't require
# an existing directory with configuration files for the
# environments.  An application without environments is still
# valid and works.
has environments_location => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    default => sub {
        # short circuit
        defined $ENV{'DANCER_ENVDIR'}
            and return $ENV{'DANCER_ENVDIR'};

        my $self = shift;

        foreach my $maybe_path ( $self->config_location, $self->location ) {
            my $path = Path::Tiny::path($maybe_path, 'environments');
            $path->exists && $path->is_dir
              and return $path->stringify;
        }

        return '';
    },
);

has _config_location_path => (
    is       => 'ro',
    lazy     => 1,
    builder  => '_build_config_location_path',
    init_arg => undef,
);

has _environments_location_path => (
    is       => 'ro',
    lazy     => 1,
    builder  => '_build_environments_location_path',
    init_arg => undef,
);

sub _build_config_location_path {
    my $self = shift;
    return Path::Tiny::path( $self->config_location );
}

sub _build_environments_location_path {
    my $self = shift;
    return Path::Tiny::path( $self->environments_location );
}

has config => (
    is      => 'ro',
    isa     => HashRef,
    lazy    => 1,
    builder => '_build_config',
);

has environment => (
    is      => 'ro',
    isa     => Str,
    required => 1,
);

has config_readers => (
    is      => 'ro',
    lazy    => 1,
    isa     => ArrayRef,
    builder => '_build_config_readers',
);

# The config builder
sub _build_config {
    my ($self) = @_;

    my $config  = $self->default_config;

    my $nbr_config = 0;

    my @readers = @{ $self->config_readers };

    my $config_to_object = sub {
        my $thing = $_;

        return $thing if blessed $thing;

        $thing = { $thing => {} } unless ref $thing;

        die "additional_config_readers entry must have exactly one key\n"
            if keys %$thing != 1;

        my( $class, $args ) = %$thing;

        return use_module($class)->new(
            location    => $self->location,
            environment => $self->environment,
            %$args,
        );
    };

    while( my $r = shift @readers ) {
        die <<"END" if $nbr_config++ >= $MAX_CONFIGS;
MAX_CONFIGS exceeded: read over $MAX_CONFIGS configurations

Looks like you have an infinite recursion in your configuration system.
Re-run with DANCER_CONFIG_VERBOSE=1 to see what is going on.

If your application really read that many configs (may \$dog have mercy
on your soul), you can increase the limit via the environment variable
DANCER_MAX_CONFIGS.

END
        warn "Reading config from @{[ $r->name() ]}\n" if $ENV{DANCER_CONFIG_VERBOSE};
        my $local_config = $r->read_config;

        if( my $additionals = delete $local_config->{additional_config_readers} ) {

            warn "Additional config readers found\n" if $ENV{DANCER_CONFIG_VERBOSE};

            unshift @readers, map { $config_to_object->($_) } is_arrayref($additionals) ? @$additionals : ($additionals);
        }

        $config = Hash::Merge::Simple->merge(
            $config, $local_config
        );
    }

    return $self->_normalize_config($config);
}

sub _normalize_config {
    my ( $self, $config ) = @_;

    foreach my $key ( keys %{$config} ) {
        my $value = $config->{$key};
        $config->{$key} = normalize_config_entry( $key, $value );
    }

    $self->_strict_config_keys($config);

    return $config;
}

sub _build_config_readers {
    my ($self) = @_;

    my @config_reader_names = $ENV{'DANCER_CONFIG_READERS'}
                            ? (split qr{,}msx, $ENV{'DANCER_CONFIG_READERS'})
                            : ( q{Dancer2::ConfigReader::Config::Any} );

    warn "ConfigReaders to use: @config_reader_names\n" if $ENV{DANCER_CONFIG_VERBOSE};
    return [
        map use_module($_)->new(
            location    => $self->location,
            environment => $self->environment,
        ), @config_reader_names
    ];
}

sub _strict_config_keys {
    my ( $self, $config ) = @_;

    return
        if exists $config->{'strict_config'}
        && !$config->{'strict_config'};

    my %allowed_keys;
    if ( exists $config->{'strict_config_allow'} ) {
        my $allow = $config->{'strict_config_allow'};
        if ( is_arrayref($allow) ) {
            %allowed_keys = map +( $_ => 1 ), @{$allow};
        } else {
            croak('strict_config_allow can only be arrayref');
        }
    }

    my @warnings = map +(
        $KNOWN_CORE_KEYS{$_} || $allowed_keys{$_}
        ? ()
        : "Unknown configuration key '$_'"
    ), sort keys %{$config};

    if ( my $engines = $config->{'engines'} ) {
        push @warnings, $self->_warn_unknown_engine_config_keys($engines);
    }

    @warnings or return;

    warn join(
        "\n",
        @warnings,
        'Set strict_config => 0 to silence these warnings.'
    ) . "\n";
}

sub _warn_unknown_engine_config_keys {
    my ( $self, $engines ) = @_;
    is_hashref($engines)
        or return;

    my @warnings;

    for my $engine_type ( sort keys %{$engines} ) {
        my $type_config = $engines->{$engine_type};
        is_hashref($type_config)
            or next;

        my $known_type = $KNOWN_ENGINE_CONFIG{$engine_type}
            or next;

        my $base_keys     = $known_type->{'base_keys'} || {};
        my $known_engines = $known_type->{'engines'}   || {};

        for my $engine_name ( sort keys %{$type_config} ) {
            my $engine_config = $type_config->{$engine_name};
            is_hashref($engine_config)
                or next;

            my $normalized = _normalize_engine_name($engine_name);
            defined $normalized
                or next;

            my $known_engine = $known_engines->{$normalized} or next;
            next if $known_engine->{'allow_any'};

            my %allowed = (%{$base_keys}, %{ $known_engine->{keys} || {} });

            for my $key ( sort keys %{$engine_config} ) {
                next if $allowed{$key};
                push @warnings,
                    "Unknown configuration key '$key' for engine '$engine_type/$engine_name'";
            }
        }
    }

    return @warnings;
}

sub _normalize_engine_name {
    my ($name) = @_;

    return if !defined $name;
    return if $name =~ /::/xms;

    my $normalized = lc $name;
    $normalized =~ s/_//xmsg;
    return $normalized;
}

1;

__END__