###########################################################################
# package Net::SIP::Authorize
# use in ReceiveChain in front of StatelessProxy, Endpoint.. to authorize request
# by enforcing authorization and only handling request only if it was
# fully authorized
###########################################################################

use strict;
use warnings;

package Net::SIP::Authorize;
use Carp 'croak';
use Net::SIP::Debug;
use Net::SIP::Util ':all';
use Digest::MD5 'md5_hex';
use fields qw( realm opaque user2pass user2a1 i_am_proxy dispatcher filter );

###########################################################################
# creates new Authorize object
# Args: ($class,%args)
#   %args
#     realm: which realm to announce
#     user2pass: hash of (username => password) or callback which returns
#        password if given username
#     dispatcher: Dispatcher object
#     i_am_proxy: true if should send Proxy-Authenticate, not WWW-Authenticate
#     filter: hashref with extra verification chain, see packages below.
#      Usage:
#      filter => {
#       # filter chain for registration
#       REGISTER => [
#        # all of this three must succeed (user can regist himself)
#        [ 'ToIsFrom','FromIsRealm','FromIsAuthUser' ],
#        # or this must succeed
#        \&call_back, # callback. If arrayref you MUST set [ \&call_back ]
#       ]
#       # filter chain for invites
#       INVITE => 'FromIsRealm',
#      }
# Returns: $self
###########################################################################
sub new {
	my ($class,%args) = @_;
	my $self = fields::new( $class );
	$self->{realm} = $args{realm} || 'p5-net-sip';
	$self->{opaque} = $args{opaque};

	$args{user2pass} || $args{user2a1} || croak 'no user2pass or user2a1 known';

	$self->{user2pass} = $args{user2pass};
	$self->{user2a1} = $args{user2a1};
	$self->{i_am_proxy} = $args{i_am_proxy};
	$self->{dispatcher} = $args{dispatcher} || croak 'no dispatcher';

	if ( my $f = $args{filter}) {
		croak 'filter must be hashref' if ref($f) ne 'HASH';
		my %filter;
		while (my($method,$chain) = each %$f) {
			$chain = [ $chain ] if ref($chain) ne 'ARRAY';
			map { $_ = [$_] if ref($_) ne 'ARRAY' } @$chain;
			# now we have:
			# method => [[ cb00,cb01,cb02,..],[ cb10,cb11,cb12,..],...]
			# where either the cb0* chain or the cb1* chain or the cbX* has to succeed
			for my $or (@$chain) {
				for (@$or) {
					if (ref($_)) {
						# assume callback
					} else {
						# must have authorize class with verify method
						my $pkg = __PACKAGE__."::$_";
						my $sub = UNIVERSAL::can($pkg,'verify') || do {
							# load package
							eval "require $pkg";
							UNIVERSAL::can($pkg,'verify')
						} or die "cannot find sub ${pkg}::verify";
						$_ = $sub;
					}
				}
			}
			$filter{uc($method)} = $chain;
		}
		$self->{filter} = \%filter;
	}
	return $self;
}

