Changes

Perl Dancer

Web application development with Dancer

Perl Dancer Video course

Screencast recordings of this course are available vie Leanpub

Install Perl on Windows

• Strawberry Perl
• ActiveState Perl

Install Perl on Linux and Mac OSX

• perlbrew

• cpan.org

• cpan minus aka. cpanm

• local::lib

After following the instruction in the video add the following to ~/.bash_profile and open a new terminal:

export PATH=/opt/perl/bin:$PATH
eval $(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)

Install Editor

• VS Code
• Notepad++

Slides and Example

• Source of slides and examples

Install Dancer2

• cpanm

• Dancer2

• Install cpanm if you don't have it yet:

curl -L https://cpanmin.us | perl - App::cpanminus

• Install Dancer2:

cpanm Dancer2

Note, during the following pages I am going to use the word Dancer, however the name of the package we are using is Dancer2 and there is also a package called Dancer which was the first incarnation of this framework.

Hello World with Dancer

• get
• plackup
• to_app
• psgi

Create an empty directory where you can put your files.

Create a file called app.psgi in that directory with the following content.

The get keyword creates a so-called route that maps a URL path onto an anonymous subroutine. In this case we mapped the root page /.

Whatever the function returns will be returned to the browser. By default as HTML.

Then the to_app call basically provides a running application to plack which is a small web-server used for development purposes.

package App;
use Dancer2;

get '/' => sub {
    return 'Hello World!';
};

App->to_app;

• Run the application by cd-ing into its directory and then typing: plackup
• Then you can see it at http://localhost:5000

You might have noticed I did not add use strict and use warnings to this code. That's because Dancer2 loads both of them by default.

Testing Hello World of Dancer

• prove
• Test::More
• Plack::Test
• HTTP::Request::Common
• GET
• done_testing
• is

It is great that we can create a web page using Dancer, but if our application has any value to us then we will want to make sure it works as expected and that it continues to work even after some changes were made.

The fastest and cheapest way to do this to write tests. Unit-, integration-, acceptance tests, name them as you like, the important part is that they verify that the code works (and fails) as expected.

As this is such an integral part of writing code, we won't delay writing tests to the end of the project. We jump in right now.

Next to our app.psgi we create a file called test.t with the following content.

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);
my $res = $test->request(GET '/');

is $res->status_line, '200 OK', 'Status';
is $res->content, 'Hello World!', 'Content';

done_testing();

We can then run it by typing in prove -v test.t on the command line. this is going to be the output:

prove -v test.t

• Test::More
• Plack::Test
• Plack::Util
• HTTP::Response

test.t .. 
ok 1 - Status
ok 2 - Content
1..2
ok
All tests successful.
Files=1, Tests=2,  0 wallclock secs ( 0.02 usr  0.01 sys +  0.28 cusr  0.01 csys =  0.32 CPU)
Result: PASS

Showing the current time with Dancer

In the first example we saw how to show a simple page that does not change between executions.

We now go a small step further and show a page that will show a different output every time we access it.

Still nothing fancy, just showing the current date and time.

We could of course use the built-in time function or the also built-in localtime function, but I wanted to show something a bit nicer. So we are using the DateTime module to generate an object representing the current timestamp and then we use the strftime method to create a nice-looking timestamp.

Dancer-wise we don't do much, we just return the resulting string.

package App;
use Dancer2;
use DateTime;

get '/' => sub {
    my $dt = DateTime->now;
    return $dt->strftime( '%Y-%m-%d %H:%M:%S' );
};

App->to_app;

• Run plackup
• Access at http://127.0.0.1:5000/
• Output: 2020-07-22 11:11:55

Testing the current time with Dancer

• like
• qr

Just like in the first case, we would like to make sure our code works now and that it keeps working after we make changes. So we are going to write a test for this application as well.

However unlike in the previous case, here we cannot compare the results to a fixed value as the result will be different every time we run the test.

We could mock the time generating code of the Dancer application, but for this application it would be an overkill.

So instead of that we weaken our test and compare the results to a regular expression. So we don't know that the returned string is indeed the correct date and time, but at least we can know that it looks like one.

The like keyword of Test::More provides this testing functionality.

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);
my $res = $test->request(GET '/');

is $res->status_line, '200 OK', 'Status';
like $res->content, qr/\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d/, 'Content';

done_testing();

• Run as prove test.t

404 Not Found in Dancer

If a user tries to access a path that has no matching route defined then Dancer will return a default "404 Not Found" error page with the appropriate HTTP status code.

Later we'll see how can we change the content of this page to be branded to our site.

package App;
use Dancer2;

get '/' => sub {
    return 'Hello World!';
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');
    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'Hello World!', 'Content';
};

subtest not_found => sub {
    my $res = $test->request(GET '/first');
    is $res->status_line, '404 Not Found', 'Status';
    like $res->content, qr{<title>Error 404 - Not Found</title>};
    like $res->content, qr{Powered by <a href="http://perldancer.org/">Dancer2</a>};
};

done_testing();

500 Internal Server Error in Dancer

Mistakes can happen. There might be an exception somewhere in one of the routes. Don't worry though. If that happens Dancer will show a standard "500 Internal Error" page.

In our sample application the "/calc" route tries to make some calculation but a division by 0 error occures. This will trigger the "500 Internal Error".

Usually you don't plan to have certain URLs and certain input generate such error, so you probably will never write a test for this, but now, that we are showing it I put together one.

Later we'll see how can we change the content of this page to be branded to our site.

package App;
use Dancer2;

get '/' => sub {
    return 'Hello World!';
};

get '/calc' => sub {
    my $x = 1;
    my $y = 0;
    my $z = $x / $y;
    return 'OK';
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');
    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'Hello World!', 'Content';
};

subtest calc => sub {
    my $res = $test->request(GET '/calc');
    is $res->status_line, '500 Internal Server Error', 'Status';
    like $res->content, qr{<title>Error 500 - Internal Server Error</title>};
    like $res->content, qr{Powered by <a href="http://perldancer.org/">Dancer2</a>};
};


done_testing();

Process GET (query request) parameters in Dancer

• query_parameters
• GET
• form
• input
• submit

Once we know how to generate responses on-the-fly, probably the next things we would like to know is how to handle user-input. There are several ways to get input from a user of a web application. One of them is called query parameters that are sent in via GET requests. You are probably familiar with them as they appear in the URL of a page after a question mark. Like this:

echo?message=Foo+Bar

Anyone could type in such a URL, but usually you have a HTML form on your page and when the user clicks on the submit button then the browser sends in the data from the INPUT fields.

In our example the main route sends back a form with two INPUT elements. One of them is a text field the other one is the submit button. In the FORM tag you can see the path to which the data of the form will be submitted along with the name of the method: GET. (The latter is optional as GET is the default method.)

When the user visits the page, she will see an empty text box with a button that says "Echo". She can then type in some text (e.g. Foo Bar), click on the button and the browser will submit the content by accessing the URL echo?message=Foo+Bar.

In the Dancer application this will trigger the '/echo' route where using the get method of the query_parameters object we can receive the text sent in by the user. Then it is only a simple matter of sending it back to show what the user has typed in.

We are embedding the HTML in this code so it will be a one-file solution. In a bigger application we would use the template system and put the HTML in an external file.

package App;
use Dancer2;

get '/' => sub {
    return <<'HTML';
<form action="/echo" method="GET">
<input type="text" name="message">
<input type="submit" value="Echo">
</form>
HTML

};

