File Coverage

blib/lib/MikroTik/Client.pm
Criterion Covered Total %
statement 130 147 88.4
branch 35 48 72.9
condition 22 28 78.5
subroutine 36 41 87.8
pod 4 4 100.0
total 227 268 84.7


line stmt bran cond sub pod time code
1             package MikroTik::Client;
2 4     4   240219 use MikroTik::Client::Mo;
  4         12  
  4         21  
3              
4 4     4   1008 use AnyEvent;
  4         5671  
  4         106  
5 4     4   2999 use AnyEvent::Handle;
  4         74071  
  4         167  
6 4     4   36 use Digest::MD5 'md5_hex';
  4         8  
  4         260  
7 4     4   1880 use MikroTik::Client::Response;
  4         12  
  4         132  
8 4     4   26 use MikroTik::Client::Sentence 'encode_sentence';
  4         8  
  4         171  
9 4     4   22 use Carp ();
  4         7  
  4         69  
10 4     4   34 use Scalar::Util 'weaken';
  4         8  
  4         219  
11              
12 4     4   24 use constant CONN_TIMEOUT => $ENV{MIKROTIK_CLIENT_CONNTIMEOUT};
  4         9  
  4         499  
13 4   50 4   27 use constant DEBUG => $ENV{MIKROTIK_CLIENT_DEBUG} || 0;
  4         9  
  4         320  
14 4     4   49 use constant PROMISES => !!(eval { require Promises; 1 });
  4         8  
  4         8  
  4         1757  
  0         0  
