OpenResty - General-purpose web service platform for web applications

  L<http://groups.google.com/group/openresty>

package OpenResty;

our $VERSION = '0.005012';

use strict;
use warnings;

#use Smart::Comments '####';
use Data::UUID;
use YAML::Syck ();
use JSON::XS ();
use Compress::Zlib;

use List::Util qw(first);
use Params::Util qw(_HASH _STRING _ARRAY0 _ARRAY _SCALAR);
use Encode qw(from_to encode decode);
use Data::Structure::Util qw( _utf8_on _utf8_off );
use DBI;
use OpenResty::QuasiQuote::SQL;

use OpenResty::SQL::Select;
use OpenResty::SQL::Update;
use OpenResty::SQL::Insert;

use OpenResty::Backend;
use OpenResty::Limits;

#use encoding "utf8";

use OpenResty::Util;
use Encode::Guess;

#$YAML::Syck::ImplicitUnicode = 1;
#$YAML::Syck::ImplicitBinary = 1;

our ($Backend, $BackendName);
our (%AccountFiltered, %UnsafeAccounts, %UnlimitedAccounts );
our $Cache;
our $UUID = Data::UUID->new;

# XXX we should really put this into the Action handler...
our %AllowForwarding;

our $JsonXs = JSON::XS->new->utf8->allow_nonref;

our %OpMap = (
    contains => 'like',
    gt => '>',
    ge => '>=',
    lt => '<',
    le => '<=',
    eq => '=',
    ne => '<>',
);

sub json_encode {
    _utf8_on($_[0]);
    local *_ = \( $JsonXs->encode($_[0]) );
    _utf8_off($_[0]);
    $_;
}

our %ext2dumper = (
    '.yml' => sub { _utf8_on($_[0]); YAML::Syck::Dump($_[0]); },
    '.yaml' => sub { _utf8_on($_[0]); YAML::Syck::Dump($_[0]); },
    '.js' => \&json_encode,
    '.json' => \&json_encode,
);

our %EncodingMap = (
    'cp936' => 'GBK',
    'utf8'  => 'UTF-8',
    'euc-cn' => 'GB2312',
    'big5-eten' => 'Big5',
);

our %ext2importer = (
    '.yml' => \&YAML::Syck::Load,
    '.yaml' => \&YAML::Syck::Load,
    '.js' => sub { $JsonXs->decode($_[0]) },
    '.json' => sub { $JsonXs->decode($_[0]) },
);

our $Ext = qr/\.(?:js|json|xml|yaml|yml)/;
#our $Dumper = 
our $Dumper = $ext2dumper{'.js'};
our $Importer = $ext2importer{'.js'};

sub version {
    (my $ver = $OpenResty::VERSION) =~ s{^(\d+)\.(\d{3})(\d{3})$}{join '.', int($1), int($2), int($3)}e;
    $ver;
}

# XXX more data types...
sub parse_data {
    #shift;
    my $data = $_[0]->{_importer}->($_[1]);
    _utf8_off($data);
    return $data;
}

sub new {
    my ($class, $cgi, $call_level) = @_;
    return bless {
        _cgi => $cgi,
        _client_ip => $cgi->remote_host(),
        _charset => 'UTF-8',
        _call_level => $call_level,
        _dumper => $Dumper,
        _importer => $Importer,
        _http_status => 'HTTP/1.1 200 OK',
        _unlimited => undef
    }, $class;
}

sub call_level {
    return $_[0]->{_call_level};
}

sub config {
    my $key = pop;
    $OpenResty::Config{$key};
}

sub cache {
    $OpenResty::Cache;
}

