perl5 implementation

2 files changed, 230 insertions, 0 deletions

diff --git a/p5/cpanfile b/p5/cpanfile
new file mode 100644
index 0000000..63031da
--- /dev/null
+++ b/p5/cpanfile
@@ -0,0 +1,8 @@
+# -*- mode: perl -*-
+requires perl => '5.026';
+requires 'Moo';
+requires 'experimental';
+requires 'HTTP::Response';
+requires 'IO::Async::Listener';
+requires 'IO::Async::Loop';
+requires 'Net::Async::HTTP::Server';
diff --git a/p5/mixed-server.pl b/p5/mixed-server.pl
new file mode 100644
index 0000000..698198c
--- /dev/null
+++ b/p5/mixed-server.pl
@@ -0,0 +1,222 @@
+#!/usr/bin/env perl
+use 5.026;
+use strict;
+use warnings;
+use experimental 'signatures';
+
+package Model {
+    use Moo;
+    use experimental 'signatures';
+
+    has _words => ( is => 'ro', default => sub { +{} } );
+
+    sub add_words($self,$words) {
+        ++$self->_words->{$_} for $words->@*;
+        return;
+    }
+
+    sub get_words($self) {
+        return +{ $self->_words->%* };
+    }
+
+    sub get_pairs($self) {
+        my $w = $self->_words;
+        return [ map { [ $_, $w->{$_} ] } keys $w->%* ];
+    }
+
+    sub get_most_common_pairs($self,$how_many) {
+        my $pairs = $self->get_pairs;
+        my @ranked_pairs = reverse sort { $a->[1] <=> $b->[1] } $pairs->@*;
+        splice @ranked_pairs,$how_many;
+        return \@ranked_pairs;
+    }
+};
+
+package View {
+    use Moo;
+    use experimental 'signatures';
+
+    sub words_from_input($self,$input) {
+        my @words = grep { length } split /\s+/, $input;
+        return \@words;
+    }
+
+    sub table_from_ranked_pairs($self,$ranked_pairs) {
+        return join "\n", map {
+            sprintf '%-15s %3d', $_->@*;
+        } $ranked_pairs->@*;
+    }
+};
+
+package HTTPController {
+    use Moo;
+    use experimental 'signatures';
+    use HTTP::Response;
+
+    has model => ( is => 'ro', required => 1 );
+    has view => ( is => 'ro', required => 1 );
+
+    sub on_request($self,$req) {
+        if ($req->method eq 'GET') {
+            $self->get_words($req);
+        }
+        elsif ($req->method eq 'POST') {
+            $self->post_words($req);
+        }
+    }
+
+    sub _text_response($self,$req,$text) {
+        my $response = HTTP::Response->new( 200 );
+        $response->add_content( "$text\n" );
+        $response->content_type( "text/plain" );
+        $response->content_length( length $response->content );
+
+        $req->respond($response);
+    }
+
+    sub get_words($self,$req) {
+        my $how_many = $req->query_param('n') || 10;
+
+        my $most_common_pairs = $self->model->get_most_common_pairs($how_many);
+
+        my $table = $self->view->table_from_ranked_pairs($most_common_pairs);
+
+        $self->_text_response($req,$table);
+        return;
+    }
+
+    sub post_words($self,$req) {
+        my $body = $req->body;
+
+        my $words = $self->view->words_from_input($body);
+
+        $self->model->add_words($words);
+
+        $self->_text_response($req,'ok');
+    }
+};
+
+package LineController {
+    use Moo;
+    use experimental 'signatures';
+
+    has model => ( is => 'ro', required => 1 );
+    has view => ( is => 'ro', required => 1 );
+
+    sub on_command($self,$stream,$command,$args_string) {
+        if ($command eq 'get') {
+            $self->get_words($stream,$args_string);
+        }
+        elsif ($command eq 'put') {
+            $self->put_words($stream,$args_string);
+        }
+        else {
+            $self->_reply($stream,"bad command, only 'get' and 'put'");
+        }
+    }
+
+    sub _reply($self,$stream,$text) {
+        $stream->write("$text\n");
+    }
+
+    sub get_words($self,$stream,$args_string) {
+        my $how_many = $args_string || 10;
+
+        my $most_common_pairs = $self->model->get_most_common_pairs($how_many);
+
+        my $table = $self->view->table_from_ranked_pairs($most_common_pairs);
+
+        $self->_reply($stream,$table);
+        return;
+    }
+
+    sub put_words($self,$stream,$args_string) {
+        my $words = $self->view->words_from_input($args_string);
+
+        $self->model->add_words($words);
+
+        $self->_reply($stream,'ok');
+    }
+};
+
+package TextServer {
+    use Moo;
+    use experimental 'signatures';
+    use IO::Async::Listener;
+
+    extends 'IO::Async::Notifier';
+
+    has listener => ( is => 'lazy', handles => ['listen'] );
+    sub _build_listener($self) {
+        my $listener = IO::Async::Listener->new(
+            on_stream => sub ($l,$stream,@) {
+                $stream->configure(
+                    on_read => sub($stream,$buffref,$eof) {
+                        while( $$buffref =~ s/^(.*\n)// ) {
+                            $self->handle_command($stream,$1);
+                        }
+                        return 0;
+                    },
+                );
+                $self->add_child($stream);
+            },
+        );
+        $self->add_child($listener);
+        return $listener;
+    }
+
+    has on_command => ( is => 'rwp' );
+    sub configure($self,%params) {
+        $self->_set_on_command(delete $params{on_command});
+        return $self->next::method(%params);
+    }
+
+    sub handle_command($self,$stream,$command_line) {
+        my ($command,$args) = split /\s+/,$command_line,2;
+        $self->on_command->($stream,$command,$args);
+        return;
+    }
+};
+
+use Net::Async::HTTP::Server;
+use IO::Async::Loop;
+
+my $model = Model->new();
+my $view = View->new();
+
+my $loop = IO::Async::Loop->new();
+
+my $httpcontroller = HTTPController->new({
+    model => $model,
+    view => $view,
+});
+
+my $httpserver = Net::Async::HTTP::Server->new(
+    on_request => sub($self,$req,@) {
+        $httpcontroller->on_request($req);
+    },
+);
+
+$loop->add( $httpserver );
+
+my $linecontroller = LineController->new({
+    model => $model,
+    view => $view,
+});
+my $textserver = TextServer->new(
+    on_command => sub($stream,$command,$args_string) {
+        $linecontroller->on_command($stream,$command,$args_string);
+    },
+);
+
+$loop->add( $textserver );
+
+$httpserver->listen(
+    addr => { family => "inet6", socktype => "stream", port => 8080 },
+)->retain;
+
+$textserver->listen(
+    addr => { family => "inet6", socktype => "stream", port => 2020 },
+)->retain;
+
+$loop->run;