ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-MP/bin/aemp
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 ***

File Contents

# User Rev Content
1 root 1.1 #!/opt/bin/perl
2    
3 root 1.20
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 root 1.1 =head1 NAME
23    
24     aemp - AnyEvent:MP utility
25    
26     =head1 SYNOPSIS
27    
28     aemp command args...
29    
30     # protocol commands
31 root 1.19 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 root 1.8
36     # run a node
37 root 1.19 aemp run initialise_args... # run a node
38 root 1.8
39     # node configuration: protocol endpoints
40 root 1.19 aemp setnodeid <nodeid> # configure the real node id
41     aemp delnodeid # reset node id to default (= inherit)
42 root 1.1
43     # node configuration: secret
44 root 1.19 aemp gensecret # generate a random shared secret
45     aemp setsecret <secret> # set the shared secret
46     aemp delsecret # remove the secret (= inherit)
47 root 1.1
48     # node configuration: TLS
49 root 1.19 aemp gencert # generate a random certificate
50     aemp setcert <file> # set a certificate (key.pem + certificate.pem)
51     aemp delcert # remove certificate (= inherit)
52 root 1.8
53 root 1.17 # node configuration: seed addresses for bootstrapping
54 root 1.19 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 root 1.17
59     # node configuration: bind addresses
60 root 1.19 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 root 1.8
65     # node configuration: services
66 root 1.19 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 root 1.6
71 root 1.10 # profile-specific configuration
72     aemp profile <name> <command>... # apply command to profile only
73 root 1.19 aemp delprofile <name> # eradicate the named profile
74     aemp showprofile <name> # display given profile
75     aemp showconfig <name> # display effective config
76 root 1.10
77 root 1.11 # debugging
78 root 1.19 aemp trace <nodeid> # trace the network topology
79 root 1.11
80 root 1.1 =head1 DESCRIPTION
81    
82 root 1.8 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 root 1.1
88     =cut
89    
90     use common::sense;
91    
92 root 1.19 # should come before anything else, so all modules
93     # will be loaded on each restart
94 root 1.20 #BEGIN {
95 root 1.8 if ($ARGV[0] eq "run") {
96     shift;
97    
98 root 1.13 # d'oh
99 root 1.20 # require AnyEvent::Watchdog;
100 root 1.19 # now we can load extra modules
101    
102 root 1.20 # AnyEvent::Watchdog::autorestart (1);
103     # AnyEvent::Watchdog::heartbeat (300);
104 root 1.13
105 root 1.8 require AnyEvent;
106     require AnyEvent::MP;
107     AnyEvent::MP::initialise_node (@ARGV);
108    
109 root 1.16 AnyEvent::detect () eq "AnyEvent::Impl::EV"
110 root 1.8 ? EV::loop ()
111     : AE::cv ()->recv;
112     }
113 root 1.20 #}
114 root 1.8
115 root 1.1 use Carp ();
116    
117 root 1.17 use JSON::XS;
118    
119 root 1.1 use AnyEvent;
120 root 1.4 use AnyEvent::Util;
121    
122 root 1.8 use AnyEvent::MP;
123 root 1.1 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 root 1.2 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 root 1.5 "<", "/dev/null",
142 root 1.1 ">" , \my $cert,
143     "3>", \my $key,
144 root 1.4 "2>", "/dev/null";
145 root 1.1
146     "$cert$key"
147     }
148    
149 root 1.10 our $cfg = AnyEvent::MP::Config::config;
150 root 1.8 our $profile = $cfg;
151 root 1.1
152 root 1.11 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 root 1.19 initialise_node "anon/";
163 root 1.11
164     my $reply = port {
165 root 1.12 my ($node, @neigh) = @_;
166 root 1.11
167 root 1.12 @neigh = grep $_ ne $NODE, @neigh;
168    
169     print +(join " ", $node, @neigh), "\n";
170    
171     for (@neigh) {
172 root 1.11 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 root 1.10 sub docmd;
188    
189 root 1.1 our %CMD = (
190     snd => sub {
191 root 1.17 my $port = shift @ARGV;
192 root 1.19 initialise_node "anon/";
193 root 1.1
194 root 1.7 snd $port, @ARGV; @ARGV = ();
195 root 1.1
196     my $cv = AE::cv;
197 root 1.7 my $to = AE::timer 5, 0, sub { $cv->("timeout") };
198 root 1.1 mon $port, $cv;
199 root 1.19 my $reply = port sub { &$cv };
200     snd node_of $port, snd => $reply, "message sent successfully";
201 root 1.1
202     print join " ", $cv->recv, "\n";
203     },
204    
205 root 1.7 rpc => sub {
206 root 1.17 my $port = shift @ARGV;
207 root 1.19 initialise_node "anon/";
208 root 1.7
209     my $cv = AE::cv;
210     my $to = AE::timer 5, 0, sub { $cv->("timeout") };
211 root 1.19 snd $port, @ARGV, port { &$cv }; @ARGV = ();
212 root 1.7 mon $port, $cv;
213    
214     print join " ", $cv->recv, "\n";
215     },
216    
217 root 1.1 mon => sub {
218 root 1.17 my $port = shift @ARGV;
219 root 1.19 initialise_node "anon/";
220 root 1.1
221     mon $port, my $cv = AE::cv;
222     print join " ", $cv->recv, "\n";
223     },
224    
225 root 1.19 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 root 1.11 trace => sub {
243     @ARGV >= 1
244 root 1.17 or die "node id missing\n";
245 root 1.11
246 root 1.17 trace shift @ARGV;
247 root 1.11 },
248    
249 root 1.17 setnodeid => sub {
250 root 1.8 @ARGV >= 1
251     or die "shared secret missing\n";
252    
253 root 1.17 $profile->{nodeid} = shift @ARGV;
254 root 1.8 ++$cfg->{dirty};
255     },
256 root 1.17 delnodeid => sub {
257     delete $profile->{nodeid};
258 root 1.8 ++$cfg->{dirty};
259     },
260    
261 root 1.1 setsecret => sub {
262 root 1.8 @ARGV >= 1
263 root 1.1 or die "shared secret missing\n";
264    
265 root 1.8 $profile->{secret} = shift @ARGV;
266 root 1.1 ++$cfg->{dirty};
267     },
268     gensecret => sub {
269 root 1.18 $profile->{secret} = AnyEvent::MP::Kernel::alnumbits AnyEvent::MP::Kernel::nonce 64;
270 root 1.1 ++$cfg->{dirty};
271     },
272 root 1.17 delsecret => sub {
273 root 1.8 delete $profile->{secret};
274 root 1.1 ++$cfg->{dirty};
275     },
276    
277     setcert => sub {
278 root 1.8 @ARGV >= 1
279 root 1.1 or die "key+certificate pem filename missing\n";
280    
281     open my $fh, "<", $ARGV[0]
282     or die "$ARGV[0]: $!";
283    
284     local $/;
285 root 1.8 $profile->{cert} = <$fh>;
286 root 1.1 ++$cfg->{dirty};
287     },
288     gencert => sub {
289 root 1.8 $profile->{cert} = gen_cert;
290 root 1.1 ++$cfg->{dirty};
291     },
292 root 1.17 delcert => sub {
293 root 1.8 delete $profile->{cert};
294 root 1.1 ++$cfg->{dirty};
295     },
296 root 1.6
297 root 1.17 setbinds => sub {
298 root 1.19 @ARGV >= 1
299     or die "bind addresses missing\n";
300     $profile->{binds} = [split /,/, shift @ARGV];
301 root 1.17 ++$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 root 1.6 setseeds => sub {
326 root 1.19 @ARGV >= 1
327     or die "seed addresses missing\n";
328     $profile->{seeds} = [split /,/, shift @ARGV];
329 root 1.6 ++$cfg->{dirty};
330     },
331 root 1.17 delseeds => sub {
332     delete $profile->{seeds};
333     ++$cfg->{dirty};
334     },
335 root 1.6 addseed => sub {
336 root 1.10 @ARGV >= 1
337 root 1.17 or die "seed address missing\n";
338 root 1.6 my $seed = shift @ARGV;
339 root 1.10
340 root 1.8 @{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
341     push @{ $profile->{seeds} }, $seed;
342     ++$cfg->{dirty};
343     },
344     delseed => sub {
345 root 1.10 @ARGV >= 1
346 root 1.17 or die "seed address missing\n";
347 root 1.8 my $seed = shift @ARGV;
348 root 1.10
349 root 1.8 @{ $profile->{seeds} } = grep $_ ne $seed, @{ $profile->{seeds} };
350     ++$cfg->{dirty};
351     },
352    
353     setservices => sub {
354 root 1.19 @ARGV >= 1
355     or die "service specifications missing\n";
356     $profile->{services} = [split /,/, shift @ARGV];
357 root 1.8 @ARGV = ();
358 root 1.6 ++$cfg->{dirty};
359     },
360 root 1.17 delservices => sub {
361     delete $profile->{services};
362     ++$cfg->{dirty};
363     },
364 root 1.9 addservice => sub {
365 root 1.10 @ARGV >= 1
366     or die "service specification missing\n";
367 root 1.8 my $service = shift @ARGV;
368     push @{ $profile->{services} }, $service;
369     ++$cfg->{dirty};
370     },
371 root 1.9 delservice => sub {
372 root 1.10 @ARGV >= 1
373     or die "service specification missing\n";
374 root 1.8 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 root 1.6 ++$cfg->{dirty};
381     },
382 root 1.10
383     profile => sub {
384 root 1.19 @ARGV >= 1
385     or die "profile name is missing\n";
386 root 1.10 my $name = shift @ARGV;
387    
388     $profile = $cfg->{profile}{$name} ||= {};
389 root 1.14 ++$cfg->{dirty};
390 root 1.10 },
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 root 1.14 ++$cfg->{dirty};
398 root 1.10 },
399 root 1.17 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 root 1.1 );
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 root 1.19 docmd while @ARGV;
426 root 1.1
427