[ViewVC] Contents of: cvs/AnyEvent-MP/bin/aemp

#!/opt/bin/perl


# very stupid leak checker, checks after some time whether the passed
# object is still around and tracks it via Devel::FindRef.
sub leakcheck($$) {#d#
   my ($after, $ref) = @_;

use EV;#d#
   Scalar::Util::weaken $ref;

   my $w; $w = EV::timer $after, 0, sub {
      undef $w;
      return unless $ref;

      require Devel::FindRef;
      warn "object $ref still alive after $after seconds:\n"
           . Devel::FindRef::track ($ref, 30);
   };
}

=head1 NAME

   aemp - AnyEvent:MP utility

=head1 SYNOPSIS

   aemp command args...

   # protocol commands
   aemp snd <port> <arg...>      # send a message
   aemp mon <port>               # wait till port is killed
   aemp rpc <port> <arg...>      # send message, append reply
   aemp eval <node> <expr...>    # evaluate expression

   # run a node
   aemp run initialise_args...   # run a node

   # node configuration: protocol endpoints
   aemp setnodeid <nodeid>       # configure the real node id
   aemp delnodeid                # reset node id to default (= inherit)

   # node configuration: secret
   aemp gensecret                # generate a random shared secret
   aemp setsecret <secret>       # set the shared secret
   aemp delsecret                # remove the secret (= inherit)

   # node configuration: TLS
   aemp gencert                  # generate a random certificate
   aemp setcert <file>           # set a certificate (key.pem + certificate.pem)
   aemp delcert                  # remove certificate (= inherit)

   # node configuration: seed addresses for bootstrapping
   aemp setseeds <host:port>,... # set seeds
   aemp delseeds                 # clear all seeds (= inherit)
   aemp addseed <host:port>      # add a seed
   aemp delseed <host:port>      # remove seed

   # node configuration: bind addresses
   aemp setbinds <host:port>,... # set binds
   aemp delbinds                 # clear all binds (= inherit)
   aemp addbind <host:port>      # add a bind address
   aemp delbind <host:port>      # remove a bind address

   # node configuration: services
   aemp setservices initfunc,... # set service functions
   aemp delservices              # clear all services (= inherit)
   aemp addservice <initfunc>    # add an instance of a service
   aemp delservice <initfunc>    # delete one instance of a service

   # profile-specific configuration
   aemp profile <name> <command>... # apply command to profile only
   aemp delprofile <name>        # eradicate the named profile
   aemp showprofile <name>       # display given profile
   aemp showconfig <name>        # display effective config

   # debugging
   aemp trace <nodeid>           # trace the network topology

=head1 DESCRIPTION

With aemp you can configure various aspects of AnyEvent::MP and its
protocol.

You can also start a "default node", a node that only depends on the
static configuration.

=cut

use common::sense;

# should come before anything else, so all modules
# will be loaded on each restart
#BEGIN {
   if ($ARGV[0] eq "run") {
      shift;

      # d'oh
#      require AnyEvent::Watchdog;
      # now we can load extra modules

#      AnyEvent::Watchdog::autorestart (1);
#      AnyEvent::Watchdog::heartbeat (300);

      require AnyEvent;
      require AnyEvent::MP;
      AnyEvent::MP::initialise_node (@ARGV);

      AnyEvent::detect () eq "AnyEvent::Impl::EV"
         ? EV::loop ()
         : AE::cv ()->recv;
   }
#}

use Carp ();

use JSON::XS;

use AnyEvent;
use AnyEvent::Util;

use AnyEvent::MP;
use AnyEvent::MP::Config;

sub my_run_cmd {
   my ($cmd) = @_;

   my $cv = &run_cmd;
   my $status = $cv->recv;

   $status
      and die "@$cmd: command failed with exit status $status.";
}

sub gen_cert {
   my_run_cmd [qw(openssl req 
                     -new -nodes -x509 -days 3650
                     -newkey rsa:2048 -keyout /dev/fd/3
                     -batch -subj /CN=AnyEvent::MP
              )],
      "<", "/dev/null",
      ">" , \my $cert,
      "3>", \my $key,
      "2>", "/dev/null";

   "$cert$key"
}

