view release on metacpan or  search on metacpan

script/peri-htserve  view on Meta::CPAN

            cmdline_aliases => {M=>{}},
            cmdline_on_getopt => sub {
                my %args = @_;
                my $val = $args{value};
                if (my ($mod, $imp) = $val =~ /(.+?)=(.+)/) {
                    load $mod;
                    $mod->import(split /,/, $imp);
                } else {
                    autoload $val;
                }
            },
        },
        require => {
            schema => ['array' => of => 'str*'],
            summary => 'Require a Perl module, a la Perl\'s -m',
            cmdline_aliases => {m=>{}},
            cmdline_on_getopt => sub {
                my %args = @_;
                load $args{val};
            },
        },

        parse_form => {
            schema => ['bool'],
            summary => 'Passed to Plack::Middleware::PeriAHS::ParseRequest',
        },
        parse_reform => {
            schema => ['bool'],
            summary => 'Passed to Plack::Middleware::PeriAHS::ParseRequest',
        },
        parse_path_info => {
            schema => ['bool'],
            summary => 'Passed to Plack::Middleware::PeriAHS::ParseRequest',
        },
        user => {
            schema => ['str*'],
            summary => 'Protect with HTTP authentication, specify username',
        },
        password => {
            schema => ['str*'],
            summary => 'Protect with HTTP authentication, specify password',
        },
        enable_logging => {
            schema  => ['bool', default=>1],
            summary => 'Can be used to test server with no support for logging',
        },

        metadb => {
            summary => 'Path to SQLite Rinci metadata database',
            schema  => 'str*',
            description => <<'_',

This is an experimental option for testing serving metadata from database. If
set, will use `Perinci::Access::Schemeless::DBI` (with option
`fallback_on_completion`) instead of `Perinci::Access::Schemeless` for the Riap
client.

_
        },
    },
    'x.perinci.sub.wrapper.disable_validate_args' => 1,
};
sub serve {
    my %args = @_; # VXALIDATE_ARGS

    my $server = $args{server} // 'Gepok';
    #$log->tracef("TMP: modules/packages: %s", $args{module_or_package});
    log_info("Starting server (using %s) ...", $server);

    my $riap_access_log_path = $args{riap_access_log_path} //
        File::HomeDir->my_home . "/peri-htserve-riap_access.log";

    log_debug("Modules to load: %s", $args{-modules});
    for my $m (@{$args{-modules}}) {
        log_info("Loading module %s ...", $m);
        eval { load $m };
        return [500, "Failed to load module $m: $@"] if $@;
        gen_meta_for_module(module=>$m, load=>0);
    }

    my $fwr;
    {
        my ($dir, $leaf) = $riap_access_log_path =~ m!(.+)/(.+)!;
        if (!$dir) { $dir = "."; $leaf = $riap_access_log_path }
        $fwr = File::Write::Rotate->new(
            dir       => $dir,
            prefix    => $leaf,
            size      => $args{riap_access_log_size},
            histories => $args{riap_access_log_histories},
        );
    }

    my @pkgs = (@{ $args{-modules} // [] }, @{ $args{-packages} // [] });

    # let's only allow access to perl modules (and not other schemes like http).
    # let's not dynamically load modules except the ones explicitly specified
    # and loaded above. let's only allow seeing the specified modules.
    my $pa;
    {
        my $class;
        my %extra_opts;
        if ($args{metadb}) {
            $class = "Perinci::Access::Schemeless::DBI";
            $extra_opts{fallback_on_completion} = 1;

            require DBI;
            my $dbh = DBI->connect(
                "dbi:SQLite:dbname=$args{metadb}", "", "", {RaiseError=>1});
            $extra_opts{dbh} = $dbh;
        } else {
            $class = "Perinci::Access::Schemeless";
        }
        load $class;
        $pa = $class->new(
            load => 0,
            allow_paths => [map {(my $url = $_) =~ s!::!/!g; "/$url"} @pkgs],
            %extra_opts,
        );
    }

    my $app = builder {