get '/echo' => sub {
    my $message = query_parameters->get('message');
    return "You typed in $message";
};

App->to_app;

{% embed include file="src/img/echo_form.png)

• Run as plackup app.psgi and then access at http://localhost:5000/

Testing GET request with query parameters in Dancer

• GET
• like

Before we go on to the next feature let's make our usual step and write a test for the route handling the query parameters.

The main page now returns a chunk of HTML code. We could repeat the same HTML in our tests, but that would not give as any real value. We would be better off trying to look for some key elements in the page. In a real-world application that might be verifying if a certain HTML element is in the response or not. We won't be able to check equality here, so in this example I used the like function of Test::More to compare the content of the page to a regular expression.

The really interesting test is the "echo" subtest where we submit a request with a query string and then check if the result is as we expected. (The + sign represents a space.)

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<form action="/echo" method="GET">}, 'Content';
};

subtest echo => sub {
    my $res = $test->request(GET '/echo?message=Foo+Bar');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'You typed in Foo Bar', 'Content';
};


done_testing();

• Run as prove test.t

Process POST requests in Dancer

• body_parameters
• POST

In addition to the GET request the other common verb used in HTTP is POST. When you are implementing a REST API these verbs have real meaning, but when you are writing a user-facing web application the choice between GET and POST usually boils down to the question if you'd like the people to see the parameters passing in the URL or not.

With GET you'd have the visible query string, with POST the browser will send the same data in the body of the HTTP request invisible to the regular user. The data is still sent and if the server does not use https, the data is still readable by anyone listening on the wire.

You probably use GET if you'd like to allow your users to send the specific URL with the data to someone else or if you'd like to let them bookmark the page with the data. You'd use POST if you prefer they don't send the data to their friends as well.

In the code we had to make the following changes:

On the main page the form now sets the method to be POST.

The /echo route is now declared with the post keyword telling Dancer to execute this function when a POST request arrives at that route.

The data is extracted from the request in the body_parameters hash.

package App;
use Dancer2;

get '/' => sub {
    return <<'HTML';
<form action="/echo" method="POST">
<input type="text" name="message">
<input type="submit" value="Echo">
</form>
HTML

};

post '/echo' => sub {
    my $message = body_parameters->get('message');
    return "You typed in $message";
};

App->to_app;

• Run as plackup app.psgi and then access at http://localhost:5000/

Test POST requests in Dancer

Testing a POST request is as simple as testing a GET request.

In the test if the index page we need to expect the method="POST".

In the echo subtest we use the POST keyword to tell the client to send in a POST-request and we pass in the content of the body as an anonymous hash.

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<form action="/echo" method="POST">}, 'Content';
};

subtest echo => sub {
    my $res = $test->request(POST '/echo', { message => 'Foo Bar' });

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'You typed in Foo Bar', 'Content';
};


done_testing();

• Run as prove test.t

Exercise: Dancer Calculator

• Create a web application that has a form with 3 fields. Two text fields to accept two numbers and a drop-down list where the user can select one of the 4 basic math operations.

• When the user submits the for the server will calculate and display the results of the calculation.

• Also write tests that will verify the proper beahvior of the application

• You can create a solution using GET and a solution using POST. Just for fun.

Exercise: Dancer Counter

• Create an application that will show you a growing number on every visit.
• Can you make it so that the counter will continue even after we restarted the server?
• Write tests for the application.

Solution: Dancer Calculator - try 1

package App;
use Dancer2;

get '/' => sub {
    return <<'HTML';
<form action="/calc" method="POST">
<input type="text" name="x">
<select name="op">
<option value="add">+</option>
<option value="deduct">-</option>
<option value="div">/</option>
<option value="multiply">*</option>
</select>
<input type="text" name="y">
<input type="submit" value="Calculate">
</form>
HTML

};

post '/calc' => sub {
    my $x = body_parameters->get('x');
    my $y = body_parameters->get('y');
    my $op = body_parameters->get('op');
    my $result;

    $result = $x + $y if $op eq 'add';
    $result = $x - $y if $op eq 'deduct';
    $result = $x * $y if $op eq 'multiply';
    $result = $x / $y if $op eq 'div';

    return "The result is $result";
};

App->to_app;

Solution: Dancer Calculator - try 2

package App;
use Dancer2;

get '/' => sub {
    return <<'HTML';
<form action="/calc" method="POST">
<input type="text" name="x">
<select name="op">
<option value="add">+</option>
<option value="deduct">-</option>
<option value="div">/</option>
<option value="multiply">*</option>
</select>
<input type="text" name="y">
<input type="submit" value="Calculate">
</form>
HTML

};

post '/calc' => sub {
    my $x = body_parameters->get('x') || 0;
    my $y = body_parameters->get('y') || 0;
    my $op = body_parameters->get('op');
    my $result;

    if ($op eq 'div' and $y == 0) {
        status 'bad_request';
        return 'Cannot divide by 0';
    }
    $result = $x + $y if $op eq 'add';
    $result = $x - $y if $op eq 'deduct';
    $result = $x * $y if $op eq 'multiply';
    $result = $x / $y if $op eq 'div';

    return "The result is $result";
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<form action="/calc" method="POST">}, 'Content';
};

subtest calc => sub {
    my @cases = (
        [{ x => '10', y => '2', op => 'add'}, '12'],
        [{ x => '10', y => '2', op => 'multiply'}, '20'],
        [{ x => '10', y => '2', op => 'deduct'}, '8'],
        [{ x => '10', y => '2', op => 'div'}, '5'],
    );

    for my $case (@cases) {
        my $res = $test->request(POST '/calc', $case->[0]);
        is $res->status_line, '200 OK', 'Status';
        is $res->content, "The result is $case->[1]", 'Content';
    }


    my $res = $test->request(POST '/calc', { y => '0', op => 'div'});
    is $res->status_line, '400 Bad Request', 'Status';
    is $res->content, 'Cannot divide by 0', 'Content';
};


done_testing();

Solution: Dancer Calculator

package App;
use Dancer2;
use Scalar::Util qw(looks_like_number);

get '/' => sub {
    return <<'HTML';
<form action="/calc" method="POST">
<input type="text" name="x">
<select name="op">
<option value="add">+</option>
<option value="deduct">-</option>
<option value="div">/</option>
<option value="multiply">*</option>
</select>
<input type="text" name="y">
<input type="submit" value="Calculate">
</form>
HTML

};

post '/calc' => sub {
    my $x = body_parameters->get('x');
    my $y = body_parameters->get('y');
    my $op = body_parameters->get('op');

    my %valid_ops = map { $_ => 1 } qw(add deduct multiply div);

    if (not looks_like_number($x) or not looks_like_number($y) or not defined $op or not exists $valid_ops{$op}) {
        status 'bad_request';
        return 'Invalid input';
    }

    my $result;

    if ($op eq 'div' and $y == 0) {
        status 'bad_request';
        return 'Cannot divide by 0';
    }
    $result = $x + $y if $op eq 'add';
    $result = $x - $y if $op eq 'deduct';
    $result = $x * $y if $op eq 'multiply';
    $result = $x / $y if $op eq 'div';

    return "The result is $result";
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<form action="/calc" method="POST">}, 'Content';
};

