Jifty::Request - Canonical internal representation of an incoming Jifty request

   bla=bap|beep=bop|foo=bar

use warnings;
use strict;

package Jifty::Request;

use Any::Moose;
extends 'Jifty::Object';

has 'env' => (is => "ro", isa => "HashRef", default => sub { {} });
has '_top_request' => (is => 'rw');
has 'arguments' => (is => 'rw');
has 'template_arguments' => (is => 'rw');
has 'just_validating' => (is => 'rw');
has 'continuation_id' => (is => 'rw');
has 'future_continuation_id' => (is => 'rw');
has 'continuation_type' => (is => 'rw');
has 'continuation_path' => (is => 'rw');

has 'parameters' => (is => 'rw', isa => 'HashRef', default => sub { {} });
has 'uploads' => (is => 'rw', isa => 'HashRef');
has 'headers' => (is => 'rw', isa => 'HTTP::Headers', default => sub { HTTP::Headers->new });
has 'uri' => (is => 'rw', isa => 'URI', default => sub { URI->new('http:///') });
has 'cookies' => (is => 'rw', isa => 'HashRef', default => sub { {} } );
has 'scheme' => (is => "rw", isa => "Str", default => sub { 'http' });

has 'request_uri' => (
    is      => "rw",
    isa     => "Str",
);

sub address     { $_[0]->env->{REMOTE_ADDR} }
sub remote_host { $_[0]->env->{REMOTE_HOST} }
sub protocol    { $_[0]->env->{SERVER_PROTOCOL} }
sub method      { $_[0]->env->{REQUEST_METHOD} = $_[1] if @_ > 1; $_[0]->env->{REQUEST_METHOD} }
sub request_method { Carp::carp "request_method is deprecated, use method instead"; goto \&method }
sub port        { $_[0]->env->{SERVER_PORT} }
sub user        { $_[0]->env->{REMOTE_USER} }
sub path_info   { $_[0]->env->{PATH_INFO} }
sub script_name { $_[0]->env->{SCRIPT_NAME} }
sub secure      { $_[0]->scheme eq 'https' }
sub body        { $_[0]->env->{'psgi.input'} }
sub input       { $_[0]->env->{'psgi.input'} }

sub header { shift->headers->header(@_) }
sub path {
    return @_ == 1 ? $_[0]->uri->path
                   : $_[0]->uri->path( Jifty::Util->canonicalize_path( $_[1], 1 ) )
}
sub content_length   { shift->headers->content_length(@_) }
sub content_type     { shift->headers->content_type(@_) }
sub referer          { shift->headers->referer(@_) }
sub user_agent       { shift->headers->user_agent(@_) }

use Jifty::JSON;
use Jifty::YAML;
use Jifty::Web::FileUpload;
use Plack::Util ();

sub BUILD {
    my $self = shift;
    my ($args) = @_;

    $self->setup_subrequest_env if Jifty->web->request;

    $self->{'actions'} = {};
    $self->{'state_variables'} = {};
    $self->{'fragments'} = {};
    $self->method('GET') unless $self->method;

    $self->path($args->{path}) if $args->{path};
    $self->arguments({});
    $self->template_arguments({});
}

sub setup_subrequest_env {
    my $self = shift;
    # Copy a bunch of information off of the top Plack request
    my $env = Jifty->web->request->top_request->env;
    $self->{env} = {};
    $self->{env}{$_} = $env->{$_} for qw/psgi.version psgi.multithread psgi.multiprocess psgi.errors/;
    # Stub in an empty input filehandle
    $self->{env}{"psgi.input"} = Plack::Util::inline_object( read => sub {0} );
}

sub clone {
    my $self = shift;
    
    # "Semi-shallow" clone
    my $ret = bless({map {
        my $val = $self->{$_};
        $_ => (ref($val) eq "HASH" ? { %$val } : ref($val) eq "ARRAY" ? [ @$val ] : $val);
    } keys %$self}, ref($self));

    $ret->uri( $self->uri->clone );
    return $ret;
}