###########################################################################
# handle packet, called from Net::SIP::Dispatcher on incoming requests
# Args: ($self,$packet,$leg,$addr)
#  $packet: Net::SIP::Request
#  $leg: Net::SIP::Leg where request came in (and response gets send out)
#  $addr: ip:port where request came from and response will be send
# Returns: TRUE if it handled the packet
###########################################################################
sub receive {
	my Net::SIP::Authorize $self = shift;
	my ($packet,$leg,$addr) = @_;

	# don't handle responses
	if ( $packet->is_response ) {
		DEBUG( 100,"pass thru response" );
		return;
	}
	my $method = $packet->method;

	# check authorization on request
	my ($rq_key,$rs_key,$acode) = $self->{i_am_proxy}
		? ( 'proxy-authorization', 'proxy-authenticate',407 )
		: ( 'authorization','www-authenticate',401 )
		;
	my @auth = $packet->get_header( $rq_key );
	my $user2pass = $self->{user2pass};
	my $user2a1 = $self->{user2a1};
	my $realm = $self->{realm};
	my $opaque = $self->{opaque};

	# there might be multiple auth, pick the right realm
	my (@keep_auth,$authorized);

	foreach my $auth ( @auth ) {
		# RFC 2617
		my ($data,$param) = sip_hdrval2parts( $rq_key => $auth );
		if ( $param->{realm} ne $realm ) {
			# not for me
			push @keep_auth,$auth;
			next;
		}
		if ( defined $opaque ) {
			if ( ! defined $param->{opaque} ) {
				DEBUG( 10,"expected opaque value, but got nothing" );
				next;
			} elsif ( $param->{opaque} ne $opaque ) {
				DEBUG( 10,"got wrong opaque value '$param->{opaque}', expected '$opaque'" );
				next;
			}
		}

		my ($user,$nonce,$uri,$resp,$qop,$cnonce,$algo ) =
			@{$param}{ qw/ username nonce uri response qop cnonce algorithm / };
		if ( lc($data) ne 'digest'
			|| ( $algo && lc($algo) ne 'md5' )
			|| ( $qop && $qop ne 'auth' ) ) {
			DEBUG( 10,"unsupported response: $auth" );
			next;
		};

		# we support with and w/o qop
		# get a1_hex from either user2a1 or user2pass
		my $a1_hex;
		if ( ref($user2a1)) {
			if ( ref($user2a1) eq 'HASH' ) {
				$a1_hex = $user2a1->{$user}
			} else {
				$a1_hex = invoke_callback( $user2a1,$user,$realm );
			}
		}
		if ( ! defined($a1_hex) && ref($user2pass)) {
			my $pass;
			if ( ref($user2pass) eq 'HASH' ) {
				$pass = $user2pass->{$user}
			} else {
				$pass = invoke_callback( $user2pass,$user );
			}
			# if wrong credentials ask again for authorization
			last if ! defined $pass;
			$a1_hex = md5_hex(join( ':',$user,$realm,$pass ));
		}

		last if ! defined $a1_hex; # not in user2a1 || user2pass

		# ACK just reuse the authorization from INVITE, so they should
		# be checked against method INVITE
		# for CANCEL the RFC doesn't say anything, so we assume it uses
		# CANCEL but try INVITE if this fails
		my @a2 =
			$method eq 'ACK' ? ("INVITE:$uri") :
			$method eq 'CANCEL' ? ("CANCEL:$uri","INVITE:$uri") :
			("$method:$uri");

		while (my $a2 = shift(@a2)) {
			my $want_response;
			if ( $qop ) {
				# 3.2.2.1
				$want_response = md5_hex( join( ':',
					$a1_hex,
					$nonce,
					1,
					$cnonce,
					$qop,
					md5_hex($a2)
				));
			} else {
				 # 3.2.2.1 compability with RFC2069
				 $want_response = md5_hex( join( ':',
					$a1_hex,
					$nonce,
					md5_hex($a2)
				));
			}

			if ( $resp eq $want_response ) {
				if ($self->{filter} and my $or = $self->{filter}{$method}) {
					for my $and (@$or) {
						$authorized = 1;
						for my $cb (@$and) {
							if ( ! invoke_callback(
								$cb,$packet,$leg,$addr,$user,$realm)) {
								$authorized = 0;
								last;
							}
						}
						last if $authorized;
					}
				} else {
					$authorized = 1;
				}
				last;
			}
		}
	}

	# if authorized remove authorization data from this realm
	# and pass packet thru
	if ( $authorized ) {
		DEBUG( 10, "Request authorized ". $packet->dump );
		# set header again
		$packet->set_header( $rq_key => \@keep_auth );
		return;
	}

	# CANCEL or ACK cannot be prompted for authorization, so
	# they should provide the right data already
	# unauthorized CANCEL or ACK are only valid as response to
	# 401/407 from this Authorize, so they should not be propagated
	if ($method eq 'ACK') {
		# cancel delivery of response to INVITE
		$self->{dispatcher}->cancel_delivery( $packet->tid );
		return $acode;
	} elsif ($method eq 'CANCEL') {
		return $acode;
	}

	# not authorized yet, ask to authenticate
	# keep it simple RFC2069 style
	my $digest = qq[Digest algorithm=MD5, realm="$realm",].
		( defined($opaque) ? qq[ opaque="$opaque",] : '' ).
		' nonce="'. md5_hex( $realm.rand(2**32)).'"';

	my $resp = $packet->create_response(
		$acode,
		'Authorization required',
		{ $rs_key => $digest }
	);

	$self->{dispatcher}->deliver( $resp, leg => $leg, dst_addr => $addr );

	# return $acode (TRUE) to show that packet should
	# not passed thru
	return $acode;
}

###########################################################################
# additional verifications
#  Net::SIP::Authorize::FromIsRealm - checks if the domain in 'From' is
#   the same as the realm in 'Authorization'
#  Net::SIP::Authorize::FromIsAuthUser - checks if the user in 'From' is
#   the same as the username in 'Authorization'
#  Net::SIP::Authorize::ToIsFrom - checks if 'To' and 'From' are equal
#
# Args each: ($packet,$leg,$addr,$auth_user,$auth_realm)
#  $packet: Net::SIP::Request
#  $leg: Net::SIP::Leg where request came in (and response gets send out)
#  $addr: ip:port where request came from and response will be send
#  $auth_user: username from 'Authorization'
#  $auth_realm: realm from 'Authorization'
# Returns: TRUE (1) | FALSE (0)
###########################################################################

package Net::SIP::Authorize::FromIsRealm;
use Net::SIP::Util qw( sip_hdrval2parts sip_uri2parts );
use Net::SIP::Debug;
sub verify {
	my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_;
	my $from = $packet->get_header('from');
	($from) = sip_hdrval2parts( from => $from );
	my ($domain) = sip_uri2parts($from);
	$domain =~s{:\w+$}{};
	return 1 if lc($domain) eq lc($auth_realm); # exact domain
	return 1 if $domain =~m{\.\Q$auth_realm\E$}i; # subdomain
	DEBUG( 10, "No Auth-success: From-domain is '$domain' and realm is '$auth_realm'" );
	return 0;
}

package Net::SIP::Authorize::FromIsAuthUser;
use Net::SIP::Util qw( sip_hdrval2parts sip_uri2parts );
use Net::SIP::Debug;
sub verify {
	my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_;
	my $from = $packet->get_header('from');
	($from) = sip_hdrval2parts( from => $from );
	my (undef,$user) = sip_uri2parts($from);
	return 1 if lc($user) eq lc($auth_user);
	DEBUG( 10, "No Auth-success: From-user is '$user' and auth_user is '$auth_user'" );
	return 0;
}

package Net::SIP::Authorize::ToIsFrom;
use Net::SIP::Util qw( sip_hdrval2parts );
use Net::SIP::Debug;
sub verify {
	my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_;
	my $from = $packet->get_header('from');
	($from) = sip_hdrval2parts( from => $from );
	my $to = $packet->get_header('to');
	($to) = sip_hdrval2parts( to => $to );
	return 1 if lc($from) eq lc($to);
	DEBUG( 10, "No Auth-success: To is '$to' and From is '$from'" );
	return 0;
}

1;