view release on metacpan or  search on metacpan

lib/Net/Fritz/Service.pm  view on Meta::CPAN

    # SOAP::Lite just dies on transport error (eg. 401 Unauthorized), so eval this
    my $som;
    eval {
	$som = $soap->call($action, @args, $auth);
    };

    # if we got a 503 authentication error: fine!
    # now we gots us a nonce and can retry
    if (! $@
	and $som->fault
	and exists $som->fault->{detail}->{UPnPError}->{errorCode}
	and $som->fault->{detail}->{UPnPError}->{errorCode} == 503) {

	if (defined $self->fritz->username
	    and defined $self->fritz->password) {

	    $auth = $self->_get_real_auth($som->headers);

	    eval {
		$som = $soap->call($action, @args, $auth);
	    };
	}
	else {
	    return Net::Fritz::Error->new("authentication needed, but no credentials given");
	}
    }

    if ($@) {
	return Net::Fritz::Error->new($@);
    }
    elsif ($som->fault) {
	my @error = (
	    $som->fault->{faultcode},
	    $som->fault->{faultstring},
	    $som->fault->{detail}->{UPnPError}->{errorCode},
	    $som->fault->{detail}->{UPnPError}->{errorDescription}
	    );
	@error = map { defined $_ ? $_ : () } @error;
	return Net::Fritz::Error->new(join ' ', @error);
    }
    else {
	# according to the docs, $som->paramsin returns an array of hashes.  I don't see this :-/
	my $args_out = $som->body->{$action.'Response'};
	$args_out = {} unless ref $args_out; # fix empty responses

	$err = _hash_check(
	    $args_out,
	    { map { $_ => 0 } @{$self->action_hash->{$action}->args_out} },
	    'unknown output argument',
	    'missing output argument'
	    );
	return $err if $err->error;

	return Net::Fritz::Data->new($args_out);
    }
}

sub _get_initial_auth {
    my $self = shift;

    my $userid = SOAP::Header->name('UserID')
	->value($self->fritz->username);

    return SOAP::Header
	->name('h:InitChallenge')
	->attr({'xmlns:h' => 'http://soap-authentication.org/digest/2001/10/',
		's:mustUnderstand' => '1'})
	->value(\$userid);
}

sub _get_real_auth {
    my $self = shift;

    my $parm = shift;

    my $secret = md5_hex( join (':',
				$self->fritz->username,
				$parm->{Realm},
				$self->fritz->password,
			  ) );

    my $auth = SOAP::Header->name('Auth')
	->value(
	md5_hex( $secret . ':' . $parm->{Nonce} )
	);

    my $nonce = SOAP::Header->name('Nonce')
	->value($parm->{Nonce});

    my $realm = SOAP::Header->name('Realm')
	->value($parm->{Realm});

    my $userid = SOAP::Header->name('UserID')
	->value($self->fritz->username);

    return SOAP::Header
	->name('h:ClientAuth')
	->attr({'xmlns:h' => 'http://soap-authentication.org/digest/2001/10/',
		's:mustUnderstand' => '1'})
	->value(\SOAP::Header->value($nonce, $auth, $userid, $realm));
}

sub _hash_check {
    my ($hash_a, $hash_b, $msg_a, $msg_b) = (@_);

    foreach my $arg (keys %{$hash_a}) {
	if (! exists $hash_b->{$arg}) {
	    return Net::Fritz::Error->new("$msg_a $arg");
	}
    }

    foreach my $arg (keys %{$hash_b}) {
	if (! exists $hash_a->{$arg}) {
	    return Net::Fritz::Error->new("$msg_b $arg");
	}
    }

    return Net::Fritz::Data->new();
}


sub dump {
    my $self = shift;

    my $indent = shift;
    $indent = '' unless defined $indent;

    my $text = "${indent}Net::Fritz::Service:\n";
    $indent .= '  ';
    $text .= "${indent}serviceType     = " . $self->serviceType . "\n";
    $text .= "${indent}controlURL      = " . $self->controlURL  . "\n";
    $text .= "${indent}SCPDURL         = " . $self->SCPDURL     . "\n";

    my @actions = values %{$self->action_hash};
    if (@actions) {
	$text .= "${indent}actions         = {\n";
	foreach my $action (@actions) {
	    $text .= $action->dump($indent . '  ');
	}
	$text .= "${indent}}\n";
    }

    return $text;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Net::Fritz::Service - represents a TR064 service

=head1 VERSION