sub promote {
    my $class = shift;
    my ($req) = @_;

    die Carp::longmess("old calling style") unless ref $req;

    # Import all props from Plack::Request object

    # path of $req->uri is escaped by Plack::Request, we want it unescaped here
    # see also http://github.com/miyagawa/Plack/commit/a01c607cb6d0b6470308987cb94aa4b011c2d7ff
    my $uri = $req->uri;
    $uri->path( URI::Escape::uri_unescape( $uri->path ) );

    my $self = $class->new( env => $req->env,
                            headers => $req->headers,
                            parameters => $req->parameters->mixed,
                            uploads => $req->uploads->mixed,
                            scheme => $req->scheme,
                            uri => $uri,
                            request_uri => $req->request_uri,
                            cookies => $req->cookies,
                            actions => {},
                            state_variables => {},
                            fragments => {},
                            arguments => {},
                            template_arguments => {} );

    # Grab content type and posted data, if any
    my $ct   = $req->content_type;
    my $data = $req->content;

    # Check it for something appropriate
    if ($data) {
        if ($ct =~ m{^text/x-json}) {
            return $self->from_data_structure(eval{Jifty::JSON::decode_json($data)});
        } elsif ($ct =~ m{^text/x-yaml}) {
            return $self->from_data_structure(eval{Jifty::YAML::Load($data)});
        }
    }

    # Fall back on using the straight HTTP arguments
    return $self->from_args;
}

sub from_data_structure {
    my $self = shift;
    my $data = shift;

    my $path = $data->{'path'};
    $path ||= $self->path || '/';

    $self->path( $path );
    $self->just_validating( $data->{validating} ) if $data->{validating};

    if ( ref $data->{continuation} eq "HASH" ) {
        # Back-compat
        $data->{continuation}{current} ||= $data->{continuation}{id};
        delete $data->{continuation}{id} if ($data->{continuation}{type} || "") eq "parent";

        $self->continuation_id( $data->{continuation}{current} );
        $self->future_continuation_id( $data->{continuation}{id} );
        $self->continuation_type( $data->{continuation}{type} );
        $self->continuation_path( $data->{continuation}{create} );
    }

    my %actions = %{ $data->{actions} || {} };
    for my $moniker ( keys %actions ) {
        my $a = $actions{$moniker};
        next unless ref $a eq "HASH";
        my %arguments;
        if ( exists $a->{fields} ) {
            for my $arg ( keys %{ $a->{fields} || {} } ) {
                if ( ref $a->{fields}{$arg} ) {

                    for my $type (qw/fallback value/) {
                        $arguments{$arg} = $a->{fields}{$arg}{$type}
                            if exists $a->{fields}{$arg}{$type};
                    }
                } else {
                    $arguments{$arg} = $a->{fields}{$arg};
                }
            }
        } elsif ( exists $a->{params} ) {
            %arguments = %{$a->{params}};
        }

        $self->add_action(
            moniker => $a->{moniker} || $moniker,
            class   => $a->{class},
            order   => $a->{order},
            active => exists $a->{active} ? $a->{active} : 1,
            arguments => \%arguments,
        );
    }

    my %variables
        = ref $data->{variables} eq "HASH" ? %{ $data->{variables} } : ();
    for my $v ( keys %variables ) {
        $self->add_state_variable( key => $v, value => $variables{$v} );
    }

    my %fragments
        = ref $data->{fragments} eq "HASH" ? %{ $data->{fragments} } : ();
    for my $f ( values %fragments ) {
        next unless ref $f eq "HASH";
        my $current = $self->add_fragment(
            name      => $f->{name},
            path      => $f->{path},
            arguments => $f->{args},
            wrapper   => $f->{wrapper} || 0,
            in_form   => $f->{in_form},
        );
        while ( ref $f->{parent} eq "HASH" and $f = $f->{parent} ) {
            $current = $current->parent(
                Jifty::Request::Fragment->new(
                    {   name      => $f->{name},
                        path      => $f->{path},
                        arguments => $f->{args},
                    }
                )
            );
        }
    }

    return $self;
}

sub from_args {
    my $self = shift;

    my %args = %{ $self->parameters };

    # Either CGI.pm or HTML::Mason should really deal with encoding for us.
    for my $k (keys %args) {
        my $val = $args{$k};
        if(ref($val) && ref($val) eq 'ARRAY') {
            $args{$k} = [
                map { Jifty::I18N->promote_encoding( $_, $self->content_type ) }
                  @$val
            ];
        } elsif(!ref($val)) {
            $args{$k} = Jifty::I18N->promote_encoding($val, $self->content_type);
        }
    }

    my $uploads = $self->uploads;
    for my $k ( keys %$uploads ) {
        my $val = $uploads->{$k};
        if ( ref $val eq 'ARRAY' ) {
            $args{$k} =
              [ map { Jifty::Web::FileUpload->new_from_plack($_) } @$val ];
        }
        else {
            $args{$k} = Jifty::Web::FileUpload->new_from_plack($val);
        }
    }
    my @splittable_names = grep /=|\|/, keys %args;
    for my $splittable (@splittable_names) {
        delete $args{$splittable};
        for my $newarg (split /\|/, $splittable) {
            # If your key has a '=', you may just lose
            my ($k, $v) = split /=/, $newarg, 2;
            $args{$k} = $v;
        }
    }
    return $self->from_webform( %args );
}