15              
16             our $VERSION = "v0.520";
17              
18             has ca => sub { $ENV{MIKROTIK_CLIENT_CA} };
19             has cert => sub { $ENV{MIKROTIK_CLIENT_CERT} };
20             has error => '';
21             has host => '192.168.88.1';
22             has insecure => 0;
23             has key => sub { $ENV{MIKROTIK_CLIENT_KEY} };
24             has new_login => sub { $_[0]->tls || 0 };
25             has password => '';
26             has port => 0;
27             has timeout => 10;
28             has tls => 1;
29             has user => 'admin';
30             has _tag => 0;
31              
32             # Aliases
33             {
34 4     4   24 no strict 'refs';
  4         8  
  4         8604  
35             *{__PACKAGE__ . "::cmd"} = \&command;
36             *{__PACKAGE__ . "::cmd_p"} = \&command_p;
37             *{__PACKAGE__ . "::_fail"} = \&_finish;
38             }
39              
40             sub DESTROY {
41 1 50 33 1   796587 (defined ${^GLOBAL_PHASE} && ${^GLOBAL_PHASE} eq 'DESTRUCT')
42             or shift->_cleanup();
43             }
44              
45             sub cancel {
46 2 50   2 1 26 my $cb = ref $_[-1] eq 'CODE' ? pop : sub { };
        2      
47 2         11 return shift->_command('/cancel', {'tag' => shift}, undef, $cb);
48             }
49              
50             sub command {
51 13 100   13 1 2999 my $cb = ref $_[-1] eq 'CODE' ? pop : undef;
52 13         35 my ($self, $cmd, $attr, $query) = @_;
53              
54             # non-blocking
55 13 100       40 return $self->_command($cmd, $attr, $query, $cb) if $cb;
56              
57             # blocking
58 10         332 my $cv = AnyEvent->condvar;
59 10     10   297 $self->_command($cmd, $attr, $query, sub { $cv->send($_[2]) });
  10         54  
60 10         41 return $cv->recv;
61             }
62              
63             sub command_p {
64 0     0 1 0 Carp::croak 'Promises 0.99+ is required for this functionality.'
65             unless PROMISES;
66 0         0 my ($self, $cmd, $attr, $query) = @_;
67              
68 0         0 my $d = Promises::deferred();
69             $self->_command($cmd, $attr, $query,
70 0 0   0   0 sub { $_[1] ? $d->reject(@_[1, 2]) : $d->resolve($_[2]) });
  0         0  
71              
72 0         0 return $d->promise;
73             }
74              
75             sub subscribe {
76 1 50   1 1 6 do { $_[0]->{error} = 'can\'t subscribe in blocking mode'; return; }
  0         0  
  0         0  
77             unless ref $_[-1] eq 'CODE';
78 1         3 my $cb = pop;
79 1         4 my ($self, $cmd, $attr, $query) = @_;
80 1         3 $attr->{'.subscription'} = 1;
81 1         4 return $self->_command($cmd, $attr, $query, $cb);
82             }
83              
84             sub _cleanup {
85 1     1   3 my $self = shift;
86 1         3 delete $_->{timeout} for values %{$self->{requests}};
  1         6  
87 1         10 delete $self->{handle};
88             }
89              
90             sub _close {
91 4     4   14 my ($self, $err) = @_;
92 4   100     28 $self->_fail_all($err || 'closed prematurely');
93 4         72 delete @{$self}{qw(handle response requests)};
  4         45  
94             }
95              
96             sub _command {
97 21     21   412 my ($self, $cmd, $attr, $query, $cb) = @_;
98              
99 21         49 my $tag = ++$self->{_tag};
100 21         123 my $r = $self->{requests}{$tag} = {tag => $tag, cb => $cb};
101 21         48 $r->{subscription} = delete $attr->{'.subscription'};
102              
103 21         29 warn "-- got request for command '$cmd' (tag: $tag)\n" if DEBUG;
104              
105 21         86 $r->{sentence} = encode_sentence($cmd, $attr, $query, $tag);
106 21         73 return $self->_send_request($r);
107             }
108              
109             sub _connect {
110 5     5   13 my ($self, $r) = @_;
111              
112 5         6 warn "-- creating new connection\n" if DEBUG;
113              
114 5         17 my $queue = $self->{queue} = [$r];
115              
116 5         15 my $tls = $self->tls;
117 5 50       14 my $port = $self->port ? $self->{port} : $tls ? 8729 : 8728;
    100          
118              
119 5         18 my $tls_opts = {verify => !$self->insecure, cipher_list => "HIGH"};
120             $self->{$_} && ($tls_opts->{$_ . "_file"} = $self->{$_})
121 5   33     27 for qw(ca cert key);
122              
123 5         20 weaken $self;
124             $self->{handle} = AnyEvent::Handle->new(
125             connect => [$self->host, $port],
126             timeout => 60,
127              
128             $tls ? (tls => "connect", tls_ctx => $tls_opts) : (),
129              
130             on_connect => sub {
131 4     4   1030 warn "-- connection established\n" if DEBUG;
132              
133 4         8 delete $self->{queue};
134              
135             $self->_login(sub {
136 4 100       11 return $self->_close($_[1]) if $_[1];
137 2         6 $self->_write_sentence($_) for @$queue;
138 4         18 });
139             },
140              
141             on_connect_error => sub {
142 1     1   220 delete @{$self}{qw(handle queue)};
  1         8  
143 1         34 $self->_close($_[1]);
144             },
145              
146 1 50   1   250970 on_eof => sub { $self && $self->_close },
147 0 0   0   0 on_error => sub { $self && $self->_close($_[2]) },
148 15     15   38604 on_read => sub { $self->_read(\$_[0]->{rbuf}) },
149 5     5   1695 on_prepare => sub {CONN_TIMEOUT},
150 0 0   0   0 on_timeout => sub { $self && $self->_close }
151 5 50       25 );
152              
153 5         788 return $r->{tag};
154             }
155              
156             sub _enqueue {
157 5     5   12 my ($self, $r) = @_;
158 5 50       20 return $self->_connect($r) unless my $queue = $self->{queue};
159 0         0 push @$queue, $r;
160 0         0 return $r->{tag};
161             }
162              
163             sub _fail_all {
164 4     4   9 my @requests = values %{$_[0]->{requests}};
  4         24  
165 4         22 $_[0]->_fail($_, $_[1]) for @requests;
166             }
167              
168             sub _finish {
169 21     21   62 my ($self, $r, $err) = @_;
170 21         83 delete $self->{requests}{$r->{tag}};
171 21         114 delete $r->{timeout};
172 21   100     149 $r->{cb}->($self, ($self->{error} = $err // ''), $r->{data});
173             }
174              
175             sub _login {
176 4     4   10 my ($self, $cb) = @_;
177 4         6 warn "-- trying to log in\n" if DEBUG;
178              
179             $self->_command(
180             '/login',
181             (
182             $self->new_login
183             ? {name => $self->user, password => $self->password}
184             : {}
185             ),
186             undef,
187             sub {
188 4     4   11 my ($self, $err, $res) = @_;
189 4 100       10 return $self->$cb($err) if $err;
190 3 100       13 return $self->$cb() if !$res->[0]{ret}; # New style login
191              
192             my $secret
193 1         4 = md5_hex("\x00", $self->password, pack 'H*', $res->[0]{ret});
194              
195 1         6 $self->_command('/login',
196             {name => $self->user, response => "00$secret"},
197             undef, $cb);
198             }
199 4 100       13 );
200             }
201              
202             sub _read {
203 15     15   38 my ($self, $buf) = @_;
204              
205 15         20 warn _term_esc("-- read buffer (" . length($$buf) . " bytes)\n$$buf\n")
206             if DEBUG;
207              
208 15   66     68 my $response = $self->{response} ||= MikroTik::Client::Response->new();
209 15         52 my $data = $response->parse($buf);
210              
211 15         43 for (@$data) {
212 25 100       80 next unless my $r = $self->{requests}{delete $_->{'.tag'}};
213 24         48 my $type = delete $_->{'.type'};
214 24 100 100     85 push @{$r->{data} ||= []}, $_ if %$_ && !$r->{subscription};
  15   100     69  
215              
216 24 100 100     132 if ($type eq '!re' && $r->{subscription}) {
    100 100        
    100          
217 1         9 $r->{cb}->($self, '', $_);
218              
219             }
220             elsif ($type eq '!done') {
221 8   100     31 $r->{data} ||= [];
222 8         23 $self->_finish($r);
223              
224             }
225             elsif ($type eq '!trap' || $type eq '!fatal') {
226 7         77 $self->_fail($r, $_->{message});
227             }
228             }
229             }
230              
231             sub _send_request {
232 21     21   42 my ($self, $r) = @_;
233 21 100       67 return $self->_enqueue($r) unless $self->{handle};
234 16         43 return $self->_write_sentence($r);
235             }
236              
237             sub _term_esc {
238 0     0   0 my $str = shift;
239 0         0 $str =~ s/([\x00-\x09\x0b-\x1f\x7f\x80-\x9f])/sprintf '\\x%02x', ord $1/ge;
  0         0  
240 0         0 return $str;
241             }
242              
243             sub _write_sentence {
244 18     18   38 my ($self, $r) = @_;
245 18         24 warn _term_esc("-- writing sentence for tag: $r->{tag}\n$r->{sentence}\n")
246             if DEBUG;
247              
248 18         79 $self->{handle}->push_write($r->{sentence});
249              
250 18 100       1593 return $r->{tag} if $r->{subscription};
251              
252 17         54 weaken $self;
253             $r->{timeout} = AnyEvent->timer(
254             after => $self->timeout,
255 2     2   1498999 cb => sub { $self->_fail($r, 'response timeout') }
256 17         60 );
257              
258 17         349 return $r->{tag};
259             }
260              
261             1;
262              
263             =encoding utf8
264              
265             =head1 NAME
266              
267             MikroTik::Client - Non-blocking interface to MikroTik API
268              
269             =head1 SYNOPSIS
270              
271             my $api = MikroTik::Client->new();
272              
273             # Blocking
274             my $list = $api->command(
275             '/interface/print',
276             {'.proplist' => '.id,name,type'},
277             {type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'}
278             );
279             if (my $err = $api->error) { die "$err\n" }
280             printf "%s: %s\n", $_->{name}, $_->{type} for @$list;
281              
282              
283             # Non-blocking
284             my $cv = AE::cv;
285             my $tag = $api->command(
286             '/system/resource/print',
287             {'.proplist' => 'board-name,version,uptime'} => sub {
288             my ($api, $err, $list) = @_;
289             ...;
290             $cv->send;
291             }
292             );
293             $cv->recv;
294              
295             # Subscribe
296             $tag = $api->subscribe(
297             '/interface/listen' => sub {
298             my ($api, $err, $el) = @_;
299             ...;
300             }
301             );
302             AE::timer 3, 0, cb => sub { $api->cancel($tag) };
303              
304             # Errors handling
305             $api->command(
306             '/random/command' => sub {
307             my ($api, $err, $list) = @_;
308              
309             if ($err) {
310             warn "Error: $err, category: " . $list->[0]{category};
311             return;
312             }
313              
314             ...;
315             }
316             );
317            
318             # Promises
319             $cv = AE::cv;
320             $api->cmd_p('/interface/print')
321             ->then(sub { my $res = shift }, sub { my ($err, $attr) = @_ })
322             ->finally($cv);
323             $cv->recv;
324              
325             =head1 DESCRIPTION
326              
327             Both blocking and non-blocking (don't mix them though) interface to a MikroTik
328             API service. With queries, command subscriptions and optional Promises.
329              
330             =head1 ATTRIBUTES
331              
332             L implements the following attributes.
333              
334             =head2 ca
335              
336             my $ca = $api->ca;
337             $api->ca("/etc/ssl/certs/ca-bundle.crt")
338              
339             Path to TLS certificate authority file used to verify the peer certificate,
340             defaults to the value of the C environment variable.
341              
342             =head2 cert
343              
344             my $cert = $api->cert;
345             $api->cert("./client.crt")
346              
347             Path to TLS certificate file used to authenticate against the peer. Can be bundled
348             with a private key and additional signing certificates. If file contains the private key,
349             L attribute is optional. Defaults to the value of the C
350             environment variable.
351              
352             =head2 error
353              
354             my $last_error = $api->error;
355              
356             Keeps an error from last L call. Empty string on successful commands.
357              
358             =head2 host
359              
360             my $host = $api->host;
361             $api = $api->host('border-gw.local');
362              
363             Host name or IP address to connect to. Defaults to C<192.168.88.1>.
364              
365             =head2 insecure
366              
367             my $insecure = $api->insecure;
368             $api->insecure(1);
369              
370             Do not verify TLS certificates I<(highly discouraged)>. Connection will be encrypted,
371             but a peer certificate won't be validated. Disabled by default.
372              
373             =head2 key
374              
375             my $key = $api->key;
376             $api->key("./client.crt")
377              
378             Path to TLS key file. Optional if a private key bundled with a L file. Defaults to
379             the value of the C environment variable.
380              
381             =head2 new_login
382              
383             my $new_login = $api->new_login;
384             $api = $api->new_login(1);
385              
386             Use new login scheme introduced in RouterOS C and fallback to previous
387             one for older systems. Since in this mode a password will be send in clear text,
388             it will be default only for L connections.
389              
390             =head2 password
391              
392             my $pass = $api->password;
393             $api = $api->password('secret');
394              
395             Password for authentication. Empty string by default.
396              
397             =head2 port
398              
399             my $port = $api->port;
400             $api = $api->port(8000);
401              
402             API service port for connection. Defaults to C<8729> and C<8728> for TLS and
403             clear text connections respectively.
404              
405             =head2 timeout
406              
407             my $timeout = $api->timeout;
408             $api = $api->timeout(15);
409              
410             Timeout in seconds for sending request and receiving response before command
411             will be canceled. Default is C<10> seconds.
412              
413             =head2 tls
414              
415             my $tls = $api->tls;
416             $api = $api->tls(1);
417              
418             Use TLS for connection. Enabled by default.
419              
420             =head2 user
421              
422             my $user = $api->user;
423             $api = $api->user('admin');
424              
425             User name for authentication purposes. Defaults to C.
426              
427             =head1 METHODS
428              
429             =head2 cancel
430              
431             # subscribe to a command output
432             my $tag = $api->subscribe('/ping', {address => '127.0.0.1'} => sub {...});
433              
434             # cancel command after 10 seconds
435             my $t = AE::timer 10, 0, sub { $api->cancel($tag) };
436              
437             # or with callback
438             $api->cancel($tag => sub {...});
439              
440             Cancels background commands. Can accept a callback as last argument.
441              
442             =head2 cmd
443              
444             my $list = $api->cmd('/interface/print');
445              
446             An alias for L.
447              
448             =head2 cmd_p
449              
450             my $promise = $api->cmd_p('/interface/print');
451              
452             An alias for L.
453              
454             =head2 command
455              
456             my $command = '/interface/print';
457             my $attr = {'.proplist' => '.id,name,type'};
458             my $query = {type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'};
459              
460             my $list = $api->command($command, $attr, $query);
461             die $api->error if $api->error;
462             for (@$list) {...}
463              
464             $api->command('/user/set', {'.id' => 'admin', comment => 'System admin'});
465              
466             # Non-blocking
467             $api->command('/ip/address/print' => sub {
468             my ($api, $err, $list) = @_;
469              
470             return if $err;
471              
472             for (@$list) {...}
473             });
474              
475             # Omit attributes
476             $api->command('/user/print', undef, {name => 'admin'} => sub {...});
477              
478             # Errors handling
479             $list = $api->command('/random/command');
480             if (my $err = $api->error) {
481             die "Error: $err, category: " . $list->[0]{category};
482             }
483              
484             Executes a command on a remote host and returns list with hashrefs containing
485             elements returned by a host. You can append a callback for non-blocking calls.
486              
487             In a case of error, returned value may keep additional attributes such as category
488             or an error code. You should never rely on defines of the result to catch errors.
489              
490             For a query syntax refer to L.
491              
492             =head2 command_p
493              
494             my $promise = $api->command_p('/interface/print');
495              
496             $promise->then(
497             sub {
498             my $res = shift;
499             ...
500             })->catch(sub {
501             my ($err, $attr) = @_;
502             });
503              
504             Same as L, but always performs requests non-blocking and returns a
505             promise instead of accepting a callback. L v0.99+ is required for
506             this functionality.
507              
508             =head2 subscribe
509              
510             my $tag = $api->subscribe('/ping',
511             {address => '127.0.0.1'} => sub {
512             my ($api, $err, $res) = @_;
513             });
514              
515             AE::timer 3, 0, sub { $api->cancel($tag) };
516              
517             Subscribe to an output of commands with continuous responses such as C or
518             C. Should be terminated with L.
519              
520             =head1 DEBUGGING
521              
522             You can set the MIKROTIK_CLIENT_DEBUG environment variable to get some debug output
523             printed to stderr.
524              
525             Also, you can change connection timeout with the MIKROTIK_CLIENT_CONNTIMEOUT variable.
526              
527             =head1 COPYRIGHT AND LICENSE
528              
529             Andre Parker, 2017-2019.
530              
531             This program is free software, you can redistribute it and/or modify it under
532             the terms of the Artistic License version 2.0.
533              
534             =head1 SEE ALSO
535              
536             L, L
537              
538             =cut