subtest calc => sub {
    my @cases = (
        [{ x => '10', y => '2', op => 'add'}, '12'],
        [{ x => '10', y => '2', op => 'multiply'}, '20'],
        [{ x => '10', y => '2', op => 'deduct'}, '8'],
        [{ x => '10', y => '2', op => 'div'}, '5'],
    );

    for my $case (@cases) {
        my $res = $test->request(POST '/calc', $case->[0]);
        is $res->status_line, '200 OK', "Status x=$case->[0]{x} y=$case->[0]{y} op=$case->[0]{op}";
        is $res->content, "The result is $case->[1]", 'Content';
    }

    my @bad_cases = (
        [{ x => 'hello', y => '2', op => 'add'}, 'Invalid input'],
        [{ x => '', y => '2', op => 'add'}, 'Invalid input'],
        [{ y => '2', op => 'add'}, 'Invalid input'],
        [{ x => '2', y => 'world', op => 'add'}, 'Invalid input'],
        [{ x => '2', y => 'world', op => 'add'}, 'Invalid input'],
        [{ x => '2', y => '', op => 'add'}, 'Invalid input'],
        [{ x => '2', op => 'add'}, 'Invalid input'],
        [{ x => '10', y => '2', op => 'else'}, 'Invalid input'],
        [{ x => '10', y => '2', op => ''}, 'Invalid input'],
        [{ x => '10', y => '2'}, 'Invalid input'],
    );

    for my $case (@bad_cases) {
        my $res = $test->request(POST '/calc', $case->[0]);
        no warnings 'uninitialized';
        is $res->status_line, '400 Bad Request', "Status x=$case->[0]{x} y=$case->[0]{y} op=$case->[0]{op}";
        is $res->content, $case->[1], "Content x=$case->[0]{x} y=$case->[0]{y} op=$case->[0]{op}";
    }

    my $res = $test->request(POST '/calc', { x => '3', y => '0', op => 'div'});
    is $res->status_line, '400 Bad Request', 'Status';
    is $res->content, 'Cannot divide by 0', 'Content';
};


done_testing();

• HTTP status
• HTTP status codes

Solution: Dancer Counter - try 1

package App;
use Dancer2;

my $counter = 0;

get '/' => sub {
    $counter++;
    return $counter;
};

App->to_app;

Solution: Dancer Counter - try 2

package App;
use Dancer2;

use FindBin;
use File::Spec;

my $counter_file = File::Spec->catfile($FindBin::Bin, 'count.txt');

get '/' => sub {
    my $counter = 0;
    if (-e $counter_file) {
        if (open(my $fh, '<', $counter_file)) {
            $counter = <$fh>;
        }
    }
    $counter++;
    if (open(my $fh, '>', $counter_file)) {
        print $fh $counter;
    }
    return $counter;
};

App->to_app;

Solution: Dancer Counter

package App;
use Dancer2;

use FindBin;
use File::Spec;

my $counter_file = $ENV{COUNTER_TEST_FILE} || File::Spec->catfile($FindBin::Bin, 'count.txt');

get '/' => sub {
    my $counter = 0;
    if (-e $counter_file) {
        if (open(my $fh, '<', $counter_file)) {
            $counter = <$fh>;
        }
    }
    $counter++;
    if (open(my $fh, '>', $counter_file)) {
        print $fh $counter;
    }
    return $counter;
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use File::Temp qw(tempdir);
use File::Spec;

my $tmpdir = tempdir( CLEANUP => 1 );
$ENV{COUNTER_TEST_FILE} = File::Spec->catfile($tmpdir, 'cnt.txt');
diag $ENV{COUNTER_TEST_FILE};

my $app = Plack::Util::load_psgi './app.psgi';


subtest one => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1', 'Content';
};

subtest two => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '2', 'Content';
};



done_testing;

Dancer: show errors during development

package App;
use Dancer2;

set show_errors => $ENV{DANCER_ERROR};

get '/' => sub {
    return 'Hello World! <a href="/calc">calc</a>';

};

get '/calc' => sub {
    my $x = 1;
    my $y = 0;
    my $z = $x / $y;
    return 'OK';
};

App->to_app;

Dancer: Logging

package App;
use Dancer2;

set log => 'warning';

get '/' => sub {
    debug 'debug in main';
    info 'info in main';
    warning 'warning in main';
    error 'error in main';

    return 'Hello World!';
};

App->to_app;

• Dancer2::Core::Role::Logger

Dancer: Receive parameter in route

• param
• subtest

Each URL path can be mapped to a specific function, but we can also map a whole set of URLs to a single function and use parts of the URL path as parameters. For example we might want to show information about each user via their profile URL which is /user/ID where the ID is their user id. (For public URL it is probably a better idea to let them have a unique username and use that, but the basic concept is the same.)

We can set it up in the following way:

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/user/1">One</a><br>
        <a href="/user/2">Two</a><br>
        <a href="/user/foobar">foobar</a><br>
        <a href="/user">user</a><br>
        <a href="/user/">user/</a><br>
        <a href="/user/a/b">a/b</a><br>
        <a href="/user/-1">-1</a><br>
        <a href="/user/1.1">1.1</a><br>
    };
};

get '/user/:id' => sub {
    my $id = route_parameters->get('id');
    return $id;
};

App->to_app;

Dancer: Test parameter in route

If you have seen the previous examples then this test script won't surprise you.

The first subtest, called 'main', checks the main page of our web application. Because this is such a small example we check equality here using the is function.

The second subtest, called 'one', checks a value that can be a valid user-id.

The third subtest, called 'anything', checks some arbitrary string as a user-id. As you can see, in our current version this call is also expected to work and return the word "anything". That's right for this test as our current version of the application does not do any input validation.

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest one => sub {
    my $res = $test->request(GET '/user/1');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1', 'Content';
};

subtest anything => sub {
    my $res = $test->request(GET '/user/anything');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'anything', 'Content';
};


done_testing();

Dancer: Type-checking for the route parameters

• Int

Dancer allows us to use type-constraints to limit what values we accept in a route. For example we can tell it that the value must be an integer.

If the request does not match the expected type then that route does not match. If none of the routes match then we get a "404 Not Found" error as expected.

• Route-Handlers
• Types

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/user/1">One</a><br>
        <a href="/user/2">Two</a><br>
        <a href="/user/foobar">foobar</a><br>
        <a href="/user">user</a><br>
        <a href="/user/">user/</a><br>
        <a href="/user/a/b">a/b</a><br>
        <a href="/user/-1">-1</a><br>
        <a href="/user/1.1">1.1</a><br>
    };
};

get '/user/:id[Int]' => sub {
    my $id = route_parameters->get('id');
    return $id;
};

App->to_app;

Dancer: Test Type-checking for the route parameters

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest one => sub {
    my $res = $test->request(GET '/user/1');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1', 'Content';
};

subtest anything => sub {
    my $res = $test->request(GET '/user/anything');

    is $res->status_line, '404 Not Found', 'Status';
    like $res->content, qr{<title>Error 404 - Not Found</title>};
    like $res->content, qr{Powered by <a href="http://perldancer.org/">Dancer2</a>};
};

subtest minus_one => sub {
    my $res = $test->request(GET '/user/-1');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '-1', 'Content';
};


done_testing();

Dancer: Send 404 Not Found manually

• status
• not_found
• 404

If a user arrives to a URL path that is not associated with anything then Dancer will automatically return a 404 Not Found page. What if we have a catch-all route as in the previous example, where one part of the URL path is the ID of a user. What if then someone tries to access a page that does not belong to any user? Ideally the application would return a 404 Not Found page this time as well, but Dancer cannot automatically understand which ID is valid and when to send a 404 Not found page.

