File Coverage

blib/lib/OpenID/Lite/RelyingParty/Discover/Service.pm

Criterion	Covered	Total	%
statement	29	72	40.2
branch	2	20	10.0
condition	5	8	62.5
subroutine	9	22	40.9
pod	10	13	76.9
total	55	135	40.7

package OpenID::Lite::RelyingParty::Discover::Service;

use Any::Moose;
use OpenID::Lite::Constants::Namespace
    qw(SERVER_2_0 SPEC_2_0 SPEC_1_0 SIGNON_2_0 SIGNON_1_1 SIGNON_1_0);
use URI;
use List::MoreUtils qw(any none);

has 'uris' => (
    is      => 'ro',
    isa     => 'ArrayRef',
    default => sub { [] },
);

has 'types' => (
    is      => 'ro',
    isa     => 'ArrayRef',
    default => sub { [] },
);

has 'claimed_identifier' => (
    is  => 'rw',
    isa => 'Str',
);

has 'op_local_identifier' => (
    is  => 'rw',
    isa => 'Str',
);

my @PRIORITY_ORDER = ( SERVER_2_0, SIGNON_2_0, SIGNON_1_1, SIGNON_1_0 );

has 'type_priority' => (
    is      => 'rw',
    isa     => 'Int',
    default => sub {$#PRIORITY_ORDER}
);

has '_display_identifier' => (
    is  => 'rw',
    isa => 'Str',
);

sub copy {
    my $self   = shift;
    my $class  = ref($self);
    my $copied = $class->new;
    my $uris   = $self->uris;
    $copied->add_uri($_) for @$uris;
    my $types = $self->types;
    $copied->add_type($_) for @$types;
    $copied->claimed_identifier( $self->claimed_identifier )
        if $self->claimed_identifier;
    $copied->op_local_identifier( $self->op_local_identifier )
        if $self->op_local_identifier;
    $copied->_display_identifier( $self->_display_identifier )
        if $self->_display_identifier;
    return $copied;
}

sub display_identifier {
    my $self = shift;
    my $dispid = shift;
    if ($dispid) {
        $self->_display_identifier($dispid);
    } else {
        return $self->_display_identifier if $self->_display_identifier;
        return unless $self->claimed_identifier;
        my $parsed_id = URI->new($self->claimed_identifier);
        return $self->claimed_identifier if not $parsed_id->fragment;
        $parsed_id->fragment(undef);
        return $parsed_id->as_string;
    }
}

sub find_local_identifier {
    my $self = shift;
    return $self->op_local_identifier || $self->claimed_identifier;
}

sub url {
    my $self = shift;
    my $uris = $self->uris;
    return $uris->[0] || '';
}

sub is_op_identifier {
    my $self  = shift;
    my $types = $self->types;
    return ( any { $_ eq SERVER_2_0 } @$types );
}

sub preferred_namespace {
    my $self = shift;
    $self->requires_compatibility_mode ? SPEC_1_0 : SPEC_2_0;
}

sub requires_compatibility_mode {
    my $self  = shift;
    my $types = $self->types;
    return ( none { $_ eq SERVER_2_0 || $_ eq SIGNON_2_0 } @$types );
}

sub has_uri {
    my ( $self, $uri ) = @_;
    return ( any { $_ eq $uri } @{ $self->uris } );
}

sub add_uri {
    my ( $self, $uri ) = @_;
    my $uris = $self->uris;
    push @$uris, $uri;
}

sub add_uris {
    my $self = shift;
    $self->add_uri($_) for @_;
}

sub add_type {
    my ( $self, $type ) = @_;
    my $types = $self->types;
    for ( my $i = 0; $i < @PRIORITY_ORDER; $i++ ) {
        if (   $type eq $PRIORITY_ORDER[$i]
            && $self->type_priority > $i )
        {
            $self->type_priority($i);
        }
    }
    push @$types, $type;
}

sub add_types {
    my $self = shift;
    $self->add_type($_) for @_;
}

sub has_type {
    my ( $self, $type ) = @_;
    return ( any { $_ eq $type } @{ $self->types } );
}

no Any::Moose;
__PACKAGE__->meta->make_immutable;
1;

=head1 NAME

OpenID::Lite::Relyingparty::Discover::Service - Discovered information

=head1 SYNOPSIS

    $service->url;
    $service->claimed_identifier
    $service->op_local_identifier
    $service->copy;
    $service->find_local_identifier;
    $service->is_op_identifier;
    $service->preferred_namespace;
    $service->requires_compatibility_mode;
    $service->has_type(  );
    $service->add_type();
    $service->has_uri();
    $service->add_uri();

=head1 DESCRIPTION

This class's object represents discovered information.

=head1 METHODS

=head2 new

    my $service = OpenID::Lite::RelyingParty::Discover::Service->new;

=head2 url

Returns service endpoint url.

    my $service_endpoint_url = $service->url;

=head2 add_type

Add a type of service the OP provides.

    use OpenID::Lite::Constants::Namespace qw( SERVER_2_0 SIGNON_2_0 );

    $service->add_type( SERVER_2_0 );
    $service->add_type( SIGNON_2_0 );

=head2 has_type

Check if the OP provides indicated type of service.

    use OpenID::Lite::Constants::Namespace qw( SERVER_2_0 );
    $service->has_type( SERVER_2_0 );

=head2 add_uri

Add endpoint uri

    $service->has_uri(q{http://yourapp.com/openid/endpoint});

=head2 has_uri

Check if the service includes indicated uri.

    if ( $service->has_uri( $endpoint_uri ) ) {
        ...
    }

=head2 claimed_identifier

Return claimed identitifier if it has.
(When discovery is carried out with claimed_id)

    my $claimed_id = $service->claimed_identifier;

=head2 op_local_identifier

Return op local identitifier if it has.
(When discovery is carried out with claimed_id and the response which OP returns includes LocalID)

    my $op_local_identifier = $service->op_local_identifier;

=head2 find_local_identifier

Returns op_local_identfier if it found.
Or return claimed id.

    my $identity = $service->find_local_identifier;


=head2 copy

    my $copied_service = $service->copy();

=head2 is_op_identifier

Return true if this is for OP identifier
(When discovery is carried out with OP identifier)

    if ( $service->is_op_identifier ) {
        ...
    }

=head2 preferred_namespace

Return proper namespace for openid.ns

=head2 requires_compatibility_mode

If the endpoint accepts only OpenID 1.x version protocol,
return true.

=head1 AUTHOR

Lyo Kato, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Lyo Kato

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut