410 lines
12 KiB
Perl
410 lines
12 KiB
Perl
#!/usr/bin/perl
|
|
#
|
|
# DW::Request::Base
|
|
#
|
|
# Methods that are the same over most or all DW::Request modules
|
|
#
|
|
# Authors:
|
|
# Andrea Nall <anall@andreanall.com>
|
|
#
|
|
# Copyright (c) 2010 by Dreamwidth Studios, LLC.
|
|
#
|
|
# This program is free software; you may redistribute it and/or modify it under
|
|
# the same terms as Perl itself. For a copy of the license, please reference
|
|
# 'perldoc perlartistic' or 'perldoc perlgpl'.
|
|
#
|
|
|
|
package DW::Request::Base;
|
|
|
|
use strict;
|
|
use Carp qw/ croak confess cluck /;
|
|
use CGI::Cookie;
|
|
use CGI::Util qw( unescape );
|
|
use LJ::JSON;
|
|
|
|
use fields (
|
|
'cookies_in',
|
|
'cookies_in_multi',
|
|
|
|
# If you use post_args, then you must not use content. If you use
|
|
# content, you must not use post_args. Mutually exclusive.
|
|
'content', # raw content of the request (POST only!)
|
|
'post_args', # hashref of POST arguments (form encoding)
|
|
'json_obj', # JSON object that was posted (application/json)
|
|
'uploads', # arrayref of hashrefs of uploaded files
|
|
|
|
# Query string arguments, every request might have these.
|
|
'get_args',
|
|
'msgs',
|
|
'msgkey',
|
|
);
|
|
|
|
sub new {
|
|
my $self = $_[0];
|
|
confess "This is a base class, you can't use it directly."
|
|
unless ref $self;
|
|
|
|
$self->{cookies_in} = undef;
|
|
$self->{cookies_in_multi} = undef;
|
|
$self->{post_args} = undef;
|
|
$self->{content} = undef;
|
|
$self->{get_args} = undef;
|
|
$self->{json_obj} = undef;
|
|
$self->{uploads} = undef;
|
|
$self->{msgs} = undef;
|
|
$self->{msgkey} = undef;
|
|
}
|
|
|
|
sub host {
|
|
return lc( $_[0]->header_in("Host") // "" );
|
|
}
|
|
|
|
sub cookie {
|
|
my DW::Request::Base $self = $_[0];
|
|
|
|
$self->parse( $self->header_in('Cookie') ) unless defined $self->{cookies_in};
|
|
my $val = $self->{cookies_in}->{ $_[1] } || [];
|
|
return wantarray ? @$val : $val->[0];
|
|
}
|
|
|
|
sub cookie_multi {
|
|
my DW::Request::Base $self = $_[0];
|
|
|
|
$self->parse( $self->header_in('Cookie') ) unless defined $self->{cookies_in_multi};
|
|
return @{ $self->{cookies_in_multi}->{ $_[1] } || [] };
|
|
}
|
|
|
|
sub add_cookie {
|
|
my DW::Request::Base $self = shift;
|
|
my %args = (@_);
|
|
|
|
confess "Must provide name" unless $args{name};
|
|
confess "Must provide value (try delete_cookie if you really mean this)"
|
|
unless exists $args{value};
|
|
|
|
# if the domain is just '.', remove it since that means 'current domain'.
|
|
# this is primarily needed for devcontainer since that uses localhost.
|
|
delete $args{domain} if defined $args{domain} && $args{domain} eq '.';
|
|
|
|
# we need to give all cookies the secure attribute on HTTPS sites
|
|
if ( $LJ::PROTOCOL eq "https" ) {
|
|
$args{secure} = 1;
|
|
}
|
|
else { # if we're not secure, hopefully we're in a development environment
|
|
$args{SameSite} = 'Lax' if $LJ::IS_DEV_SERVER;
|
|
|
|
# TODO: test and see if the site works as expected with
|
|
# SameSite=Lax turned on for all cookies - Lax prevents
|
|
# cross-domain POST requests but GETs are allowed. Not
|
|
# setting it at all is equivalent to SameSite=None, which
|
|
# newer browsers only allow if the secure attribute is set.
|
|
}
|
|
|
|
# extraneous parenthesis inside map {} needed to force BLOCK mode map
|
|
my $cookie = CGI::Cookie->new( map { ( "-$_" => $args{$_} ) } keys %args );
|
|
$self->err_header_out_add( 'Set-Cookie' => $cookie );
|
|
|
|
return $cookie;
|
|
}
|
|
|
|
sub delete_cookie {
|
|
my DW::Request::Base $self = shift;
|
|
my %args = (@_);
|
|
|
|
confess "Must provide name" unless $args{name};
|
|
|
|
$args{value} = '';
|
|
$args{expires} = "-1d";
|
|
|
|
return $self->add_cookie(%args);
|
|
}
|
|
|
|
# Per RFC, method must be GET, POST, etc. We don't allow lowercase or any other
|
|
# presentation of the method to count as a post.
|
|
sub did_post {
|
|
my DW::Request::Base $self = $_[0];
|
|
return $self->method eq 'POST';
|
|
}
|
|
|
|
# Returns an array of uploads that were received in this request. Each upload
|
|
# is a hashref of certain data: body, name.
|
|
sub uploads {
|
|
my DW::Request::Base $self = $_[0];
|
|
return $self->{uploads} if defined $self->{uploads};
|
|
|
|
my $body = $self->content;
|
|
return $self->{uploads} = []
|
|
unless $body && $self->method eq 'POST';
|
|
|
|
my $sep =
|
|
( $self->header_in('Content-Type') =~ m!^multipart/form-data;\s*boundary=(\S+)! )
|
|
? $1
|
|
: undef;
|
|
croak 'Unknown content type in upload.' unless defined $sep;
|
|
|
|
my @lines = split /\r\n/, $body;
|
|
my $line = shift @lines;
|
|
croak 'Error parsing upload, it looks invalid.'
|
|
unless $line eq "--$sep";
|
|
|
|
my $ret = [];
|
|
while (@lines) {
|
|
$line = shift @lines;
|
|
|
|
my %h;
|
|
while ( defined $line && $line ne "" ) {
|
|
$line =~ /^(\S+?):\s*(.+)/;
|
|
$h{ lc($1) } = $2;
|
|
$line = shift @lines;
|
|
}
|
|
while ( defined $line && $line ne "--$sep" ) {
|
|
last if $line eq "--$sep--";
|
|
$h{body} .= "\r\n" if $h{body};
|
|
$h{body} .= $line;
|
|
$line = shift @lines;
|
|
}
|
|
if ( $h{'content-disposition'} =~ /name="(\S+?)"/ ) {
|
|
$h{name} = $1 || $2;
|
|
push @$ret, \%h;
|
|
}
|
|
}
|
|
|
|
return $self->{uploads} = $ret;
|
|
}
|
|
|
|
# returns a Hash::MultiValue object containing the post arguments if this is a
|
|
# valid request, or it returns undef.
|
|
sub post_args {
|
|
my DW::Request::Base $self = $_[0];
|
|
return $self->{post_args} if defined $self->{post_args};
|
|
|
|
# Requires a POST with the proper content type for us to parse it, else just
|
|
# bail and return empty.
|
|
return Hash::MultiValue->new
|
|
unless $self->method eq 'POST'
|
|
&& $self->header_in('Content-Type') =~ m!^application/x-www-form-urlencoded(?:;.+)?$!;
|
|
|
|
return $self->{post_args} = $self->_string_to_multivalue( $self->content );
|
|
}
|
|
|
|
# returns a Hash::MultiValue of query string arguments
|
|
sub get_args {
|
|
my DW::Request $self = shift;
|
|
return $self->{get_args} if defined $self->{get_args};
|
|
|
|
my %opts = @_;
|
|
|
|
# We lowercase GET arguments because these are often typed by users, and
|
|
# that's nicer on them. This isn't always desired behavior, though.
|
|
# In particular, it confuses post_fields_by_widget in LJ::Widget.
|
|
|
|
my $lc = $opts{preserve_case} ? 0 : 1;
|
|
|
|
return $self->{get_args} =
|
|
$self->_string_to_multivalue( $self->query_string, lowercase => $lc );
|
|
}
|
|
|
|
# Returns a JSON object contained in the body of this request if and only if
|
|
# this request contains a JSON object.
|
|
sub json {
|
|
my DW::Request $self = $_[0];
|
|
return $self->{json_obj} if defined $self->{json_obj};
|
|
|
|
# Content type must start with "application/json" and may have a semi-colon
|
|
# followed by charset, etc. It must also be a POST.
|
|
return undef
|
|
unless $self->method eq 'POST'
|
|
&& $self->header_in('Content-Type') =~ m!^application/json(?:;.+)?$!;
|
|
|
|
# If they submit bad JSON, we want to ignore the error and not crash. Just
|
|
# let the caller know it wasn't a valid input.
|
|
my $obj;
|
|
eval { $obj = from_json( $self->content ); };
|
|
return undef if $@;
|
|
|
|
# Temporarily caches it, in case someone tries to ask for it again.
|
|
return $self->{json_obj} = $obj;
|
|
}
|
|
|
|
# FIXME: This relies on the behavior parse_args
|
|
# and the \0 seperated arguments. This should be cleaned
|
|
# up at the same point parse_args is.
|
|
sub _string_to_multivalue {
|
|
my ( $class, $input, %opts ) = @_;
|
|
my %gets = LJ::parse_args($input);
|
|
|
|
my @out;
|
|
foreach my $key ( keys %gets ) {
|
|
|
|
my @parts = defined $gets{$key} ? split( /\0/, $gets{$key} ) : '';
|
|
push @out, map { $opts{lowercase} ? lc $key : $key => $_ } @parts;
|
|
}
|
|
|
|
return Hash::MultiValue->new(@out);
|
|
}
|
|
|
|
# simply sets the location header and returns REDIRECT
|
|
sub redirect {
|
|
my %opts = @_;
|
|
my DW::Request $self = $_[0];
|
|
$self->header_out( Location => $_[1] );
|
|
return $opts{permanent} ? $self->MOVED_PERMANENTLY : $self->REDIRECT;
|
|
}
|
|
|
|
# Constants for message alert levels
|
|
sub DEFAULT { return INFO(); }
|
|
sub INFO { return 'info'; }
|
|
sub WARN { return 'warning'; }
|
|
sub WARNING { return WARN(); }; # alias because both are common usages.
|
|
sub ERROR { return 'error'; }
|
|
sub SUCCESS { return 'success'; }
|
|
my @MSG_LEVELS = ( DEFAULT(), INFO(), WARN(), ERROR(), SUCCESS() );
|
|
|
|
# Generate memcache key for session messages
|
|
sub msgkey {
|
|
my DW::Request $self = $_[0];
|
|
return $self->{msgkey} if defined $self->{msgkey};
|
|
|
|
my $cookie = $self->cookie('ljuniq');
|
|
if ($cookie) {
|
|
my ( $uniq, $ts ) = split( /:/, $self->cookie('ljuniq') );
|
|
$self->{msgkey} = "req_msgs:$uniq";
|
|
}
|
|
return $self->{msgkey};
|
|
}
|
|
|
|
# Gets session messages to display inline on pages
|
|
sub msgs {
|
|
my DW::Request $self = $_[0];
|
|
|
|
return $self->{msgs} if defined $self->{msgs};
|
|
my $msgkey = $self->msgkey;
|
|
$self->{msgs} = LJ::MemCache::get($msgkey) if $msgkey;
|
|
return $self->{msgs};
|
|
}
|
|
|
|
# Clear session messages from the request and from memcache.
|
|
# Should be used after messages have been displayed to user.
|
|
sub clear_msgs {
|
|
my DW::Request $self = $_[0];
|
|
|
|
my $msgkey = $self->msgkey;
|
|
LJ::MemCache::delete($msgkey) if $msgkey;
|
|
$self->{msgs} = undef;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# Add a session message to be displayed inline. Log level can be
|
|
# one of INFO, WARNING, ERROR, SUCCESS, or DEFAULT, or none.
|
|
sub add_msg {
|
|
my DW::Request $self = $_[0];
|
|
my $msg = $_[1];
|
|
my $level = $_[2];
|
|
|
|
croak "Invalid message level $level" if $level && !( grep { $level eq $_ } @MSG_LEVELS );
|
|
$msg =
|
|
$level ? { 'item' => $msg, 'level' => $level } : { 'item' => $msg, 'level' => DEFAULT() };
|
|
|
|
my $msgs = $self->msgs;
|
|
if ($msgs) {
|
|
push @$msgs, $msg;
|
|
}
|
|
else {
|
|
$msgs = [$msg];
|
|
}
|
|
|
|
my $msgkey = $self->msgkey;
|
|
LJ::MemCache::set( $msgkey, $msgs ) if $msgkey;
|
|
$self->{msgs} = $msgs;
|
|
return 1;
|
|
}
|
|
|
|
# Add a session message and redirect. This is a helper
|
|
# method that wraps add_msg and redirect in one call.
|
|
sub msg_redirect {
|
|
my DW::Request $self = $_[0];
|
|
my $msg = $_[1];
|
|
my $level = $_[2];
|
|
my $location = $_[3];
|
|
|
|
$self->add_msg( $msg, $level );
|
|
return $self->redirect($location);
|
|
}
|
|
|
|
# indicates that this request has been handled
|
|
sub OK { return 0; }
|
|
|
|
# HTTP status codes that we return in other methods
|
|
sub HTTP_OK { return 200; }
|
|
sub HTTP_CREATED { return 201; }
|
|
sub MOVED_PERMANENTLY { return 301; }
|
|
sub REDIRECT { return 302; }
|
|
sub NOT_FOUND { return 404; }
|
|
sub HTTP_GONE { return 410; }
|
|
sub SERVER_ERROR { return 500; }
|
|
sub HTTP_UNAUTHORIZED { return 401; }
|
|
sub HTTP_BAD_REQUEST { return 400; }
|
|
sub HTTP_UNSUPPORTED_MEDIA_TYPE { return 415; }
|
|
sub HTTP_SERVER_ERROR { return 500; }
|
|
sub HTTP_METHOD_NOT_ALLOWED { return 405; }
|
|
sub FORBIDDEN { return 403; }
|
|
|
|
# Unimplemented method block. These are things that the derivative classes must
|
|
# implement. In the future, it'd be nice to roll as many of these up to the base
|
|
# as we can, but that's in the post-Apache days.
|
|
sub header_out {
|
|
confess 'Unimplemented call on base class.';
|
|
}
|
|
*header_out_add = \&header_out;
|
|
*err_header_out = \&header_out;
|
|
*err_header_out_add = \&header_out;
|
|
*header_in = \&header_out;
|
|
*header_in_add = \&header_out;
|
|
*err_header_in = \&header_out;
|
|
*err_header_in_add = \&header_out;
|
|
*method = \&header_out;
|
|
|
|
sub call_response_handler {
|
|
|
|
# Default behavior is to call immediately
|
|
return $_[1]->();
|
|
}
|
|
|
|
#
|
|
# Following sub was copied from CGI::Cookie and modified.
|
|
#
|
|
# Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
|
|
# It may be used and modified freely, but I do request that this copyright
|
|
# notice remain attached to the file. You may modify this module as you
|
|
# wish, but if you redistribute a modified version, please attach a note
|
|
# listing the modifications you have made.
|
|
#
|
|
sub parse {
|
|
my DW::Request::Base $self = $_[0];
|
|
my %results;
|
|
my %results_multi;
|
|
|
|
my @pairs = split( "[;,] ?", defined $_[1] ? $_[1] : '' );
|
|
foreach (@pairs) {
|
|
$_ =~ s/\s*(.*?)\s*/$1/;
|
|
my ( $key, $value ) = split( "=", $_, 2 );
|
|
|
|
# Some foreign cookies are not in name=value format, so ignore
|
|
# them.
|
|
next unless defined($value);
|
|
my @values = ();
|
|
if ( $value ne '' ) {
|
|
@values = map unescape($_), split( /[&;]/, $value . '&dmy' );
|
|
pop @values;
|
|
}
|
|
$key = unescape($key);
|
|
$results{$key} ||= \@values;
|
|
push @{ $results_multi{$key} }, \@values;
|
|
}
|
|
|
|
$self->{cookies_in} = \%results;
|
|
$self->{cookies_in_multi} = \%results_multi;
|
|
}
|
|
|
|
1;
|