view release on metacpan or  search on metacpan

lib/Plack/Middleware/PeriAHS/ParseRequest.pm  view on Meta::CPAN

            #        unless $self->{accept_phps};
            #    require PHP::Serialization;
            #    eval { $v = PHP::Serialization::unserialize($v) };
            #    return errpage(
            #        $env, [400, "Invalid PHP serialized data in ".
            #                       "query parameter $k: $@") if $@;
            }
            if ($k =~ /\A-riap-([\w-]+)/) {
                my $rk = lc $1; $rk =~ s/-/_/g;
                return errpage(
                    $env, [400, "Invalid Riap request key `$rk` (from form)"])
                    unless $rk =~ /\A\w+\z/;
                $rreq->{$rk} = $v unless exists $rreq->{$rk};
            } else {
                $rreq->{args}{$k} = $v unless exists $rreq->{args}{$k};
            }
        }
    }

    if ($self->{parse_reform} && $env->{'periahs._form_cache'} &&
            $env->{'periahs._form_cache'}{'-submit'}) {
        {
            last unless $rreq->{uri};
            my $res = $env->{'periahs._meta_res_cache'} //
                $self->{riap_client}->request(meta => $rreq->{uri});
            return errpage($env, [$res->[0], $res->[1]])
                unless $res->[0] == 200;
            $env->{'periahs._meta_res_cache'} //= $res;
            my $meta = $res->[2];
            last unless $meta;
            last unless $meta->{args};

            require ReForm::HTML;
            require Perinci::Sub::To::ReForm;
            my $rf = ReForm::HTML->new(
                spec => Perinci::Sub::To::ReForm::gen_form_spec_from_rinci_meta(
                    meta => $meta,
                )
            );
            $res = $rf->get_data(psgi_env => $env);
            return errpage($env, [$res->[0], $res->[1]])
                unless $res->[0] == 200;
            $rreq->{args} = $res->[2];
        }
    }

    if ($self->{parse_path_info}) {
        {
            last unless $rreq->{uri};
            my $res = $env->{'periahs._meta_res_cache'} //
                $self->{riap_client}->request(meta => $rreq->{uri});
            return errpage($env, [$res->[0], $res->[1]])
                unless $res->[0] == 200;
            $env->{'periahs._meta_res_cache'} //= $res;
            my $meta = $res->[2];
            last unless $meta;
            last unless $meta->{args};

            my $pi = $env->{PATH_INFO} // "";
            $pi =~ s!^/+!!;
            my @pi = map {uri_unescape($_)} split m!/+!, $pi;
            $res = get_args_from_array(array=>\@pi, meta=>$meta);
            return errpage(
                $env, [500, "Bad metadata for function $rreq->{uri}: ".
                           "Can't get arguments: $res->[0] - $res->[1]"])
                unless $res->[0] == 200;
                for my $k (keys %{$res->[2]}) {
                    $rreq->{args}{$k} //= $res->[2]{$k};
                }
        }
    }

    # defaults
    $rreq->{v}      //= 1.1;
    $rreq->{fmt}    //= $env->{"periahs.default_fmt"};
    if (!$rreq->{action}) {
        if ($rreq->{uri} =~ m!/$!) {
            $rreq->{action} = 'list';
            $rreq->{detail} //= 1;
        } else {
            $rreq->{action} = 'call';
        }
    }

    # sanity: check required keys
    for (qw/uri v action/) {
        defined($rreq->{$_}) or return errpage(
            $env, [500, "Required Riap request key '$_' has not been defined"]);
    }

    # add uri prefix
    $rreq->{uri} = "$self->{riap_uri_prefix}$rreq->{uri}";

    # special handling for php clients #2
    {
        last unless $self->{deconfuse_php_clients} &&
            $rcua && $rcua =~ $self->{php_clients_ua_re};
        my $rargs = $rreq->{args};
        last unless $rargs;

        # XXX this is repetitive, must refactor
        my $res = $env->{'periahs._meta_res_cache'} //
            $self->{riap_client}->request(meta => $rreq->{uri});
        return errpage($env, [$res->[0], $res->[1]])
            unless $res->[0] == 200;
        $env->{'periahs._meta_res_cache'} //= $res;
        my $meta = $res->[2];

        if ($meta->{args}) {
            for my $arg (keys %$rargs) {
                my $argm = $meta->{args}{$arg};
                if ($argm && $argm->{schema}) {
                    # convert {} -> [] if function expects array
                    if (ref($rargs->{$arg}) eq 'HASH' &&
                            !keys(%{$rargs->{$arg}}) &&
                                $argm->{schema}[0] eq 'array') {
                        $rargs->{$arg} = [];
                    }
                    # convert [] -> {} if function expects hash
                    if (ref($rargs->{$arg}) eq 'ARRAY' &&
                            !@{$rargs->{$arg}} &&