The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Plack::App::PgREST;
use methods;
use 5.008_001;
our $VERSION = '0.01';
use Plack::Builder;
use Router::Resource;
use parent qw(Plack::Component);
use Plack::Util::Accessor qw( dsn dbh pg_version );
use Plack::Request;
use IPC::Run3 qw(run3);
use JSON::PP qw(encode_json decode_json);

# maintain json object field order
use Tie::IxHash;
my $obj_parser_sub = \&JSON::PP::object;
*JSON::PP::object = sub {
	tie my %obj, 'Tie::IxHash';
	$obj_parser_sub->(\%obj);
};

sub n {
    my $n = shift;
    return $n unless $n;
    return undef if $n eq 'NaN';
    return int($n);
}

sub j {
    my $n = shift;
    return $n unless $n;
    return decode_json $n

}

method select($param, $args) {
    use Data::Dumper;
    my $req = encode_json({
        collection => $args->{collection},
        l => n($param->get('l')),
        sk => n($param->get('sk')),
        c => n($param->get('c')),
        s => j($param->get('s')),
        q => j($param->get('q')),
    });
    my $ary_ref = $self->{dbh}->selectall_arrayref("select postgrest_select(?)", {}, $req);
    if (my $callback = $param->get('callback')) {
        $callback =~ s/[^\w\[\]\.]//g;
        return [200, ['Content-Type', 'application/javascript; charset=UTF-8'],
            [
                ";($callback)($ary_ref->[0][0]);"
            ]
        ];
    }
    return [200, ['Content-Type', 'application/json; charset=UTF-8'], [$ary_ref->[0][0]]];
}

method _mk_func($name, $param, $ret, $body, $lang, $dont_compile) {
    my (@params, @args);
    $lang ||= 'plv8';
    while( my ($name, $type) = splice(@$param, 0, 2) ) {
        push @params, "$name $type";
        if ($type eq 'pgrest_json') {
            push @args, "JSON.parse($name)"
        }
        else {
            push @args, $name;
        }
    }

    my $compiled = '';
    if ($lang eq 'plls' && !$dont_compile) {
        $lang = 'plv8';

        $compiled = $self->{dbh}->selectall_arrayref("select jsapply(?,?)", {}, "LiveScript.compile", encode_json([$body, {bare =>  true}]))->[0][0];
        $compiled =~ s/;$//;
    }

    $compiled ||= $body;
    $body = "JSON.stringify((eval($compiled))(@{[ join(',', @args) ]}));";
#    $body = ($self->{pg_version} lt '9.2.0')
#        ? "JSON.stringify(($compiled)(@{[ join(',', map { qq!JSON.parse($_)! } @args) ]}));"
#        : "($compiled)(@{[ join(',', @args) ]})";
    return qq<
DO \$EOF\$ BEGIN

DROP FUNCTION IF EXISTS $name (@{[ join(',', @params) ]});
DROP FUNCTION IF EXISTS $name (@{[ join(',', map { /pgrest_json/ ? 'json' : $_ } @params) ]});

CREATE FUNCTION $name (@{[ join(',', @params) ]}) RETURNS $ret AS \$\$
return $body
\$\$ LANGUAGE $lang IMMUTABLE STRICT;

EXCEPTION WHEN OTHERS THEN END; \$EOF\$;
    >;
}

method bootstrap {

    ($self->{pg_version}) = $self->{dbh}->selectall_arrayref("select version()")->[0][0] =~ m/PostgreSQL ([\d\.]+)/;
    if ($self->{pg_version} ge '9.1.0') {
        $self->{dbh}->do(<<'EOF');
DO $$ BEGIN
    CREATE EXTENSION IF NOT EXISTS plv8;
EXCEPTION WHEN OTHERS THEN END; $$;
DO $$ BEGIN
    CREATE EXTENSION IF NOT EXISTS plls;
EXCEPTION WHEN OTHERS THEN END; $$;
EOF
    }
    else {
        # bootstrap with sql
        
    }
    
    
    if ($self->{pg_version} lt '9.2.0') {
        $self->{dbh}->do(<<'EOF');
DO $$ BEGIN
    CREATE FUNCTION json_syntax_check(src text) RETURNS boolean AS '
        try { JSON.parse(src); return true; } catch (e) { return false; }
    ' LANGUAGE plv8 IMMUTABLE;
EXCEPTION WHEN OTHERS THEN END; $$;

DO $$ BEGIN
    CREATE DOMAIN pgrest_json AS text CHECK ( json_syntax_check(VALUE) );
EXCEPTION WHEN OTHERS THEN END; $$;
EOF
    }
    else {
        $self->{dbh}->do(<<'EOF');
DO $$ BEGIN
    CREATE DOMAIN pgrest_json AS json;
EXCEPTION WHEN OTHERS THEN END; $$;
EOF
    }

    $self->{dbh}->do($self->_mk_func("jseval", [str => "text"], "text", << 'END', 'plv8'));
function(str) { return eval(str) }
END

    $self->{dbh}->do($self->_mk_func("jsapply", [str => "text", "args" => "pgrest_json"], "pgrest_json", << 'END', 'plv8'));
function (func, args) {
    return eval(func).apply(null, args);
}
END

# XXX: use File::ShareDir
    my $ls = do { local $/; open my $fh, '<', './share/livescript.js'; <$fh> };
    $ls =~ s/\$\$/\\\$\\\$/g;
    $self->{dbh}->do($self->_mk_func("lsbootstrap", [], "pgrest_json", << "END", 'plv8'));
function() { jsid = 0; LiveScript = $ls }
END
    $self->{dbh}->do("select lsbootstrap()");

    $self->{dbh}->do($self->_mk_func("jsevalit", [str => "text"], "text", << 'END', 'plls'));
(str) ->
    ``jsid = jsid || 0; ++jsid;``
    eval "jsid#jsid = " + str; "jsid#jsid"
END

    $self->{dbh}->do($self->_mk_func("postgrest_select", [req => "pgrest_json"], "pgrest_json", << 'END', 'plls'));

q = -> """
    '#{ "#it".replace /'/g "''" }'
"""
qq = ->
    it.replace /\.(\d+)/g -> "[#{ parseInt(RegExp.$1) + 1}]"
      .replace /^(\w+)/ -> "#{ RegExp.$1.replace /"/g '""' }"