We have to send it manually. For this, before sending back the page we first call status 'not_found'; to tell Dancer to set the HTTP return status to 404. Then we can send back any HTML (or plain text). It will be displayed but the browser, or whatever client the user uses will be also told the status code is 404.

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/user/1">One</a><br>
        <a href="/user/2">Two</a><br>
        <a href="/user/foobar">foobar</a><br>
        <a href="/user">user</a><br>
        <a href="/user/">user/</a><br>
        <a href="/user/a/b">a/b</a><br>
        <a href="/user/-1">-1</a><br>
        <a href="/user/1.1">1.1</a><br>
    };
};

get '/user/:id' => sub {
    my $id = route_parameters->get('id');
    if (not valid_id($id)) {
        status 'not_found';
        return 'No such ID';
    }
    return $id;
};

App->to_app;

sub valid_id {
    my ($id) = @_;

    # Database lookup
    return if $id <= 0;
    return if $id >= 42;
    return 1;
}

Dancer: Test sending 404 Not Found manually

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest one => sub {
    my $res = $test->request(GET '/user/1');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1', 'Content';
};

subtest minus_one => sub {
    my $res = $test->request(GET '/user/-1');

    is $res->status_line, '404 Not Found', 'Status';
    is $res->content, 'No such ID', 'Content';
};

subtest no42 => sub {
    my $res = $test->request(GET '/user/42');

    is $res->status_line, '404 Not Found', 'Status';
    is $res->content, 'No such ID', 'Content';
};


done_testing();

Dancer: Optional route parameter

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/user/foobar">/user/foobar</a><br>
        <a href="/user/">/user/</a><br>
        <a href="/user">/user</a><br>
    };
};

get '/user/:username?' => sub {
    my $username = route_parameters->get('username');
    return 'undef' if not defined $username;
    return 'empty' if $username eq '';
    return $username;
};

App->to_app;

Dancer: Regex route parameter

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/user/foobar-42">foobar</a><br>
    };
};

get '/user/:username[StrMatch[qr{^[a-z]+-[0-9]+$}]]' => sub {
    my $username = route_parameters->get('username');
    return $username;
};

App->to_app;

Dancer: Wildcard route parameter

package App;
use Dancer2;
use Data::Dumper qw(Dumper);

get '/' => sub {
    return q{
        <a href="/user/foobar">/user/foobar</a><br>
        <a href="/user/foo/bar">/user/foo/bar</a><br>
    };
};

get '/user/**' => sub {
    my ($parts) = splat;
    return Dumper $parts;
};

App->to_app;

Redirect

• Redirection

package App;
use Dancer2;

get '/' => sub {
    return q{
        <html><head><title>Redirection</title></head><body>
        <h1>Main Page</h1>
        <a href="/go/home">Go home</a><br>
        <a href="/go/away">Go away</a><br>
        <a href="/go/elsewhere">Go elsewhere</a><br>
        </body></html>
    };
};

get '/home' => sub {
    return '<h1>Home</h1>Back to the <a href="/">main page</a>';
};


get '/go/:to' => sub {
    my $to = route_parameters->get('to');
    if ($to eq 'home') {
        redirect '/home';
    }
    if ($to eq 'away') {
        redirect 'https://perlmaven.com/';
    }
    return 'Invalid redirect';
};

App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest redirect => sub {
   my $res = $test->request(GET '/go/home');
   is $res->status_line, '302 Found', 'Status';
   is $res->headers->{location}, '/home';
};

subtest redirect_away => sub {
   my $res = $test->request(GET '/go/away');
   is $res->status_line, '302 Found', 'Status';
   is $res->headers->{location}, 'https://perlmaven.com/';
};

subtest redirect_other => sub {
   my $res = $test->request(GET '/go/other');
   is $res->status_line, '200 OK', 'Status';
   ok not exists $res->headers->{location};
   is $res->content, 'Invalid redirect';
};


done_testing();

Exercise: Route-based multi-counter

Create an application that will count from 1 up for every url like this: /apple and will show the list of counters when the / page is accessed.

Exercise: Random Redirect

• Create an application that has a list of URLs (they can be stored inside the program) and has a path that will randomly select one of the URLs and redirect the visitor to it.
• Write a test as well

Solution: Route-based multi-counter

package App;
use Dancer2;

use FindBin;
use File::Spec;

my $counter_file = $ENV{COUNTER_FILE} || File::Spec->catfile($FindBin::Bin, 'count.json');

get '/' => sub {
    my $html = '<h1>Counters</h1>';
    my $counter = read_data();
    if (%$counter) {
        $html .= "<ul>\n";
        for my $name (keys %$counter) {
            $html .= "<li>$name: $counter->{$name}</li>\n";
        }
        $html .= "</ul>\n";
    }
    return $html;
};

get '/:name' => sub {
    my $name = route_parameters->get('name');
    my $counter = read_data();

    $counter->{$name}++;
    if (open(my $fh, '>', $counter_file)) {
        print $fh encode_json($counter);
    }
    return $counter->{$name};
};


App->to_app;

sub read_data {
    my $counter = {};
    if (-e $counter_file) {
        if (open(my $fh, '<', $counter_file)) {
            local $/ = undef;
            my $json_str = <$fh>;
            $counter = decode_json($json_str);
        }
    }
    return $counter;
}

Solution: Testing Route-based multi-counter

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use File::Temp qw(tempdir);
use File::Spec;

my $tmpdir = tempdir( CLEANUP => 1 );
$ENV{COUNTER_FILE} = File::Spec->catfile($tmpdir, 'cnt.json');
diag $ENV{COUNTER_FILE};

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main_1 => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<h1>Counters</h1>}, 'title';
    unlike $res->content, qr{apple}, 'title';
    unlike $res->content, qr{peach}, 'title';
};

my @cases = (
    ['/apple' => '1'],
    ['/apple' => '2'],
    ['/apple' => '3'],
    ['/peach' => '1'],
    ['/apple' => '4'],
);

subtest count => sub {
    for my $case (@cases) {
        my $res = $test->request(GET $case->[0]);
        is $res->status_line, '200 OK', 'Status';
        is $res->content, $case->[1], 'one';
    }
};

subtest main_2 => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{<h1>Counters</h1>}, 'title';
    like $res->content, qr{<li>apple: 4</li>}, 'title';
    like $res->content, qr{<li>peach: 1</li>}, 'title';
};


done_testing;

Solution: Random Redirect

package App;
use Dancer2;

my @urls = qw(
    https://perlmaven.com/
    https://perl.org/
    https://perl.com/
    https://metacpan.org/
    https://www.perlfoundation.org/
    https://perlmonks.org/
);

get '/' => sub {
    return 'Get random <a href="/red">redirect</a>';
};

get '/red' => sub {
    my $num = int rand scalar @urls;
    #return $urls[$num];
    redirect $urls[$num];
};

App->to_app;

Solution: Testing Random Redirect

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');
    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'Get random <a href="/red">redirect</a>';
};

subtest redirect => sub {
    for (1..10) {
        my $res = $test->request(GET '/red');
        is $res->status_line, '302 Found', 'Status';
        ok exists $res->headers->{location};
        diag $res->headers->{location}
    }
};


done_testing();

Show configuration

package App;
use Dancer2;

get '/' => sub {
    my $config = config();
    return '<pre>' . to_json($config, {pretty => 1, canonical => 1}) . '</pre>';
};

