Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
t/mungers.t view on Meta::CPAN
my $nib = $M->build( { munger => 'bit', mask => '0xf0', mode => 'value' } );
is( $nib->('0xab'), 10, 'bit value: high nibble, shifted down' );
is( $nib->(0), 0, 'bit value of 0' );
eval { $synack->('nope') };
like( $@, qr/not a non-negative integer/, 'bit rejects non-integer input' );
eval { $synack->(-3) };
like( $@, qr/not a non-negative integer/, 'bit rejects negative input' );
eval { $M->build( { munger => 'bit' } ) };
like( $@, qr/requires a 'mask'/, 'bit requires a mask outside popcount' );
eval { $M->build( { munger => 'bit', mask => 0 } ) };
like( $@, qr/must be non-zero/, 'bit rejects a zero mask' );
eval { $M->build( { munger => 'bit', mask => 'zz' } ) };
like( $@, qr/'mask' must be/, 'bit rejects a garbage mask' );
eval { $M->build( { munger => 'bit', mask => 1, mode => 'nope' } ) };
like( $@, qr/unknown mode 'nope'/, 'bit rejects bad mode' );
# base => 16: read a bare-hex input, e.g. Suricata's tcp_flags "1b".
my $hsyn = $M->build( { munger => 'bit', mask => '0x02', base => 16 } );
is( $hsyn->('1b'), 1, 'bit base16: SYN set in bare-hex 1b' );
is( $hsyn->('0x1b'), 1, 'bit base16 still accepts a 0x prefix' );
is( $hsyn->('11'), 0, 'bit base16: "11" is hex 0x11 (no SYN), not decimal' );
my $hpop = $M->build( { munger => 'bit', mode => 'popcount', base => 16 } );
is( $hpop->('1b'), 4, 'bit base16 popcount of 0x1b' );
eval { $hsyn->('zz') };
like( $@, qr/not a non-negative integer \(hex\)/, 'bit base16 rejects non-hex, names the form' );
eval { $M->build( { munger => 'bit', mask => 1, base => 2 } ) };
like( $@, qr/'base' must be 10 or 16/, 'bit rejects an unsupported base' );
}
# ---- Suricata named enums ---------------------------------------------------
{
my $ap = $M->build( { munger => 'app_proto_enum', default => -1 } );
is( $ap->('http'), 2, 'app_proto http' );
is( $ap->('TLS'), $ap->('tls'), 'app_proto is case-insensitive' );
is( $ap->('ssl'), $ap->('tls'), 'app_proto ssl aliases tls' );
is( $ap->('ikev2'), $ap->('ike'), 'app_proto ikev2 aliases ike' );
is( $ap->('unknown'), 0, 'app_proto keeps unknown as a class' );
is( $ap->('failed'), 1, 'app_proto keeps failed as a class' );
is( $ap->('wat'), -1, 'app_proto default for unlisted' );
eval { $M->build( { munger => 'app_proto_enum' } )->(6) };
like( $@, qr/no mapping for '6'/, 'app_proto does not pass a number through' );
my $ts = $M->build( { munger => 'tcp_state_enum' } );
is( $ts->('none'), 0, 'tcp_state none' );
is( $ts->('ESTABLISHED'), 3, 'tcp_state established (case-insensitive)' );
is( $ts->('closed'), 10, 'tcp_state closed' );
ok( $ts->('syn_sent') < $ts->('established'), 'tcp_state is ordinal along the lifecycle' );
my $fs = $M->build( { munger => 'flow_state_enum' } );
is( $fs->('new'), 0, 'flow_state new' );
is( $fs->('local_bypass'), 4, 'flow_state local_bypass' );
my $fr = $M->build( { munger => 'flow_reason_enum' } );
is( $fr->('timeout'), 0, 'flow_reason timeout' );
is( $fr->('shutdown'), 2, 'flow_reason shutdown' );
my $ac = $M->build( { munger => 'suricata_action_enum' } );
is( $ac->('allowed'), 0, 'suricata_action allowed' );
is( $ac->('blocked'), 1, 'suricata_action blocked' );
is( $ac->('drop'), 3, 'suricata_action drop (IPS)' );
}
# ---- Postfix / mail named enums ---------------------------------------------
{
my $ps = $M->build( { munger => 'postfix_status_enum', default => -1 } );
is( $ps->('sent'), 0, 'postfix_status sent' );
is( $ps->('DEFERRED'), 1, 'postfix_status is case-insensitive' );
is( $ps->('bounced'), 2, 'postfix_status bounced' );
is( $ps->('undeliverable'), 5, 'postfix_status undeliverable (verify)' );
is( $ps->('whatever'), -1, 'postfix_status default for unlisted' );
ok( $ps->('sent') < $ps->('bounced'), 'postfix_status ordered sent-before-bounced' );
my $spf = $M->build( { munger => 'spf_result_enum' } );
is( $spf->('pass'), 0, 'spf pass' );
is( $spf->('softfail'), 3, 'spf softfail' );
is( $spf->('permerror'), 6, 'spf permerror' );
is( $spf->('error'), $spf->('temperror'), 'spf error aliases temperror' );
is( $spf->('unknown'), $spf->('permerror'), 'spf unknown aliases permerror' );
my $dkim = $M->build( { munger => 'dkim_result_enum' } );
is( $dkim->('pass'), 0, 'dkim pass' );
is( $dkim->('policy'), 3, 'dkim policy' );
is( $dkim->('fail'), 4, 'dkim fail' );
my $dmarc = $M->build( { munger => 'dmarc_result_enum', default => -1 } );
is( $dmarc->('pass'), 0, 'dmarc pass' );
is( $dmarc->('fail'), 2, 'dmarc fail' );
is( $dmarc->('bestguesspass'), 5, 'dmarc opendmarc bestguesspass' );
is( $dmarc->('quarantine'), -1, 'dmarc result != disposition (quarantine unlisted)' );
eval { $M->build( { munger => 'spf_result_enum' } )->(4) };
like( $@, qr/no mapping for '4'/, 'mail result enums do not pass a number through' );
}
# ---- Apache / Dovecot named enums -------------------------------------------
{
# The full mechanism set the two SASL mungers share.
my @mechs = qw(
anonymous plain login apop cram-md5 digest-md5 ntlm skey otp securid
rpa kerberos_v4 srp scram-sha-1 scram-sha-1-plus scram-sha-256
scram-sha-256-plus xoauth2 oauthbearer openid20 saml20 gssapi gs2-krb5
gss-spnego external
);
is( scalar(@mechs), 25, 'fuller SASL registry has 25 mechanisms' );
my $s = $M->build( { munger => 'sasl_mech_enum', default => -1 } );
my $i = $M->build( { munger => 'sasl_mech_iana_enum', default => -1 } );
# Both mungers cover exactly the same set, distinctly numbered.
my ( %seen_s, %seen_i, $dup_s, $dup_i );
for my $m (@mechs) {
$dup_s++ if $seen_s{ $s->($m) }++;
$dup_i++ if $seen_i{ $i->($m) }++;
isnt( $s->($m), -1, "sasl_mech knows '$m'" );
isnt( $i->($m), -1, "sasl_mech_iana knows '$m'" );
}
ok( !$dup_s, 'sasl_mech numbers are distinct' );
ok( !$dup_i, 'sasl_mech_iana numbers are distinct' );
t/mungers.t view on Meta::CPAN
my $sm = $M->build( { munger => 'ssh_auth_method_enum', default => -1 } );
is( $sm->('none'), 0, 'ssh none' );
is( $sm->('password'), 1, 'ssh password' );
is( $sm->('keyboard-interactive'), 2, 'ssh keyboard-interactive' );
is( $sm->('publickey'), 4, 'ssh publickey' );
is( $sm->('gssapi'), $sm->('gssapi-with-mic'), 'ssh gssapi aliases gssapi-with-mic' );
ok( $sm->('password') < $sm->('publickey'), 'ssh_auth_method weakest-to-strongest' );
is( $sm->('magic'), -1, 'ssh_auth_method default for unlisted' );
my $am = $M->build( { munger => 'amavis_category_enum', default => -1 } );
is( $am->('clean'), 0, 'amavis clean' );
is( $am->('spam'), 4, 'amavis spam' );
is( $am->('bad-header'), $am->('badheader'), 'amavis bad-header aliases badheader' );
is( $am->('virus'), $am->('infected'), 'amavis virus aliases infected' );
ok( $am->('clean') < $am->('infected'), 'amavis_category ordered clean-to-worst' );
my $sr = $M->build( { munger => 'systemd_result_enum', default => -1 } );
is( $sr->('success'), 0, 'systemd success' );
is( $sr->('timeout'), 2, 'systemd timeout' );
is( $sr->('exit-code'), 3, 'systemd exit-code' );
is( $sr->('exit_code'), $sr->('exit-code'), 'systemd exit_code underscore alias' );
is( $sr->('oom_kill'), $sr->('oom-kill'), 'systemd oom_kill underscore alias' );
my $cv = $M->build( { munger => 'clamav_result_enum', default => -1 } );
is( $cv->('OK'), 0, 'clamav OK (case-insensitive)' );
is( $cv->('FOUND'), 1, 'clamav FOUND' );
is( $cv->('error'), 2, 'clamav error' );
is( $cv->('whatnow'), -1, 'clamav default for unlisted' );
eval { $M->build( { munger => 'rspamd_action_enum' } )->(2) };
like( $@, qr/no mapping for '2'/, 'daemon enums do not pass a number through' );
}
# ---- Windows / Kerberos named enums -----------------------------------------
{
# kerberos_etype: hex spellings and names resolve to the RFC 3961 etype
# number, and a decimal (the wire value) passes straight through.
my $ke = $M->build( { munger => 'kerberos_etype_enum', default => -1 } );
is( $ke->('0x17'), 23, 'kerberos_etype hex 0x17 is rc4-hmac' );
is( $ke->('rc4-hmac'), 23, 'kerberos_etype rc4-hmac name' );
is( $ke->('RC4'), 23, 'kerberos_etype rc4 alias, case-insensitive' );
is( $ke->('0x12'), 18, 'kerberos_etype hex 0x12 is aes256' );
is( $ke->('aes256'), 18, 'kerberos_etype aes256 name' );
is( $ke->(23), 23, 'kerberos_etype decimal 23 passes through (wire value)' );
is( $ke->('0x17'), $ke->('rc4-hmac'), 'kerberos_etype hex and name agree' );
ok( $ke->('rc4-hmac') > $ke->('aes256'), 'kerberos_etype rc4 sorts above aes256 (downgrade signal)' );
is( $ke->('0xdead'), -1, 'kerberos_etype default for unlisted' );
my $il = $M->build( { munger => 'windows_integrity_level_enum', default => -1 } );
is( $il->('Untrusted'), 0, 'integrity untrusted (case-insensitive)' );
is( $il->('Medium'), 2, 'integrity medium' );
is( $il->('System'), 4, 'integrity system' );
is( $il->('mediumplus'), 2, 'integrity mediumplus folds into medium' );
is( $il->('S-1-16-12288'), 3, 'integrity high mandatory-label SID' );
ok( $il->('Low') < $il->('System'), 'windows_integrity_level is ordinal' );
is( $il->('bogus'), -1, 'integrity default for unlisted' );
my $ls = $M->build( { munger => 'windows_logon_status_enum', default => -1 } );
is( $ls->('0xC0000064'), 0, 'logon_status no-such-user (case-insensitive hex)' );
is( $ls->('0xc000006a'), 1, 'logon_status bad password' );
is( $ls->('0xc0000234'), 10, 'logon_status locked out' );
is( $ls->('0xc000015b'), 11, 'logon_status type not granted' );
is( $ls->('0x0'), -1, 'logon_status default for a success/unlisted code' );
my $im = $M->build( { munger => 'windows_impersonation_level_enum', default => -1 } );
is( $im->('Anonymous'), 0, 'impersonation anonymous' );
is( $im->('Impersonation'), 2, 'impersonation impersonation' );
is( $im->('Delegation'), 3, 'impersonation delegation' );
is( $im->('%%1832'), 1, 'impersonation %%1832 token is identification' );
is( $im->('%%1833'), 2, 'impersonation %%1833 token is impersonation' );
ok( $im->('anonymous') < $im->('delegation'), 'windows_impersonation_level ordered by reach' );
eval { $M->build( { munger => 'windows_integrity_level_enum' } )->(3) };
like( $@, qr/no mapping for '3'/, 'windows ordinal enums do not pass a number through' );
}
# ---- O365 / Azure AD / AWS cloud named enums --------------------------------
{
# aad_signin_error: the sparse ResultType code space collapsed to reasons.
my $se = $M->build( { munger => 'aad_signin_error_enum', default => -1 } );
is( $se->('0'), 0, 'aad_signin_error 0 is success' );
is( $se->('50126'), 1, 'aad_signin_error 50126 bad-password' );
is( $se->('50056'), $se->('50126'), 'aad_signin_error 50056 shares bad-password bucket' );
is( $se->('50144'), $se->('50055'), 'aad_signin_error 50144 shares password-expired bucket' );
is( $se->('53000'), 8, 'aad_signin_error 53000 blocked-by-CA bucket' );
is( $se->(50053), 4, 'aad_signin_error accepts an integer code' );
is( $se->('99999'), -1, 'aad_signin_error default for an unlisted code' );
my $rl = $M->build( { munger => 'risk_level_enum', default => -1 } );
is( $rl->('none'), 0, 'risk_level none' );
is( $rl->('High'), 3, 'risk_level high (case-insensitive)' );
is( $rl->('hidden'), -1, 'risk_level hidden is off-scale (default)' );
ok( $rl->('low') < $rl->('high'), 'risk_level is ordinal' );
my $pt = $M->build( { munger => 'aws_principal_type_enum', default => -1 } );
is( $pt->('Root'), 0, 'aws_principal_type root (the alert signal)' );
is( $pt->('AssumedRole'), 2, 'aws_principal_type assumedrole' );
is( $pt->('IAMUser'), 1, 'aws_principal_type iamuser (case-insensitive)' );
is( $pt->('nope'), -1, 'aws_principal_type default for unlisted' );
# aad_client_app: modern < 2, legacy >= 2 (the legacy-auth threshold).
my $ca = $M->build( { munger => 'aad_client_app_enum', default => -1 } );
is( $ca->('Browser'), 0, 'aad_client_app browser is modern' );
is( $ca->('Mobile Apps and Desktop clients'), 1, 'aad_client_app modern desktop' );
ok( $ca->('IMAP4') >= 2, 'aad_client_app IMAP4 is legacy (>= 2)' );
ok( $ca->('POP3') >= 2, 'aad_client_app POP3 is legacy (>= 2)' );
is( $ca->('imap'), $ca->('IMAP4'), 'aad_client_app imap short alias' );
ok( $ca->('Browser') < 2 && $ca->('Other clients') >= 2,
'aad_client_app: modern sorts below the legacy-auth threshold' );
my $rs = $M->build( { munger => 'risk_state_enum', default => -1 } );
is( $rs->('none'), 0, 'risk_state none' );
is( $rs->('atRisk'), 4, 'risk_state atRisk (case-insensitive)' );
is( $rs->('confirmedCompromised'), 5, 'risk_state confirmedCompromised' );
my $ls = $M->build( { munger => 'vpc_flow_log_status_enum', default => -1 } );
is( $ls->('OK'), 0, 'vpc_flow_log_status OK' );
is( $ls->('NODATA'), 1, 'vpc_flow_log_status NODATA' );
is( $ls->('SKIPDATA'), 2, 'vpc_flow_log_status SKIPDATA' );
my $et = $M->build( { munger => 'aws_event_type_enum', default => -1 } );
is( $et->('AwsApiCall'), 0, 'aws_event_type AwsApiCall' );
is( $et->('AwsConsoleSignIn'), 3, 'aws_event_type AwsConsoleSignIn (the signal)' );
my $cs = $M->build( { munger => 'conditional_access_result_enum', default => -1 } );
is( $cs->('success'), 0, 'conditional_access success' );
is( $cs->('notApplied'), 1, 'conditional_access notApplied (case-insensitive)' );
is( $cs->('failure'), 4, 'conditional_access failure' );
eval { $M->build( { munger => 'aws_principal_type_enum' } )->(0) };
like( $@, qr/no mapping for '0'/, 'cloud category enums do not pass a number through' );
}
# ---- ip_class ---------------------------------------------------------------
{
my $c = $M->build( { munger => 'ip_class' } );
# v4: one probe per class
is( $c->('8.8.8.8'), 0, 'ip_class v4 global' );
is( $c->('10.1.2.3'), 1, 'ip_class 10/8 private' );
is( $c->('172.16.0.1'), 1, 'ip_class 172.16/12 private' );
is( $c->('172.32.0.1'), 0, 'ip_class 172.32 is NOT private' );
is( $c->('192.168.99.1'), 1, 'ip_class 192.168/16 private' );
is( $c->('100.64.0.1'), 1, 'ip_class CGNAT counts as private' );
is( $c->('100.128.0.1'), 0, 'ip_class just past CGNAT is global' );
( run in 2.997 seconds using v1.01-cache-2.11-cpan-800906f7e73 )