walk = (model, meta) ->
    return [] unless meta?[model]
    for col, spec of meta[model]
        [compile(model, spec), col]

compile = (model, field) ->
    {$query, $from, $and, $} = field ? {}
    switch
    | $from? => """
        (SELECT COALESCE(ARRAY_TO_JSON(ARRAY_AGG(_)), '[]') FROM (SELECT * FROM #from-table
            WHERE #{ qq "_#model" } = #model-table."_id" AND #{
                switch
                | $query?                   => cond model, $query
                | _                         => true
            }
        ) AS _)
    """ where from-table = qq "#{$from}s", model-table = qq "#{model}s"
    | $? => cond model, $
    | typeof field is \object => cond model, field
    | _ => field

cond = (model, spec) -> switch typeof spec
    | \number => spec
    | \string => qq spec
    | \object =>
        # Implicit AND on all k,v
        ([ test model, qq(k), v for k, v of spec ].reduce (+++)) * " AND "
    | _ => it

test = (model, key, expr) -> switch typeof expr
    | <[ number boolean ]> => ["(#key = #expr)"]
    | \string => ["(#key = #{ q expr })"]
    | \object =>
        for op, ref of expr
            switch op
            | \$lt =>
                res = evaluate model, ref
                "(#key < #res)"
            | \$gt =>
                res = evaluate model, ref
                "(#key > #res)"
            | \$ =>
                "#key = #model-table.#{ qq ref }" where model-table = qq "#{model}s"
            | _ => throw "Unknown operator: #op"
    | \undefined => [true]

evaluate = (model, ref) -> switch typeof ref
    | <[ number boolean ]> => "#ref"
    | \string => q ref
    | \object => for op, v of ref => switch op
        | \$ => "#model-table.#{ qq v }" where model-table = qq "#{model}s"
        | \$ago => "'now'::timestamptz - #{ q "#v ms" }::interval"
        | _ => continue

order-by = (fields) ->
    sort = for k, v of fields
        "#{qq k} " + switch v
        |  1 => \ASC
        | -1 => \DESC
        | _  => throw "unknown order type: #q #k"
    sort * ", "
#module.exports = exports = { walk, compile }

({collection, l = 30, sk = 0, q, c, s, fo}) ->
    cond = compile collection, q if q
    query = "SELECT * from #collection"
    #plv8.elog WARNING, JSON.stringify q
    #plv8.elog WARNING, cond
    query += " WHERE #cond" if cond?
    [{count}] = plv8.execute "select count(*) from (#query) cnt"
    return { count } if c

    query += " ORDER BY " + order-by s if s
    do
        paging: { count, l, sk }
        entries: plv8.execute "#query limit $1 offset $2" [l, sk]
        query: cond
END
}

method to_app {
    unless ($self->{dbh}) {
        require DBIx::Connector;
        $self->{conn} = DBIx::Connector->new($self->{dsn}, '', '', {
          RaiseError => 1,
          AutoCommit => 1,
        });
        $self->{dbh} = $self->{conn}->dbh;
    }
    die unless $self->{dbh};
    $self->bootstrap;
    my $router = router {
        resource '/collections/{collection}' => sub {
            GET  { $self->select(Plack::Request->new($_[0])->parameters, $_[1]) };
        };
    };

    builder {
        sub { $router->dispatch(shift) };
    };
}

1;
__END__

=encoding utf-8

=for stopwords

=head1 NAME

Plack::App::PgREST - http://postgre.st/

=head1 SYNOPSIS

  use Plack::App::PgREST;

=head1 DESCRIPTION

Plack::App::PgREST is:

=over

=item

a JSON document store

=item

running inside PostgreSQL

=item

working with existing relational data

=item

capable of loading Node.js modules

=item

compatible with MongoLab's REST API

=back

=head1 AUTHOR

Chia-liang Kao E<lt>clkao@clkao.orgE<gt>
Audrey Tang E<lt>audreyt@audreyt.orgE<gt>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

=cut