use strict;
use warnings;
use XML::Twig;
use Digest::MD5;
use Getopt::Long::Descriptive;
no warnings 'once';
use JSON::MaybeXS;
use Data::UUID;
my $ug = Data::UUID -> new();
my ($opt, $usage) = describe_options(
'%c %o <some-arg>',
[ 'actions|a!', "toggle dump actions", { default => 0 } ],
[ 'patterns|p!', "toggle dump patterns", { default => 1 } ],
[ 'examples|e!', "toggle dump examples", { default => 1 } ],
[ 'program|P!', "toggle prepend '\$PROGRAM: '", { default => 0 } ],
);
sub init {
my $twig = XML::Twig -> new(
Twig_handlers => {
ruleset => \&ruleset,
rule => \&rule,
description => \&ruleset_description,
'ruleset/pattern' => \&ruleset_pattern,
'ruleset/patterns/pattern' => \&ruleset_pattern,
'rule/pattern' => \&rule_pattern,
'rule/patterns/pattern' => \&rule_pattern,
'rule/example' => \&example,
'rule/examples/example' => \&example,
'action' => \&action,
'rule/tags/tag' => \&rule_tag,
'rule/tag' => \&rule_tag,
'rule/values/value' => \&rule_value,
'rule/value' => \&rule_value,
}
);
}
my %ruleset;
sub ruleset {
my ($twig, $ruleset) = @_;
my $name = $ruleset -> {att} -> {name} || $ruleset -> {id};
$ruleset{$name}->{id} = $ruleset -> id;
$ruleset{$name}->{pubdate} = $ruleset -> parent -> {att} -> {pub_date};
$ruleset{$name}->{version} = $ruleset -> parent -> {att} -> {version};
}
sub ruleset_description {
my ($twig, $description) = @_;
my $ruleset_id = $_ -> parent('ruleset') -> {att} -> {name} || $_ -> parent('ruleset') -> id;
$description -> trim;
$ruleset{$ruleset_id}->{description} = $description -> text;
}
sub ruleset_pattern {
my ($twig, $pattern) = @_;
my $ruleset_id = $pattern -> parent('ruleset') -> {att} -> {name} || $pattern -> parent('ruleset') -> id;
if (! defined $ruleset{$ruleset_id}->{patterns}) {
$ruleset{$ruleset_id}->{patterns} = [];
}
push @{$ruleset{$ruleset_id}->{patterns}}, $pattern -> text;
}
my %rule;
sub rule {
my ($twig, $rule) = @_;
my $ruleset_id = $rule -> parent('ruleset') -> {att} -> {name} || $rule -> parent('ruleset') -> id;
$rule{$rule->id}->{id} = $rule -> id;
$rule{$rule->id}->{ruleset} = $ruleset_id;
$rule{$rule->id}->{ruleclass} = $rule -> class;
map {
(my $k = $_) =~ s/-/_/;
$rule{$rule->id}->{$k} = $rule -> {att} -> {$_} if defined $rule -> {att} -> {$_};
} qw/provider context-scope context-id context-timeout/;
}
sub rule_pattern {
my ($twig, $pattern) = @_;
my $rule_id = $pattern -> parent('rule') -> id;
if (! defined $rule{$rule_id}->{patterns}) {
$rule{$rule_id}->{patterns} = [];
}
push @{$rule{$rule_id}->{patterns}}, $pattern -> text;
}
sub example {
my ($twig, $example) = @_;
my $rule_id = $example -> parent('rule') -> id;
if (! defined $rule{$rule_id}->{examples}) {
$rule{$rule_id}->{examples} = [];
}
my $test_message = $example -> last_child('test_message');
my $test_values = $example -> last_child('test_values');
my %test_value;
if (defined $test_values) {
while ($test_values = $test_values -> next_elt('test_value')) {
$test_value{test_values}->{ $test_values -> {att} -> {name} } = $test_values -> text;
}
}
push @{$rule{$rule_id}->{examples}}, {
test_message => $test_message -> text,
program => $test_message -> {att} -> {program},
%test_value
} if $opt -> examples;
}
sub rule_tag {
my ($twig, $tag) = @_;
my $rule_id = $tag -> parent('rule') -> id;
$rule{$rule_id}->{tags} = [] unless defined $rule{$rule_id}->{tags};
push @{$rule{$rule_id}->{tags}}, $tag -> text;
}
sub rule_value {
my ($twig,$value) = @_;
my $rule_id = $value -> parent('rule') -> id;
$rule{$rule_id}->{values}->{$value -> {att} -> {name}} = $value -> text;
}
my @action;
sub action {
my ($twig, $action) = @_;
my $rule_id = $action -> parent('rule') -> id;
my $message = $action -> next_elt('message');
my $values = $message -> next_elt('values');
my $tags = $message -> next_elt('tags');
my (%value, %tag, %trigger, %condition, %inherit);
%inherit = defined ($message -> {att} -> {'inherit-properties'}) ? ( inherit_properties => $message -> {att} -> {'inherit-properties'} ) : ();
%trigger = ( trigger => $action -> {att} -> {trigger}) if (defined $action -> {att} -> {trigger});
%condition = ( condition => $action -> {att} -> {condition}) if (defined $action -> {att} -> {condition});
if (defined $values) {
while ($values = $values -> next_elt('value')) {
$value{values}->{$values -> {att} -> {name} } = $values -> text;
}
}
$tag{tags} = [];
if (defined $tags) {
while ($tags = $tags -> next_elt('tag')) {
push @{$tag{tags}}, $tags -> text;
}
}
push @action, {
rule => $rule_id,
%trigger,
%condition,
message => {
%inherit,
%value,
%tag,
}
};
}
my $infile = $ARGV[0];
my $twig = init();
$twig -> parsefile($infile);
if ($opt -> actions) {
warn "Unsupported\n";
exit 2;
}
if ($opt -> patterns) {
my @adb_pattern;
my $p_id;
while (my ($uuid, $rule) = each %rule) {
my $ruleset = $rule -> {ruleset};
my @programs;
if (ref $ruleset{$ruleset}->{patterns} eq "ARRAY") {
@programs = @{$ruleset{$ruleset}->{patterns}}
} else {
@programs = ($ruleset{$ruleset}->{patterns})
}
if (@programs > 1) {
warn "rule `${uuid}` belongs to a ruleset with multiple patterns (or programs). You must manually check it\n";
}
my $program = $programs[0];
unless (defined $program) {
warn "rule `${uuid}` belongs to ruleset with no pattern/program. This is unsupported\n";
next;
}
my @test_messages = _test_messages($rule -> {examples});
my %extra_values;
my %extra_tags;
if ($rule -> {values}) {
while (my ($k,$v) = each %{$rule -> {values}}) {
for ($v) {
if (/\$\(/) {
warn "rule `${uuid}` contains key-value with macro: `${k}=${v}`. Unsupported\n"
} else {
$extra_values{values}->{$k} = $v;
}
}
}
}
if ($rule -> {tags}) {
%extra_tags = ( tags => $rule -> {tags})
}
if (@test_messages > 0 && @{$rule->{patterns}} > 1) {
warn "rule `${uuid}` has multiple patterns *and* test_messages. You must manually redistribute test_messages\n";
}
my $pattern_uuid = $uuid;
for my $pattern (@{$rule->{patterns}}) {
my $adbp;
if ($opt -> program) {
$adbp = "${program}: ";
}
$adbp .= _p2p($pattern);
push @adb_pattern, {
uuid => $pattern_uuid,
pattern => $adbp,
name => $rule->{ruleset} . "_" . $p_id++,
test_messages => \@test_messages,
%extra_values,
%extra_tags,
} if _p2p($pattern);
$pattern_uuid = $ug->create();
$pattern_uuid = $ug -> to_string($pattern_uuid);
}
}
my $endresult = { patterns => \@adb_pattern };
my $json = JSON::MaybeXS->new(utf8 => 1, pretty => 1);
print $json -> encode($endresult);
}
sub _test_messages {
my @out;
for my $example (@{$_[0]}) {
my $adbtm;
if ($opt -> program) {
$adbtm = $example -> {program} . ": ";
}
$adbtm .= $example -> {test_message};
push @out, {
message => $adbtm,
values => $example -> {test_values}
};
}
return @out
}
sub _p2p {
my @pattern = split /(@)/, $_[0];
my @out;
my $is_pattern = 0;
for my $p (@pattern) {
if ($p eq '@') {
if ($is_pattern) {
$is_pattern = 0;
next
} else {
$is_pattern = 1;
next
}
} else {
if ($is_pattern) {
if (_validate_pattern($p)) {
push @out, _validate_pattern($p);
} else {
warn "unsupported `$p`\n";
return;
}
} else {
push @out, _unescape_pattern($p);
next
}
}
}
return join ("", @out)
}
sub _unescape_pattern {
(my $out = shift) =~ s/@@/@/g;
return $out;
}
sub _validate_pattern {
my ($type,$key,$opt) = split(/:/,$_[0]);
$key ||= "pdb2adb2ignore";
$type ||= "";
for ($type) {
if (/^$/) {
return "";
} elsif (/^ESTRING$/) {
$opt = ":" if (substr($_[0],-2) eq "::");
return "%{GREEDY:$key}$opt";
} elsif (/QSTRING/) {
my $a = substr($opt,0,1);
my $b;
if (length($opt) > 1) {
$b = substr($opt,1,1);
} else {
$b = $a;
}
return "${a}%{GREEDY:$key}${b}";
} elsif (/^NUMBER$/) {
return "%{INT:$key}";
} elsif (/^HOSTNAME$/) {
my $adbset = "SET(\"AZERTYUIOPQSDFGHJKLMWXCVBNazertyuiopqsdfghjklmwxcvbn1234567890-.\")";
return "%{$adbset:$key}";
} elsif (/^FLOAT|DOUBLE$/) {
my $adbset = "SET(\"1234567890.\")";
warn "pdb(`$type`) partially supported by $adbset\n";
return "%{$adbset:$key}";
} elsif (/^STRING$/) {
if ($opt) {
my $adbset = "SET(\"AZERTYUIOPQSDFGHJKLMWXCVBNazertyuiopqsdfghjklmwxcvbn1234567890$opt\")";
warn "pdb(`$type`) with options `$opt` partially supported by $adbset\n";
return "%{$adbset:$key}";
}
return "%{SET(\"AZERTYUIOPQSDFGHJKLMWXCVBNazertyuiopqsdfghjklmwxcvbn1234567890\"):$key}";
} elsif (/^PCRE$/) {
warn "unsupported pattern parser `$type`\n";
return
} elsif (/^ANYSTRING$/) {
return "%{GREEDY:$key}";
} elsif (/^SET$/) {
return "%{SET(\"$opt\"):$key}";
} elsif (/^(IPvANY|MACADDR|IPv4|LLADDR)/) {
warn "pdb(`$type`) will use adb('GREEDY') which may match your messages differently.\n";
return "%{GREEDY:$key}"
} else {
warn "unsupported pattern parser `$type`\n";
return
}
}
}