sub init {
    my ($self, $rurl) = @_;
    my $class = ref $self;
    my $cgi = $self->{_cgi};

    if (!$Backend || !$Backend->ping) {
        warn "Re-connecting the database...\n";
        eval { $Backend->disconnect };
        OpenResty::Dispatcher->init({});
    }

    # cache the results of CGI::Simple::url_param
    my (%url_params, %builtin_params);

    my $cgi2 = bless {}, 'CGI::Simple';
    $cgi2->_parse_params( $ENV{'QUERY_STRING'} );
    for my $param ($cgi2->param) {
        if ($param =~ /^[A-Za-z]\w*$/) {
            $url_params{$param} = $cgi2->param($param);
        } elsif ($param =~ /^_\w+/) {
            $builtin_params{$param} = $cgi2->param($param);
        }
    }

    $self->{_url_params} = \%url_params;
    $self->{_builtin_params} = \%builtin_params;
    $self->{_use_cookie}  = $self->builtin_param('_use_cookie') || 0;
    $self->{_session}  = $self->builtin_param('_session');

    my $charset = $self->builtin_param('_charset') || 'UTF-8';

    if ($charset =~ /^guess(?:ing)?$/i) {
        undef $charset;
        my $url  = $ENV{REQUEST_URI};
        $url =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
        ### Raw URL: $url
        my $data = $url .
            ($cgi->param('PUTDATA') || '') .
            ($cgi->param('POSTDATA') || '');
        ### $data
        my @enc = qw( UTF-8 GB2312 Big5 GBK Latin1 );
        for my $enc (@enc) {
            my $decoder = guess_encoding($data, $enc);
            if (ref $decoder) {
                $charset = $decoder->name;
                $charset = $EncodingMap{$charset} || $charset;
                last;
            }
        }
        if (!$charset) {
            die "Can't determine the charset of the input.\n";
        }
        ### $charset
    }
    $self->{'_charset'} = $charset;

    $self->{'_var'} = $self->builtin_param('_var');
    $self->{'_callback'} = $self->builtin_param('_callback');

    my $offset = $self->builtin_param('_offset');
    $offset ||= 0;
    if ($offset !~ /^\d+$/) {
        die "Invalid value for the \"offset\" param: $offset\n";
    }
    $self->{_offset} = $offset;

    my $limit = $self->builtin_param('_count');
    # limit is an alias for count
    if (!defined $limit) {
        $limit = $self->builtin_param('_limit');
    }
    if (!defined $limit) {
        $limit = $MAX_SELECT_LIMIT;
    } else {
        $limit ||= 0;
        if ($limit !~ /^\d+$/) {
            die "Invalid value for the \"_count\" param: $limit\n";
        }
        if ($limit > $MAX_SELECT_LIMIT) {
            die "Value too large for the _limit param: $limit\n";
        }
    }
    $self->{_limit} = $limit;

    my $http_meth = $ENV{REQUEST_METHOD};

    my $url = $$rurl;
    if ($charset ne 'UTF-8') {
        eval {
            #warn "HERE!";
            from_to($url, $charset, 'utf8');
        };
        warn $@ if $@;
    }
    #warn $url;

    $url =~ s{/+$}{}g;
    $url =~ s/\%2A/*/g;
    if ($url =~ s/$Ext$//) {
        my $ext = $&;
        # XXX obsolete
        $self->set_formatter($ext);
    } else {
        $self->set_formatter;
    }
    my $req_data;
    if ($http_meth eq 'POST') {
        $req_data = $cgi->param('POSTDATA');
        #die "Howdy! >>$req_data<<", $cgi->param('data'), "\n";
        #die $Dumper->(\%ENV);

        if (!defined $req_data) {
            $req_data = $cgi->param('data');
            if (!defined $req_data) {
                my $len = $ENV{CONTENT_LENGTH} || 0;
                if ($len > $POST_LEN_LIMIT) {
                    die "Exceeded POST content length limit: $POST_LEN_LIMIT\n";
                } else {
                    die "No POST content specified or no \"data\" field found.\n";
                }
            }
        } else {
            if (length($req_data) > $POST_LEN_LIMIT) {
                die "Exceeded POST content length limit: $POST_LEN_LIMIT\n";
            }
        }
    }
    elsif ($http_meth eq 'PUT') {
        $req_data = $cgi->param('PUTDATA');

        if (!defined $req_data) {
            $req_data = $cgi->param('data');
            if (!defined $req_data) {
                my $len = $ENV{CONTENT_LENGTH} || 0;
                if ($len > $POST_LEN_LIMIT) {
                    die "Exceeded PUT content length limit: $POST_LEN_LIMIT\n";
                } else {
                    die "No PUT content specified.\n";
                }
            }
        } else {
            if (length($req_data) > $POST_LEN_LIMIT) {
                die "Exceeded PUT content length limit: $POST_LEN_LIMIT\n";
            }
        }
    }

    if ($http_meth eq 'POST' and $url =~ s{^=/put/}{=/}) {
        $http_meth = 'PUT';
    } elsif ($http_meth =~ /^(?:GET|POST)$/ and $url =~ s{^=/delete/}{=/}) {
        $http_meth = 'DELETE';
    } elsif ($http_meth eq 'GET' and $url =~ s{^=/(post|put)/}{=/} ) {
        $http_meth = uc($1);
        $req_data = $self->builtin_param('_data');
        #$req_data = $Importer->($content);

        #warn "Content: ", $Dumper->($content);
        #warn "Data: ", $Dumper->($req_data);
    }

    #
    $$rurl = $url;
    $self->{'_url'} = $url;
    $self->{'_http_method'} = $http_meth;

    if ($req_data) {
        from_to($req_data, $charset, 'UTF-8');
        #warn "from_to is_utf8(req_data): ", Encode::is_utf8($req_data), "\n";
        $req_data = $self->parse_data($req_data);
    }

    $self->{_req_data} = $req_data;
}

sub fatal {
    my ($self, $s) = @_;
    #warn "fatal-ing...: $s\n";
    $self->error($s);
    $self->response();
}

sub error {
    my ($self, $s) = @_;
    my $lowlevel = ($s =~ s/^DBD::Pg::(?:db|st) \w+ failed:\s*//);
    #warn $s, "\n";
    if ($s =~ s{^\s*ERROR:\s+PL/Proxy function \w+.\w+\(\d+\): remote error:\s*}{}) {
        $s =~ s/\s+CONTEXT:  .*//s;
    }
    $s =~ s/^ERROR:\s*//g;
    if (!$OpenResty::Config{'frontend.debug'} && $lowlevel) {
        $s = 'Operation failed.';
    } else {
        $s =~ s/(.+) at \S+\/OpenResty\.pm line \d+(?:, <DATA> line \d+)?\.?$/Syntax error found in the JSON input: $1./;
        $s =~ s{ at \S+ line \d+\.?$}{}g;
        $s =~ s{ at \S+ line \d+, <\w+> line \d+\.?$}{}g;
    }
    #$s =~ s/^DBD::Pg::db do failed:\s.*?ERROR:\s+//;
    $self->{_error} .= $s . "\n";

}

