Perl Weekly Challenge: Week 17

I returned from my trip this weekend but unfortunately I once again had to travel through my prime perl hacking time. Lucky for me, this weeks challenges were pretty easy so I was able to submit them on time. I even found time to do the optional API challenge.

Challenge 1:

Create a script to demonstrate Ackermann function. The Ackermann function is defined as below, m and n are positive number:

A(m, n) = n + 1                  if m = 0
A(m, n) = A(m - 1, 1)            if m > 0 and n = 0
A(m, n) = A(m - 1, A(m, n - 1))  if m > 0 and n > 0

Example expansions as shown in wiki page.

A(1, 2) = A(0, A(1, 1))
        = A(0, A(0, A(1, 0)))
        = A(0, A(0, A(0, 1)))
        = A(0, A(0, 2))
        = A(0, 3)
        = 4

This can be easily modeled by a recursive function with two special cases. (Plus an extra check to make sure the inputs are positive integers.) Here is the Perl5 version.

sub ackermann {
    my ($m, $n) = @_;

    if ($m < 0 || $n < 0) {
        return undef;
    }

    if ($m == 0) {
        return $n + 1;
    }

    if ($n == 0) {
        return ackermann($m - 1, 1);
    }

    return ackermann($m - 1, ackermann($m, $n - 1));
}

(Full code on Github.)

In Perl6 we can use the multi sub functionality for each case and parameter validation is built in.

multi sub ackermann (
    Int $m where { $m == 0 },
    Int $n where { $n >= 0 },
) {
    return $n + 1;
}

multi sub ackermann (
    Int $m where { $m >= 0 },
    Int $n where { $n == 0 },
) {
    return ackermann($m - 1, 1);
}

multi sub ackermann (
    Int $m where { $m >= 0 },
    Int $n where { $n >= 0 },
) {
    return ackermann($m - 1, ackermann($m, $n - 1));
}

(Full code on Github.)

Challenge 2:

Create a script to parse URL and print the components of URL. According to Wiki page, the URL syntax is as below:

scheme:[//[userinfo@]host[:port]]path[?query][#fragment]

For example: jdbc://user:password@localhost:3306/pwc?profile=true#h1

scheme:   jdbc
userinfo: user:password
host:     localhost
port:     3306
path:     /pwc
query:    profile=true
fragment: h1

This is my Perl5 version. I looked at RFC 3986 for the authoritative description of URL syntax. I think my code is pretty good at covering the spec. The biggest omission is support for IPv6 addresses. There are two regex features I made good use of. The /x flag let's you use whitespace in a regex which helps ease the "line noise" effect which is a common criticism of perl code. The ?<> construct is another readability aid. It lets you give matches a name instead of having to refer to them as $1, $2, $3... etc.

my $dec_octet = qr / \d | [1-9]\d | 1\d\d | 2[0-4]\d | 25[0-5] /x;
my $hex_octet = qr /  [ 0-9 A-F a-f ]{2} /x;
my $pct_encoded = qr/ % $hex_octet /x;
my $sub_delim  = qr/ [ ! $ & ' ( ) * + , ; = ] /x;
my $scheme = qr/ [ A-Z a-z 0-9 + - . ] /x;
my $unreserved = qr/ [ A-Z a-z 0-9 - . _ ~ ] /x;

my $ipv4 = qr/$dec_octet \. $dec_octet \. $dec_octet \. $dec_octet /x;
my $userinfo = qr/ $unreserved | $pct_encoded | $sub_delim | : /x;
my $pchar = qr/ $userinfo | @ /x;
my $path = qr / $pchar | \/ /x;
my $query_or_fragment = qr/ $pchar | \/ | \? /x;

my $url = shift;

$url =~ /
    (?<scheme>$scheme+)
    :
    (?:
        \/\/?
        (?: (?<userinfo> $userinfo+? ) @ )?
        (?<host> $ipv4 | $unreserved+ )
        (?: : (?<port> \d+ ) )?
    )?
    (?<path> $path+ )?
    (?: \? (?<query> $query_or_fragment+ ) )?
    (?: \# (?<fragment> $query_or_fragment+ ) )?
/msx;

for my $part (qw/ scheme userinfo host port path query fragment /) {
    say "$part: ", $+{$part} // q{};
}

(Full code on Github.)

The Perl6 version uses that languages grammar feature to make the code even cleaner. I find I still trip over some of the changes made to regex syntax in Perl6 sometimes but I am steadily getting better.

grammar URL {
    token TOP {
        <Scheme>
        ':'
        [
            '//'?
            [ <Userinfo> '@' ]?
            <Host>
            [ ':' <Port> ]?
        ]?
        <Path>?
        [ '?' <Query> ]?
        [ '#' <Fragment> ]?
    }

    token Scheme { <SchemeChar>+ }
    token Userinfo { <UserinfoChar>+ }
    token Host { <IPv4> | <Unreserved>+ }
    token Port { \d+ }
    token Path { <PathChar>+ }
    token Query { <QueryOrFragment>+ }
    token Fragment { <QueryOrFragment>+ }

    token SchemeChar { <[ A..Z a..z 0..9 + \- . ]> }
    token DecOctet { \d | <[1..9]>\d | 1\d\d | 2<[0..4]>\d | 25<[0..5]> }
    token HexOctet { <[ 0..9 A..F a..f ]> ** 2 }
    token IPv4 { <DecOctet> \. <DecOctet> \. <DecOctet> \. <DecOctet> }
    token PChar { <UserinfoChar> | '@' }
    token PathChar { <PChar> | '/' }
    token PctEncoded { \% <HexOctet> }
    token QueryOrFragment { <PChar> | \/ | \? }
    token SubDelim { <[ \! $ & \' \( \) * \+ \, \; \= ]> }
    token Unreserved { <[ A..Z a..z 0..9 \- . _ \~ ]> }
    token UserinfoChar { <Unreserved> | <PctEncoded> | <SubDelim> | ':' }
}

class URLAction {

    method Scheme($/) {
        say 'Scheme: ', $/.Str;
    }

    method Userinfo($/) {
        say 'Userinfo: ', $/.Str;
    }

    method Host($/) {
        say 'Host: ', $/.Str;
    }

    method Port($/) {
        say 'Port: ', $/.Str;
    }

    method Path($/) {
        say 'Path: ', $/.Str;
    }

    method Query($/) {
        say 'Query: ', $/.Str;
    }

    method Fragment($/) {
        say 'Fragment: ', $/.Str;
    }

}

(Full code on Github.)

Challenge 3:

Write a script to use Bhagavad Gita API. For more information about API, please visit page.

Having finished the first two tasks quickly I found I had some extra time and a Bhagavadgita API is an irresistable target so I did the third challenge, a first for me. But only in Perl5; Networking in Perl6 is still a little beyond my knowledge for now.

I used Moo as the OOP framework. While Perl5's builtin features would have been adequate for this task, Moo is more systematic yet not as heavyweight as e.g. Moose.

The first two classes model the Chapters and Verses which are returned by Bhagavadgita API calls.

package WWW::Bhagavadgita::Chapter;

has [qw/
        chapter_number
        chapter_summary
        name
        name_meaning
        name_translation
        name_transliterated
        verses_count
    /] => (
    is       => 'ro',
    required => 1
);

package WWW::Bhagavadgita::Verse;

has [qw/
        meaning
        text
        transliteration
        verse_number
        word_meanings
    /] => (
    is       => 'ro',
    required => 1
);

The main class models the API calls themselves. I used the LWP, HTTP::Request::Common and JSON modules to handle the actual network back and forth.

package WWW::Bhagavadgita;

Moo creates a constructor (new() method) for your class. By specifying client_id and client_secret as read-only (is => 'ro') and required (required => 1) members, I require them to be specified as parameters to the constructor. You get the id and secret by from your API dashboard after you register with bhagavadgita.io

has [qw/ client_id  client_secret /] => (
    is       => 'ro',
    required => 1
);

The Bhagavadgita API uses OAuth for authentication which means you have to acquire a special token before you can use any of the APIs. I store the token in a member because it can be used in multiple API calls providing they are made within 300 seconds after which the token expires and you have to get another one.

has token => (
    is => 'rw',
);

sub _get_token {
    my ($self) = @_;

    my $request = POST(
        'https://bhagavadgita.io/auth/oauth/token',
        [
            client_id     => $self->client_id,
            client_secret => $self->client_secret,
            grant_type    => 'client_credentials',
            scope         => 'verse chapter',
        ],
        Content_Type  => 'application/x-www-form-urlencoded',
    );

    my $response = $self->ua->request($request);
    if ($response->is_success) {
        my $results = decode_json($response->decoded_content);
        $self->token($results->{access_token});
    } else {
        $self->token(undef);
    }
}

Sometimes you might create a WWW::Bhagavadgita object but not use it straight away. In such a scenario it would not make sense to create heavyweight object members such as an LWP::UserAgent object until it was actually needed. Moo lets you delay construction of members by specifying them as is => 'lazy'. Also as creating these objects often requires more than just ->new(), it lets you provide a _build_*() method where you can initialize the member in a more elaborate way. For instance in this code, we not only create a new LWP::UserAgent object but set its' user agent identification string and a default HTTP header. Usually I make user agent strings the scripts name and version number but it appears that bhagavadgita.io blocks user agents it doesn't recognize so instead this script pretends to be cUrl.

has ua => (
    is  => 'lazy',
);

sub _build_ua {
    my ($self) = @_;

    my $ua = LWP::UserAgent->new(
        agent => "curl/7.58.0",
    );
    $ua->default_header( 'Accept' => 'application/json' );

    return $ua;
}

The actual client-server communication is centralized in the _call() method.

sub _call {
    my ($self, @args) = @_;
    my $url = 'https://bhagavadgita.io/api/v1/';

    if (scalar @args) {
        $url .= join(q{/}, @args);

    } else {
        return { error => "Not enough arguments." };

    }

    $self->token // $self->_get_token();
    if (!defined $self->token) {
        return { error => "Couldn't get auth token." };
    }

    my $request = GET($url,cauthorization => 'Bearer ' . $self->token);

    my $response = $self->ua->request($request);
    if ($response->is_success) {
        return { data => $response->decoded_content };
    } else {
        return { error => $response->status_line };
    }
}

The API methods. One thing I definitely must fix is that I only return undef in the event of an error instead of a descriptive message.

=head2 chapters()

Get all the 18 Chapters of the Bhagavad Gita.

Returns an array of L<WWW::Bhagavadgita::Chapter> objects or undef if there
has been an error.

=cut

sub chapters {
    my ($self) = @_;

    my $result = $self->_call('chapters');

    if (defined $result->{error}) {
        return undef;
    } else {
        my @chapters;
        for my $chapter (@{ decode_json( $result->{data} ) }) {
            push @chapters, WWW::Bhagavadgita::Chapter->new($chapter);
        };
        return @chapters;
    }
}

=head2 chapter($chapter_number)

Get a specific chapter from the Bhagavad Gita.

Returns a L<WWW::Bhagavadgita::Chapter> object or undef if there
has been an error.

=cut

sub chapter {
    my ($self, $chapter_number) = @_;

    my $result = $self->_call('chapters', $chapter_number);

    if (defined $result->{error}) {
        return undef;
    } else {
        return WWW::Bhagavadgita::Chapter->new(decode_json($result->{data}));
    }
}

=head2 verses()

Get all the verses in the Bhagavad Gita.

Returns an array of L<WWW::Bhagavadgita::Verse> objects or undef if there
has been an error.

=cut

sub verses {
    my ($self) = @_;

    my $result = $self->_call('verses');

    if (defined $result->{error}) {
        return undef;
    } else {
        my @verses;
        for my $verse (@{ decode_json( $result->{data} ) }) {
            push @verses, WWW::Bhagavadgita::Verse->new($verse);
        };
        return @verses;
    }
}

=head2 verse($chapter_number, $verse_number)

Get a particular verse from a chapter.

Returns a L<WWW::Bhagavadgita::Verse> object or undef if there
has been an error.

=cut

sub verse {
    my ($self, $chapter_number, $verse_number) = @_;

    my $result =
        $self->_call('chapters', $chapter_number, 'verses', $verse_number);

    if (defined $result->{error}) {
        return undef;
    } else {
        return WWW::Bhagavadgita::Verse->new(decode_json($result->{data}));
    }
}

=head2 chapter_verses($chapter_number)

Get all the Verses from a Chapter.

Returns an array of L<WWW::Bhagavadgita::Verse> objects or undef if there
has been an error.

=cut

sub chapter_verses {
    my ($self, $chapter_number, $verse_number) = @_;

    my $result =
        $self->_call('chapters', $chapter_number, 'verses');

    if (defined $result->{error}) {
        return undef;
    } else {
        my @verses;
        for my $verse (@{ decode_json( $result->{data} ) }) {
            push @verses, WWW::Bhagavadgita::Verse->new($verse);
        };
        return @verses;
    }
}

(Full code on Github.)

I am going to turn this script into a proper module and upload it to CPAN.