our $cfg     = AnyEvent::MP::Config::config;
our $profile = $cfg;

sub trace {
   my ($node) = @_;
   my $cv = AE::cv;
   my %seen;

   my $to = AE::timer 15, 0, sub {
      warn "timeout\n";
      $cv->();
   };

   initialise_node "anon/";

   my $reply = port {
      my ($node, @neigh) = @_;

      @neigh = grep $_ ne $NODE, @neigh;

      print +(join " ", $node, @neigh), "\n";

      for (@neigh) {
         unless ($seen{$_}++) {
            $cv->begin;
            snd $_, up_nodes => $SELF => $_;
         }
      }

      $cv->end;
   };

   $cv->begin;
   snd $reply, seed => $node;

   $cv->recv;
}

sub docmd;

our %CMD = (
   snd => sub {
      my $port = shift @ARGV;
      initialise_node "anon/";

      snd $port, @ARGV; @ARGV = ();

      my $cv = AE::cv;
      my $to = AE::timer 5, 0, sub { $cv->("timeout") };
      mon $port, $cv;
      my $reply = port sub { &$cv };
      snd node_of $port, snd => $reply, "message sent successfully";

      print join " ", $cv->recv, "\n";
   },

   rpc => sub {
      my $port = shift @ARGV;
      initialise_node "anon/";

      my $cv = AE::cv;
      my $to = AE::timer 5, 0, sub { $cv->("timeout") };
      snd $port, @ARGV, port { &$cv }; @ARGV = ();
      mon $port, $cv;

      print join " ", $cv->recv, "\n";
   },

   mon => sub {
      my $port = shift @ARGV;
      initialise_node "anon/";

      mon $port, my $cv = AE::cv;
      print join " ", $cv->recv, "\n";
   },

   eval => sub {
      my $node = node_of shift @ARGV;
      my $expr = join " ", @ARGV; @ARGV = ();
      initialise_node "anon/";

      my $cv = AE::cv;
      my $to = AE::timer 5, 0, sub { $cv->("timeout") };
      AnyEvent::MP::Kernel::eval_on $node, $expr, port { &$cv };
      mon $node, $cv;

      my ($err, @res) = $cv->recv;

      die $err if length $err;

      print +(substr JSON::XS->new->encode (\@res), 1, -1), "\n";
   },

   trace => sub {
      @ARGV >= 1
         or die "node id missing\n";

      trace shift @ARGV;
   },

   setnodeid => sub {
      @ARGV >= 1
         or die "shared secret missing\n";

      $profile->{nodeid} = shift @ARGV;
      ++$cfg->{dirty};
   },
   delnodeid => sub {
      delete $profile->{nodeid};
      ++$cfg->{dirty};
   },

   setsecret => sub {
      @ARGV >= 1
         or die "shared secret missing\n";

      $profile->{secret} = shift @ARGV;
      ++$cfg->{dirty};
   },
   gensecret => sub {
      $profile->{secret} = AnyEvent::MP::Kernel::alnumbits AnyEvent::MP::Kernel::nonce 64;
      ++$cfg->{dirty};
   },
   delsecret => sub {
      delete $profile->{secret};
      ++$cfg->{dirty};
   },

   setcert => sub {
      @ARGV >= 1
         or die "key+certificate pem filename missing\n";

      open my $fh, "<", $ARGV[0]
         or die "$ARGV[0]: $!";

      local $/;
      $profile->{cert} = <$fh>;
      ++$cfg->{dirty};
   },
   gencert => sub {
      $profile->{cert} = gen_cert;
      ++$cfg->{dirty};
   },
   delcert => sub {
      delete $profile->{cert};
      ++$cfg->{dirty};
   },

   setbinds => sub {
      @ARGV >= 1
         or die "bind addresses missing\n";
      $profile->{binds} = [split /,/, shift @ARGV];
      ++$cfg->{dirty};
   },
   delbinds => sub {
      delete $profile->{binds};
      ++$cfg->{dirty};
   },
   addbind => sub {
      @ARGV >= 1
         or die "bind address missing\n";
      my $bind = shift @ARGV;

      @{ $profile->{binds} } = grep $_ ne $bind, @{ $profile->{binds} };
      push @{ $profile->{binds} }, $bind;
      ++$cfg->{dirty};
   },
   delbind => sub {
      @ARGV >= 1
         or die "bind address missing\n";
      my $bind = shift @ARGV;

      @{ $profile->{binds} } = grep $_ ne $bind, @{ $profile->{binds} };
      ++$cfg->{dirty};
   },

   setseeds => sub {
      @ARGV >= 1
         or die "seed addresses missing\n";
      $profile->{seeds} = [split /,/, shift @ARGV];
      ++$cfg->{dirty};
   },
   delseeds => sub {
      delete $profile->{seeds};
      ++$cfg->{dirty};
   },
   addseed => sub {
      @ARGV >= 1
         or die "seed address missing\n";
      my $seed = shift @ARGV;

      @{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
      push @{ $profile->{seeds} }, $seed;
      ++$cfg->{dirty};
   },
   delseed => sub {
      @ARGV >= 1
         or die "seed address missing\n";
      my $seed = shift @ARGV;

      @{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
      ++$cfg->{dirty};
   },

   setservices => sub {
      @ARGV >= 1
         or die "service specifications missing\n";
      $profile->{services} = [split /,/, shift @ARGV];
      @ARGV = ();
      ++$cfg->{dirty};
   },
   delservices => sub {
      delete $profile->{services};
      ++$cfg->{dirty};
   },
   addservice => sub {
      @ARGV >= 1
         or die "service specification missing\n";
      my $service = shift @ARGV;
      push @{ $profile->{services} }, $service;
      ++$cfg->{dirty};
   },
   delservice => sub {
      @ARGV >= 1
         or die "service specification missing\n";
      my $service = shift @ARGV;
      for (0 .. $#{ $profile->{services} }) {
         next unless $profile->{services}[$_] eq $service;
         splice @{ $profile->{services} }, $_, 1;
         last;
      }
      ++$cfg->{dirty};
   },

   profile => sub {
      @ARGV >= 1
         or die "profile name is missing\n";
      my $name = shift @ARGV;

      $profile = $cfg->{profile}{$name} ||= {};
      ++$cfg->{dirty};
   },
   delprofile => sub {
      @ARGV >= 1
         or die "profile name is missing\n";
      my $name = shift @ARGV;

      delete $cfg->{profile}{$name};
      ++$cfg->{dirty};
   },
   showprofile => sub {
      @ARGV >= 1
         or die "profile name is missing\n";
      my $name = shift @ARGV;

      print JSON::XS->new->pretty->encode ($cfg->{profile}{$name} || {});
   },
   showconfig => sub {
      my $name = @ARGV ? shift @ARGV : AnyEvent::MP::Kernel::_nodename;

      print JSON::XS->new->pretty->encode (AnyEvent::MP::Config::find_profile $name);
   },
);

sub docmd {
   my $cmd = shift @ARGV;

   $CMD{$cmd}
      or die "$cmd: no such aemp command (try man aemp)";

   $CMD{$cmd}();
}

@ARGV
   or die "Usage: aemp subcommand ... (try man aemp)\n";

docmd while @ARGV;


Revision:	1.20
Committed:	Sun Aug 30 13:22:46 2009 UTC (14 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.19:	+24 -5 lines
Log Message:	* empty log message *
#	Content
1	#!/opt/bin/perl
2
3
4	# very stupid leak checker, checks after some time whether the passed
5	# object is still around and tracks it via Devel::FindRef.
6	sub leakcheck($$) {#d#
7	my ($after, $ref) = @_;
8
9	use EV;#d#
10	Scalar::Util::weaken $ref;
11
12	my $w; $w = EV::timer $after, 0, sub {
13	undef $w;
14	return unless $ref;
15
16	require Devel::FindRef;
17	warn "object $ref still alive after $after seconds:\n"
18	. Devel::FindRef::track ($ref, 30);
19	};
20	}
21
22	=head1 NAME
23
24	aemp - AnyEvent:MP utility
25
26	=head1 SYNOPSIS
27
28	aemp command args...
29
30	# protocol commands
31	aemp snd <port> <arg...> # send a message
32	aemp mon <port> # wait till port is killed
33	aemp rpc <port> <arg...> # send message, append reply
34	aemp eval <node> <expr...> # evaluate expression
35
36	# run a node
37	aemp run initialise_args... # run a node
38
39	# node configuration: protocol endpoints
40	aemp setnodeid <nodeid> # configure the real node id
41	aemp delnodeid # reset node id to default (= inherit)
42
43	# node configuration: secret
44	aemp gensecret # generate a random shared secret
45	aemp setsecret <secret> # set the shared secret
46	aemp delsecret # remove the secret (= inherit)
47
48	# node configuration: TLS
49	aemp gencert # generate a random certificate
50	aemp setcert <file> # set a certificate (key.pem + certificate.pem)
51	aemp delcert # remove certificate (= inherit)
52
53	# node configuration: seed addresses for bootstrapping
54	aemp setseeds <host:port>,... # set seeds
55	aemp delseeds # clear all seeds (= inherit)
56	aemp addseed <host:port> # add a seed
57	aemp delseed <host:port> # remove seed
58
59	# node configuration: bind addresses
60	aemp setbinds <host:port>,... # set binds
61	aemp delbinds # clear all binds (= inherit)
62	aemp addbind <host:port> # add a bind address
63	aemp delbind <host:port> # remove a bind address
64
65	# node configuration: services
66	aemp setservices initfunc,... # set service functions
67	aemp delservices # clear all services (= inherit)
68	aemp addservice <initfunc> # add an instance of a service
69	aemp delservice <initfunc> # delete one instance of a service
70
71	# profile-specific configuration
72	aemp profile <name> <command>... # apply command to profile only
73	aemp delprofile <name> # eradicate the named profile
74	aemp showprofile <name> # display given profile
75	aemp showconfig <name> # display effective config
76
77	# debugging
78	aemp trace <nodeid> # trace the network topology
79
80	=head1 DESCRIPTION
81
82	With aemp you can configure various aspects of AnyEvent::MP and its
83	protocol.
84
85	You can also start a "default node", a node that only depends on the
86	static configuration.
87
88	=cut
89
90	use common::sense;
91
92	# should come before anything else, so all modules
93	# will be loaded on each restart
94	#BEGIN {
95	if ($ARGV[0] eq "run") {
96	shift;
97
98	# d'oh
99	# require AnyEvent::Watchdog;
100	# now we can load extra modules
101
102	# AnyEvent::Watchdog::autorestart (1);
103	# AnyEvent::Watchdog::heartbeat (300);
104
105	require AnyEvent;
106	require AnyEvent::MP;
107	AnyEvent::MP::initialise_node (@ARGV);
108
109	AnyEvent::detect () eq "AnyEvent::Impl::EV"
110	? EV::loop ()
111	: AE::cv ()->recv;
112	}
113	#}
114
115	use Carp ();
116
117	use JSON::XS;
118
119	use AnyEvent;
120	use AnyEvent::Util;
121
122	use AnyEvent::MP;
123	use AnyEvent::MP::Config;
124
125	sub my_run_cmd {
126	my ($cmd) = @_;
127
128	my $cv = &run_cmd;
129	my $status = $cv->recv;
130
131	$status
132	and die "@$cmd: command failed with exit status $status.";
133	}
134
135	sub gen_cert {
136	my_run_cmd [qw(openssl req
137	-new -nodes -x509 -days 3650
138	-newkey rsa:2048 -keyout /dev/fd/3
139	-batch -subj /CN=AnyEvent::MP
140	)],
141	"<", "/dev/null",
142	">" , \my $cert,
143	"3>", \my $key,
144	"2>", "/dev/null";
145
146	"$cert$key"
147	}
148
149	our $cfg = AnyEvent::MP::Config::config;
150	our $profile = $cfg;
151
152	sub trace {
153	my ($node) = @_;
154	my $cv = AE::cv;
155	my %seen;
156
157	my $to = AE::timer 15, 0, sub {
158	warn "timeout\n";
159	$cv->();
160	};
161
162	initialise_node "anon/";
163
164	my $reply = port {
165	my ($node, @neigh) = @_;
166
167	@neigh = grep $_ ne $NODE, @neigh;
168
169	print +(join " ", $node, @neigh), "\n";
170
171	for (@neigh) {
172	unless ($seen{$_}++) {
173	$cv->begin;
174	snd $_, up_nodes => $SELF => $_;
175	}
176	}
177
178	$cv->end;
179	};
180
181	$cv->begin;
182	snd $reply, seed => $node;
183
184	$cv->recv;
185	}
186
187	sub docmd;
188
189	our %CMD = (
190	snd => sub {
191	my $port = shift @ARGV;
192	initialise_node "anon/";
193
194	snd $port, @ARGV; @ARGV = ();
195
196	my $cv = AE::cv;
197	my $to = AE::timer 5, 0, sub { $cv->("timeout") };
198	mon $port, $cv;
199	my $reply = port sub { &$cv };
200	snd node_of $port, snd => $reply, "message sent successfully";
201
202	print join " ", $cv->recv, "\n";
203	},
204
205	rpc => sub {
206	my $port = shift @ARGV;
207	initialise_node "anon/";
208
209	my $cv = AE::cv;
210	my $to = AE::timer 5, 0, sub { $cv->("timeout") };
211	snd $port, @ARGV, port { &$cv }; @ARGV = ();
212	mon $port, $cv;
213
214	print join " ", $cv->recv, "\n";
215	},
216
217	mon => sub {
218	my $port = shift @ARGV;
219	initialise_node "anon/";
220
221	mon $port, my $cv = AE::cv;
222	print join " ", $cv->recv, "\n";
223	},
224
225	eval => sub {
226	my $node = node_of shift @ARGV;
227	my $expr = join " ", @ARGV; @ARGV = ();
228	initialise_node "anon/";
229
230	my $cv = AE::cv;
231	my $to = AE::timer 5, 0, sub { $cv->("timeout") };
232	AnyEvent::MP::Kernel::eval_on $node, $expr, port { &$cv };
233	mon $node, $cv;
234
235	my ($err, @res) = $cv->recv;
236
237	die $err if length $err;
238
239	print +(substr JSON::XS->new->encode (\@res), 1, -1), "\n";
240	},
241
242	trace => sub {
243	@ARGV >= 1
244	or die "node id missing\n";
245
246	trace shift @ARGV;
247	},
248
249	setnodeid => sub {
250	@ARGV >= 1
251	or die "shared secret missing\n";
252
253	$profile->{nodeid} = shift @ARGV;
254	++$cfg->{dirty};
255	},
256	delnodeid => sub {
257	delete $profile->{nodeid};
258	++$cfg->{dirty};
259	},
260
261	setsecret => sub {
262	@ARGV >= 1
263	or die "shared secret missing\n";
264
265	$profile->{secret} = shift @ARGV;
266	++$cfg->{dirty};
267	},
268	gensecret => sub {
269	$profile->{secret} = AnyEvent::MP::Kernel::alnumbits AnyEvent::MP::Kernel::nonce 64;
270	++$cfg->{dirty};
271	},
272	delsecret => sub {
273	delete $profile->{secret};
274	++$cfg->{dirty};
275	},
276
277	setcert => sub {
278	@ARGV >= 1
279	or die "key+certificate pem filename missing\n";
280
281	open my $fh, "<", $ARGV[0]
282	or die "$ARGV[0]: $!";
283
284	local $/;
285	$profile->{cert} = <$fh>;
286	++$cfg->{dirty};
287	},
288	gencert => sub {
289	$profile->{cert} = gen_cert;
290	++$cfg->{dirty};
291	},
292	delcert => sub {
293	delete $profile->{cert};
294	++$cfg->{dirty};
295	},
296
297	setbinds => sub {
298	@ARGV >= 1
299	or die "bind addresses missing\n";
300	$profile->{binds} = [split /,/, shift @ARGV];
301	++$cfg->{dirty};
302	},
303	delbinds => sub {
304	delete $profile->{binds};
305	++$cfg->{dirty};
306	},
307	addbind => sub {
308	@ARGV >= 1
309	or die "bind address missing\n";
310	my $bind = shift @ARGV;
311
312	@{ $profile->{binds} } = grep $_ ne $bind, @{ $profile->{binds} };
313	push @{ $profile->{binds} }, $bind;
314	++$cfg->{dirty};
315	},
316	delbind => sub {
317	@ARGV >= 1
318	or die "bind address missing\n";
319	my $bind = shift @ARGV;
320
321	@{ $profile->{binds} } = grep $_ ne $bind, @{ $profile->{binds} };
322	++$cfg->{dirty};
323	},
324
325	setseeds => sub {
326	@ARGV >= 1
327	or die "seed addresses missing\n";
328	$profile->{seeds} = [split /,/, shift @ARGV];
329	++$cfg->{dirty};
330	},
331	delseeds => sub {
332	delete $profile->{seeds};
333	++$cfg->{dirty};
334	},
335	addseed => sub {
336	@ARGV >= 1
337	or die "seed address missing\n";
338	my $seed = shift @ARGV;
339
340	@{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
341	push @{ $profile->{seeds} }, $seed;
342	++$cfg->{dirty};
343	},
344	delseed => sub {
345	@ARGV >= 1
346	or die "seed address missing\n";
347	my $seed = shift @ARGV;
348
349	@{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
350	++$cfg->{dirty};
351	},
352
353	setservices => sub {
354	@ARGV >= 1
355	or die "service specifications missing\n";
356	$profile->{services} = [split /,/, shift @ARGV];
357	@ARGV = ();
358	++$cfg->{dirty};
359	},
360	delservices => sub {
361	delete $profile->{services};
362	++$cfg->{dirty};
363	},
364	addservice => sub {
365	@ARGV >= 1
366	or die "service specification missing\n";
367	my $service = shift @ARGV;
368	push @{ $profile->{services} }, $service;
369	++$cfg->{dirty};
370	},
371	delservice => sub {
372	@ARGV >= 1
373	or die "service specification missing\n";
374	my $service = shift @ARGV;
375	for (0 .. $#{ $profile->{services} }) {
376	next unless $profile->{services}[$_] eq $service;
377	splice @{ $profile->{services} }, $_, 1;
378	last;
379	}
380	++$cfg->{dirty};
381	},
382
383	profile => sub {
384	@ARGV >= 1
385	or die "profile name is missing\n";
386	my $name = shift @ARGV;
387
388	$profile = $cfg->{profile}{$name} \|\|= {};
389	++$cfg->{dirty};
390	},
391	delprofile => sub {
392	@ARGV >= 1
393	or die "profile name is missing\n";
394	my $name = shift @ARGV;
395
396	delete $cfg->{profile}{$name};
397	++$cfg->{dirty};
398	},
399	showprofile => sub {
400	@ARGV >= 1
401	or die "profile name is missing\n";
402	my $name = shift @ARGV;
403
404	print JSON::XS->new->pretty->encode ($cfg->{profile}{$name} \|\| {});
405	},
406	showconfig => sub {
407	my $name = @ARGV ? shift @ARGV : AnyEvent::MP::Kernel::_nodename;
408
409	print JSON::XS->new->pretty->encode (AnyEvent::MP::Config::find_profile $name);
410	},
411	);
412
413	sub docmd {
414	my $cmd = shift @ARGV;
415
416	$CMD{$cmd}
417	or die "$cmd: no such aemp command (try man aemp)";
418
419	$CMD{$cmd}();
420	}
421
422	@ARGV
423	or die "Usage: aemp subcommand ... (try man aemp)\n";
424
425	docmd while @ARGV;
426
427