sub data {
    $_[0]->{_data} = $_[1];
}

sub warning {
    $_[0]->{_warning} = $_[1];
}

sub http_status {
    $_[0]->{_http_status} = $_[1];
}

sub response {
    my $self = shift;
    if ($self->{_no_response}) { return; }
    my $charset = $self->{_charset};
    my $cgi = $self->{_cgi};
    my $cookie_data = $self->{_cookie};
    my @cookies;
    if ($cookie_data) {
        while (my ($key, $val) = each %$cookie_data) {
            push @cookies, CGI::Simple::Cookie->new(
                -name => $key, -value => $val
            );
        }
    }

    my $use_gzip = $OpenResty::Config{'frontend.use_gzip'} &&
        index($ENV{HTTP_ACCEPT_ENCODING} || '', 'gzip') >= 0;
    #warn "use gzip: $use_gzip\n";
    my $http_status = $self->{_http_status};
    if ($OpenResty::Server::IsRunning) {
        print "$http_status\r\n";
    } else {
        $http_status =~ s{^\s*HTTP/\d+\.\d+\s*}{};
        #warn "http_status: $http_status\n";
        binmode \*STDOUT;
        print "Status: $http_status\r\n";
    }
    #print "$http_status\r\n";
    # warn "$http_status";
    my $type = $self->{_type} || 'text/plain';
    #warn $s;
    my $str = '';
    if (my $bin_data = $self->{_bin_data}) {
        local $_;
        if (my $callback = $self->{_callback}) {
            chomp($bin_data);
            *_ = \"$callback($bin_data);\n";
        } else {
            *_ = \$bin_data;
        }

        print $cgi->header(
            -type => "$type" . ($type =~ /text/ ? "; charset=$charset" : ""),
            '-content-length' => length,
            @cookies ? (-cookie => \@cookies) : ()
        ), $_;
        return;
    }
    if (exists $self->{_error}) {
        $str = $self->emit_error($self->{_error});
    } elsif (exists $self->{_data}) {
        my $data = $self->{_data};
        if ($self->{_warning}) {
            $data->{warning} = $self->{_warning};
        }
        $str = $self->emit_data($data);
    }
    #die $charset;
    # XXX if $charset is 'UTF-8' then don't bother decoding and encoding...
    if ($charset ne 'UTF-8') {
        #warn "HERE!";
        eval {
            #$str = decode_utf8($str);
            #if (is_utf8($str)) {
                #} else {
                #warn "Encoding: $charset\n";
            from_to($str, 'utf8', $charset);
                #$str = decode('UTF-8', $str);
                #$str = encode($charset, $str);
                #}
        }; warn $@ if $@;
    }
    #warn $Dumper;
    #warn $ext2dumper{'.js'};
    $str =~ s/\n+$//s;
    if (my $var = $self->{_var}) {
        if ($self->{_dumper} eq $ext2dumper{'.js'}) {
            $str = "$var=$str;";
        } else {
            $str = "$var=" . OpenResty::json_encode($str) . ";";
        }
    } elsif (my $callback = $self->{_callback}) {
        if ($self->{_dumper} eq $ext2dumper{'.js'}) {
            $str = "$callback($str);";
        } else {
            $str = "$callback(" . OpenResty::json_encode($str) . ");";
        }
    }

    #my $meth = $self->{_http_method};
    if (my $LastRes = $OpenResty::Dispatcher::Handlers{last}) {
        $LastRes->set_last_response($self, $str);
    }
    #warn ">>>>>>>>>>>>Cookies<<<<<<<<<<<<<<: @cookies\n";
    #if (length($str) < 500 && $use_gzip) {
    #undef $use_gzip;
    #}
    {
        local $_;
        if ($use_gzip) {
            # compress the content part
            *_ = \(Compress::Zlib::memGzip($str));
        } else {
            *_ = \"$str\n";
        }

        print $cgi->header(
            -type => "$type" . ($type =~ /text/ ? "; charset=$charset" : ""),
            '-content-length' => length,
            $use_gzip ? ('-content-encoding' => 'gzip', '-accept-encoding' => 'Vary') : (),
            @cookies ? (-cookie => \@cookies) : ()
        ), $_;
    }
}