App->to_app;

The default values in JSON format:

{
   "appdir" : "/home/gabor/work/slides/perl/examples/dancer/show-config",
   "apphandler" : "PSGI",
   "behind_proxy" : 0,
   "charset" : "",
   "content_type" : "text/html",
   "environment" : "development",
   "host" : "0.0.0.0",
   "logger" : "console",
   "no_server_tokens" : 0,
   "port" : "3000",
   "public_dir" : "/home/gabor/work/slides/perl/examples/dancer/show-config/public",
   "route_handlers" : [
      [
         "AutoPage",
         1
      ]
   ],
   "startup_info" : 1,
   "static_handler" : null,
   "template" : "Tiny",
   "traces" : 0,
   "views" : "/home/gabor/work/slides/perl/examples/dancer/show-config/views"
}

Session

package App;
use Dancer2;

#set session => 'YAML';

get '/' => sub {
    my $counter = session('counter');
    $counter++;
    session counter => $counter;
    return $counter;
};

App->to_app;

Test Session

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $web = Plack::Test->create($app);

subtest count => sub {
    my $res = $web->request(GET '/');
    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1';

    TODO: {
        local $TODO = 'Send cookie or it starts counting from 1 again';
        $res = $web->request(GET '/');
        is $res->content, '2';
    }

    my $cookie = $res->headers->{'set-cookie'};
    diag $cookie;
};


done_testing();

Test Session use cookie jar

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use HTTP::Cookies;

my $app = Plack::Util::load_psgi './app.psgi';

my $web = Plack::Test->create($app);
my $jar  = HTTP::Cookies->new;
my $base = 'http://localhost/';

subtest count => sub {
    my $res = $web->request(GET $base);
    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1';
    $jar->extract_cookies($res);
};

subtest count2 => sub {
    my $req = GET $base;
    $jar->add_cookie_header($req);

    my $res = $web->request($req);
    is $res->content, '2';
};


done_testing();

Test Session use cookie jar - 2 browsers

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use HTTP::Cookies;

my $app1 = Plack::Util::load_psgi './app.psgi';
my $web1 = Plack::Test->create($app1);
my $jar1  = HTTP::Cookies->new;

my $app2 = Plack::Util::load_psgi './app.psgi';
my $web2 = Plack::Test->create($app2);
my $jar2  = HTTP::Cookies->new;

my $base = 'http://localhost/';

subtest count1_1 => sub {
    my $res = $web1->request(GET $base);
    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1';
    $jar1->extract_cookies($res);
};

subtest count1_2 => sub {
    my $req = GET $base;
    $jar1->add_cookie_header($req);

    my $res = $web1->request($req);
    is $res->content, '2';
};

subtest count1_3 => sub {
    my $req = GET $base;
    $jar1->add_cookie_header($req);

    my $res = $web1->request($req);
    is $res->content, '3';
};

subtest count2_1 => sub {
    my $res = $web2->request(GET $base);
    is $res->status_line, '200 OK', 'Status';
    is $res->content, '1';
    $jar2->extract_cookies($res);
};

subtest count1_4 => sub {
    my $req = GET $base;
    $jar1->add_cookie_header($req);

    my $res = $web1->request($req);
    is $res->content, '4';
};


subtest count2_2 => sub {
    my $req = GET $base;
    $jar2->add_cookie_header($req);

    my $res = $web2->request($req);
    is $res->content, '2';
};




done_testing();

Test Session use Test::WWW::Mechanize::PSGI

use strict;
use warnings;

use Test::More;
use Test::WWW::Mechanize::PSGI;

my $app = Plack::Util::load_psgi './app.psgi';
my $mech = Test::WWW::Mechanize::PSGI->new( app => $app );

subtest count => sub {
    $mech->get_ok( '/' );
    $mech->content_is('1');

    $mech->get_ok( '/' );
    $mech->content_is('2');

    $mech->get_ok( '/' );
    $mech->content_is('3');
};


done_testing;

Test Session use Test::WWW::Mechanize::PSGI - 2 browsers

use strict;
use warnings;

use Test::More;
use Test::WWW::Mechanize::PSGI;

my $app1 = Plack::Util::load_psgi './app.psgi';
my $mech1 = Test::WWW::Mechanize::PSGI->new( app => $app1 );

my $app2 = Plack::Util::load_psgi './app.psgi';
my $mech2 = Test::WWW::Mechanize::PSGI->new( app => $app2 );

subtest count => sub {
    $mech1->get_ok( '/' );
    $mech1->content_is('1');

    $mech1->get_ok( '/' );
    $mech1->content_is('2');

    $mech1->get_ok( '/' );
    $mech1->content_is('3');

    $mech2->get_ok( '/' );
    $mech2->content_is('1');

    $mech1->get_ok( '/' );
    $mech1->content_is('4');

    $mech2->get_ok( '/' );
    $mech2->content_is('2');
};


done_testing;

Return JSON

package App;
use Dancer2;

get '/' => sub {
    return q{
        <a href="/api/1">api/1</a><br>
    };
};

get '/api/1' => sub {
    my %data  = (
        name => 'Dancer',
        language => 'Perl',
    );
    send_as JSON => \%data;
};

get '/api/2' => sub {
    my %data  = (
        name => 'Dancer2',
        language => 'Perl 7',
    );
    send_as JSON => \%data,
        { content_type => 'application/json; charset=UTF-8' };
};

get '/api/3' => sub {
    my %data  = (
        answer => 42,
    );
    push_header 'Content-type' => 'application/json';
    return encode_json( \%data );
};



App->to_app;

Testing Return JSON

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use JSON::MaybeXS qw(decode_json);

my $app = Plack::Util::load_psgi './app.psgi';

subtest main => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    is $res->headers->{'content-type'}, 'text/html; charset=UTF-8';
};

subtest one => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/api/1');

    is $res->status_line, '200 OK', 'Status';
    is_deeply decode_json($res->content), {
        name => 'Dancer',
        language => 'Perl',
    };
    is $res->headers->{'content-type'}, 'application/json';
};

subtest two => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/api/2');

    is $res->status_line, '200 OK', 'Status';
    is_deeply decode_json($res->content), {
        name => 'Dancer2',
        language => 'Perl 7',
    };
    is $res->headers->{'content-type'}, 'application/json; charset=UTF-8';
};

subtest three => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/api/3');

    is $res->status_line, '200 OK', 'Status';
    is_deeply decode_json($res->content), {
        answer => '42',
    };
    is $res->headers->{'content-type'}, 'application/json';
};




done_testing();

Dancer: before and after hooks

• hook

• before

• after

• var

• vars

• hooks

package App;
use Dancer2;
use Time::HiRes ();

get '/' => sub {
    my $db = vars->{'db'};
    return "DB: $db<br>PLACEHOLDER";
};

hook before => sub {
    var start_time => Time::HiRes::time;
    var db => 'database.json';
};

hook after => sub {
	my ($response) = @_;  # Dancer2::Core::Response
	my $start_time = vars->{'start_time'};
    debug $response;

	if ($start_time) {
		my $elapsed_time = Time::HiRes::time - $start_time;
        debug "Elapsed time: $elapsed_time";
        $response->{content} =~ s/PLACEHOLDER/Elapsed time: $elapsed_time/;
	}
	return;
};


App->to_app;

Dancer: testing before and after hooks

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';


subtest main => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{Elapsed}, 'Content';
};


