From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 16 Feb 2011 10:57:24 +0000 (+0000)
Subject: basically operating chain code
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=327a4b1a20939c6f165dc432ace73d24624047a4;p=scpubgit%2FClifton.git

basically operating chain code
---

diff --git a/lib/App/Clifton/Chain.pm b/lib/App/Clifton/Chain.pm
index 400ee9b..3641613 100644
--- a/lib/App/Clifton/Chain.pm
+++ b/lib/App/Clifton/Chain.pm
@@ -2,7 +2,28 @@ package App::Clifton::Chain;
 
 use Moo;
 
+extends 'App::Clifton::Component';
+
 has jabber_user => (is => 'ro', required => 1);
 has irc_channel => (is => 'ro', required => 1);
 
+has jabber_tower => (is => 'ro', required => 1);
+has irc_tower => (is => 'ro', required => 1, weak_ref => 1);
+
+sub handle_xmpp_message {
+  my ($self, $msg) = @_;
+  $self->irc_tower->send_irc_message({
+    to => $self->irc_channel,
+    text => $msg->body
+  });
+}
+
+sub handle_irc_message {
+  my ($self, $message, $hints) = @_;
+  $self->jabber_tower->send_xmpp_message({
+    to => $self->jabber_user,
+    body => join(': ', $hints->{prefix_name}, $hints->{text})
+  });
+}
+
 1;
diff --git a/lib/App/Clifton/Component.pm b/lib/App/Clifton/Component.pm
index 7f80acd..6f857ba 100644
--- a/lib/App/Clifton/Component.pm
+++ b/lib/App/Clifton/Component.pm
@@ -6,6 +6,7 @@ sub _debug_self {
   "${self}: ".join ', ', map "$_ => ".$args->{$_}, keys %$args;
 }
 
+use Try::Tiny;
 use Log::Contextual qw(:log);
 use Moo;
 
@@ -54,9 +55,7 @@ sub _eval_cb {
   my ($self, $code) = @_;
   my $str = "$self";
   sub {
-    local $@;
-    eval { $code->(@_); 1 }
-      or log_error { "Exception from ${self}: $@" };
+    try { $code->(@_) } catch { log_error { "Exception from ${self}: $_" } }
   };
 }
 
diff --git a/lib/App/Clifton/Server.pm b/lib/App/Clifton/Server.pm
index c154786..4a46499 100644
--- a/lib/App/Clifton/Server.pm
+++ b/lib/App/Clifton/Server.pm
@@ -2,6 +2,8 @@ package App::Clifton::Server;
 
 use aliased 'App::Clifton::ConsoleService';
 use aliased 'App::Clifton::ConfigLoader';
+use aliased 'App::Clifton::Tower::Jabber' => 'Jabber_Tower';
+use aliased 'App::Clifton::Tower::IRC' => 'IRC_Tower';
 use Moo;
 
 extends 'App::Clifton::Service';
@@ -22,6 +24,10 @@ sub _build_config_loader { ConfigLoader->new }
 
 has console_service => (is => 'lazy');
 
