Implement vici Perl binding
This commit is contained in:
parent
cbc43f1b43
commit
a101bce862
|
@ -299,6 +299,8 @@ ARG_ENABL_SET([ruby-gems], [enable build of provided ruby gems.])
|
|||
ARG_ENABL_SET([ruby-gems-install],[enable installation of provided ruby gems.])
|
||||
ARG_ENABL_SET([python-eggs], [enable build of provided python eggs.])
|
||||
ARG_ENABL_SET([python-eggs-install],[enable installation of provided python eggs.])
|
||||
ARG_ENABL_SET([perl-cpan], [enable build of provided perl CPAN module.])
|
||||
ARG_ENABL_SET([perl-cpan-install],[enable installation of provided CPAN module.])
|
||||
# compile options
|
||||
ARG_ENABL_SET([coverage], [enable lcov coverage report generation.])
|
||||
ARG_ENABL_SET([leak-detective], [enable malloc hooks to find memory leaks.])
|
||||
|
@ -1622,6 +1624,7 @@ AM_CONDITIONAL(USE_SYSTEMD, test x$systemd = xtrue)
|
|||
AM_CONDITIONAL(USE_LEGACY_SYSTEMD, test -n "$systemdsystemunitdir" -a "x$systemdsystemunitdir" != xno)
|
||||
AM_CONDITIONAL(USE_RUBY_GEMS, test x$ruby_gems = xtrue)
|
||||
AM_CONDITIONAL(USE_PYTHON_EGGS, test x$python_eggs = xtrue)
|
||||
AM_CONDITIONAL(USE_PERL_CPAN, test x$perl_cpan = xtrue)
|
||||
AM_CONDITIONAL(USE_PY_TEST, test "x$PY_TEST" != x)
|
||||
|
||||
# ========================
|
||||
|
@ -1835,6 +1838,7 @@ AC_CONFIG_FILES([
|
|||
src/libcharon/plugins/stroke/Makefile
|
||||
src/libcharon/plugins/vici/Makefile
|
||||
src/libcharon/plugins/vici/ruby/Makefile
|
||||
src/libcharon/plugins/vici/perl/Makefile
|
||||
src/libcharon/plugins/vici/python/Makefile
|
||||
src/libcharon/plugins/updown/Makefile
|
||||
src/libcharon/plugins/dhcp/Makefile
|
||||
|
|
|
@ -79,3 +79,7 @@ endif
|
|||
if USE_PYTHON_EGGS
|
||||
SUBDIRS += python
|
||||
endif
|
||||
|
||||
if USE_PERL_CPAN
|
||||
SUBDIRS += perl
|
||||
endif
|
||||
|
|
|
@ -0,0 +1,19 @@
|
|||
Copyright (c) 2015 Andreas Steffen
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
|
||||
THE SOFTWARE.
|
|
@ -0,0 +1 @@
|
|||
include LICENSE
|
|
@ -0,0 +1,6 @@
|
|||
EXTRA_DIST = LICENSE \
|
||||
Vici/Message.pm \
|
||||
Vici/Packet.pm \
|
||||
Vici/Session.pm \
|
||||
Vici/Transport.pm
|
||||
|
|
@ -0,0 +1,214 @@
|
|||
package Vici::Message;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(new, from_data, hash, encode, raw);
|
||||
our @VERSION = 0.9;
|
||||
|
||||
use strict;
|
||||
use Switch;
|
||||
use Vici::Transport;
|
||||
|
||||
use constant {
|
||||
SECTION_START => 1, # Begin a new section having a name
|
||||
SECTION_END => 2, # End a previously started section
|
||||
KEY_VALUE => 3, # Define a value for a named key in the section
|
||||
LIST_START => 4, # Begin a named list for list items
|
||||
LIST_ITEM => 5, # Define an unnamed item value in the current list
|
||||
LIST_END => 6, # End a previously started list
|
||||
};
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $hash = shift;
|
||||
my $self = {
|
||||
Hash => $hash
|
||||
};
|
||||
bless($self, $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub from_data {
|
||||
my $class = shift;
|
||||
my $data = shift;
|
||||
my %hash = ();
|
||||
|
||||
parse($data, \%hash);
|
||||
|
||||
my $self = {
|
||||
Hash => \%hash
|
||||
};
|
||||
bless($self, $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
return $self->{Hash};
|
||||
}
|
||||
|
||||
sub encode {
|
||||
my $self = shift;
|
||||
return encode_hash($self->{'Hash'});
|
||||
}
|
||||
|
||||
sub raw {
|
||||
my $self = shift;
|
||||
return '{' . raw_hash($self->{'Hash'}) . '}';
|
||||
}
|
||||
|
||||
# private functions
|
||||
|
||||
sub parse {
|
||||
my $data = shift;
|
||||
my $hash = shift;
|
||||
|
||||
while (length($data) > 0)
|
||||
{
|
||||
(my $type, $data) = unpack('Ca*', $data);
|
||||
|
||||
if ($type == SECTION_END)
|
||||
{
|
||||
return $data;
|
||||
}
|
||||
|
||||
(my $key, $data) = unpack('C/a*a*', $data);
|
||||
|
||||
switch ($type)
|
||||
{
|
||||
case KEY_VALUE
|
||||
{
|
||||
(my $value, $data) = unpack('n/a*a*', $data);
|
||||
$hash->{$key} = $value;
|
||||
}
|
||||
case SECTION_START
|
||||
{
|
||||
my %section = ();
|
||||
$data = parse($data, \%section);
|
||||
$hash->{$key} = \%section;
|
||||
}
|
||||
case LIST_START
|
||||
{
|
||||
my @list = ();
|
||||
my $more = 1;
|
||||
|
||||
while (length($data) > 0 and $more)
|
||||
{
|
||||
(my $type, $data) = unpack('Ca*', $data);
|
||||
switch ($type)
|
||||
{
|
||||
case LIST_ITEM
|
||||
{
|
||||
(my $value, $data) = unpack('n/a*a*', $data);
|
||||
push(@list, $value);
|
||||
}
|
||||
case LIST_END
|
||||
{
|
||||
$more = 0;
|
||||
$hash->{$key} = \@list;
|
||||
}
|
||||
else
|
||||
{
|
||||
die "message parsing error: ", $type, "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
die "message parsing error: ", $type, "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
sub encode_hash {
|
||||
my $hash = shift;
|
||||
my $enc = '';
|
||||
|
||||
while ( (my $key, my $value) = each %$hash )
|
||||
{
|
||||
switch (ref($value))
|
||||
{
|
||||
case 'HASH'
|
||||
{
|
||||
$enc .= pack('CC/a*', SECTION_START, $key);
|
||||
$enc .= encode_hash($value);
|
||||
$enc .= pack('C', SECTION_END);
|
||||
}
|
||||
case 'ARRAY'
|
||||
{
|
||||
$enc .= pack('CC/a*', LIST_START, $key);
|
||||
|
||||
foreach my $item (@$value)
|
||||
{
|
||||
$enc .= pack('Cn/a*', LIST_ITEM, $item);
|
||||
}
|
||||
$enc .= pack('C', LIST_END);
|
||||
}
|
||||
else
|
||||
{
|
||||
$enc .= pack('CC/a*n/a*', KEY_VALUE, $key, $value);
|
||||
}
|
||||
}
|
||||
}
|
||||
return $enc;
|
||||
}
|
||||
|
||||
sub raw_hash {
|
||||
my $hash = shift;
|
||||
my $raw = '';
|
||||
my $first = 1;
|
||||
|
||||
while ( (my $key, my $value) = each %$hash )
|
||||
{
|
||||
if ($first)
|
||||
{
|
||||
$first = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
$raw .= ' ';
|
||||
}
|
||||
$raw .= $key;
|
||||
|
||||
switch (ref($value))
|
||||
{
|
||||
case 'HASH'
|
||||
{
|
||||
$raw .= '{' . raw_hash($value) . '}';
|
||||
}
|
||||
case 'ARRAY'
|
||||
{
|
||||
my $first_item = 1;
|
||||
$raw .= '[';
|
||||
|
||||
foreach my $item (@$value)
|
||||
{
|
||||
if ($first_item)
|
||||
{
|
||||
$first_item = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
$raw .= ' ';
|
||||
}
|
||||
$raw .= $item;
|
||||
}
|
||||
$raw .= ']';
|
||||
}
|
||||
else
|
||||
{
|
||||
$raw .= '=' . $value;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $raw;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
package Vici::Packet;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(new, request, register, unregister, streamed_request);
|
||||
our @VERSION = 0.9;
|
||||
|
||||
use strict;
|
||||
use Switch;
|
||||
use Vici::Transport;
|
||||
|
||||
use constant {
|
||||
CMD_REQUEST => 0, # Named request message
|
||||
CMD_RESPONSE => 1, # Unnamed response message for a request
|
||||
CMD_UNKNOWN => 2, # Unnamed response if requested command is unknown
|
||||
EVENT_REGISTER => 3, # Named event registration request
|
||||
EVENT_UNREGISTER => 4, # Named event de-registration request
|
||||
EVENT_CONFIRM => 5, # Unnamed confirmation for event (de-)registration
|
||||
EVENT_UNKNOWN => 6, # Unnamed response if event (de-)registration failed
|
||||
EVENT => 7, # Named event message
|
||||
};
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $socket = shift;
|
||||
my $self = {
|
||||
Transport => Vici::Transport->new($socket),
|
||||
};
|
||||
bless($self, $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub request {
|
||||
my ($self, $command, $data) = @_;
|
||||
my $request = pack('CC/a*a*', CMD_REQUEST, $command, $data);
|
||||
$self->{'Transport'}->send($request);
|
||||
|
||||
my $response = $self->{'Transport'}->receive();
|
||||
my ($type, $msg) = unpack('Ca*', $response);
|
||||
|
||||
switch ($type)
|
||||
{
|
||||
case CMD_RESPONSE
|
||||
{
|
||||
return $msg
|
||||
}
|
||||
case CMD_UNKNOWN
|
||||
{
|
||||
die "unknown command '", $command, "'\n"
|
||||
}
|
||||
else
|
||||
{
|
||||
die "invalid response type\n"
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, $event) = @_;
|
||||
my $request = pack('CC/a*a*', EVENT_REGISTER, $event);
|
||||
$self->{'Transport'}->send($request);
|
||||
|
||||
my $response = $self->{'Transport'}->receive();
|
||||
my ($type, $data) = unpack('Ca*', $response);
|
||||
|
||||
switch ($type)
|
||||
{
|
||||
case EVENT_CONFIRM
|
||||
{
|
||||
return
|
||||
}
|
||||
case EVENT_UNKNOWN
|
||||
{
|
||||
die "unknown event '", $event, "'\n"
|
||||
}
|
||||
else
|
||||
{
|
||||
die "invalid response type\n"
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub unregister {
|
||||
my ($self, $event) = @_;
|
||||
my $request = pack('CC/a*a*', EVENT_UNREGISTER, $event);
|
||||
$self->{'Transport'}->send($request);
|
||||
|
||||
my $response = $self->{'Transport'}->receive();
|
||||
my ($type, $data) = unpack('Ca*', $response);
|
||||
|
||||
switch ($type)
|
||||
{
|
||||
case EVENT_CONFIRM
|
||||
{
|
||||
return
|
||||
}
|
||||
case EVENT_UNKNOWN
|
||||
{
|
||||
die "unknown event '", $event, "'\n"
|
||||
}
|
||||
else
|
||||
{
|
||||
die "invalid response type\n"
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub streamed_request {
|
||||
my ($self, $command, $event, $data) = @_;
|
||||
$self->register($event);
|
||||
|
||||
my $request = pack('CC/a*a*', CMD_REQUEST, $command, $data);
|
||||
$self->{'Transport'}->send($request);
|
||||
my $more = 1;
|
||||
my $msg = "";
|
||||
|
||||
while ($more)
|
||||
{
|
||||
my $response = $self->{'Transport'}->receive();
|
||||
my ($type, $data) = unpack('Ca*', $response);
|
||||
|
||||
switch ($type)
|
||||
{
|
||||
case EVENT
|
||||
{
|
||||
(my $event_name, $data) = unpack('C/a*a*', $data);
|
||||
if ($event_name == $event)
|
||||
{
|
||||
$msg .= $data;
|
||||
}
|
||||
}
|
||||
case CMD_RESPONSE
|
||||
{
|
||||
$self->unregister($event);
|
||||
$more = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
$self->unregister($event);
|
||||
die "invalid response type\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $msg;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
package Vici::Session;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(new, version, stats, reload_settings, initiate, list_sas,
|
||||
list_policies, list_conns, get_conns, list_certs,
|
||||
list_authorities, get_authorities, get_pools);
|
||||
our @VERSION = 0.9;
|
||||
|
||||
use strict;
|
||||
use Vici::Packet;
|
||||
use Vici::Message;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $socket = shift;
|
||||
my $self = {
|
||||
Packet => Vici::Packet->new($socket),
|
||||
};
|
||||
bless($self, $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub version {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('version');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub stats {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('stats');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub reload_settings {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('reload-settings');
|
||||
my $msg = Vici::Message->from_data($data);
|
||||
my $res = $msg->hash();
|
||||
return $res->{'success'} == 'yes';
|
||||
}
|
||||
|
||||
sub initiate {
|
||||
my ($self, $msg) = @_;
|
||||
my $vars = '';
|
||||
if (defined $msg)
|
||||
{
|
||||
$vars = $msg->encode();
|
||||
}
|
||||
my $data = $self->{'Packet'}->request('initiate', $vars);
|
||||
my $msg = Vici::Message->from_data($data);
|
||||
my $res = $msg->hash();
|
||||
return $res->{'success'} == 'yes';
|
||||
}
|
||||
|
||||
sub list_sas {
|
||||
my ($self, $msg) = @_;
|
||||
my $vars = '';
|
||||
if (defined $msg)
|
||||
{
|
||||
$vars = $msg->encode();
|
||||
}
|
||||
my $data = $self->{'Packet'}->streamed_request('list-sas',
|
||||
'list-sa', $vars);
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub list_policies {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->streamed_request('list-policies',
|
||||
'list-policy');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub list_conns {
|
||||
my ($self, $msg) = @_;
|
||||
my $vars = '';
|
||||
if (defined $msg)
|
||||
{
|
||||
$vars = $msg->encode();
|
||||
}
|
||||
my $data = $self->{'Packet'}->streamed_request('list-conns',
|
||||
'list-conn', $vars);
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub get_conns {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('get-conns');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub list_certs {
|
||||
my ($self, $msg) = @_;
|
||||
my $vars = '';
|
||||
if (defined $msg)
|
||||
{
|
||||
$vars = $msg->encode();
|
||||
}
|
||||
my $data = $self->{'Packet'}->streamed_request('list-authorities',
|
||||
'list-authority', $vars);
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub list_authorities {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->streamed_request('list-authorities',
|
||||
'list-authority');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub get_authorities {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('get-authorities');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
sub get_pools {
|
||||
my $self = shift;
|
||||
my $data = $self->{'Packet'}->request('get-pools');
|
||||
return Vici::Message->from_data($data);
|
||||
}
|
||||
|
||||
1;
|
|
@ -0,0 +1,39 @@
|
|||
package Vici::Transport;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(new, send, receive);
|
||||
our @VERSION = 0.9;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
Socket => shift,
|
||||
};
|
||||
bless($self, $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub send {
|
||||
my ($self, $data) = @_;
|
||||
my $packet = pack('N/a*', $data);
|
||||
$self->{'Socket'}->send($packet);
|
||||
}
|
||||
|
||||
sub receive {
|
||||
my $self = shift;
|
||||
my $packet_header;
|
||||
my $data;
|
||||
|
||||
$self->{'Socket'}->recv($packet_header, 4);
|
||||
my $packet_len = unpack('N', $packet_header);
|
||||
$self->{'Socket'}->recv($data, $packet_len);
|
||||
return $data;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
Loading…
Reference in New Issue