Merge pull request #1022 from hamiltont/kelp-1011

Kelp: Fix verification issues

frameworks/Perl/kelp/README.md

@@ -2,41 +2,38 @@
 
 * Perl 5.10+
 * MySQL 5.5
+* MongoDB
 * Wrk 2.0
 
 # Requirements
 
 * Kelp (install from CPAN)
 * Kelp::Module::JSON::XS (install from CPAN)
+* Kelp::Module::Template::Toolkit (install from CPAN)
 * DBD::mysql (install from CPAN)
 * Starman (install from CPAN)
+* MongoDB (install from CPAN)
 * nginx (if you want to front with nginx, nginx.conf provided)
 
 # Deployment
 
-## uWSGI (Recommended)
+## uWSGI (recommended)
 
-1. Create a configuration file. Bare bones example of app.ini:
+1. Make sure you have installed the psgi plugin.
+2. Deploy:
 
-    [uwsgi]
-    http-socket = :8080
-    psgi = app.pl
-
-2. Make sure you have installed the psgi plugin.
-
-3. Deploy with uwsgi
-
-    uwsgi --http-modifier1 5 --plugin psgi --ini app.ini
+    ./uwsgi --plugins psgi --init app.ini
 
 ## Plack + Starman
 
 1. Deploy via plackup
 
-    plackup -E production -s Starman --workers=5 -l /tmp/frameworks-benchmark.sock -a ./app.pl
+    plackup -E deployment -s Starman --workers=25 -l /tmp/frameworks-benchmark.sock -a ./app.pl
 
 2. If you want to front it with nginx, otherwise
 
-    plackup -E production -s Starman --port=8080 --workers=5 -a ./app.pl
-    
+    plackup -E deployment -s Starman --port=8080 --workers=25 -a ./app.pl
+
 # Expert contact
+
 @naturalist ([email protected])

frameworks/Perl/kelp/app.ini

@@ -0,0 +1,4 @@
+[uwsgi]
+http-socket = :8080
+psgi = app.pl
+disable-logging = True

frameworks/Perl/kelp/app.pl

@@ -1,77 +1,105 @@
 #!/usr/bin/env perl
+
 use Kelp::Less;
+use HTML::Escape 'escape_html';
+use MongoDB;
 use DBI;
+use utf8;
 
-my $dsn  = "dbi:mysql:database=hello_world;host=localhost;port=3306";
-my $dbh  = DBI->connect( $dsn, 'benchmarkdbuser', 'benchmarkdbpass', {} );
-my $sth  = $dbh->prepare("SELECT * FROM World WHERE id = ?");
-my $sth1 = $dbh->prepare("SELECT * FROM Fortune");
-my $sth2 = $dbh->prepare("UPDATE World SET randomNumber = ? WHERE id = ?");
-
-get '/populate' => sub {
-    $dbh->do("DELETE FROM World");
-    $dbh->do("DELETE FROM Fortune");
-    srand;
+module 'JSON::XS';
 
-    # Add some random numbers
-    my @rand = map {'(' . $_ . ',' . int(rand(10_000)) . ')'} (1 .. 10_000);
-    $dbh->do(q[INSERT INTO World (id, randomNumber) VALUES ] . join(',', @rand));
+my $mongo   = MongoDB::MongoClient->new( host => 'localhost', port => 27017 );
+my $mdb     = $mongo->get_database('hello_world');
+my $world   = $mdb->get_collection('World');
+my $fortune = $mdb->get_collection('Fortune');
 
-    # Add some fortunes
-    my @fortunes = map { '("' . 'x' x (int(rand(20)) + 1) . '")' } (1 .. 30);
-    $dbh->do(q[INSERT INTO Fortune (message) VALUES ] . join(',', @fortunes));
+my $dbh = DBI->connect(
+    "dbi:mysql:database=hello_world;host=localhost;port=3306",
+    'benchmarkdbuser',
+    'benchmarkdbpass',
+    { RaiseError => 0, PrintError => 0, mysql_enable_utf8 => 1 }
+);
 
-    "OK";
-};
+my @sth = map { $dbh->prepare($_) } (
+    "SELECT * FROM World WHERE id = ?",
+    "SELECT * FROM Fortune",
+    "UPDATE World SET randomNumber = ? WHERE id = ?",
+);
 
 get '/json' => sub {
-    my $self = shift;
     { message => 'Hello, World!' };
 };
 
