trAvis - MANAGER
Edit File: ACL.pm
package Milter::SMTPAuth::Utils::ACLEntry; use Moose; use Scalar::Util qw(looks_like_number); use Net::IP; use Milter::SMTPAuth::Exception; use Milter::SMTPAuth::Utils; use Math::BigInt; use Data::Dumper; has 'address' => ( isa => 'Net::IP', is => 'ro', required => 1 ); has 'name' => ( isa => 'Maybe[Str]', is => 'ro' ); has 'value' => ( isa => 'Any', is => 'rw' ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig( @_ ); if ( !exists( $args->{address} ) ) { Milter::SMTPAuth::ArugmentError->throw( error_message => "new Milter::SMTPAuth::Utils::ACLEntry must be specified address.", ); } if ( !defined( blessed( $args->{address} ) ) ) { $args->{address} = new Net::IP( $args->{address} ); if ( !$args->{address} ) { Milter::SMTPAuth::ArugmentError->throw( error_message => q{address must be Net::IP instance or "network/netmask" string}, ); } } return $args; }; =head1 NAME Milter::SMTPAuth::Utils::ACLEntry - Network ACL entry. =head1 SYNOPSIS Quick summary of what the module does. # log server use Milter::SMTPAuth::Utils::ACL; my $my_network = new Milter::SMTPAuth::Utils::ACLEntry( address => '172.16.10.0/24', name => 'my network', value => 1, ); =head1 SUBROUTINES/METHODS =head2 new =over 4 =item * address Net::IP instance. =item * name Network name. =item * value =back =head2 network =cut sub network { my $this = shift; return new Math::BigInt( $this->address()->intip() ); } =head2 netmask =cut sub netmask { my $this = shift; my $bit_length = $this->version() == 4 ? 32 : 128; return bit_n( $bit_length ) - bit_n( $bit_length - $this->address()->prefixlen() ); } =head2 bit_n( $n ) return 0x01 << $n by Math::BigInt. if $n < 0 return 0. =cut sub bit_n { my ( $n ) = @_; if ( $n >= 0 ) { return Math::BigInt->new( 1 )->blsft( $n ); } else { return Math::BigInt->new( 0 ); } } =head2 version If network address is IPv4, return 4. If network address is IPv6, return 6. =cut sub version { my $this = shift; return $this->address->version(); } =head2 check_ip_address( $str ) Check $str is IP address format, and return Net::IP instance. If $str is not IP address format, throw ArgumentError exception. =cut sub check_ip_address { my ( $str ) = @_; my $ip_addr = new Net::IP( $str ); if ( !defined( $ip_addr ) ) { Milter::SMTPAuth::ArgumentError->throw( error_message => sprintf( q{Invalid network address "%s"(%s).}, $str, Net::IP::Error() ), ); } return $ip_addr; } no Moose; __PACKAGE__->meta->make_immutable; package Milter::SMTPAuth::Utils::ACLBit; use Moose; has 'bit' => ( isa => 'Int', is => 'ro', required => 1 ); has 'next_0' => ( isa => 'Maybe[Milter::SMTPAuth::Utils::ACLBit]', is => 'rw', default => undef ); has 'next_1' => ( isa => 'Maybe[Milter::SMTPAuth::Utils::ACLBit]', is => 'rw', default => undef ); has 'acl_entry' => ( isa => 'Maybe[Milter::SMTPAuth::Utils::ACLEntry]', is => 'rw', default => undef ); sub print_acl_bit { my $this = shift; printf STDERR "bit %d, next_1: %d, next_0: %d, acl_entry: %s\n", $this->bit, $this->next_1 ? 1 : 0, $this->next_0 ? 1 : 0, $this->acl_entry ? $this->acl_entry->name : "none"; } no Moose; __PACKAGE__->meta->make_immutable; =head1 NAME Milter::SMTPAuth::Utils::ACL - ACL. =head1 VERSION =head1 SYNOPSIS Quick summary of what the module does. # log server use Milter::SMTPAuth::Utils::ACL; my $my_network = new Milter::SMTPAuth::Utils::ACLEntry( address => '172.16.10.0/24', name => 'my network', value => 1, ); my $group_network = new Milter::SMTPAuth::Utils::ACLEntry( address => '172.16.10.0/16', name => 'group network', value => 2, ); my $my_host = new Milter::SMTPAuth::Utils::ACLEntry( address => '172.16.10.101', name => 'my host', value => 0, ); # make ACL. my $acl = new Milter::SMTPAuth::Utils::ACL; $acl->add( $my_network ); $acl->add( $group_network ); $acl->add( $my_host ); $acl->match( '10.0.0.1' ); # unmatched, return undef. my $acl_entry1 = $acl->match( '172.16.230.24' ) # matched $group_network, return $group_network. print $acl_entry1->name; # "group network" my $acl_entry2 = $acl->match( '172.16.10.24' ) # matched $my_network, return $my_network. print $acl_entry2->name; # "my network" my $acl_entry3 = $acl->match( '172.16.10.101' ) # matched $my_host, return $my_host. print $acl_entry3->name; # "my host" =cut package Milter::SMTPAuth::Utils::ACLImp; use Moose; use Data::Dumper; has '_top' => ( isa => 'Milter::SMTPAuth::Utils::ACLBit', is => 'ro', default => sub { new Milter::SMTPAuth::Utils::ACLBit( bit => 0 ) } ); has '_bit_length' => ( isa => 'Int', is => 'ro', required => 1 ); =head1 SUBROUTINES/METHODS =head2 new( _bit_length => $bit_length ) Bit length of IP address, Bit length of IPv4 address length is 32, bit length of IPv6 address is 128. =head2 add( $acl_entry ) add acl_entry, and return self. =cut sub add { my $this = shift; my ( $ac ) = @_; my $node = $this->_top(); for ( my $i = 1; $i <= $this->_bit_length + 1; $i++ ) { my $bit = Milter::SMTPAuth::Utils::ACLEntry::bit_n( $this->_bit_length - $i ); if ( !( $ac->netmask & $bit ) ) { $node->acl_entry( $ac ); last; } if ( $ac->network & $bit ) { if ( !defined( $node->next_1 ) ) { $node->next_1( new Milter::SMTPAuth::Utils::ACLBit( bit => 1 ) ); } $node = $node->next_1; } else { if ( !defined( $node->next_0 ) ) { $node->next_0( new Milter::SMTPAuth::Utils::ACLBit( bit => 0 ) ); } $node = $node->next_0; } } return $this; } =head2 match( $address ) whether IP address $address is matched or not. If $address is matched, this method return matched ACLEntry. If not matched, this method return undef. =cut sub match { my $this = shift; my ( $address ) = @_; my $address_binary = $address->intip(); my $node = $this->_top(); my $matched_acl_entry = undef; my $i = 0; while ( $node ) { my $bit = Milter::SMTPAuth::Utils::ACLEntry::bit_n( $this->_bit_length - 1 - $i ); if ( $node->acl_entry ) { $matched_acl_entry = $node->acl_entry; } if ( $bit & $address_binary ) { $node = $node->next_1; } else { $node = $node->next_0; } $i++; } return $matched_acl_entry; } sub print_bits { my $this = shift; my ( $num ) = @_; for ( my $i = 0; $i < $this->_bit_length; $i++ ) { if ( $i % 8 == 0 ) { print STDERR " "; } my $bit = Milter::SMTPAuth::Utils::ACLEntry::bit_n( $this->_bit_length - $i - 1 ); printf STDERR "%d", $bit & $num ? 1 : 0; } print STDERR "\n"; } package Milter::SMTPAuth::Utils::ACL; use Moose; use Data::Dumper; has '_ipv4_acl' => ( isa => 'Milter::SMTPAuth::Utils::ACLImp', is => 'rw', default => sub { new Milter::SMTPAuth::Utils::ACLImp( _bit_length => 32 ) } ); has '_ipv6_acl' => ( isa => 'Milter::SMTPAuth::Utils::ACLImp', is => 'rw', default => sub { new Milter::SMTPAuth::Utils::ACLImp( _bit_length => 128 ) } ); =head1 SUBROUTINES/METHODS =head2 =head2 add( $acl_entry ) add acl_entry. =cut sub add { my $this = shift; my ( $acl_entry ) = @_; my $acl = $this->_get_acl( $acl_entry->address() ); $acl->add( $acl_entry ); } =head2 match( $address ) whether IP address $address is matched or not. If $address is matched, this method return matched ACLEntry. If not matched, this method return undef. =cut sub match { my $this = shift; my ( $str ) = @_; my $address = Milter::SMTPAuth::Utils::ACLEntry::check_ip_address( $str ); my $acl = $this->_get_acl( $address ); return $acl->match( $address ); } sub _get_acl { my $this = shift; my ( $address ) = @_; if ( $address->version() == 4 ) { return $this->_ipv4_acl; } elsif ( $address->version() == 6 ) { return $this->_ipv6_acl; } else { Milter::SMTPAuth::ArgumentError->throw( error_message => sprintf( q{unknown protocol version "%d"}, $address->version ), ); } } 1;