done_testing();

DSL - Domain Specific Language

• DSL keywords

Upload a file

• upload

package App;
use Dancer2;

get '/' => sub {
    return '<a href="/upload">Upload</a>';
};


get '/upload' => sub {
    return q{
        <form action="/upload" method="POST" enctype="multipart/form-data">
        <input type="file" name="file">
        <input type="submit" name="submit" value="Upload">
        </form>
    }
};

post '/upload' => sub {
    my $data = request->upload('file');
    return 'Error' if not defined $data;

    my $dir = $ENV{UPLOAD_DIR} || path(config->{appdir}, 'uploads');
    mkdir $dir if not -e $dir;

    my $path = path($dir, $data->basename);
    if (-e $path) {
        return "'$path' already exists";
    }
    $data->link_to($path);
    return "Uploaded";
};

App->to_app;

Testing file Uploading

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use File::Temp qw(tempdir);
use Path::Tiny qw(path);

my $source_dir = tempdir( CLEANUP => 1 );
my $upload_dir = tempdir( CLEANUP => 1 );
$ENV{UPLOAD_DIR} = $upload_dir;

my $app = Plack::Util::load_psgi './app.psgi';
my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, '<a href="/upload">Upload</a>', 'Content';
};

subtest empty_upload => sub {
    my $res = $test->request(POST '/upload');
    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'Error', 'Content is error';

};

subtest upload => sub {
    my $filename = path($source_dir, 'abc.txt');
    my $original_content = "First row\nSecond row\n";
    path($filename)->spew($original_content);

    my $res = $test->request(POST '/upload', Content_Type => 'form-data',  Content => [ file  => [$filename, 'new.txt']]);
    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'Uploaded', 'Response Content';
    my $uploaded_file = path($upload_dir)->child('new.txt');
    ok -e $uploaded_file, 'file exists';
    my $uploaded_content = $uploaded_file->slurp;
    is $uploaded_content, $original_content, 'content was uploaded';
};


done_testing();

Exercise: Simple Single-user TODO list API

• Write a web application that serves JSON files. Create the following end-points:
• /api/add/Task to do will store the "Task to do" in a "database" and if successful it will return:

{"status": "ok", elapsed: "0.00003", id: "13124"}

• /api/list will return the list of all the items with their id: { "items": [ { "text": "Task to do", "id": "13124" }, { "text": "Other thing", "id" : "7238" }], elapsed: "0.0004", "status": "ok" }

• `/api/get/ID will return the given task from the database. Will return {"text": "Task to do", "id": "13124", "status": "ok"} if ID was 13124, will return {"status": "failure"} if failed. (e.g. the item was not in the database) set HTTP code to 404 if no such ID found.

• `/api/del/ID will remove the given task from the database. Will return {"status": "ok"} if managed to remove, will return {"status": "failure"} if failed. (e.g. the item was not in the database)

• elapsed is the time the operation took

• id is some unique id for the task

• status can be ok or failure

Solution: Simple Single-user TODO list API

• setting

• response_header

• encode_json

• decode_json

• Time::HiRes

package App;
use Dancer2;
use Time::HiRes ();

get '/' => sub {
    return 'TODO';
};

get '/api/add/:text' => sub {
    my $text = route_parameters->get('text');
    my $data = vars->{'data'};
    my $id = int(1000000 * Time::HiRes::time);
    #debug "ID: $id";
    $data->{$id} = $text;
    save_data(vars->{'db'}, $data);
    my %res = (
        status => 'ok',
        id => $id,
    );

    response_header 'Content-type' => 'application/json';
    return encode_json( \%res );
};

get '/api/get/:id' => sub {
    my $id = route_parameters->get('id');

    my %res;
    my $data = vars->{'data'};
    if (exists $data->{$id}) {
        %res = (
            id => $id,
            text => $data->{$id},
            status => "ok",
        );
    } else {
        status 'not_found';
        %res = (
            "id" => $id,
            "status" => "failure",
        );
    }

    response_header 'Content-type' => 'application/json';
    return encode_json( \%res );

};

get '/api/list' => sub {
    my $data = vars->{'data'};
    my %res = (
        status => 'ok',
        items => [ map { { id => $_, text => $data->{$_} } }  keys %$data ],
    );
    response_header 'Content-type' => 'application/json';
    return encode_json( \%res );
};

get '/api/del/:id' => sub {
    my $id = route_parameters->get('id');

    my %res;
    my $data = vars->{'data'};
    if (exists $data->{$id}) {
        %res = (
            id => $id,
            text => $data->{$id},
            status => "ok",
        );
        delete $data->{$id};
        save_data(vars->{'db'}, $data);
    } else {
        status 'not_found';
        %res = (
            "id" => $id,
            "status" => "failure",
        );
    }


    response_header 'Content-type' => 'application/json';
    return encode_json( \%res );
};


hook before => sub {
    var start_time => Time::HiRes::time;
    my $db = $ENV{TODO_DB} || 'todo.json';
    var db => $db;

    my $data = {};
    if (-e $db) {
        if (open (my $fh, '<', $db)) {
            local $/ = undef;
            my $json_str = <$fh>;
            $data = decode_json( $json_str);
        }
    }
    var data => $data;
};

hook after => sub {
	my ($response) = @_;
    #debug $response;

	my $start_time = vars->{'start_time'};

	if ($start_time) {
		my $elapsed_time = Time::HiRes::time - $start_time;
        #debug "Elapsed time: $elapsed_time";
        #debug $response->{content};
        if ($response->headers->{'content-type'} eq 'application/json') {
            my $json = decode_json($response->{content});
            $json->{elapsed} = $elapsed_time;
            #debug $json;
            $response->{content} = encode_json($json);
        }
	}
	return;
};

sub save_data {
    my ($db, $data) = @_;
    if (open (my $fh, '>', $db)) {
        print $fh encode_json( $data );
    }
}

App->to_app;

Solution: Simple Single-user TODO list API - testing

• Test::Deep
• Path::Tiny
• JSON::MaybeXS

use strict;
use warnings;

use Test::More;
use Test::Deep;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use JSON::MaybeXS qw(decode_json encode_json);
use File::Temp qw(tempdir);
use Path::Tiny qw(path);
use Storable qw(dclone);

my $tmpdir = tempdir( CLEANUP => 1 );
my $db_file = path($tmpdir)->child('todo.json');
$ENV{TODO_DB} = $db_file;
my $ELAPSED = qr{^\d+\.\d+$};

my %data = (
    "123" => "Hello world",
    "124" => "Something else",
    "738" => "A 3rd row",
);


my $app = Plack::Util::load_psgi './app.psgi';

subtest main => sub {
    my $test = Plack::Test->create($app);
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'TODO', 'content of HTML page';
};



subtest add_first => sub {
    my $test = Plack::Test->create($app);

    unlink $db_file if -e $db_file;

    my $text = 'First item';
    my $res_add = $test->request(GET "/api/add/$text");
    is $res_add->status_line, '200 OK', 'Status';
    diag $res_add->content;
    my $resp_add = decode_json($res_add->content);
    is $resp_add->{status}, "ok", 'status field exists';
    like $resp_add->{elapsed}, $ELAPSED, 'elapsed field looks good';
    my $id = $resp_add->{id};
    like $id, qr{^\d{8,}$}, 'id looks good';
    diag $id;

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, { $id => $text };
};