sub set_formatter {
    my ($self, $ext) = @_;
    $ext ||= '.js';
    #warn "Ext: $ext";
    $self->{_dumper} = $ext2dumper{$ext};
    $self->{_importer} = $ext2importer{$ext};
}

sub connect {
    my $self = shift;
    my $name = shift || $BackendName;
    $BackendName = $name;
    #warn "connect: $BackendName\n";
    $Backend = OpenResty::Backend->new($name);
    #warn "Backend: $Backend\n";
    #$Backend->select("");
}

sub emit_data {
    my ($self, $data) = @_;
    #warn "$data";
    return $self->{_dumper}->($data);
}

sub get_session {
    my ($self) = @_;
    my $session_from_cookie;
    my $call_level = $self->{_call_level};
    if ($call_level == 0) { # only check cookies on the toplevel call
        my $cookies = CGI::Cookie::XS->fetch;
        if ($cookies) {
            my $cookie = $cookies->{session};
            if ($cookie) {
                $self->{_session_from_cookie} =
                    $session_from_cookie = $cookie->[-1];
            }
        }
    }
    $self->{_session} || $session_from_cookie;
}

sub has_feed {
    my ($self, $feed) = @_;

    _IDENT($feed) or die "Bad feed name: $feed\n";
    my $sql = [:sql|
        select id
        from _feeds
        where name = $feed
        limit 1;
    |];
    my $ret;
    eval { $ret = $self->select($sql)->[0][0]; };
    return $ret;
}

