File Coverage

blib/lib/Test/OpenID/Consumer.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             #!/usr/bin/env perl
2 1     1   829 use warnings;
  1         2  
  1         47  
3 1     1   4 use strict;
  1         2  
  1         42  
4              
5             package Test::OpenID::Consumer;
6 1     1   551 use Net::OpenID::Consumer;
  0            
  0            
7             use LWPx::ParanoidAgent;
8             use Cache::FileCache;
9             use base qw/Test::HTTP::Server::Simple HTTP::Server::Simple::CGI/;
10              
11             our $VERSION = '0.01';
12              
13             =head1 NAME
14              
15             Test::OpenID::Consumer - setup a simulated OpenID consumer
16              
17             =head1 SYNOPSIS
18              
19             Test::OpenID::Consumer will provide a consumer to test your OpenID server
20             against. To use it, do something like this:
21              
22             use Test::More tests => 1;
23             use Test::OpenID::Consumer;
24             my $consumer = Test::OpenID::Consumer->new;
25             my $url_root = $consumer->started_ok("server started ok");
26              
27             $consumer->verify_ok('http://server/identity/openid');
28              
29             =cut
30              
31             use Test::Builder;
32             my $Tester = Test::Builder->new;
33              
34             =head1 METHODS
35              
36             =head2 new
37              
38             Create a new test OpenID consumer
39              
40             =cut
41              
42             sub new {
43             my $class = shift;
44             my $port = shift;
45              
46             $port = int(rand(5000) + 10000) if not defined $port;
47            
48             my $self = $class->SUPER::new( $port );
49              
50             my $ua = LWPx::ParanoidAgent->new;
51             $ua->whitelisted_hosts( qw/localhost 127.0.0.1/ );
52             $self->ua( $ua );
53              
54             return $self;
55             }
56              
57             =head2 ua [OBJECT]
58              
59             Get/set the LWP useragent to use for fetching pages. Defaults to an instance of
60             L with localhost whitelisted.
61              
62             =cut
63              
64             sub ua {
65             my $self = shift;
66             $self->{'ua'} = shift if @_;
67             return $self->{'ua'};
68             }
69              
70             =head2 started_ok
71              
72             Test whether the consumer's server started, and if it did, return the URL
73             it's at.
74              
75             =head1 METHODS
76              
77             =head2 verify_ok URL [TEST_NAME]
78              
79             Attempts to verify the given OpenID. At the moment, the verification MUST
80             NOT require any logging in or setup, but it may be supported in the future.
81              
82             =cut
83              
84             sub verify_ok {
85             my $self = shift;
86             my $openid = shift;
87             my $text = shift || 'verified OpenID';
88              
89             my ( $failed, $data ) = $self->_verify( $openid );
90              
91             if ( $failed ) {
92             $Tester->ok( 0, $text );
93             $self->_diag( $data );
94             }
95             else {
96             $Tester->ok( 1, $text );
97             }
98             }
99              
100             =head2 verify_cancelled URL [TEST_NAME]
101              
102             Like L, but the test passes if the OpenID verification process is
103             cancelled (i.e. the user chose not to trust the authenticating site).
104              
105             =cut
106              
107             sub verify_cancelled {
108             my $self = shift;
109             my $openid = shift;
110             my $text = shift || 'verification cancelled';
111              
112             my ( $failed, $data ) = $self->_verify( $openid );
113              
114             if ( $failed ) {
115             if ( $failed == 2 && $data->status_line =~ /canceled/i ) {
116             $Tester->ok( 1, $text );
117             }
118             else {
119             $Tester->ok( 0, $text );
120             $self->_diag( $data );
121             }
122             }
123             else {
124             $Tester->ok( 0, $text );
125             $Tester->diag( "successfully verified OpenID" );
126             }
127             }
128              
129             =head2 verify_invalid URL [TEST_NAME]
130              
131             Like L but the test passes if the OpenID client is unable to find
132             a valid OpenID identity at the URL given.
133              
134             =cut
135              
136             sub verify_invalid {
137             my $self = shift;
138             my $openid = shift;
139             my $text = shift || 'invalid OpenID';
140              
141             my ( $failed, $data ) = $self->_verify( $openid );
142              
143             if ( $failed == 1 ) {
144             $Tester->ok( 1, $text );
145             }
146             else {
147             $Tester->ok( 0, $text );
148             $self->_diag( $data );
149             }
150             }
151              
152             sub _diag {
153             my $self = shift;
154             my $data = shift;
155              
156             if ( ref $data ) {
157             $Tester->diag( "Error: " . $data->status_line );
158             $Tester->diag( "Content: " . $data->content )
159             if $data->content;
160             }
161             else {
162             $Tester->diag( $data );
163             }
164             }
165              
166             sub _verify {
167             my $self = shift;
168             my $openid = shift;
169              
170             my $baseurl = 'http://'
171             . ($self->host || 'localhost')
172             . ':' . ($self->port || '80');
173              
174             my $csr = Net::OpenID::Consumer->new(
175             ua => $self->ua,
176             cache => Cache::FileCache->new,
177             args => { },
178             consumer_secret => 'secret',
179             required_root => $baseurl
180             );
181              
182             my $claimed = $csr->claimed_identity( $openid );
183              
184             if ( not defined $claimed ) {
185             return ( 1, $csr->err );
186             }
187              
188             $openid = $claimed->claimed_url;
189              
190             my $check_url = $claimed->check_url(
191             return_to => "$baseurl/return",
192             trust_root => $baseurl,
193             delayed_return => 0
194             );
195              
196             my $res = $self->ua->get( $check_url );
197              
198             if ( not $res->is_success ) {
199             return ( 2, $res );
200             }
201             else {
202             return ( 0, undef );
203             }
204             }
205              
206             =head1 INTERAL METHODS
207              
208             These methods implement the HTTP server (see L)
209             that the consumer uses. You shouldn't call them.
210              
211             =head2 handle_request
212              
213             =cut
214              
215             sub handle_request {
216             my $self = shift;
217             my $cgi = shift;
218              
219             if ( $ENV{'PATH_INFO'} eq '/return' ) {
220             # We're dealing with the return path
221            
222             my $csr = Net::OpenID::Consumer->new(
223             ua => $self->ua,
224             cache => Cache::FileCache->new,
225             args => $cgi,
226             consumer_secret => 'secret'
227             );
228              
229             if ( my $setup = $csr->user_setup_url ) {
230             print "HTTP/1.0 412 Setup required\r\n";
231             print "Content-Type: text/plain\r\n\r\n";
232             print "verification required setup: $setup\n";
233             return;
234             }
235             elsif ( $csr->user_cancel ) {
236             print "HTTP/1.0 401 Canceled\r\n";
237             print "Content-Type: text/plain\r\n\r\n";
238             print "verification canceled\n";
239             return;
240             }
241              
242             my $ident = $csr->verified_identity;
243              
244             if ( not defined $ident ) {
245             print "HTTP/1.0 401 Failed authentication\r\n";
246             print "Content-Type: text/plain\r\n\r\n";
247             print $csr->err, "\n";
248             }
249             else {
250             print "HTTP/1.0 200 OK\r\n";
251             print "Content-Type: text/plain\r\n\r\n";
252             print "verification succeeded\n";
253             }
254             }
255             else {
256             print "HTTP/1.0 200 OK\r\n";
257             print "Content-Type: text/html\r\n\r\n";
258             print <<" END";
259            
260            
261            

This is an OpenID consumer. It needs an HTTP server for testing.

262            
263            
264             END
265             }
266             }
267              
268             =head1 AUTHORS
269              
270             Thomas Sibley
271              
272             =head1 COPYRIGHT
273              
274             Copyright (c) 2007, Best Practical Solutions, LLC. All rights reserved.
275              
276             =head1 LICENSE
277              
278             You may distribute this module under the same terms as Perl 5.8 itself.
279              
280             =cut
281              
282             1;