subtest add_more => sub {
    my $test = Plack::Test->create($app);

    path($db_file)->spew(encode_json(\%data));

    my $text = 'Another item';
    my $res_add = $test->request(GET "/api/add/$text");
    is $res_add->status_line, '200 OK', 'Status';
    diag $res_add->content;
    my $resp_add = decode_json($res_add->content);
    is $resp_add->{status}, "ok", 'status field exists';
    like $resp_add->{elapsed}, $ELAPSED, 'elapsed field looks good';
    my $id = $resp_add->{id};
    like $id, qr{^\d{8,}$}, 'id looks good';
    diag $id;

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, { %data, $id => $text };
};


subtest good_get => sub {
    my $test = Plack::Test->create($app);

    path($db_file)->spew(encode_json(\%data));

    my $id = '123';

    my $res_add = $test->request(GET "/api/get/$id");
    is $res_add->status_line, '200 OK', 'Status';
    diag $res_add->content;
    my $resp = decode_json($res_add->content);
    like $resp->{elapsed}, $ELAPSED, 'elapsed';
    delete $resp->{elapsed};
    is_deeply $resp, { "status" => "ok", text => $data{$id}, id => $id }, 'returned json data';

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, \%data;
};

subtest bad_get => sub {
    my $test = Plack::Test->create($app);

    path($db_file)->spew(encode_json(\%data));

    my $id = '42';

    my $res_add = $test->request(GET "/api/get/$id");
    is $res_add->status_line, '404 Not Found', 'Status';
    diag $res_add->content;
    my $resp = decode_json($res_add->content);
    like $resp->{elapsed}, $ELAPSED, 'elapsed';
    delete $resp->{elapsed};
    is_deeply $resp, { "status" => "failure", id => $id }, 'returned json data';

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, \%data;
};

subtest good_del => sub {
    my $test = Plack::Test->create($app);

    path($db_file)->spew(encode_json(\%data));

    my $id = '123';

    my $res_add = $test->request(GET "/api/del/$id");
    is $res_add->status_line, '200 OK', 'Status';
    diag $res_add->content;
    my $resp = decode_json($res_add->content);
    like $resp->{elapsed}, $ELAPSED, 'elapsed';
    delete $resp->{elapsed};
    is_deeply $resp, { "status" => "ok", id => $id, text => $data{$id} }, 'returned json data';

    my $json = decode_json(path($db_file)->slurp);
    my $reduced_data = dclone \%data;
    delete $reduced_data->{$id};
    is_deeply $json, $reduced_data;
};



subtest bad_del => sub {
    my $test = Plack::Test->create($app);

    path($db_file)->spew(encode_json(\%data));

    my $id = '42';

    my $res_add = $test->request(GET "/api/del/$id");
    is $res_add->status_line, '404 Not Found', 'Status';
    diag $res_add->content;
    my $resp = decode_json($res_add->content);
    like $resp->{elapsed}, $ELAPSED, 'elapsed';
    delete $resp->{elapsed};
    is_deeply $resp, { "status" => "failure", id => $id }, 'returned json data';

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, \%data;
};


subtest list => sub {
    my $test = Plack::Test->create($app);

    my @items = map { { id => $_, text => $data{$_} } }  keys %data;

    path($db_file)->spew(encode_json(\%data));

    my $res_add = $test->request(GET '/api/list');
    is $res_add->status_line, '200 OK', 'Status';
    diag $res_add->content;
    my $resp = decode_json($res_add->content);
    like $resp->{elapsed}, $ELAPSED, 'elapsed';
    delete $resp->{elapsed};
    cmp_deeply $resp, { "status" => "ok", items => bag @items }, 'returned json data';

    my $json = decode_json(path($db_file)->slurp);
    is_deeply $json, \%data;
};


done_testing();

Other HTTP verbs: PUT DELETE

package App;
use Dancer2;

get '/' => sub {
    return <<'HTML';
Try PUT /myput
HTML

};

put '/myput' => sub {
    my $message = body_parameters->get('message');
    return "got PUT with $message";
};

del '/mydel' => sub {
    my $message = query_parameters->get('message');
    return "got DELETE with $message";
};

patch '/mypatch' => sub {
    my $message = body_parameters->get('message');
    return "got PATCH with $message";
};

options '/myoptions' => sub {
    my $message = body_parameters->get('message');
    return "got OPTIONS with $message";
};


App->to_app;

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common qw(GET PUT DELETE PATCH OPTIONS);

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);

subtest main => sub {
    my $res = $test->request(GET '/');

    is $res->status_line, '200 OK', 'Status';
    like $res->content, qr{Try PUT /myput}, 'Content';
};

subtest myput => sub {
    my $res = $test->request(PUT '/myput', { message => 'Foo Bar' });

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'got PUT with Foo Bar', 'Content';
};

subtest mydel => sub {
    my $res = $test->request(DELETE '/mydel?message=Foo Bar');

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'got DELETE with Foo Bar', 'Content';
};

subtest mypatch => sub {
    my $res = $test->request(PATCH '/mypatch', { message => 'Foo Bar' });

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'got PATCH with Foo Bar', 'Content';
};

subtest myoptions => sub {
    my $res = $test->request(OPTIONS '/myoptions', { message => 'Foo Bar' });

    is $res->status_line, '200 OK', 'Status';
    is $res->content, 'got OPTIONS with Foo Bar', 'Content';
};



done_testing();

Dancer with Templates

Template Tiny

.
├── app.psgi
└── views
    └── main.tt

• The default templating engine is the Tiny engine Dancer2::Template::Tiny
• Template::Tiny

package App;
use Dancer2;

debug config->{template};

get '/' => sub {
    return template 'main.tt', {
        name => 'Perl Dancer',
        on => 0,
        languages => ['Perl', 'Python', 'Go'],
        perl => {
            creator => 'Larry Wall',
            release => 1987,
        },
        fruits => [
            {
                name => 'Apple',
                color => 'Red',
            },
            {
                name => 'Banana',
                color => 'Yellow',
            },
            {
                name => 'Peach',
                color => 'Peach',
            }
        ],
        template_name => config->{template},
    };
};

App->to_app;

Template Tiny - the template

<h1>Hello World</h1>
<h2>[% name %]</h2>

[% IF on %]
<h2>It is on</h2>
[% ELSE %]
<h2>It is off</h2>
[% END %]

[% IF languages %]
  <h2>Languages</h2>
  <ul>
    [% FOREACH lang IN languages %]
      <li>[% lang %]</li>
    [% END %]
  </ul>
[% END %]

<h2>Perl</h2>
Creator: [% perl.creator %]<br>
Release: [% perl.release %]<br>

<h2>Fruits</h2>
<table>
[% FOREACH fruit IN fruits %]
  <tr><td>[% fruit.name %]</td><td>[% fruit.color %]</td></tr>
[% END %]
</table>

<hr>
Template [% template_name %]

Template Toolkit

• Dancer2::Template::TemplateToolkit
• Template::Toolkit on MetaCPAN
• Template::Toolkit

---
template: "template_toolkit"

package App;
use Dancer2;

debug config->{template};

get '/' => sub {
    return template 'main.tt', {
        name => 'Perl Dancer',
        on => 0,
        languages => ['Perl', 'Python', 'Go'],
        perl => {
            creator => 'Larry Wall',
            release => 1987,
        },
        fruits => [
            {
                name => 'Apple',
                color => 'Red',
            },
            {
                name => 'Banana',
                color => 'Yellow',
            },
            {
                name => 'Peach',
                color => 'Peach',
            }
        ],
        template_name => config->{template},
    };
};