sub from_webform {
    my $self = shift;

    my %args = (@_);

    # Pull in all of the arguments
    $self->arguments(\%args);

    # Extract actions and state variables
    $self->from_data_structure($self->webform_to_data_structure(%args));

    return $self;
}

sub argument {
    my $self = shift;

    my $key = shift;
    if (@_) {
        my $value = shift;
        
        $self->arguments->{$key} = $value;

        # Continuation type is often undef, so give it a sane default
        # so we can use eq without warnings
        my $cont_type = $self->continuation_type || "";

        if ($key eq "J:VALIDATE") {
            $self->{validating} = $value;
        } elsif ($key eq "J:C") {
            $self->continuation_id($value);
        } elsif ($key eq "J:CALL" and $cont_type ne "return") {
            # J:CALL doesn't take preference over J:RETURN
            $self->future_continuation_id($value);
            $self->continuation_type("call");
        } elsif ($key eq "J:RETURN") {
            # J:RETURN trumps all
            $self->future_continuation_id($value);
            $self->continuation_type("return");
        } elsif ($key eq "J:PATH") {
            $self->continuation_path($value);
        } elsif ($key =~ /^J:V-(.*)/s) {
            $self->add_state_variable(key => $1, value => $value);
        } elsif ($key =~ /^J:A-(?:(\d+)-)?(.+)/s) {
            $self->add_action(moniker => $2, class => $value, order => $1, arguments => {}, active => 1);
        } else {
            # It's possibly a form field
            my ($t, $a, $m) = $self->parse_form_field_name($key);
            if ($t and $t eq "J:A:F" and $self->action($m)) {
                $self->action($m)->argument($a => $value);
                $self->action($m)->modified(1);
            }
        }
    }

    defined(my $val = $self->arguments->{$key}) or return undef;

    $val;
}

sub template_argument {
    my $self = shift;

    my $key = shift;
    $self->template_arguments({}) unless $self->template_arguments;
    if (@_) {
        my $value = shift;
        $self->template_arguments->{$key} = $value;
    }
    defined(my $val = $self->template_arguments->{$key}) or return undef;
    $val;
}

sub delete {
    my $self = shift;

    my $key = shift;
    $self->template_arguments({}) unless $self->template_arguments;
    if (exists $self->template_arguments->{$key}) {
        delete $self->template_arguments->{$key};
        return;
    }
    delete $self->arguments->{$key};
    if ($key =~ /^J:A-(?:(\d+)-)?(.+)/s) {
        $self->remove_action($2);
    } elsif ($key =~ /^J:A:F-(\w+)-(.+)/s and $self->action($2)) {
        $self->action($2)->delete($1);
        $self->action($2)->modified(1);
    } elsif ($key =~ /^J:V-(.*)/s) {
        $self->remove_state_variable($1);
    }
}

sub parse_form_field_name {
    my $self       = shift;
    my $field_name = shift;

    my ( $type, $argument, $moniker );
    if ( $field_name =~ /^(.*?)-(\w+)-(.*)$/ ) {
        $type     = $1;
        $argument = $2;
        $moniker  = $3;
    }

    else {
        return undef;
    }

    return ( $type, $argument, $moniker );
}

