413 lines
12 KiB
Perl
413 lines
12 KiB
Perl
package Mail::AuthenticationResults::Parser;
|
|
# ABSTRACT: Class for parsing Authentication Results Headers
|
|
|
|
require 5.008;
|
|
use strict;
|
|
use warnings;
|
|
our $VERSION = '2.20231031'; # VERSION
|
|
use Carp;
|
|
|
|
use Mail::AuthenticationResults::Header;
|
|
use Mail::AuthenticationResults::Header::AuthServID;
|
|
use Mail::AuthenticationResults::Header::Comment;
|
|
use Mail::AuthenticationResults::Header::Entry;
|
|
use Mail::AuthenticationResults::Header::SubEntry;
|
|
use Mail::AuthenticationResults::Header::Version;
|
|
|
|
use Mail::AuthenticationResults::Token::Assignment;
|
|
use Mail::AuthenticationResults::Token::Comment;
|
|
use Mail::AuthenticationResults::Token::QuotedString;
|
|
use Mail::AuthenticationResults::Token::Separator;
|
|
use Mail::AuthenticationResults::Token::String;
|
|
|
|
use JSON;
|
|
|
|
|
|
sub new {
|
|
my ( $class, $auth_header ) = @_;
|
|
my $self = {};
|
|
bless $self, $class;
|
|
|
|
if ( $auth_header ) {
|
|
$self->parse( $auth_header );
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
|
|
sub parse {
|
|
my ( $self, $header ) = @_;
|
|
|
|
$self->tokenise( $header );
|
|
|
|
$self->_parse_authservid();
|
|
|
|
while ( @{ $self->{ 'tokenised' } } ) {
|
|
$self->_parse_entry();
|
|
}
|
|
|
|
return $self->parsed();
|
|
}
|
|
|
|
|
|
sub from_authentication_results_json {
|
|
my ( $self, $json ) = @_;
|
|
my $j = JSON->new();
|
|
my $hashref = $j->decode( $json );
|
|
return $self->_from_hashref( $hashref );
|
|
}
|
|
|
|
sub _from_hashref {
|
|
my ( $self, $hashref ) = @_;
|
|
my $type = $hashref->{'type'};
|
|
my $object
|
|
= $type eq 'header' ? Mail::AuthenticationResults::Header->new()
|
|
: $type eq 'authservid' ? Mail::AuthenticationResults::Header::AuthServID->new()
|
|
: $type eq 'entry' ? Mail::AuthenticationResults::Header::Entry->new()
|
|
: $type eq 'subentry' ? Mail::AuthenticationResults::Header::SubEntry->new()
|
|
: $type eq 'comment' ? Mail::AuthenticationResults::Header::Comment->new()
|
|
: croak "unknown type $type";
|
|
|
|
if ( $type eq 'header' ) {
|
|
my $authserv_id = $self->_from_hashref( $hashref->{ 'authserv_id' } );
|
|
$object->set_value( $authserv_id );
|
|
}
|
|
else {
|
|
$object->set_key( $hashref->{'key'} ) if exists $hashref->{'key'};
|
|
$object->safe_set_value( $hashref->{'value'} ) if exists $hashref->{'value'};
|
|
}
|
|
|
|
if ( exists $hashref->{'children'} ) {
|
|
for my $child ( @{ $hashref->{'children'} } ) {
|
|
my $child_object = $self->_from_hashref( $child );
|
|
$object->add_child( $child_object );
|
|
}
|
|
}
|
|
|
|
return $object;
|
|
}
|
|
|
|
|
|
|
|
sub tokenise {
|
|
my ( $self, $header ) = @_;
|
|
|
|
my @tokenised;
|
|
|
|
$header =~ s/\n/ /g;
|
|
$header =~ s/\r/ /g;
|
|
$header =~ s/^\s+//;
|
|
|
|
# Remove Header part if present
|
|
if ( $header =~ /^Authentication-Results:/i ) {
|
|
$header =~ s/^Authentication-Results://i;
|
|
}
|
|
|
|
my $args = {};
|
|
while ( length($header) > 0 ) {
|
|
|
|
my $token;
|
|
$header =~ s/^\s+//;
|
|
|
|
my $last_non_comment_type = exists( $args->{ 'last_non_comment_type' } ) ? $args->{ 'last_non_comment_type' }->is() : 'none';
|
|
|
|
if ( length( $header ) == 0 ) {
|
|
last;
|
|
}
|
|
elsif ( $header =~ /^\(/ ) {
|
|
$token = Mail::AuthenticationResults::Token::Comment->new( $header, $args );
|
|
}
|
|
elsif ( $header =~ /^;/ ) {
|
|
$token = Mail::AuthenticationResults::Token::Separator->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
elsif ( $header =~ /^"/ ) {
|
|
$token = Mail::AuthenticationResults::Token::QuotedString->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
elsif ( $last_non_comment_type ne 'assignment' && $header =~ /^\./ ) {
|
|
$token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
elsif ( $last_non_comment_type eq 'assignment' && $header =~ /^\./ ) {
|
|
# a . after an assignment cannot be another assignment, likely an unquoted string.
|
|
$token = Mail::AuthenticationResults::Token::String->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
elsif ( $header =~ /^\// ) {
|
|
$token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
elsif ( $header =~ /^=/ ) {
|
|
$token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
else {
|
|
$token = Mail::AuthenticationResults::Token::String->new( $header, $args );
|
|
$args->{ 'last_non_comment_type' } = $token;
|
|
}
|
|
|
|
$header = $token->remainder();
|
|
push @tokenised, $token;
|
|
}
|
|
|
|
croak 'Nothing to parse' if ! @tokenised;
|
|
|
|
$self->{ 'tokenised' } = \@tokenised;
|
|
|
|
return;
|
|
}
|
|
|
|
sub _parse_authservid {
|
|
my ( $self ) = @_;
|
|
my $tokenised = $self->{ 'tokenised' };
|
|
my $token;
|
|
|
|
my $authserv_id = Mail::AuthenticationResults::Header::AuthServID->new();
|
|
|
|
# Find the ServID
|
|
while ( @$tokenised ) {
|
|
$token = shift @$tokenised;
|
|
if ( $token->is() eq 'string' ) {
|
|
$authserv_id->set_value( $token->value() );
|
|
last;
|
|
}
|
|
elsif ( $token->is() eq 'comment' ) {
|
|
$authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
|
|
}
|
|
else {
|
|
# assignment or separator, both are bogus
|
|
croak 'Invalid AuthServ-ID';
|
|
}
|
|
}
|
|
|
|
my $expecting = 'key';
|
|
my $key;
|
|
|
|
TOKEN:
|
|
while ( @$tokenised ) {
|
|
$token = shift @$tokenised;
|
|
|
|
if ( $token->is() eq 'assignment' ) {
|
|
if ( $expecting eq 'assignment' ) {
|
|
if ( $token->value() eq '=' ) {
|
|
$expecting = 'value';
|
|
}
|
|
else {
|
|
croak 'unexpected token';
|
|
}
|
|
}
|
|
else {
|
|
croak 'not expecting an assignment';
|
|
}
|
|
}
|
|
elsif ( $token->is() eq 'comment' ) {
|
|
$authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
|
|
}
|
|
elsif ( $token->is() eq 'separator' ) {
|
|
last TOKEN;
|
|
}
|
|
if ( $token->is() eq 'string' ) {
|
|
if ( $expecting eq 'key' ) {
|
|
$key = $token;
|
|
$expecting = 'assignment';
|
|
}
|
|
elsif ( $expecting eq 'value' ) {
|
|
$authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() )->set_value( $token->value() ) );
|
|
$expecting = 'key';
|
|
undef $key;
|
|
}
|
|
else {
|
|
croak 'not expecting a string';
|
|
}
|
|
}
|
|
|
|
}
|
|
if ( $expecting ne 'key' ) {
|
|
if ( $key->value() =~ /^[0-9]+$/ ) {
|
|
# Looks like a version
|
|
$authserv_id->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $key->value() ) );
|
|
}
|
|
else {
|
|
# Probably bogus, but who knows!
|
|
$authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() ) );
|
|
}
|
|
}
|
|
|
|
$self->{ 'header' } = Mail::AuthenticationResults::Header->new()->set_value( $authserv_id );
|
|
$self->{ 'tokenised' } = $tokenised;
|
|
|
|
return;
|
|
}
|
|
|
|
sub _parse_entry {
|
|
my ( $self ) = @_;
|
|
my $tokenised = $self->{ 'tokenised' };
|
|
|
|
my $entry = Mail::AuthenticationResults::Header::Entry->new();
|
|
my $working_on = $entry;
|
|
|
|
my $expecting = 'key';
|
|
my $is_subentry = 0;
|
|
TOKEN:
|
|
while ( @$tokenised ) {
|
|
my $token = shift @$tokenised;
|
|
|
|
if ( $token->is() eq 'assignment' ) {
|
|
if ( $expecting eq 'assignment' ) {
|
|
if ( $token->value() eq '=' ) {
|
|
$expecting = 'value';
|
|
}
|
|
elsif ( $token->value() eq '.' ) {
|
|
$expecting = 'keymod';
|
|
}
|
|
elsif ( $token->value() eq '/' ) {
|
|
$expecting = 'version';
|
|
}
|
|
}
|
|
else {
|
|
croak 'not expecting an assignment';
|
|
}
|
|
}
|
|
elsif ( $token->is() eq 'comment' ) {
|
|
$working_on->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
|
|
}
|
|
elsif ( $token->is() eq 'separator' ) {
|
|
last TOKEN;
|
|
}
|
|
if ( $token->is() eq 'string' ) {
|
|
if ( $expecting eq 'key' ) {
|
|
if ( ! $is_subentry ) {
|
|
if ( $token->value() eq 'none' ) {
|
|
# Special case the none
|
|
$expecting = 'no_more_after_none';
|
|
}
|
|
else {
|
|
$entry->set_key( $token->value() );
|
|
$expecting = 'assignment';
|
|
}
|
|
}
|
|
else {
|
|
$working_on = Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $token->value() );
|
|
$expecting = 'assignment';
|
|
}
|
|
}
|
|
elsif ( $expecting eq 'keymod' ) {
|
|
$working_on->set_key( $working_on->key() . '.' . $token->value() );
|
|
$expecting = 'assignment';
|
|
}
|
|
elsif ( $expecting eq 'version' ) {
|
|
if ( $token->value() =~ /^[0-9]+$/ ) {
|
|
# Looks like a version
|
|
$working_on->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $token->value() ) );
|
|
}
|
|
else {
|
|
croak 'bad version token';
|
|
}
|
|
$expecting = 'assignment';
|
|
}
|
|
elsif ( $expecting eq 'value' ) {
|
|
if ( ! $is_subentry ) {
|
|
$entry->set_value( $token->value() );
|
|
$is_subentry = 1;
|
|
}
|
|
else {
|
|
$entry->add_child( $working_on->set_value( $token->value() ) );
|
|
}
|
|
$expecting = 'key';
|
|
}
|
|
else {
|
|
croak 'not expecting a string';
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
if ( $expecting eq 'no_more_after_none' ) {
|
|
$self->{ 'tokenised' } = $tokenised;
|
|
# We may have comment entries, if so add those to the header object
|
|
foreach my $child ( @{ $entry->children() } ) {
|
|
delete $child->{ 'parent' };
|
|
$self->{ 'header' }->add_child( $child );
|
|
}
|
|
return;
|
|
}
|
|
|
|
if ( $expecting ne 'key' ) {
|
|
if ( $is_subentry ) {
|
|
$entry->add_child( $working_on );
|
|
}
|
|
}
|
|
|
|
$self->{ 'header' }->add_child( $entry );
|
|
$self->{ 'tokenised' } = $tokenised;
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
sub parsed {
|
|
my ( $self ) = @_;
|
|
return $self->{ 'header' };
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Mail::AuthenticationResults::Parser - Class for parsing Authentication Results Headers
|
|
|
|
=head1 VERSION
|
|
|
|
version 2.20231031
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Class for parsing Authentication Results headers into objects.
|
|
|
|
takes a string and returns a L<Mail::AuthenticationResults::Header> object
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new( $header )
|
|
|
|
Return a new Parser instance.
|
|
|
|
If $header is supplied then parse it and return the parsed object.
|
|
|
|
=head2 parse( $header )
|
|
|
|
Parse $header and return the parsed object.
|
|
|
|
=head2 from_authentication_results_json( $json )
|
|
|
|
Parse $json as the json returned from an as_json method call and return the parsed object.
|
|
|
|
=head2 tokenise( $header )
|
|
|
|
Tokenise the given $header string
|
|
|
|
=head2 parsed()
|
|
|
|
Return the parsed object tree
|
|
|
|
=head1 AUTHOR
|
|
|
|
Marc Bradshaw <marc@marcbradshaw.net>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
This software is copyright (c) 2021 by Marc Bradshaw.
|
|
|
|
This is free software; you can redistribute it and/or modify it under
|
|
the same terms as the Perl 5 programming language system itself.
|
|
|
|
=cut
|