App->to_app;

<h1>Hello World</h1>
<h2>[% name %]</h2>

[% IF on %]
<h2>It is on</h2>
[% ELSE %]
<h2>It is off</h2>
[% END %]

[% IF languages %]
  <h2>Languages</h2>
  <ul>
    [% FOREACH lang IN languages %]
      <li>[% lang %]</li>
    [% END %]
  </ul>
[% END %]

<h2>Perl</h2>
Creator: [% perl.creator %]<br>
Release: [% perl.release %]<br>

<h2>Fruits</h2>
<table>
[% FOREACH fruit IN fruits %]
  <tr><td>[% fruit.name %]</td><td>[% fruit.color %]</td></tr>
[% END %]
</table>

<hr>
Template [% template_name %]

Template Toolkit change tags

---
template: "template_toolkit"
engines:
  template:
    template_toolkit:
      # Note: start_tag and end_tag are regexes
      start_tag: '<%'
      end_tag:   '%>'

package App;
use Dancer2;

debug config->{template};

get '/' => sub {
    return template 'main.tt', {
        name => 'Perl Dancer',
        on => 0,
        languages => ['Perl', 'Python', 'Go'],
        perl => {
            creator => 'Larry Wall',
            release => 1987,
        },
        fruits => [
            {
                name => 'Apple',
                color => 'Red',
            },
            {
                name => 'Banana',
                color => 'Yellow',
            },
            {
                name => 'Peach',
                color => 'Peach',
            }
        ],
        template_name => config->{template},
    };
};

App->to_app;

<h1>Hello World</h1>
<h2><% name %></h2>

<% IF on %>
<h2>It is on</h2>
<% ELSE %>
<h2>It is off</h2>
<% END %>

<% IF languages %>
  <h2>Languages</h2>
  <ul>
    <% FOREACH lang IN languages %>
      <li><% lang %></li>
    <% END %>
  </ul>
<% END %>

<h2>Perl</h2>
Creator: <% perl.creator %><br>
Release: <% perl.release %><br>

<h2>Fruits</h2>
<table>
<% FOREACH fruit IN fruits %>
  <tr><td><% fruit.name %></td><td><% fruit.color %></td></tr>
<% END %>
</table>

<hr>
Template <% template_name %>

Template Toolkit include

• INCLUDE

---
template: "template_toolkit"

package App;
use Dancer2;

get '/' => sub {
    return template 'main.tt', {
        name => 'Perl Dancer',
    };
};

App->to_app;

[% INCLUDE 'incl/header.tt' %]

<h1>main.tt - [% name %]</h1>

[% INCLUDE 'incl/footer.tt' %]

<!DOCTYPE html>
<html lang="en">
<head>
  <meta charset="utf-8">
  <meta name="viewport"
     content="width=device-width, initial-scale=1, user-scalable=yes">
  <title>[%- name -%]</title>
</head>
<body>
From header.tt
<hr>

<hr>
Footer
</body>
</html>

• Also include navigation etc.

Template Toolkit layout

---
template: "template_toolkit"
layout:   "general.tt"

package App;
use Dancer2;


get '/' => sub {
    return template 'main.tt', {
        title => 'Perl Dancer',
    };
};

App->to_app;

<h1>[% title %]</h1>

<h2>Hello Dancer</h2>

<!DOCTYPE html>
<html lang="en">
<head>
  <meta charset="utf-8">
  <meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes">
  <title>[% title %]</title>
</head>
<body>
From layout
<hr>
[% content %]
<hr>
Welcome to the main layout.
</body>
</html>

Showing the current time using templates

package App;
use Dancer2;
use DateTime;

get '/' => sub {
    my $dt = DateTime->now;
    return template 'page', {
        timestamp => $dt->strftime( '%Y-%m-%d %H:%M:%S' ),
    };
};

App->to_app;

<h1>Hello World!</h1>
[% timestamp %]

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);
my $res = $test->request(GET '/');

is $res->status_line, '200 OK', 'Status';
like $res->content, qr{<h1>Hello World!</h1>};
like $res->content, qr{\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d};

done_testing();

Showing an array

package App;
use Dancer2;

set 'template'     => 'template_toolkit';

get '/' => sub {
    my @planets = ('Mercury', 'Venus', 'Earth', 'Mars', 'Jupiter', 'Saturn');
    return template 'page', { planets => \@planets };
};

App->to_app;

<h1>Planets</h1>
<ul>
 [% FOR planet IN planets -%]
   <li>[% planet %]</li>
  [% END -%]
</ul>

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);
my $res = $test->request(GET '/');

is $res->status_line, '200 OK', 'Status';
like $res->content, qr{<h1>Planets</h1>};
like $res->content, qr{<li>Mercury</li>};

done_testing();

Showing Hash of Hashes

package App;
use Dancer2;

use Text::CSV;

set 'template'     => 'template_toolkit';

get '/' => sub {
    my %planets;

    my $filename = 'planets.csv';
    open my $fh, '<', $filename or die;
    my $csv = Text::CSV->new ({
        binary    => 1,
        auto_diag => 1,
    });
    my $header = $csv->getline($fh);
    $csv->column_names($header);
    while (my $row = $csv->getline_hr($fh)) {
        $row->{Distance} = delete $row->{"Distance (AU)"};
        $planets{ $row->{"Planet name"} } = $row;
    }
    return template 'page', { planets => \%planets };
};

App->to_app;

<h1>Planets</h1>

<table>
   <tr><th>Planet name</th><th>Distance (AU)</th><th>Mass</th></tr>
   [% FOR planet IN planets.keys.sort -%]
   <tr><td>[% planet %]</td><td>[% planets.$planet.Distance %]</td><td>[% planets.$planet.Mass %]</td></tr>
   [% END -%]
</table>


[% USE Dumper %]
<pre>
[% Dumper.dump(planets) %]
</pre>

{% embed include file="src/examples/dancer/show_hoh/planets.csv)

use strict;
use warnings;

use Test::More;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;

my $app = Plack::Util::load_psgi './app.psgi';

my $test = Plack::Test->create($app);
my $res = $test->request(GET '/');

is $res->status_line, '200 OK', 'Status';
like $res->content, qr{<h1>Planets</h1>};
like $res->content, qr{<td>Mercury</td>};

done_testing();

Dancer Skeleton

Create skeleton with dancer2 -a

dancer2 -a App::Skeleton

Creates the following structure

App-Skeleton/
├── bin
│   └── app.psgi
├── config.yml
├── cpanfile
├── environments
│   ├── development.yml
│   └── production.yml
├── lib
│   └── App
│       └── Skeleton.pm
├── Makefile.PL
├── MANIFEST
├── MANIFEST.SKIP
├── public
│   ├── 404.html
│   ├── 500.html
│   ├── css
│   │   ├── error.css
│   │   └── style.css
│   ├── dispatch.cgi
│   ├── dispatch.fcgi
│   ├── favicon.ico
│   ├── images
│   │   ├── perldancer-bg.jpg
│   │   └── perldancer.jpg
│   └── javascripts
│       └── jquery.js
├── t
│   ├── 001_base.t
│   └── 002_index_route.t
└── views
    ├── index.tt
    └── layouts
        └── main.tt

11 directories, 23 files

It also tells you to

cd App-Skeleton
plackup bin/app.psgi

To run the tests:

prove -l