sub webform_to_data_structure {
    my $self = shift;
    my %args = (@_);


    my $data = {actions => {}, variables => {}};

    # Pass path through
    $data->{path} = $self->path;

    $data->{validating} = $args{'J:VALIDATE'} if defined $args{'J:VALIDATE'} and length $args{'J:VALIDATE'};

    # Continuations
    if ($args{'J:C'}) {
        $data->{continuation}{current} = $args{'J:C'};
    }

    if ($args{'J:CALL'} or $args{'J:RETURN'}) {
        $data->{continuation}{id} = $args{'J:RETURN'} || $args{'J:CALL'};
        $data->{continuation}{type} = "call"   if $args{'J:CALL'};
        $data->{continuation}{type} = "return" if $args{'J:RETURN'};
    }
    if ($args{'J:CREATE'}) {
        $data->{continuation}{create} = $args{'J:PATH'};
    }

    # Are we only setting some actions as active?
    my $active_actions;
    if (exists $args{'J:ACTIONS'}) {
        $active_actions = {};
        $active_actions->{$_} = 1 for split '!', $args{'J:ACTIONS'};
    } # else $active_actions stays undef


    # Mapping from argument types to data structure names;
    my %types = ("J:A:F:F" => "fallback", "J:A:F" => "value");

    # The "sort" here is key; it ensures that action registrations
    # come before action arguments
    for my $key (sort keys %args) {
        my $value = $args{$key};
        if( $key  =~ /^J:V-(.*)/s ) {
            # It's a variable
            $data->{variables}{$1} = $value;
        } elsif ($key =~ /^J:A-(?:(\d+)-)?(.+)/s) {
            # It's an action declatation
            $data->{actions}{$2} = {
                order   => $1,
                moniker => $2,
                class   => $value,
                active  => ($active_actions ? ($active_actions->{$2} || 0) : 1),
            };
        } else {
            # It's possibly a form field
            my ($t, $a, $m) = $self->parse_form_field_name($key);
            next unless $t and $types{$t} and $data->{actions}{$m};
            $data->{actions}{$m}{fields}{$a}{$types{$t}} = $value;
        }
    }

    return $data;
}

sub continuation {
    my $self = shift;

    $self->continuation_id(ref $_[0] ? $_[0]->id : $_[0])
      if @_;
 
    return undef unless $self->continuation_id;
    return Jifty->web->session->get_continuation($self->continuation_id);
}

sub future_continuation {
    my $self = shift;
    return undef unless defined $self->future_continuation_id;
    return Jifty->web->session->get_continuation($self->future_continuation_id);
}

sub save_continuation {
    my $self = shift;
    my $path;
    return unless $path = $self->continuation_path;

    # Clear out the create path so we don't ave the "create a
    # continuation" into the continuation!
    $self->continuation_path(undef);

    # Clear out the (locally-set) template arguments, which would
    # bloat the continuation, and can be entirely re-generated.
    $self->template_arguments({});

    my $c = Jifty::Continuation->new(
        request  => $self,
        response => Jifty->web->response,
        parent   => $self->continuation,
    );

    # Set us up with the new continuation
    Jifty->web->_redirect( 
                        $path
                      . ( $path =~ /\?/ ? "&" : "?" ) . "J:C="
                      . $c->id );
}

sub call_continuation {
    my $self = shift;
    return if $self->is_subrequest;
    return unless $self->continuation_type and $self->continuation_type eq "call" and $self->future_continuation;
    $self->log->debug("Calling continuation ".$self->future_continuation->id);
    return $self->future_continuation->call;
}

sub return_from_continuation {
    my $self = shift;
    return unless $self->continuation_type and $self->continuation_type eq "return" and $self->future_continuation;
    unless ($self->future_continuation->return_path_matches) {
        # This aborts via Jifty::Dispatcher::_abort -- but we're not
        # in the dispatcher yet, so it would go uncaught.  Catch it
        # here.
        eval {
            $self->future_continuation->call;
        };
        my $err = $@;
        warn $err if $err and $err ne "ABORT";
        return 1;
    }
    $self->log->debug("Returning from continuation ".$self->future_continuation->id);
    $self->future_continuation->return;
    return undef;
}

sub state_variables { 
    my $self = shift;
    return values %{$self->{'state_variables'}};
}

sub state_variable {
    my $self = shift;
    my $name = shift;
    return $self->{'state_variables'}{$name};
}

sub add_state_variable {
    my $self = shift;
    my %args = (
                 key => undef,
                 value => undef,
                 @_);

    my $state_var = Jifty::Request::StateVariable->new();
    
    for my $k (qw/key value/) {
        $state_var->$k($args{$k}) if defined $args{$k};
    } 
    $self->{'state_variables'}{$args{'key'}} = $state_var;

    return $state_var;
}

sub remove_state_variable {
    my $self = shift;
    my ($key) = @_;
    delete $self->{'state_variables'}{$key};
}

sub clear_state_variables {
    my $self = shift;

    $self->{'state_variables'} = {};
}

sub actions {
    my $self = shift;
    return sort {($a->order || 0) <=> ($b->order || 0)}
      values %{ $self->{'actions'} };
}

sub action {
    my $self = shift;
    my $moniker = shift;
    return $self->{'actions'}{$moniker};
} 

