Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
package Algorithm::ToNumberMunger;
use 5.006;
use strict;
use warnings;
use Carp qw(carp croak);
use Scalar::Util qw(looks_like_number);
=head1 NAME
Algorithm::ToNumberMunger - Compile declarative specs into closures that munge raw values into numbers.
=head1 VERSION
Version 0.0.1
=cut
our $VERSION = '0.0.1';
# Feature hashing (the 'hash' munger) is a tight per-byte FNV-1a loop with a
# 32-bit modular multiply. That is exactly the kind of work XS is good at and
# pure Perl is bad at (both for speed and, on a 32-bit perl, for correctness of
# the wrap-around), so we compile it in C when we can. Everything else here is a
# hash lookup or a couple of flops -- crossing the XS boundary per row would
# only make those slower, so they stay pure Perl. If the XS did not build (no
# compiler at install time) we fall back to a pure-Perl FNV-1a, which is exact
# on a 64-bit perl.
our $HAVE_XS = 0;
eval {
require XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
$HAVE_XS = 1;
1;
};
=head1 SYNOPSIS
use Algorithm::ToNumberMunger;
# one munger from a spec hash
my $code = Algorithm::ToNumberMunger->build(
{ munger => 'enum', map => { GET => 0, POST => 1, PUT => 2 } },
);
my $n = $code->('POST'); # 1
# a whole table of them at once, from a 'field => spec' hash
my $by_tag = Algorithm::ToNumberMunger->build_all(
\%mungers,
);
my $row_value = $by_tag->{method}->($raw{method});
=head1 DESCRIPTION
Many numeric pipelines -- anomaly detectors, feature stores, CSV loaders --
want every column to be a number, but the values they are handed are not always
numbers to begin with: an HTTP method is a string, a timestamp is a formatted
date, a high-cardinality label wants bucketing. An B<input munger> turns such a
raw value into a single number. Munging happens on the input side, before a row
is stored.
Mungers are declared as a plain data spec -- a hash naming a built-in munger and
carrying that munger's parameters -- so a table of them can be read straight out
of JSON or a config file:
{
"method": { "munger": "enum", "map": { "GET": 0, "POST": 1 } },
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
for my $tag (@$tags) {
push @scalar, { tag => $tag, from => $tag, code => undef }
unless $claimed{$tag};
}
return bless {
tags => [@$tags],
pos => \%pos,
scalar => \@scalar,
expand => \@expand,
combine => \@combine,
},
"${class}::Plan";
} ## end sub compile
=head2 known_mungers
my @names = ...->known_mungers;
The sorted list of built-in munger names this version understands.
=head2 has_munger
if ( ...->has_munger('enum') ) { ... }
True if the named munger is built in.
=cut
sub known_mungers { my @names = sort keys %BUILDERS; return @names }
sub has_munger { return exists $BUILDERS{ $_[1] } }
=head1 BUILT-IN MUNGERS
Every munger returns a plain number and, where the input cannot be interpreted,
croaks -- the Writer would reject a non-numeric field anyway, so failing at the
munger gives a better message. Parameters are validated when the munger is
built, not per row.
=head2 enum
{ munger => 'enum', map => { GET => 0, POST => 1 }, default => -1 }
Categorical string to number via an explicit C<map>. All map values must be
numeric. Without a C<default>, an unmapped input croaks; with one, unmapped
inputs (including C<undef>) yield the default.
=cut
sub _build_enum {
my ( $spec, $where ) = @_;
my $map = $spec->{map};
croak "enum munger$where requires a 'map' hashref"
unless ref $map eq 'HASH';
for my $k ( keys %$map ) {
croak "enum munger$where: map value for '$k' ('"
. ( defined $map->{$k} ? $map->{$k} : 'undef' )
. "') is not numeric"
unless looks_like_number( $map->{$k} );
}
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "enum munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
# Copy so a later edit of the caller's spec cannot mutate a live munger.
my %m = %$map;
return sub {
my ($v) = @_;
return $m{$v} if defined $v && exists $m{$v};
return $default if $has_default;
croak "enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
};
} ## end sub _build_enum
=head2 frozen_freq_map
{ munger => 'frozen_freq_map', counts => { jpg => 40213, exe => 12, scr => 3 },
total => 67560 }
# defaults: mode => 'neg_log_prob', smoothing => 1, unseen => 'rare'
Frequency-encoding from a B<precomputed, frozen> count table: the rarer a value
was when the table was built, the more anomalous it scores. This is C<enum>'s
cousin -- a value-to-number map -- except the numbers are derived from observed
C<counts> rather than hand-authored, with the smoothing and unseen-value policy
that "rare = interesting" needs. It stays a stateless munger: the table is
computed offline and shipped in C<info.json>; this class only I<applies> it.
C<counts> maps each value to how many times it was seen. C<total> is the overall
observation count; it defaults to the sum of C<counts>, but may be given
explicitly and larger so you can B<prune the long tail> out of C<counts> while
still computing correct probabilities. The emitted number depends on C<mode>:
=over 4
=item * C<neg_log_prob> (default) - self-information C<-ln(prob)>: rare values
score high, common ones low. This is the axis "rare = interesting" describes and
what an Isolation Forest splits on most naturally.
=item * C<freq> - the probability itself, C<(count + smoothing) / denom>.
=item * C<log_count> - C<ln(1 + count)>, the count with its heavy tail tamed.
=item * C<count> - the raw count.
=back
Probabilities use add-one style C<smoothing> (default C<1>), treating "unseen" as
one aggregate bucket: C<prob(v) = (count + smoothing) / (total + smoothing*(V+1))>
where C<V> is the number of listed values. C<unseen> controls what a value absent
from the table maps to -- C<'rare'> (default) emits that value under the current
mode as if it had been seen zero times (for C<neg_log_prob>/C<freq> this is the
smoothed unseen bucket, for C<count>/C<log_count> it is C<0>), or a number to
force a fixed default. Because an unseen value is usually the very thing you are
hunting, mapping it to "maximally rare" rather than erroring is the point.
C<frozen_freq_map> only suits B<bounded, moderate-cardinality> columns (extensions,
vendor classes, named pipes, keyboard layouts, link addresses): the table lives
in C<info.json>, so a huge one bloats every read -- building one past
C<$Algorithm::ToNumberMunger::FROZEN_FREQ_MAP_WARN_KEYS>
values (default 10000) warns. For unbounded cardinality (JA3, full user-agents)
use L</hash> instead, which needs no table but keeps only decorrelation, not
commonness.
=cut
# name => 1 for the recognized frozen_freq_map output modes.
my %FREQ_MODE = map { $_ => 1 } qw(neg_log_prob freq log_count count);
# Building a table larger than this warns: info.json ships the whole map, so a
# high-cardinality column belongs in the 'hash' munger instead.
our $FROZEN_FREQ_MAP_WARN_KEYS = 10_000;
sub _build_frozen_freq_map {
my ( $spec, $where ) = @_;
my $counts = $spec->{counts};
croak "frozen_freq_map munger$where requires a non-empty 'counts' hashref"
unless ref $counts eq 'HASH' && %$counts;
my $sum = 0;
for my $k ( keys %$counts ) {
my $c = $counts->{$k};
croak "frozen_freq_map munger$where: count for '$k' ('"
. ( defined $c ? $c : 'undef' )
. "') is not a non-negative number"
unless looks_like_number($c) && $c >= 0;
$sum += $c;
}
my $V = keys %$counts;
carp "frozen_freq_map munger$where: 'counts' has $V keys; a table this large bloats "
. "info.json -- consider the 'hash' munger for unbounded cardinality"
if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
my $total = defined $spec->{total} ? $spec->{total} : $sum;
croak "frozen_freq_map munger$where: 'total' must be numeric"
unless looks_like_number($total);
croak "frozen_freq_map munger$where: 'total' ($total) must be >= sum of counts ($sum)"
if $total < $sum;
my $mode = defined $spec->{mode} ? $spec->{mode} : 'neg_log_prob';
croak "frozen_freq_map munger$where: unknown mode '$mode' (known: " . join( ', ', sort keys %FREQ_MODE ) . ')'
unless $FREQ_MODE{$mode};
my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
croak "frozen_freq_map munger$where: 'smoothing' must be a non-negative number"
unless looks_like_number($s) && $s >= 0;
my $unseen = defined $spec->{unseen} ? $spec->{unseen} : 'rare';
croak "frozen_freq_map munger$where: 'unseen' must be 'rare' or a number"
unless $unseen eq 'rare' || looks_like_number($unseen);
# An unseen value under neg_log_prob has probability s/denom; with no
# smoothing that is 0 and -ln(0) is infinite, which would poison the column.
# Refuse to build rather than emit inf.
croak "frozen_freq_map munger$where: mode 'neg_log_prob' with unseen => 'rare' needs "
. "smoothing > 0 (an unseen value would otherwise be infinitely surprising)"
if $mode eq 'neg_log_prob' && $unseen eq 'rare' && $s == 0;
# Smoothed-probability denominator, treating "unseen" as one extra bucket.
my $denom = $total + $s * ( $V + 1 );
# raw count -> emitted number under the chosen mode.
my $emit_for = sub {
my ($c) = @_;
return $c if $mode eq 'count';
return log( 1 + $c ) if $mode eq 'log_count';
my $p = ( $c + $s ) / $denom;
return $p if $mode eq 'freq';
return -log($p); # neg_log_prob
};
my %emit = map { $_ => $emit_for->( $counts->{$_} ) } keys %$counts;
my $unseen_value = $unseen eq 'rare' ? $emit_for->(0) : $unseen;
return sub {
my ($v) = @_;
return defined $v && exists $emit{$v} ? $emit{$v} : $unseen_value;
};
} ## end sub _build_frozen_freq_map
=head2 http_enum
{ munger => 'http_enum' }
{ munger => 'http_enum', strict => 1 }
Collapse an HTTP status code to its class: C<1xx> to C<1>, C<2xx> to C<2>, C<3xx>
to C<3>, and so on (i.e. C<int(code / 100)>). This is the usual bucketing for an
HTTP status column -- the forest cares far more about "was this a 4xx vs a 2xx"
than about C<403> vs C<404>, and it keeps the feature low-cardinality without
having to spell out every code in an C<enum> C<map>. The input must be numeric.
By default any numeric input is bucketed, so a bogus C<700> would quietly become
C<7>. With a true C<strict>, inputs outside the valid HTTP status range
(C<100>-C<599>) croak instead, so a malformed code is caught at write time rather
than smuggled into the model as a spurious class.
=head2 smtp_enum
{ munger => 'smtp_enum' }
{ munger => 'smtp_enum', strict => 1 }
The SMTP counterpart of L</http_enum>: collapse an SMTP reply code to its leading
digit (C<int(code / 100)>), since that digit I<is> the reply's meaning -- C<2yz>
completion, C<3yz> intermediate, C<4yz> transient failure, C<5yz> permanent
failure. As with C<http_enum> this keeps the column low-cardinality and lets the
forest weigh "a 5xx where a 2xx was expected" without enumerating every code.
With a true C<strict>, inputs outside the valid SMTP reply range (C<200>-C<599>)
croak. SMTP never issues C<1yz> replies in practice (no command permits a
positive-preliminary reply), so the strict floor is C<200> rather than
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=head2 ftp_enum
{ munger => 'ftp_enum' }
{ munger => 'ftp_enum', strict => 1 }
The FTP counterpart of L</http_enum>, for FTP reply codes: C<int(code / 100)>,
bucketing into C<1yz>-C<5yz>. With a true C<strict>, inputs outside C<100>-C<599>
croak.
=head2 rtsp_enum
{ munger => 'rtsp_enum' }
{ munger => 'rtsp_enum', strict => 1 }
The RTSP counterpart of L</http_enum>. RTSP (RFC 2326) deliberately reuses
HTTP's status scheme, so codes collapse to their leading digit the same way.
With a true C<strict>, inputs outside C<100>-C<599> croak.
=head2 nntp_enum
{ munger => 'nntp_enum' }
{ munger => 'nntp_enum', strict => 1 }
The NNTP counterpart of L</http_enum>, for NNTP (RFC 3977) reply codes, which
follow the SMTP convention -- C<1xx> informational, C<2xx> success, C<3xx>
send-more-input, C<4xx> transient failure, C<5xx> permanent failure. Unlike
SMTP, NNTP does issue C<1xx> replies (help text, capability lists), so the
strict floor is C<100> rather than C<smtp_enum>'s C<200>. With a true
C<strict>, inputs outside C<100>-C<599> croak.
=head2 dict_enum
{ munger => 'dict_enum' }
{ munger => 'dict_enum', strict => 1 }
The DICT counterpart of L</http_enum>, for DICT protocol (RFC 2229) status
codes, which use the SMTP-style code classes. With a true C<strict>, inputs
outside C<100>-C<599> croak.
=head2 gemini_enum
{ munger => 'gemini_enum' }
{ munger => 'gemini_enum', strict => 1 }
Like L</http_enum> but for the Gemini protocol, whose status codes are B<two>
digits -- C<1x> input expected, C<2x> success, C<3x> redirect, C<4x> temporary
failure, C<5x> permanent failure, C<6x> client certificate required -- so the
class is C<int(code / 10)>. With a true C<strict>, inputs outside C<10>-C<69>
croak.
=cut
# Shared closure for the status-class mungers registered from %STATUS_PROTO.
sub _status_class_munger {
my ( $proto, $lo, $hi, $div, $spec, $where ) = @_;
my $strict = $spec->{strict} ? 1 : 0;
return sub {
my ($v) = @_;
croak "${proto}_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
unless looks_like_number($v);
croak "${proto}_enum munger$where: status code '$v' is out of range " . "($lo-$hi)"
if $strict && ( $v < $lo || $v > $hi );
return int( $v / $div );
};
} ## end sub _status_class_munger
=head2 mgcp_enum
{ munger => 'mgcp_enum' }
{ munger => 'mgcp_enum', strict => 1 }
The MGCP counterpart of L</http_enum>, for MGCP (RFC 3435) response codes:
C<int(code / 100)>. MGCP's classes are C<1xx> provisional, C<2xx> success,
C<4xx> transient error, C<5xx> permanent error, and C<8xx> package-specific --
there are no C<6xx> or C<7xx> codes, so the valid set has a B<hole> in it.
With a true C<strict>, inputs outside C<100>-C<599> B<and> outside
C<800>-C<899> croak. (That hole is why this is a hand-written builder rather
than another row of the shared status-class table, which can only express one
contiguous range.)
=cut
# MGCP's strict range is [100,599] union [800,899] -- 8xx package-specific
# codes are real, 6xx/7xx are not -- which %STATUS_PROTO's single [lo, hi]
# cannot express, hence this dedicated builder.
sub _build_mgcp_enum {
my ( $spec, $where ) = @_;
my $strict = $spec->{strict} ? 1 : 0;
return sub {
my ($v) = @_;
croak "mgcp_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
unless looks_like_number($v);
croak "mgcp_enum munger$where: status code '$v' is out of range " . "(100-599 or 800-899)"
if $strict && !( ( $v >= 100 && $v <= 599 ) || ( $v >= 800 && $v <= 899 ) );
return int( $v / 100 );
};
} ## end sub _build_mgcp_enum
=head2 dns_rcode_enum
{ munger => 'dns_rcode_enum' }
{ munger => 'dns_rcode_enum', default => -1 }
The first of the B<named-map enums>: like L</enum>, except the C<map> is baked
in from a well-known registry instead of hand-authored (and inevitably
typo'd). All named-map enums share the same lookup rules: names are matched
B<case-insensitively>; where the emitted numbers are the protocol's own wire
encoding (as here -- rcode C<3> I<is> C<NXDOMAIN>), a numeric input is passed
through unchanged, so mixed feeds (one tool logs C<NXDOMAIN>, another logs
C<3>) land in one consistent column; and an unmapped value croaks unless the
spec supplies a numeric C<default>. As with C<enum>, an unrecognized value is
often exactly the anomaly worth keeping, so C<< default => -1 >> is the usual
escape hatch.
This one maps DNS RCODE names to their IANA values: C<NOERROR> 0, C<FORMERR>
1, C<SERVFAIL> 2, C<NXDOMAIN> 3, C<NOTIMP> 4 (alias C<NOTIMPL>), C<REFUSED> 5,
C<YXDOMAIN> 6, C<YXRRSET> 7, C<NXRRSET> 8, C<NOTAUTH> 9, C<NOTZONE> 10,
C<DSOTYPENI> 11, and the extended rcodes C<BADVERS>/C<BADSIG> 16, C<BADKEY>
17, C<BADTIME> 18, C<BADMODE> 19, C<BADNAME> 20, C<BADALG> 21, C<BADTRUNC> 22,
C<BADCOOKIE> 23.
=head2 dns_qtype_enum
{ munger => 'dns_qtype_enum', default => -1 }
Named-map enum (lookup rules as L</dns_rcode_enum>; numeric inputs pass
through) mapping DNS RR type names to their IANA numbers: C<A> 1, C<NS> 2,
C<CNAME> 5, C<SOA> 6, C<NULL> 10, C<PTR> 12, C<MX> 15, C<TXT> 16, C<AAAA> 28,
C<SRV> 33, C<NAPTR> 35, C<DS> 43, C<RRSIG> 46, C<DNSKEY> 48, C<TLSA> 52,
C<SVCB> 64, C<HTTPS> 65, C<AXFR> 252, C<ANY> (or C<*>) 255, C<URI> 256,
C<CAA> 257, and the rest of the commonly-observed registry. The query-type mix
is a classic DNS-tunneling feature -- C<TXT>/C<NULL>-heavy traffic where
C<A>/C<AAAA> is normal.
=head2 syslog_severity_enum
{ munger => 'syslog_severity_enum' }
Named-map enum (lookup rules as L</dns_rcode_enum>; numeric inputs pass
through) mapping syslog severity names to their RFC 5424 codes: C<emerg> 0
(alias C<panic>), C<alert> 1, C<crit> 2, C<err> 3 (alias C<error>),
C<warning> 4 (alias C<warn>), C<notice> 5, C<info> 6 (alias
C<informational>), C<debug> 7. Genuinely ordinal -- lower is more severe --
so a threshold split on it is meaningful.
=head2 syslog_facility_enum
{ munger => 'syslog_facility_enum' }
Named-map enum (lookup rules as L</dns_rcode_enum>; numeric inputs pass
through) mapping syslog facility names to their RFC 5424 codes: C<kern> 0,
C<user> 1, C<mail> 2, C<daemon> 3, C<auth> 4 (alias C<security>), C<syslog> 5,
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
%m;
},
},
},
risk_state => {
numeric => 0,
map => {
# Entra Identity Protection riskState.
none => 0,
confirmedsafe => 1,
remediated => 2,
dismissed => 3,
atrisk => 4,
confirmedcompromised => 5,
},
},
vpc_flow_log_status => {
numeric => 0,
map => {
# VPC Flow Logs log-status.
ok => 0,
nodata => 1,
skipdata => 2,
},
},
aws_event_type => {
numeric => 0,
map => {
# CloudTrail eventType. AwsConsoleSignIn is the one you flag.
awsapicall => 0,
awsserviceevent => 1,
awsconsoleaction => 2,
awsconsolesignin => 3,
awscloudtrailinsight => 4,
},
},
conditional_access_result => {
numeric => 0,
map => {
# Azure AD sign-in conditionalAccessStatus.
success => 0,
notapplied => 1,
notenabled => 2,
reportonly => 3,
failure => 4,
},
},
);
for my $name ( keys %NAMED_ENUM ) {
my $e = $NAMED_ENUM{$name};
$BUILDERS{"${name}_enum"} = sub { _named_enum_munger( $name, $e, @_ ) };
}
# Shared closure for the named-map enums registered from %NAMED_ENUM.
sub _named_enum_munger {
my ( $name, $e, $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "${name}_enum munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
my ( $map, $numeric ) = @{$e}{qw(map numeric)};
return sub {
my ($v) = @_;
if ( defined $v ) {
return $v + 0 if $numeric && looks_like_number($v);
my $k = lc $v;
return $map->{$k} if exists $map->{$k};
}
return $default if $has_default;
croak "${name}_enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
}; ## end sub
} ## end sub _named_enum_munger
=head2 bool
{ munger => 'bool' } # Perl truthiness -> 1/0
{ munger => 'bool', true => [ 'yes', 'Y', '1', 'true' ] }
Coerce to C<1> or C<0>. With a C<true> list, only those (string-compared) values
are C<1>; otherwise ordinary Perl truthiness is used.
=cut
sub _build_bool {
my ( $spec, $where ) = @_;
if ( exists $spec->{true} ) {
croak "bool munger$where: 'true' must be an arrayref"
unless ref $spec->{true} eq 'ARRAY';
my %true = map { $_ => 1 } @{ $spec->{true} };
return sub {
my ($v) = @_;
return exists $true{ defined $v ? $v : '' } ? 1 : 0;
};
}
return sub { $_[0] ? 1 : 0 };
} ## end sub _build_bool
=head2 length
{ munger => 'length' }
The character length of the stringified input, C<undef> counting as C<0> (an
absent value is a zero-length one -- e.g. an SNI-absent TLS record). This is the
cheap shape feature behind every C<*_length> column (domain, URL, filename, SNI,
hostname, ...): tunneling and generated names run long, so raw length is a
surprisingly strong corroborator next to L</entropy>. Length is counted in
B<characters>, not bytes, so a multi-byte name is measured as a human would read
it; use L</entropy> (which is byte-oriented) when you want per-symbol randomness.
=cut
sub _build_length {
my ( $spec, $where ) = @_;
return sub {
my ($v) = @_;
return length( defined $v ? "$v" : '' );
};
}
=head2 entropy
{ munger => 'entropy' }
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
return 0 unless $n;
my %count;
$count{$_}++ for unpack 'C*', $str;
my $ln2 = log(2);
my $h = 0;
for my $c ( values %count ) {
my $p = $c / $n;
$h -= $p * ( log($p) / $ln2 );
}
return $h;
} ## end sub _entropy_pp
=head2 ngram
{ munger => 'ngram', counts => { th => 152, he => 128, in => 94, ... } }
# defaults: smoothing => 1, fold_case => 1; n is inferred from the keys
Mean per-gram surprisal of the input string against a B<precomputed, frozen>
n-gram count table: C<sum(-ln p(gram)) / gram_count>, each gram's probability
smoothed exactly as in L</frozen_freq_map>. This is C<frozen_freq_map>'s sequential cousin
and the strongest single gibberish detector: L</entropy> misses
I<pronounceable> generated names and is unreliable on short strings, while an
n-gram score against (say) hostname bigram statistics catches both -- real
words ride the common bigrams and score low, generated names keep hitting rare
ones and score high. Dividing by the gram count keeps scores comparable across
lengths.
C<counts> maps each n-gram to how often it was observed when the table was
built; all keys must be the same length, and that length B<is> C<n> (bigrams
are the usual choice -- a 26x26 table stays tiny in C<info.json>; past
C<$FROZEN_FREQ_MAP_WARN_KEYS> entries it warns like C<frozen_freq_map>). C<total> defaults
to the sum of counts and may be given larger to prune the tail, exactly as in
C<frozen_freq_map>. A gram absent from the table gets the smoothed unseen-bucket
probability -- an unseen gram is the interesting case -- so C<smoothing> must
be > 0 (default C<1>). With C<fold_case> (default on) the input is lowercased
before scoring, matching the usual lowercased table. A string with no grams
(shorter than C<n>) scores C<0>. Grams are taken over B<characters>, matching
L</length> rather than the byte-oriented C<entropy>.
=cut
sub _build_ngram {
my ( $spec, $where ) = @_;
my $counts = $spec->{counts};
croak "ngram munger$where requires a non-empty 'counts' hashref"
unless ref $counts eq 'HASH' && %$counts;
my $n;
my $sum = 0;
for my $g ( keys %$counts ) {
$n = length $g unless defined $n;
croak "ngram munger$where: all 'counts' keys must be the same length "
. "(that length is n); got '$g' alongside a $n-gram"
unless length($g) == $n;
my $c = $counts->{$g};
croak "ngram munger$where: count for '$g' ('"
. ( defined $c ? $c : 'undef' )
. "') is not a non-negative number"
unless looks_like_number($c) && $c >= 0;
$sum += $c;
} ## end for my $g ( keys %$counts )
croak "ngram munger$where: 'counts' keys must be at least 1 character"
unless $n >= 1;
my $V = keys %$counts;
carp "ngram munger$where: 'counts' has $V keys; a table this large bloats info.json"
if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
my $total = defined $spec->{total} ? $spec->{total} : $sum;
croak "ngram munger$where: 'total' must be numeric"
unless looks_like_number($total);
croak "ngram munger$where: 'total' ($total) must be >= sum of counts ($sum)"
if $total < $sum;
my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
croak "ngram munger$where: 'smoothing' must be a number > 0 "
. '(an unseen gram would otherwise be infinitely surprising)'
unless looks_like_number($s) && $s > 0;
my $fold = exists $spec->{fold_case} ? ( $spec->{fold_case} ? 1 : 0 ) : 1;
# Same smoothed-probability scheme as frozen_freq_map, "unseen" as one extra
# bucket; surprisal precomputed per listed gram.
my $denom = $total + $s * ( $V + 1 );
my %si = map { $_ => -log( ( $counts->{$_} + $s ) / $denom ) } keys %$counts;
my $unseen = -log( $s / $denom );
return sub {
my ($v) = @_;
my $str = defined $v ? "$v" : '';
$str = lc $str if $fold;
my $grams = length($str) - $n + 1;
return 0 if $grams < 1;
my $tot = 0;
for my $i ( 0 .. $grams - 1 ) {
my $g = substr( $str, $i, $n );
$tot += exists $si{$g} ? $si{$g} : $unseen;
}
return $tot / $grams;
}; ## end sub
} ## end sub _build_ngram
=head2 char
{ munger => 'char', class => 'non_alnum', mode => 'ratio' }
{ munger => 'char', class => 'non_ascii' } # mode defaults to count
Count the characters of the input that fall in a named C<class>, either as a raw
C<count> (default) or, with C<< mode => 'ratio' >>, as a fraction of the string's
length (C<0> for an empty string). This is the injection / obfuscation detector
behind columns like C<url_non_alnum> (a I<ratio>, so it stays independent of
length) and C<filename_non_ascii> (a I<count>): payloads and homoglyph tricks
are dense with punctuation, percent-encoding, or non-ASCII where normal input is
not. Counting is over B<characters>, so C<non_ascii> means codepoints above 127.
Recognised classes: C<alnum> / C<non_alnum>, C<ascii> / C<non_ascii>, C<digit>,
C<alpha>, C<upper>, C<lower>, C<vowel>, C<consonant>, C<xdigit>, C<space>,
C<punct>. C<vowel> and C<consonant> are the ASCII letters (C<y> counting as a
consonant) -- a vowel/consonant I<ratio> is a DGA corroborator that catches
consonant-heavy random strings C<entropy> alone underrates; C<xdigit> is
C<0-9a-fA-F>, dense in encoded payloads.
=cut
# class name => a counting sub over an (already copied) string. The literal-
# range classes count with tr///, which runs at C speed -- an order of
# magnitude faster than tallying regex matches. tr/// needs its ranges spelled
# at compile time, hence one sub per class rather than a data table. The 'run'
# munger's %RUN_RE mirrors these class names; keep the two in sync.
my %CHAR_COUNT = (
alnum => sub { $_[0] =~ tr/A-Za-z0-9// },
non_alnum => sub { $_[0] =~ tr/A-Za-z0-9//c },
ascii => sub { $_[0] =~ tr/\x00-\x7f// },
non_ascii => sub { $_[0] =~ tr/\x00-\x7f//c },
digit => sub { $_[0] =~ tr/0-9// },
alpha => sub { $_[0] =~ tr/A-Za-z// },
upper => sub { $_[0] =~ tr/A-Z// },
lower => sub { $_[0] =~ tr/a-z// },
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# tr///'s speed trick does not apply here.
my %RUN_RE = (
alnum => '[A-Za-z0-9]',
non_alnum => '[^A-Za-z0-9]',
ascii => '[\x00-\x7f]',
non_ascii => '[^\x00-\x7f]',
digit => '[0-9]',
alpha => '[A-Za-z]',
upper => '[A-Z]',
lower => '[a-z]',
vowel => '[aeiouAEIOU]',
consonant => '[b-df-hj-np-tv-zB-DF-HJ-NP-TV-Z]',
xdigit => '[0-9A-Fa-f]',
space => '\s',
punct => '[[:punct:]]',
);
sub _build_run {
my ( $spec, $where ) = @_;
my $class = $spec->{class};
croak "run munger$where requires a 'class'"
unless defined $class;
my $cc = $RUN_RE{$class}
or croak "run munger$where: unknown class '$class' (known: " . join( ', ', sort keys %RUN_RE ) . ')';
my $re = qr/((?:$cc)+)/;
return sub {
my ($v) = @_;
my $s = defined $v ? "$v" : '';
my $max = 0;
while ( $s =~ /$re/g ) {
$max = length $1 if length $1 > $max;
}
return $max;
};
} ## end sub _build_run
=head2 count
{ munger => 'count', of => '/' } # url_path_depth, topic_depth
{ munger => 'count', of => '.', plus => 1 } # label_count (dots + 1)
Count non-overlapping occurrences of a literal substring C<of> in the input,
optionally adding a constant C<plus>. This is the segment/depth feature behind
C<url_path_depth> and C<topic_depth> (count of C<`/`>) and C<label_count> (dots
plus one). C<of> is matched literally, not as a pattern, so C<.> means a literal
dot.
=cut
sub _build_count {
my ( $spec, $where ) = @_;
my $of = $spec->{of};
croak "count munger$where requires a non-empty 'of' string"
unless defined $of && length $of;
my $plus = defined $spec->{plus} ? $spec->{plus} : 0;
croak "count munger$where: 'plus' must be numeric"
unless looks_like_number($plus);
# index() beats a global regex match here: no pattern engine, and no
# per-call list of matches just to count them. Advancing by length($of)
# keeps the non-overlapping semantics m//g had.
my $oflen = length $of;
return sub {
my ($v) = @_;
my $s = defined $v ? "$v" : '';
my $n = 0;
my $p = 0;
while ( ( $p = index( $s, $of, $p ) ) >= 0 ) {
$n++;
$p += $oflen;
}
return $n + $plus;
}; ## end sub
} ## end sub _build_count
=head2 match
{ munger => 'match', pattern => '^xn--' } # punycode label
{ munger => 'match', pattern => '%[0-9A-Fa-f]{2}', mode => 'count' }
Match the input against a Perl regular expression C<pattern>: C<1>/C<0> under
the default C<< mode => 'bool' >>, or the number of non-overlapping matches
with C<< mode => 'count' >>. A true C<ignore_case> makes the match
case-insensitive. This is the catch-all shape test behind flags like "is this
label punycode" or "is the Host an IP literal", and counters like
percent-escapes in a URL -- anything L</char> and L</count> are not expressive
enough for. The pattern is compiled at build time, so a broken one fails at
C<write_info> rather than per row.
B<Trust note:> a pattern cannot execute code (Perl requires C<use re 'eval'>
for that, which this module does not enable), but a pathological pattern can
still backtrack catastrophically and stall a writer. Treat munger specs --
like the rest of C<info.json> -- as configuration from a trusted operator,
not as untrusted input.
=cut
sub _build_match {
my ( $spec, $where ) = @_;
my $pat = $spec->{pattern};
croak "match munger$where requires a non-empty 'pattern'"
unless defined $pat && length $pat;
my $mode = defined $spec->{mode} ? $spec->{mode} : 'bool';
croak "match munger$where: 'mode' must be 'bool' or 'count'"
unless $mode eq 'bool' || $mode eq 'count';
# qr// on spec text cannot run code -- (?{...}) needs 'use re "eval"',
# which is not enabled here -- but it can be syntactically invalid, so
# compile eagerly and croak at build time.
my $re = eval { $spec->{ignore_case} ? qr/$pat/i : qr/$pat/ };
croak "match munger$where: cannot compile pattern '$pat': $@"
unless defined $re;
if ( $mode eq 'bool' ) {
return sub {
my $s = defined $_[0] ? "$_[0]" : '';
return $s =~ $re ? 1 : 0;
};
}
return sub {
my $s = defined $_[0] ? "$_[0]" : '';
my $n = () = $s =~ /$re/g;
return $n;
};
} ## end sub _build_match
=head2 bucket
{ munger => 'bucket', bounds => [ 1024, 49152 ] } # dest_port classes
Map a number to a bucket index by ascending C<bounds>: the result is how many
bounds the value is greater than or equal to. With C<< bounds => [1024, 49152] >>
a value under C<1024> is C<0> (well-known), C<1024>-C<49151> is C<1> (registered),
and C<49152>+ is C<2> (ephemeral) -- the classic port classing, where the literal
port number is meaningless to a threshold split but the I<class> is a real
signal. C<bounds> must be strictly ascending; N bounds yield indices C<0>..C<N>.
This generalises the C<*_enum> status-class mungers, which are the special case
of bucketing a reply code by its leading digit.
=cut
sub _build_bucket {
my ( $spec, $where ) = @_;
my $bounds = $spec->{bounds};
croak "bucket munger$where requires a non-empty 'bounds' arrayref"
unless ref $bounds eq 'ARRAY' && @$bounds;
my @b = @$bounds;
for my $i ( 0 .. $#b ) {
croak "bucket munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
unless looks_like_number( $b[$i] );
croak "bucket munger$where: 'bounds' must be strictly ascending"
if $i && $b[$i] <= $b[ $i - 1 ];
}
return sub {
my ($v) = @_;
croak "bucket munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $idx = 0;
for my $bound (@b) {
last if $v < $bound;
$idx++;
}
return $idx;
}; ## end sub
} ## end sub _build_bucket
=head2 quantile
{ munger => 'quantile', bounds => [ 40, 180, 460, 2200, 64000 ] }
Piecewise-linear ECDF: map a number onto C<[0, 1]> by where it falls among
ascending C<bounds> taken from the training data's quantiles (e.g. its
min / p25 / p50 / p75 / max). Values at or below the first bound map to C<0>,
at or above the last to C<1>, and anything between two adjacent bounds
interpolates linearly between their positions. This is L</bucket>'s continuous
sibling and the heavy-tail normaliser to reach for when L</log> is not enough
and L</zscore> would let one outlier stretch the whole scale: after the
transform the training distribution is roughly uniform, so a forest threshold
split lands anywhere in it with equal ease. C<bounds> must be strictly
ascending with at least two values; like C<zscore>, the parameters are
supplied rather than learned, so munging stays stateless.
=cut
sub _build_quantile {
my ( $spec, $where ) = @_;
my $bounds = $spec->{bounds};
croak "quantile munger$where requires a 'bounds' arrayref with at least 2 values"
unless ref $bounds eq 'ARRAY' && @$bounds >= 2;
my @b = @$bounds;
for my $i ( 0 .. $#b ) {
croak "quantile munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
unless looks_like_number( $b[$i] );
croak "quantile munger$where: 'bounds' must be strictly ascending"
if $i && $b[$i] <= $b[ $i - 1 ];
}
my $segs = $#b;
return sub {
my ($v) = @_;
croak "quantile munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return 0 if $v <= $b[0];
return 1 if $v >= $b[-1];
my $i = 0;
$i++ while $v >= $b[ $i + 1 ];
return ( $i + ( $v - $b[$i] ) / ( $b[ $i + 1 ] - $b[$i] ) ) / $segs;
}; ## end sub
} ## end sub _build_quantile
=head2 scale
{ munger => 'scale', min => 0, max => 1000, clamp => 1 }
Min-max normalisation: C<(v - min) / (max - min)>, mapping C<[min, max]> onto
C<[0, 1]>. C<min> and C<max> must differ. With a true C<clamp>, results are
pinned into C<[0, 1]> so out-of-range inputs cannot escape the unit interval.
=cut
sub _build_scale {
my ( $spec, $where ) = @_;
my ( $min, $max ) = @{$spec}{qw(min max)};
croak "scale munger$where requires numeric 'min' and 'max'"
unless looks_like_number($min) && looks_like_number($max);
my $range = $max - $min;
croak "scale munger$where: 'min' and 'max' must differ"
if $range == 0;
my $clamp = $spec->{clamp} ? 1 : 0;
return sub {
my ($v) = @_;
croak "scale munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $s = ( $v - $min ) / $range;
if ($clamp) { $s = 0 if $s < 0; $s = 1 if $s > 1; }
return $s;
};
} ## end sub _build_scale
=head2 zscore
{ munger => 'zscore', mean => 42.0, std => 7.5 }
Standardise: C<(v - mean) / std>. C<std> must be non-zero. The C<mean>/C<std>
are supplied (this module does not learn them) so munging stays stateless and a
row can be munged in isolation.
=cut
sub _build_zscore {
my ( $spec, $where ) = @_;
my ( $mean, $std ) = @{$spec}{qw(mean std)};
croak "zscore munger$where requires numeric 'mean' and 'std'"
unless looks_like_number($mean) && looks_like_number($std);
croak "zscore munger$where: 'std' must be non-zero"
if $std == 0;
return sub {
my ($v) = @_;
croak "zscore munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return ( $v - $mean ) / $std;
};
} ## end sub _build_zscore
=head2 log
{ munger => 'log' } # natural log
{ munger => 'log', offset => 1 } # log1p-style, so 0 is allowed
{ munger => 'log', base => 10, offset => 1 }
Logarithm of C<v + offset>. Heavy-tailed counts (bytes, durations) compress well
under a log, which keeps a few huge values from dominating the forest. C<offset>
(default C<0>) shifts the input so zeros/small values are representable; the
shifted value must be strictly positive or the input croaks. C<base> defaults to
natural log.
=cut
sub _build_log {
my ( $spec, $where ) = @_;
my $offset = exists $spec->{offset} ? $spec->{offset} : 0;
croak "log munger$where: 'offset' must be numeric"
unless looks_like_number($offset);
my $ln_base;
if ( defined $spec->{base} ) {
croak "log munger$where: 'base' must be numeric and > 0 and != 1"
unless looks_like_number( $spec->{base} )
&& $spec->{base} > 0
&& $spec->{base} != 1;
$ln_base = log( $spec->{base} );
}
return sub {
my ($v) = @_;
croak "log munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $x = $v + $offset;
croak "log munger$where: value+offset must be > 0 (got $x)"
unless $x > 0;
my $r = log($x);
$r /= $ln_base if defined $ln_base;
return $r;
}; ## end sub
} ## end sub _build_log
=head2 clamp
{ munger => 'clamp', min => 0 }
{ munger => 'clamp', min => 0, max => 65535 }
Pass the number through, pinned into C<[min, max]>. Either bound may be omitted
to clamp on one side only. Unlike C<scale> this does not rescale; it only caps
outliers before they reach the model.
=cut
sub _build_clamp {
my ( $spec, $where ) = @_;
my ( $min, $max ) = @{$spec}{qw(min max)};
my $have_min = defined $min;
my $have_max = defined $max;
croak "clamp munger$where needs at least one of 'min' or 'max'"
unless $have_min || $have_max;
croak "clamp munger$where: 'min' must be numeric"
if $have_min && !looks_like_number($min);
croak "clamp munger$where: 'max' must be numeric"
if $have_max && !looks_like_number($max);
croak "clamp munger$where: 'min' must be <= 'max'"
if $have_min && $have_max && $min > $max;
return sub {
my ($v) = @_;
croak "clamp munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
$v = $min if $have_min && $v < $min;
$v = $max if $have_max && $v > $max;
return $v;
};
} ## end sub _build_clamp
=head2 num
{ munger => 'num', base => 16 } # '0x1a' or '1a' -> 26
{ munger => 'num' } # plain numeric coercion
Parse a string as a number in C<base> (2-36, default 10). Base 10 simply
validates and numifies. Other bases accept the digits C<0-9a-z> below the
base, case-insensitively, an optional leading C<->, and the conventional
prefix for that base (C<0x> for 16, C<0b> for 2, C<0o> for 8). Plenty of
tooling logs flag words and IDs in hex (C<0x2f>), which the Writer would
reject as non-numeric; this munger is the bridge. Croaks on anything that is
not a clean number in the chosen base.
=cut
sub _build_num {
my ( $spec, $where ) = @_;
my $base = defined $spec->{base} ? $spec->{base} : 10;
croak "num munger$where: 'base' must be an integer from 2 to 36"
unless $base =~ /\A[0-9]+\z/ && $base >= 2 && $base <= 36;
if ( $base == 10 ) {
return sub {
my ($v) = @_;
croak "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return $v + 0;
};
}
my %digit;
my $i = 0;
$digit{$_} = $i++ for ( '0' .. '9', 'a' .. 'z' );
# Strip only the base's own conventional prefix; for other bases a letter
# like 'b' is just a digit, so there is nothing to disambiguate.
my $prefix
= $base == 16 ? qr/\A0x/
: $base == 8 ? qr/\A0o/
: $base == 2 ? qr/\A0b/
: undef;
return sub {
my ($v) = @_;
my $s = defined $v ? lc "$v" : '';
my $err = "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a base-$base number";
my $neg = $s =~ s/\A-//;
$s =~ s/$prefix// if defined $prefix;
croak $err unless length $s;
my $n = 0;
for my $c ( split //, $s ) {
my $d = $digit{$c};
croak $err unless defined $d && $d < $base;
$n = $n * $base + $d;
}
return $neg ? -$n : $n;
}; ## end sub
} ## end sub _build_num
=head2 ratio
# 'io_ratio' is a tag; bytes_out and bytes_in are input fields
"io_ratio": { "munger": "ratio", "from": ["bytes_out", "bytes_in"] }
{ munger => 'ratio', from => [qw(bytes_out bytes_in)], zero => -1 }
First source divided by the second: with C<< from => [a, b] >> the column gets
C<a / b>. Asymmetry between two counters is a classic feature the counters
alone cannot express -- bytes out over bytes in flags exfiltration, requests
over responses flags scanning -- and the division has to happen at munge time
because a forest split only ever sees one column. A zero denominator yields
C<zero> (default C<0>) instead of dying, since "nothing came back" is a
legitimate row, not bad input; pick a C<zero> outside the ratio's normal range
if you want those rows to stand out. Both inputs must be numeric.
This is a B<multi-input> munger: it only makes sense with several sources, so
it is only usable through L</compile> with C<from> as an arrayref of exactly
two field names (and thus C<apply_named> / C<write_named>). The sources are
raw input fields, not other columns.
=head2 combine
{ munger => 'combine', op => 'sum', from => [qw(bytes_in bytes_out)] }
{ munger => 'combine', op => 'max', from => [qw(req_time resp_time)] }
Fold two or more numeric source fields into one column with C<op>: C<sum>,
C<diff> (first minus second; exactly two sources), C<product>, C<min>, C<max>,
or C<mean>. The general-purpose sibling of L</ratio> for when the interesting
feature is a total, a gap, or an extreme across fields rather than any one
field. Every input must be numeric.
Like C<ratio>, this is a B<multi-input> munger: only usable through
L</compile> with C<from> as an arrayref of source field names.
=cut
sub _build_ratio {
my ( $spec, $where, $nsrc ) = @_;
croak "ratio munger$where takes exactly 2 source fields (numerator, denominator), not $nsrc"
unless $nsrc == 2;
my $zero = defined $spec->{zero} ? $spec->{zero} : 0;
croak "ratio munger$where: 'zero' must be numeric"
unless looks_like_number($zero);
return sub {
for my $v (@_) {
croak "ratio munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
return $zero if $_[1] == 0;
return $_[0] / $_[1];
};
} ## end sub _build_ratio
# op => fold over the already numeric-checked source values. A table so the
# error message can enumerate them and a new op is one line.
my %COMBINE_OPS = (
sum => sub { my $t = 0; $t += $_ for @_; return $t },
diff => sub { return $_[0] - $_[1] },
product => sub { my $t = 1; $t *= $_ for @_; return $t },
min => sub {
my $t = shift;
for (@_) { $t = $_ if $_ < $t }
return $t;
},
max => sub {
my $t = shift;
for (@_) { $t = $_ if $_ > $t }
return $t;
},
mean => sub { my $t = 0; $t += $_ for @_; return $t / @_ },
);
sub _build_combine_op {
my ( $spec, $where, $nsrc ) = @_;
my $op = $spec->{op};
croak "combine munger$where requires an 'op' (one of: " . join( ', ', sort keys %COMBINE_OPS ) . ')'
unless defined $op && length $op;
my $fold = $COMBINE_OPS{$op}
or croak "combine munger$where: unknown op '$op' (known: " . join( ', ', sort keys %COMBINE_OPS ) . ')';
croak "combine munger$where: op 'diff' takes exactly 2 source fields, not $nsrc"
if $op eq 'diff' && $nsrc != 2;
return sub {
for my $v (@_) {
croak "combine munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
return $fold->(@_);
};
} ## end sub _build_combine_op
=head2 bit
{ munger => 'bit', mask => '0x12' } # SYN or ACK set?
{ munger => 'bit', mask => '0x02', mode => 'all' } # the SYN bit itself
{ munger => 'bit', mode => 'popcount' } # how many flags at all
{ munger => 'bit', mask => '0x0f', mode => 'value' } # low nibble, 0-15
{ munger => 'bit', mask => '0x02', base => 16 } # Suricata tcp_flags "1b"
Bit-level features from an integer flags word (TCP flags, DNS header flags,
protocol option words): the raw word is meaningless to a threshold split, but
individual bits and bit I<counts> are real signals. The input must be a
non-negative integer, in decimal or C<0x> hex (so a logged C<0x12> works
as-is); C<mask> may be written either way too.
Set C<< base => 16 >> to read the B<input> as bare hexadecimal with no C<0x>
prefix -- Suricata logs C<tcp.tcp_flags> (and C<tcp_flags_ts>/C<tcp_flags_tc>)
as e.g. C<"1b">, which is otherwise ambiguous with decimal. A C<0x> prefix on
the input is still accepted under C<< base => 16 >>. C<mask> is always written
in decimal or C<0x> hex regardless of C<base>. Modes:
=over 4
=item * C<any> (default) - C<1> if any bit of C<mask> is set in the value.
=item * C<all> - C<1> only if every bit of C<mask> is set.
=item * C<value> - the masked bits, shifted down to the mask's lowest set
bit: C<< mask => '0x0f' >> extracts the low nibble as C<0>-C<15>.
=item * C<popcount> - the number of set bits in C<value & mask>; C<mask> is
optional here and defaults to all bits. An abnormal flag I<count> (a
Christmas-tree packet) is anomalous even when each individual bit is common.
=back
C<mask> is required (and must be non-zero) for every mode except C<popcount>.
=cut
my %BIT_MODE = map { $_ => 1 } qw(any all value popcount);
# Accept an integer in decimal or 0x-hex form; returns the number, or undef
# if it is neither. Shared by bit's mask (spec) and value (input) parsing.
sub _bit_int {
my ($v) = @_;
return undef unless defined $v;
return hex($v) if $v =~ /\A0x[0-9a-f]+\z/i;
return $v + 0 if $v =~ /\A[0-9]+\z/;
return undef;
}
# Parse an input value as bare hex (a '0x' prefix is tolerated), for bit's
# 'base => 16' mode. Suricata logs tcp_flags as "1b" with no prefix, which
# _bit_int would read as decimal (or reject), hence a separate parser opted
# into per munger rather than a change to the ambiguous default.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
link_local => 3,
multicast => 4,
broadcast => 5,
unspecified => 6,
reserved => 7,
);
sub _ip4_class {
my ($n) = @_;
return 'unspecified' if $n == 0;
return 'broadcast' if $n == 0xffffffff;
my $a = $n >> 24;
my $b = ( $n >> 16 ) & 0xff;
my $c = ( $n >> 8 ) & 0xff;
return 'reserved' if $a == 0; # 0/8 "this network"
return 'private' if $a == 10;
return 'private' if $a == 100 && $b >= 64 && $b <= 127; # CGNAT 100.64/10
return 'loopback' if $a == 127;
return 'link_local' if $a == 169 && $b == 254;
return 'private' if $a == 172 && $b >= 16 && $b <= 31;
return 'reserved' if $a == 192 && $b == 0 && ( $c == 0 || $c == 2 );
return 'private' if $a == 192 && $b == 168;
return 'reserved' if $a == 198 && ( $b == 18 || $b == 19 ); # benchmarking
return 'reserved' if $a == 198 && $b == 51 && $c == 100; # TEST-NET-2
return 'reserved' if $a == 203 && $b == 0 && $c == 113; # TEST-NET-3
return 'multicast' if $a >= 224 && $a <= 239;
return 'reserved' if $a >= 240; # 240/4 future use
return 'global';
} ## end sub _ip4_class
sub _ip6_class {
my ($bytes) = @_;
my @o = unpack 'C16', $bytes;
my $lead0 = 1;
for my $i ( 0 .. 14 ) { $lead0 &&= $o[$i] == 0 }
if ($lead0) {
return 'unspecified' if $o[15] == 0;
return 'loopback' if $o[15] == 1;
}
# v4-mapped ::ffff:a.b.c.d -- classify as the embedded v4 address.
my $map = 1;
for my $i ( 0 .. 9 ) { $map &&= $o[$i] == 0 }
return _ip4_class( ( $o[12] << 24 ) | ( $o[13] << 16 ) | ( $o[14] << 8 ) | $o[15] )
if $map && $o[10] == 0xff && $o[11] == 0xff;
return 'multicast' if $o[0] == 0xff;
return 'private' if ( $o[0] & 0xfe ) == 0xfc; # ULA fc00::/7
return 'link_local' if $o[0] == 0xfe && ( $o[1] & 0xc0 ) == 0x80; # fe80::/10
return 'reserved' if $o[0] == 0x20 && $o[1] == 0x01 && $o[2] == 0x0d && $o[3] == 0xb8; # 2001:db8::/32
my $discard = $o[0] == 0x01; # 100::/64
for my $i ( 1 .. 7 ) { $discard &&= $o[$i] == 0 }
return 'reserved' if $discard;
return 'global';
} ## end sub _ip6_class
sub _build_ip_class {
my ( $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "ip_class munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
return $IP_CLASS{ $fam == 4 ? _ip4_class($p) : _ip6_class($p) };
}
return $default if $has_default;
croak "ip_class munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
};
} ## end sub _build_ip_class
# Build a 16-byte netmask string for an IPv6 prefix length.
sub _v6_mask {
my ($len) = @_;
my $mask = "\xff" x int( $len / 8 );
$mask .= chr( ( 0xff << ( 8 - $len % 8 ) ) & 0xff ) if $len % 8;
return $mask . ( "\0" x ( 16 - length $mask ) );
}
sub _build_cidr {
my ( $spec, $where ) = @_;
my $nets = $spec->{nets};
croak "cidr munger$where requires a non-empty 'nets' arrayref"
unless ref $nets eq 'ARRAY' && @$nets;
# [family, masked network, mask] per net; & on the 16-byte v6 strings is
# Perl's bitwise string AND, so both families match the same way.
my @match;
for my $i ( 0 .. $#$nets ) {
my $net = $nets->[$i];
croak "cidr munger$where: nets[$i] ('"
. ( defined $net ? $net : 'undef' )
. "') is not in 'address/prefix' form"
unless defined $net && $net =~ m{\A(.+)/([0-9]{1,3})\z};
my ( $addr, $len ) = ( $1, $2 );
my ( $fam, $p ) = _parse_ip($addr);
croak "cidr munger$where: nets[$i] ('$net') has an unparseable address"
unless $fam;
my $max = $fam == 4 ? 32 : 128;
croak "cidr munger$where: nets[$i] ('$net') prefix length must be 0-$max"
if $len > $max;
my $mask
= $fam == 4
? ( $len == 0 ? 0 : ( 0xffffffff << ( 32 - $len ) ) & 0xffffffff )
: _v6_mask($len);
push @match, [ $fam, $p & $mask, $mask ];
} ## end for my $i ( 0 .. $#$nets )
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "cidr munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
for my $i ( 0 .. $#match ) {
my ( $f, $network, $mask ) = @{ $match[$i] };
next unless $f == $fam;
return $i
if $fam == 4
? ( ( $p & $mask ) == $network )
: ( ( $p & $mask ) eq $network );
}
return $default if $has_default;
croak "cidr munger$where: '$v' is in none of the listed networks (and no 'default')";
} ## end if ($fam)
return $default if $has_default;
croak "cidr munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
}; ## end sub
} ## end sub _build_cidr
=head2 datetime
{ munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'epoch' }
{ munger => 'datetime', format => '%Y-%m-%d %H:%M:%S', part => 'hour' }
Parse a formatted timestamp with L<Time::Piece> (C<strptime>, so C<format> is a
standard strptime pattern) and extract one numeric C<part>:
=over 4
=item * C<epoch> (default) - seconds since the epoch.
=item * C<year>, C<mon> (1-12), C<mday> (1-31), C<hour>, C<min>, C<sec>.
=item * C<wday> - day of week, C<0>=Sunday .. C<6>=Saturday.
=item * C<yday> - day of year, C<0>-based.
=item * C<frac_day> - time of day as a fraction in C<[0, 1)>, i.e.
C<(hour*3600 + min*60 + sec) / 86400>. Handy as a cyclic-ish time-of-day feature.
=item * C<frac_week> - position within the week as a fraction in C<[0, 1)>, the
week starting Sunday to match C<wday>: C<(wday*86400 + hour*3600 + min*60 + sec)
/ 604800>. Like C<frac_day> but cycling over a week, so a weekly rhythm (weekend
vs. weekday, or a Monday-morning batch) shows up as a feature.
=item * C<sin_day> / C<cos_day>, C<sin_week> / C<cos_week> - the C<frac_*> value
mapped onto a circle, C<sin(2*pi*frac)> and C<cos(2*pi*frac)>. Prefer these over
the raw C<frac_*> when feeding the forest: a plain fraction has a false seam at
the wrap (23:59 and 00:00 sit at opposite ends, 1 vs 0, though they are a minute
apart), whereas the sin/cos pair is continuous across midnight/Sunday. Store
I<both> of a pair in two columns so the position is unambiguous.
=back
Time features often carry the anomaly (a job that normally runs at 03:00
suddenly firing at noon, or a weekday task firing on a Sunday), which is why this
is a first-class munger.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $c = $EPS_CONN{$path};
return $c->{fh} if $c && $c->{pid} == $$;
require Socket;
require IO::Socket::UNIX;
my $fh = IO::Socket::UNIX->new(
Type => Socket::SOCK_STREAM(),
Peer => $path,
) or die "cannot connect to iqbi-damiq at $path: $!\n";
# Best-effort read/write timeouts so a wedged daemon cannot hang a writer.
eval {
my $tv = pack( 'l!l!', $timeout, 0 );
setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_RCVTIMEO(), $tv );
setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_SNDTIMEO(), $tv );
};
$EPS_CONN{$path} = { fh => $fh, pid => $$ };
return $fh;
} ## end sub _eps_conn
# One pipelined transaction: send $cmd (possibly several lines) and read
# $nreplies "OK n" lines, one per command sent. The munger only ever sends
# commands that reply exactly once -- MARKRATE (which marks AND returns the
# rate in one go), RATE, COUNT, TOTAL; never a bare MARK, whose reply-only-on-
# error behavior would let a failure desynchronize the reply stream. Dies on
# ERR, EOF, or timeout; the caller still drops the cached connection on error
# as belt and braces.
sub _eps_txn {
my ( $path, $timeout, $cmd, $nreplies ) = @_;
my $fh = _eps_conn( $path, $timeout );
print {$fh} $cmd or die "write to iqbi-damiq failed: $!\n";
my @out;
for ( 1 .. $nreplies ) {
my $reply = <$fh>;
die "iqbi-damiq closed the connection (or timed out)\n"
unless defined $reply;
$reply =~ /\AOK (\S+)/
or die "iqbi-damiq replied: $reply";
push @out, $1 + 0;
}
return @out;
} ## end sub _eps_txn
# Validate the spec keys shared by the scalar and multi-output eps builders.
sub _eps_spec {
my ( $spec, $where ) = @_;
my $socket = defined $spec->{socket} ? $spec->{socket} : $EPS_SOCKET;
croak "eps munger$where: 'socket' must be a non-empty path"
unless length $socket;
my $prefix = defined $spec->{prefix} ? $spec->{prefix} : '';
croak "eps munger$where: 'prefix' may not contain whitespace or control " . 'characters'
if $prefix =~ /[\s[:cntrl:]]/;
my $mark = exists $spec->{mark} ? ( $spec->{mark} ? 1 : 0 ) : 1;
my $timeout = defined $spec->{timeout} ? $spec->{timeout} : 5;
croak "eps munger$where: 'timeout' must be a positive number"
unless looks_like_number($timeout) && $timeout > 0;
my $on_error = defined $spec->{on_error} ? $spec->{on_error} : 'die';
croak "eps munger$where: 'on_error' must be 'die' or a number"
unless $on_error eq 'die' || looks_like_number($on_error);
return ( $socket, $prefix, $mark, $timeout, $on_error );
} ## end sub _eps_spec
my %EPS_READ = map { $_ => 1 } qw(rate count total);
sub _build_eps {
my ( $spec, $where ) = @_;
croak "eps munger$where: 'parts' is for the multi-output form (needs " . "'into'); use 'read' for a single column"
if defined $spec->{parts};
my ( $socket, $prefix, $mark, $timeout, $on_error ) = _eps_spec( $spec, $where );
my $read = defined $spec->{read} ? $spec->{read} : 'rate';
croak "eps munger$where: unknown read '$read' (known: " . join( ', ', sort keys %EPS_READ ) . ')'
unless $EPS_READ{$read};
# Command plan, fixed at build time. The common case -- mark and read the
# rate -- is the daemon's single MARKRATE command. mark+count/total rides
# MARKRATE too (its rate reply is discarded) so marking failures come back
# as an ordinary first reply instead of a bare MARK's error-only surprise.
my @cmds
= !$mark ? ( uc $read )
: $read eq 'rate' ? ('MARKRATE')
: ( 'MARKRATE', uc $read );
return sub {
my ($v) = @_;
my $key = $prefix . ( defined $v ? "$v" : '' );
$key =~ s/[\s[:cntrl:]]/_/g;
my @replies = eval {
die "empty key\n" unless length $key;
_eps_txn( $socket, $timeout, join( '', map { "$_ $key\n" } @cmds ), scalar @cmds );
};
if ($@) {
my $err = $@;
delete $EPS_CONN{$socket}; # reconnect fresh next call
croak "eps munger$where: $err" if $on_error eq 'die';
return $on_error + 0;
}
return $replies[-1]; # the requested read is always the last reply
}; ## end sub
} ## end sub _build_eps
# Multi-output eps: one key, several reads (rate/count/total), one round trip.
# Returns ($list_returning_code, $arity) for compile()'s 'into' check.
sub _build_eps_multi {
my ( $spec, $where ) = @_;
my $parts = $spec->{parts};
croak "eps munger$where: 'parts' must be a non-empty arrayref"
unless ref $parts eq 'ARRAY' && @$parts;
for my $p (@$parts) {
croak "eps munger$where: unknown part '"
. ( defined $p ? $p : 'undef' )
. "' (known: "
. join( ', ', sort keys %EPS_READ ) . ')'
unless defined $p && $EPS_READ{$p};
}
( run in 1.858 second using v1.01-cache-2.11-cpan-6aa56a78535 )