+has jabber_towers => (is => 'ro', default => sub { {} });
+
+has irc_towers => (is => 'ro', default => sub { {} });
+
 sub _build_console_service {
   my ($self) = @_;
   $self->_new_child(ConsoleService, { server => $self });
@@ -37,4 +43,39 @@ sub _body_for_reload_config {
   $args->{on_finished}->($config);
 }
 
+sub start_chain { shift->_do(start_chain => @_) }
+
+sub _dependencies_for_start_chain {
+  my ($self, $args) = @_;
+  {
+    irc_tower => $self->start_irc_tower($args->{irc_tower})
+  }
+}
+
+sub _body_for_start_chain {
+  my ($self, $args) = @_;
+  $args->{irc_tower}->start_chain($args);
+}
+
+sub start_irc_tower { shift->_do(start_irc_tower => @_) }
+
+sub _guard_for_start_irc_tower {
+  my ($self, $args) = @_;
+  if (my $tower = $self->irc_towers->{$args->{server}}{$args->{irc_nick}}) {
+    ($tower);
+  } else {
+    ();
+  }
+}
+
+sub _body_for_start_irc_tower {
+  my ($self, $args) = @_;
+  $self->_new_child(IRC_Tower, {
+    irc_server => $args->{server},
+    irc_nick => $args->{irc_nick},
+    on_setup => $args->{on_finished},
+    server => $self,
+  });
+}
+
 1;
diff --git a/lib/App/Clifton/Service.pm b/lib/App/Clifton/Service.pm
index 043e877..49bb786 100644
--- a/lib/App/Clifton/Service.pm
+++ b/lib/App/Clifton/Service.pm
@@ -6,17 +6,26 @@ use Moo;
 extends 'App::Clifton::Component';
 
 sub _do {
-  my ($self, $do, @args) = @_;
+  my ($self, $do, $args) = @_;
   my $body = do {
     my $body_call = $self->_capture_weakself("_body_for_${do}");
-    sub { $body_call->(@args, @_) }
+    sub { $body_call->(@_) }
+  };
+  my @guard = do {
+    if ($self->can("_guard_for_${do}")) {
+      my $guard_call = $self->_capture_weakself("_guard_for_${do}");
+      (guard => sub { $guard_call->(@_) });
+    } else {
+      ();
+    }
   };
   my $deps = {};
   if (my $dep_call = $self->can("_dependencies_for_${do}")) {
-    $deps = $self->$dep_call(@args);
+    $deps = $self->$dep_call($args);
   }
   $self->_new_child(Task, {
-    name => $do, body => $body, dependencies => $deps
+    name => $do, body => $body, dependencies => $deps, @guard,
+    args => $args,
   });
 }
 
diff --git a/lib/App/Clifton/Task.pm b/lib/App/Clifton/Task.pm
index 216e3c3..c641be1 100644
--- a/lib/App/Clifton/Task.pm
+++ b/lib/App/Clifton/Task.pm
@@ -12,6 +12,10 @@ has name => (is => 'ro', required => 1);
 
 has body => (is => 'ro', required => 1);
 
+has guard => (is => 'ro', predicate => 'has_guard');
+
+has args => (is => 'ro', required => 1);
+
 has dependencies => (is => 'ro', default => sub { {} });
 
 has merge_point => (is => 'lazy');
@@ -20,6 +24,9 @@ sub _build_merge_point { Async::MergePoint->new }
 
 sub BUILD {
   my ($self) = @_;
+  if (my $cb = $self->args->{on_finished}) {
+    $self->on_finished($cb);
+  }
   my $deps = $self->dependencies;
   if (my @needs = keys %$deps) {
     my $mp = $self->merge_point;
@@ -37,12 +44,17 @@ sub _schedule_body {
   my ($self, %args) = @_;
   my $fire_body = $self->_capture_weakself('_fire_body');
   $args{on_finished} = $self->_finished_callback;
+  %args = (%{$self->args}, %args);
   $self->_schedule(sub { $fire_body->(\%args); });
 }
 
 sub _fire_body {
   my $self = shift;
-  $self->body->(@_);
+  if ($self->has_guard and my ($result) = $self->guard->(@_)) {
+    $_[0]->{on_finished}($result);
+  } else {
+    $self->body->(@_);
+  }
 }
 
 sub _finished_callback {
diff --git a/lib/App/Clifton/Tower/IRC.pm b/lib/App/Clifton/Tower/IRC.pm
new file mode 100644
index 0000000..5dffc0e
--- /dev/null
+++ b/lib/App/Clifton/Tower/IRC.pm
@@ -0,0 +1,63 @@
+package App::Clifton::Tower::IRC;
+
+use aliased 'Net::Async::IRC' => 'IRC_Client';
+use aliased 'App::Clifton::Chain';
+use Log::Contextual qw(:log);
+use Moo;
+             
+extends 'App::Clifton::Component';
+
+has server => (is => 'ro', required => 1, weak_ref => 1);
+has irc_server => (is => 'ro', required => 1);
+has irc_nick => (is => 'ro', required => 1);
+has irc_client => (is => 'lazy');
+has chains => (is => 'ro', default => sub { {} });
+
+sub _build_irc_client { shift->_new_child(IRC_Client, {}) }
+
+sub BUILD {
+  my ($self, $args) = @_;
+  my $on_setup = $args->{on_setup};
+  $self->irc_client->configure(
+    on_message_text => $self->_replace_weakself('receive_irc_message')
+  );
+  $self->irc_client->login(
+    nick => $self->irc_nick, host => $self->irc_server,
+    on_login => $self->_capture_weakself(sub {
+      my $self = shift;
+      $self->server->irc_towers->{$self->irc_server}{$self->irc_nick}
+        = $self;
+      $on_setup->($self);
+    }),
+  );
+}
+
+sub start_chain {
+  my ($self, $args) = @_;
+  $self->irc_client->send_message('JOIN', undef, $args->{irc_channel});
+  my $new = $self->_new_child(Chain, {
+    %$args, irc_tower => $self,
+  });
+  $self->chains->{$args->{irc_channel}} = $new;
+  # I note here that actually we should make the Chain do
+  # setup (JOIN) and confirm that first, but oh well
+  $args->{on_finished}->({
+    chain => $new,
+    message => 'SUCCESS'
+  });
+}
+
+sub send_irc_message {
+  my ($self, $args) = @_;
+  $self->irc_client->send_message('PRIVMSG', undef, @{$args}{qw(to text)});
+}
+
+sub receive_irc_message {
+  my ($self, $message, $hints) = @_;
+  return if $hints->{prefix_is_me};
+  if (my $chain = $self->chains->{$hints->{target_name}}) {
+    $chain->handle_irc_message($message, $hints);
+  }
+}
+
+1;
diff --git a/lib/App/Clifton/Tower/Jabber.pm b/lib/App/Clifton/Tower/Jabber.pm
index 381695f..44c8d0d 100644
--- a/lib/App/Clifton/Tower/Jabber.pm
+++ b/lib/App/Clifton/Tower/Jabber.pm
@@ -13,7 +13,9 @@ has xmpp_client => (is => 'lazy');
 sub xmpp_active { shift->xmpp_client->xmpp->is_loggedin }
 
 has $_ => (is => 'ro', required => 1)
-  for qw(bridge_name server jabber_config);
+  for qw(bridge_name jabber_config irc_config);
+
+has server => (is => 'ro', required => 1, weak_ref => 1);
 
 has userconfig_set => (
   is => 'ro', # Moobug init_arg => undef,
@@ -35,10 +37,13 @@ sub _login_xmpp_client {
   my $conf = $self->jabber_config;
   $xmpp->login(
     jid => $conf->user, host => $conf->server, password => $conf->pass,
+    on_message => $self->_replace_weakself('handle_message'),
   );
   $xmpp;
 }
 
+sub BUILD { $_[0]->xmpp_client }
+
 sub handle_message {
   my ($self, $msg) = @_;
 
@@ -68,8 +73,11 @@ sub handle_message {
       $self->start_chain_for($user)->on_finished(
         $self->_capture_weakself(sub {
           my ($self, $result) = @_;
+          if ($result->{chain}) {
+            $self->chain_set->add($result->{chain});
+          }
           $self->send_xmpp_message({
-            to => $from, body => 'Connection result: '.$result
+            to => $from, body => 'Connection result: '.$result->{message}
           });
         })
       );
@@ -87,6 +95,19 @@ sub send_xmpp_message {
   $self->xmpp_client->compose(%$args)->send;
 }
 
+sub start_chain_for {
+  my ($self, $user) = @_;
+  $self->server->start_chain({
+    jabber_tower => $self,
+    jabber_user => $user->name,
+    irc_tower => {
+      server => $self->irc_config->server,
+      irc_nick => $user->irc_nick
+    },
+    irc_channel => $self->irc_config->channel,
+  });
+}
+
 1;
 
 # and later
diff --git a/lib/App/Clifton/UserConfig.pm b/lib/App/Clifton/UserConfig.pm
index 0b82954..aba192a 100644
--- a/lib/App/Clifton/UserConfig.pm
+++ b/lib/App/Clifton/UserConfig.pm
@@ -2,6 +2,7 @@ package App::Clifton::UserConfig;
 
 use Moo;
 
+has name => (is => 'ro', required => 1);
 has allow => (is => 'ro', required => 1);
 has irc_nick => (is => 'ro', required => 1);
 
diff --git a/notes/jsetup b/notes/jsetup
index cc524a3..347099d 100644
--- a/notes/jsetup
+++ b/notes/jsetup
@@ -1,5 +1,7 @@
 use App::Clifton::Tower::Jabber
-my $j = $_SERVER->_new_child('App::Clifton::Tower::Jabber', { server => $_SERVER, bridge_name => 'hearts', jabber_config => $_SERVER->current_config->bridges->get({ name => 'hearts' })->jabber });
+my $hearts = $_SERVER->current_config->bridges->get({ name => 'hearts' });
+my $j = $_SERVER->_new_child('App::Clifton::Tower::Jabber', { server => $_SERVER, bridge_name => 'hearts', jabber_config => $hearts->jabber, irc_config => $hearts->irc });
+$j->userconfig_set->add($_SERVER->current_config->users->get({ name => 'mst@corvina.org' });
 my $xmpp = $j->xmpp_client;
 $xmpp->compose(to => 'mst@corvina.org', body => 'hi')->send
 $xmpp->configure(on_message => $j->_replace_weakself('handle_message'));