sub add_action {
    my $self = shift;
    my %args = (
        moniker => undef,
        class => undef,
        order => undef,
        active => 1,
        arguments => undef,
        has_run => 0,
        @_
    );

    my $action = $self->{'actions'}->{ $args{'moniker'} } || Jifty::Request::Action->new;

    for my $k (qw/moniker class order active has_run/) {
        $action->$k($args{$k}) if defined $args{$k};
    } 
    
    if ($args{'arguments'}) {
        for my $k (keys %{ $args{'arguments'} }) {
            $action->argument($k, $args{'arguments'}{$k});
        } 
    }

    $self->{'actions'}{$args{'moniker'}} = $action;

    return $action;
} 

sub clear_actions {
    my $self = shift;
    $self->{'actions'} = {};
}

sub remove_action {
    my $self = shift;
    my ($moniker) = @_;
    delete $self->{'actions'}{$moniker};
}

sub fragments {
    my $self = shift;

    return values %{$self->{'fragments'}}
}

sub fragment {
    my $self = shift;
    my $name = shift;
    return $self->{'fragments'}{$name};
}

sub add_fragment {
    my $self = shift;

    my %args = (
                name      => undef,
                path      => undef,
                arguments => undef,
                wrapper   => undef,
                in_form   => undef,
                @_
               );

    my $fragment = $self->{'fragments'}->{ $args{'name'} } || Jifty::Request::Fragment->new;

    for my $k (qw/name path wrapper in_form/) {
        $fragment->$k($args{$k}) if defined $args{$k};
    } 
    
    if ($args{'arguments'}) {
        for my $k (keys %{ $args{'arguments'} }) {
            $fragment->argument($k, $args{'arguments'}{$k});
        } 
    }

    $self->{'fragments'}{$args{'name'}} = $fragment;

    return $fragment;
}

sub do_mapping {
    my $self = shift;

    my %args = (
                request  => Jifty->web->request,
                response => Jifty->web->response,
                @_,
               );

    for (keys %{$self->arguments}) {
        my ($key, $value) = Jifty::Request::Mapper->map(destination => $_, source => $self->arguments->{$_}, %args);
        next unless $key ne $_ or not defined $value or $value ne $self->argument($_);
        delete $self->arguments->{$_};
        $self->argument($key => $value);
    }
    for ($self->state_variables) {
        my ($key, $value) = Jifty::Request::Mapper->map(destination => $_->key, source => $_->value, %args);
        next unless $key ne $_->key or not defined $value or $value ne $_->value;
        $self->remove_state_variable($_->key);
        $self->add_state_variable(key => $key, value => $value);
    }
}

sub is_subrequest {
    my $self = shift;
    return $self->_top_request ? 1 : undef;
}

sub top_request {
    my $self = shift;
    $self->_top_request(@_) if @_;
    return $self->_top_request || $self;
}

no Any::Moose;
__PACKAGE__->meta->make_immutable;


package Jifty::Request::Action;
use Any::Moose;

has 'moniker', is => 'rw';
has 'arguments', is => 'rw';
has 'class', is => 'rw';
has 'order', is => 'rw';
has 'active', is => 'rw';
has 'modified', is => 'rw';
has 'has_run', is => 'rw';

sub argument {
    my $self = shift;
    my $key  = shift;

    $self->arguments({}) unless $self->arguments;

    $self->arguments->{$key} = shift if @_;
    $self->arguments->{$key};
}

sub delete {
    my $self = shift;
    my $argument = shift;
    delete $self->arguments->{$argument};
}


no Any::Moose;
__PACKAGE__->meta->make_immutable;


package Jifty::Request::StateVariable;
use Any::Moose;

has 'key', is => 'rw';
has 'value', is => 'rw';

no Any::Moose;
__PACKAGE__->meta->make_immutable;

package Jifty::Request::Fragment;
use Any::Moose;

has 'name', is => 'rw';
has 'path', is => 'rw';
has 'wrapper', is => 'rw';
has 'in_form', is => 'rw';
has 'arguments', is => 'rw';
has 'parent', is => 'rw';

no Any::Moose;
__PACKAGE__->meta->make_immutable;

sub argument {
    my $self = shift;
    my $key  = shift;

    $self->arguments({}) unless $self->arguments;

    $self->arguments->{$key} = shift if @_;
    $self->arguments->{$key};
}

sub delete {
    my $self = shift;
    my $argument = shift;
    delete $self->arguments->{$argument};
}

no Any::Moose;
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
1;