-get '/db' => sub {
-    query(1);
+get '/db/?db' => sub {
+    my ( $self, $db ) = @_;
+    query( $db // 'mongo', 1 );
 };
 
-get '/queries' => sub {
-    my $self = shift;
-    my $count = $self->param('queries') || 1;
-    query( $count > 500 ? 500 : $count );
+get '/queries/?db' => sub {
+    my ( $self, $db ) = @_;
+    query( $db // 'mongo', $self->param('queries') );
 };
 
-get '/fortunes' => sub {
-    my $self = shift;
-    $sth1->execute();
-    my $fortunes = $sth1->fetchall_arrayref({});
-    $self->template( 'fortunes', { fortunes => $fortunes } );
+get '/fortunes/?db' => sub {
+    my ( $self, $db ) = @_;
+    $db //= 'mongo';
+    my @objects;
+    if ( $db eq 'mongo' ) {
+        my $cursor = $fortune->query( {} );
+        @objects = $cursor->all;
+    }
+    else {
+        $sth[1]->execute();
+        @objects = @{ $sth[1]->fetchall_arrayref( {} ) };
+    }
+    push @objects, { id => 0, message => "Additional fortune added at request time." };
+    fortunes( \@objects );
 };
 
-get '/updates' => sub {
-    my $self  = shift;
-    my $count = $self->param('queries');
-    my $arr   = query( $count > 500 ? 500 : $count );
+get '/update/?db' => sub {
+    my ( $self, $db ) = @_;
+    $db //= 'mongo';
+
+    my $arr = query( $db, $self->param('queries') );
+    $arr = [$arr] unless ref($arr) eq 'ARRAY';
     for my $row (@$arr) {
         $row->{randomNumber} = int( rand(10_000) ) + 1;
-        $sth2->execute( $row->{randomNumber}, $row->{id} );
+        if ( $db eq 'mongo' ) {
+            $world->update( { _id => $row->{id} },
+                { randomNumber => $row->{randomNumber} } );
+        }
+        else {
+            $row->{randomNumber} = int( rand(10_000) ) + 1;
+            $sth[2]->execute( $row->{randomNumber}, $row->{id} );
+        }
     }
 
-    $arr;
+    return $arr;
 };
 
 get '/plaintext' => sub {
-    my $self = shift;
-    $self->res->text->render('Hello, World!');
+    shift->res->text->render('Hello, World!');
 };
 
 run;
 
 sub query {
-    my $count = shift;
+    my ( $db, $count ) = @_;
+    $count //= 1;
+    $count = 1 if ( $count !~ /^\d+$/ || $count < 1 );
+    $count = 500 if $count > 500;
     my @response;
     for ( 1 .. $count ) {
         my $id = int rand 10000 + 1;
-        $sth->execute($id);
-        if ( my $row = $sth->fetchrow_hashref ) {
+        my $row;
+        if ( $db eq 'mongo' ) {
+            $row = $world->find_one( { _id => $id } );
+        }
+        else {
+            $sth[0]->execute($id);
+            $row = $sth[0]->fetchrow_hashref;
+        }
+        if ($row) {
             if ( $count == 1 ) {
                 return { id => $id, randomNumber => $row->{randomNumber} };
             }
@@ -83,3 +111,23 @@ sub query {
     }
     return \@response;
 }
+
+sub fortunes {
+    my ($objects) = @_;
+    my $res = q[<!DOCTYPE html><html><head><title>Fortunes</title></head>];
+    $res .= q[<body><table><tr><th>id</th><th>message</th></tr>];
+
+    for my $item ( sort { $a->{message} cmp $b->{message} } @$objects ) {
+        my $id = $item->{id};
+        my $message = escape_html( $item->{message} );
+
+        # HTML::Escape encodes apostrophe as &#39; because IE8 does not
+        # support &apos;. We forse an &apos; here in order to pass the
+        # test
+        $message =~ s/&#39/&apos/g;
+        $res .= "<tr><td>$id</td><td>$message</td></tr>";
+    }
+
+    $res .= q[</table></body></html>];
+    return $res;
+}

frameworks/Perl/kelp/benchmark_config

@@ -6,16 +6,39 @@
       "json_url": "/json",
       "db_url": "/db",
       "query_url": "/queries?queries=",
-      "fortune_url": "/fortune",
+      "fortune_url": "/fortunes",
       "update_url": "/update?queries=",
       "plaintext_url": "/plaintext",
       "port": 8080,
       "approach": "Realistic",
       "classification": "Fullstack",
-      "database": "MySQL",
+      "database": "SQL",
       "framework": "kelp",
       "language": "Perl",
-      "orm": "Full",
+      "orm": "Raw",
+      "platform": "Plack",
+      "webserver": "Starman",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "kelp",
+      "notes": "",
+      "versus": ""
+    },
+    "mongodb": {
+      "setup_file": "setup",
+      "json_url": "/json",
+      "db_url": "/db",
+      "query_url": "/queries/mongo?queries=",
+      "fortune_url": "/fortunes/mongo",
+      "update_url": "/update/mongo?queries=",
+      "plaintext_url": "/plaintext",
+      "port": 8080,
+      "approach": "Realistic",
+      "classification": "Fullstack",
+      "database": "MongoDB",
+      "framework": "kelp",
+      "language": "Perl",
+      "orm": "Raw",
       "platform": "Plack",
       "webserver": "Starman",
       "os": "Linux",

frameworks/Perl/kelp/conf/config.pl

@@ -1,3 +0,0 @@
-{
-    modules    => ['JSON::XS', 'Template'],
-}

frameworks/Perl/kelp/install.sh

@@ -2,5 +2,13 @@
 
 fw_depends perl nginx
 
-cpanm --notest --no-man-page Kelp DBI DBD::mysql Kelp::Module::JSON::XS Plack Starman
+cpanm --notest --no-man-page \
+    Kelp \
+    DBI \
+    DBD::mysql \
+    MongoDB \
+    Kelp::Module::JSON::XS \
+    HTML::Escape \
+    HTTP::Parser::XS \
+    Starman
 echo installed Kelp app dependencies

frameworks/Perl/kelp/setup.py

@@ -8,10 +8,10 @@ import getpass
 def start(args, logfile, errfile):
   setup_util.replace_text("kelp/app.pl", "localhost", args.database_host)
   setup_util.replace_text("kelp/nginx.conf", "USR", getpass.getuser())
-  setup_util.replace_text("kelp/nginx.conf", "server unix:.*\/FrameworkBenchmarks", "server unix:" + args.fwroot)
+  setup_util.replace_text("kelp/nginx.conf", "server unix:.*\/FrameworkBenchmarks/kelp", "server unix:" + args.troot)
 
   try:
-    subprocess.Popen("plackup -E production -s Starman --workers=" + str(args.max_threads) + " -l $TROOT/frameworks-benchmark.sock -a $TROOT/app.pl", shell=True, cwd="kelp", stderr=errfile, stdout=logfile)
+    subprocess.Popen("plackup -E deployment -s Starman --workers=" + str(args.max_threads) + " -l $TROOT/frameworks-benchmark.sock -a $TROOT/app.pl", shell=True, cwd="kelp", stderr=errfile, stdout=logfile)
     subprocess.check_call("sudo /usr/local/nginx/sbin/nginx -c $TROOT/nginx.conf", shell=True, stderr=errfile, stdout=logfile)
     return 0
   except subprocess.CalledProcessError:

frameworks/Perl/kelp/t/main.t

@@ -0,0 +1,56 @@
+use strict;
+use warnings;
+use utf8;
+
+use Kelp::Test;
+use Test::More;
+use Test::Deep;
+use HTTP::Request::Common;
+
+my $t = Kelp::Test->new( psgi => 'app.pl');
+my $world = { randomNumber => re(qr{^\d+$}), id => re(qr{^\d+$}) };
+
+subtest 'json' => sub {
+    $t->request( GET '/json' )->json_cmp( { message => 'Hello, World!' } );
+};
+
+subtest plaintext => sub {
+    $t->request( GET '/plaintext' )
+      ->content_type_is('text/plain')
+      ->content_is('Hello, World!');
+};
+
+subtest db => sub {
+    for my $uri (qw{/db /db/mongo}) {
+        $t->request( GET $uri )->json_cmp($world);
+    }
+};
+
+subtest queries => sub {
+    for my $uri (qw{/queries /queries/mongo}) {
+        $t->request( GET $uri )->json_cmp($world);
+        $t->request( GET "$uri?queries=3" )
+          ->json_cmp( [ $world, $world, $world ] );
+        $t->request( GET "$uri?queries=0" )->json_cmp($world);
+    }
+};
+
+subtest update => sub {
+    for my $uri (qw{/update /update/mongo}) {
+        $t->request( GET $uri )->json_cmp([$world]);
+        $t->request( GET "$uri?queries=3" )
+          ->json_cmp( [ $world, $world, $world ] );
+    }
+};
+
+subtest fortunes => sub {
+    for my $uri (qw{/fortunes /fortunes/mongo}) {
+        $t->request( GET $uri )
+          ->content_type_is('text/html')
+          ->content_like(qr{<script>})
+          ->content_like(qr{フレームワークのベンチマーク})
+          ->content_like(qr{Additional fortune added at request time.});
+    }
+};
+
+done_testing;

frameworks/Perl/kelp/views/fortunes.tt

@@ -1,10 +0,0 @@
-<!DOCTYPE html>
-<html>
-<head><title>Fortunes</title></head>
-<body>
-<table>
-<tr><th>id</th><th>message</th></tr>
-[% FOREACH item IN fortunes  %]<tr><td>[% item.id %]</td><td>[% item.message %]</td></tr>[% END %]
-</table>
-</body>
-</html>