sub has_role {
    my ($self, $role) = @_;
    return 'password' if $role eq 'Admin';
    return 'anonymous' if $role eq 'Public'; # shortcut...
    _IDENT($role) or
        die "Bad role name: ", $self->dump($role), "\n";


    my $user = $self->current_user;
    if (my $login_meth = $Cache->get_has_role($user, $role)) {
        #warn "has view cache HIT\n";
        #warn "from cache: $login_meth\n";
        return $login_meth;
    }

    my $sql = [:sql|
        select login
        from _roles
        where name = $role
        limit 1;
    |];
    my $ret = $self->select($sql);
    if ($ret && ref $ret) {
        $ret = $ret->[0][0];
        #warn "Returned: $ret\n";
        if ($ret) { $Cache->set_has_role($user, $role, $ret) }
        return $ret;
    }
    return undef;
    #warn "HERE!";
}

sub has_view {
    my ($self, $view) = @_;
    my $user = $self->current_user;

    _IDENT($view) or die "Bad view name: $view\n";

    if ($Cache->get_has_view($user, $view)) {
        #warn "has view cache HIT\n";
        return 1;
    }
    #warn "HERE!!! has_view: $view";
    my $sql = [:sql|
        select id
        from _views
        where name = $view
        limit 1;
    |];
    my $ret;
    eval { $ret = $self->select($sql)->[0][0]; };
    if ($ret) { $Cache->set_has_view($user, $view) }
    return $ret;
}

sub has_model {
    my ($self, $model) = @_;
    my $user = $self->current_user;

    _IDENT($model) or die "Bad model name: $model\n";
    if ($Cache->get_has_model($user, $model)) {
        #warn "has model cache HIT\n";
        return 1;
    }
    my $sql = [:sql|
        select c.oid
        from pg_catalog.pg_class c left join pg_catalog.pg_namespace n on n.oid = c.relnamespace
        where c.relkind in ('r','') and
              n.nspname = $user and
              pg_catalog.pg_table_is_visible(c.oid) and
              substr(c.relname,1,1) <> '_' and
              c.relname = $model
              limit 1
    |];

    my $ret;
    eval { $ret = $self->select($sql)->[0][0]; };
    if ($ret) { $Cache->set_has_model($user, $model) }
    return $ret;
}

sub has_user {
    my ($self, $user) = @_;
    if ($user && $Cache->get_has_user($user)) {
        #warn "Cache hit for has_user!";
        return 1;
    } else {
        my $res = $Backend->has_user($user);
        if ($res) {
            $Cache->set_has_user($user);
        }
        return $res;
    }
}

sub set_user {
    my ($self, $user) = @_;
    $Backend->set_user($user);
    $self->{_user} = $user;
}

sub current_user {
    my ($self) = @_;
    # warn "!!!", $self->{_user};
    $self->{_user};
}

sub do {
    my $self = shift;
    $Backend->do(@_);
}

sub select {
    my $self = shift;
    $Backend->select(@_);
}

sub last_insert_id {
    my $self = shift;
    $Backend->last_insert_id(@_);
}

sub emit_error {
    my $self = shift;
    my $msg = shift;
    $msg =~ s/\n+$//s;
    return $self->emit_data( { success => 0, error => $msg } );
}

sub set_role {
    my ($self, $role) = @_;
    $self->{_role} = $role;
}

sub get_role {
    $_[0]->{_role}
}

sub set_unlimited {
    $_[0]->{_unlimted} = shift;
}

sub is_unlimited {
    return $_[0]->{_unlimited};
}

sub url_param {
    if (@_ > 1) {
        $_[0]->{_url_params}->{$_[1]};
    } else {
        keys %{ $_[0]->{_url_params} };
    }
}

sub builtin_param {
    if (@_ > 1) {
        $_[0]->{_builtin_params}->{$_[1]};
    } else {
        keys %{ $_[0]->{_builtin_params} };
    }
}

1;
__END__