basic console service

diff --git a/lib/App/Clifton/ConsoleService.pm b/lib/App/Clifton/ConsoleService.pm
index 0bb27a2..4ca0e73 100644 (file)
--- a/lib/App/Clifton/ConsoleService.pm
+++ b/lib/App/Clifton/ConsoleService.pm
@@ -1,7 +1,56 @@
 package App::Clifton::ConsoleService;
 
+use Log::Contextual qw(:log);
+use aliased 'App::Clifton::ConsoleService::Session';
+use IO::Async::Listener;
+use IO::Socket::UNIX;
+use Scalar::Util qw(weaken);
 use Moo;
 
 extends 'App::Clifton::Service';
 
+has socket_location => (is => 'ro', default => sub { 'clifton.sock' });
+
+has $_ => (is => 'lazy') for qw(listener session socket);
+
+sub _build_socket {
+  my ($self) = @_;
+  my $location = $self->socket_location;
+  unlink($location) if -e $location;
+  IO::Socket::UNIX->new(
+    Local => $location,
+    Listen => 1,
+  ) or die "Cannot make UNIX socket - $!\n";
+}
+
+sub _build_listener {
+  my ($self) = @_;
+  $self->_new_child('IO::Async::Listener', {
+    on_stream => $self->_replace_weakself('_open_connection'),
+    handle => $self->socket,
+  });
+}
+
+sub _build_session {
+  my ($self) = @_;
+  Session->new->${\sub {
+    my ($session) = @_;
+    $session->lex_env->lexicals->{'$_SERVICE'} = \$self;
+    weaken(${$session->lex_env->{'$_SERVICE'}});
+    $session;
+  }};
+}
+
+sub BUILD {
+  my ($self) = @_;
+  $self->$_ for qw(listener session);
+}
+
+sub _open_connection {
+  my ($self, $stream) = @_;
+  log_debug { "Connection opened" };
+  $self->session->configure(transport => $stream);
+  $self->add_child($self->session);
+}
+
 1;

diff --git a/lib/App/Clifton/ConsoleService/Session.pm b/lib/App/Clifton/ConsoleService/Session.pm
new file mode 100644 (file)
index 0000000..3a590e9
--- /dev/null
+++ b/lib/App/Clifton/ConsoleService/Session.pm
@@ -0,0 +1,69 @@
+package App::Clifton::ConsoleService::Session;
+
+use Eval::WithLexicals;
+use Data::Dumper::Concise;
+use Moo;
+
+extends 'IO::Async::Protocol::LineStream';
+
+has lex_env => (is => 'lazy');
+
+sub _build_lex_env { Eval::WithLexicals->new }
+
+sub on_read_line {
+  my ($self, $line) = @_;
+  my ($cmd, $body) = split(/ /, $line, 2);
+  if ($cmd !~ /^([A-Z]+)$/) {
+    $self->_send_response(ERROR => "Invalid command ${cmd}");
+  } elsif (my $call = $self->can(lc "handle_${cmd}")) {
+    $self->$call($body ? eval $body : ());
+  } else {
+    $self->_send_response(ERROR => "Unknown command ${cmd}");
+  }
+}
+
+sub _send_response {
+  my ($self, $code, $body) = @_;
+
+  if (my $ref = ref($body)) {
+    ($code, $body) = (ERROR => "Command returned body of reftype ${ref}");
+  }
+  if ($code !~ /^([A-Z]+)$/) {
+    ($code, $body) = (ERROR => "Command returned malformed code ${code}");
+  }
+
+  chomp(my $enc_body = Dumper $body);
+
+  $self->write_line(join ' ', $code, $enc_body);
+}
+
+sub handle_echo {
+  my ($self, $body) = @_;
+  $self->_send_response(ECHO => $body);
+}
+
+sub handle_eval {
+  my ($self, $body) = @_;
+  return $self->_send_response(ERROR => 'You asked me to eval undef!')
+    unless defined $body;
+  if (my $ref = ref $body) {
+    return $self->_send_response(
+      ERROR => "You asked me to eval a ${ref} ref"
+    );
+  }
+  my $eval = $self->lex_env;
+  my $code = 'RESULT';
+  my @ret; local $@; eval {
+    @ret = $eval->eval($body); 1;
+  } or ($code, @ret) = (ERROR => $@);
+  $self->_send_response(
+    $code => do { local $Data::Dumper::Maxdepth = 1; Dumper @ret }
+  );
+}
+
+sub on_closed {
+  my ($self) = @_;
+  $self->parent->remove_child($self);
+}
+
+1;