line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
package AuthCAS; |
3
|
|
|
|
|
|
|
|
4
|
2
|
|
|
2
|
|
27951
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
54
|
|
5
|
2
|
|
|
2
|
|
7
|
use vars qw( $VERSION); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
149
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
$VERSION = '1.7'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=encoding utf8 |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=head1 NAME |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
AuthCAS - Client library for JA-SIG CAS 2.0 authentication server |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 VERSION |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
Version 1.7 |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 DESCRIPTION |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
AuthCAS aims at providing a Perl API to JA-SIG Central Authentication System (CAS). |
22
|
|
|
|
|
|
|
Only a basic Perl library is provided with CAS whereas AuthCAS is a full object-oriented library. |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 PREREQUISITES |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
This script requires IO::Socket::SSL and LWP::UserAgent |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 SYNOPSIS |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
A simple example with a direct CAS authentication |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
use AuthCAS; |
33
|
|
|
|
|
|
|
my $cas = new AuthCAS(casUrl => 'https://cas.myserver, |
34
|
|
|
|
|
|
|
CAFile => '/etc/httpd/conf/ssl.crt/ca-bundle.crt', |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $login_url = $cas->getServerLoginURL('http://myserver/app.cgi'); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
## The user should be redirected to the $login_url |
40
|
|
|
|
|
|
|
## When coming back from the CAS server a ticket is provided in the QUERY_STRING |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
## $ST should contain the receaved Service Ticket |
43
|
|
|
|
|
|
|
my $user = $cas->validateST('http://myserver/app.cgi', $ST); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
printf "User authenticated as %s\n", $user; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
In the following example a proxy is requesting a Proxy Ticket for the target application |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
$cas->proxyMode(pgtFile => '/tmp/pgt.txt', |
51
|
|
|
|
|
|
|
pgtCallbackUrl => 'https://myserver/proxy.cgi?callback=1 |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
## Same as before but the URL is the proxy URL |
55
|
|
|
|
|
|
|
my $login_url = $cas->getServerLoginURL('http://myserver/proxy.cgi'); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
## Like in the previous example we should receave a $ST |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
my $user = $cas->validateST('http://myserver/proxy.cgi', $ST); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
## Process errors |
62
|
|
|
|
|
|
|
printf STDERR "Error: %s\n", &AuthCAS::get_errors() unless (defined $user); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
## Now we request a Proxy Ticket for the target application |
65
|
|
|
|
|
|
|
my $PT = $cas->retrievePT('http://myserver/app.cgi'); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
## This piece of code is executed by the target application |
68
|
|
|
|
|
|
|
## It received a Proxy Ticket from the proxy |
69
|
|
|
|
|
|
|
my ($user, @proxies) = $cas->validatePT('http://myserver/app.cgi', $PT); |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
printf "User authenticated as %s via %s proxies\n", $user, join(',',@proxies); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=head1 DESCRIPTION |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
Jasig CAS is Yale University's web authentication system, heavily inspired by Kerberos. |
77
|
|
|
|
|
|
|
Release 2.0 of CAS provides "proxied credential" feature that allows authentication |
78
|
|
|
|
|
|
|
tickets to be carried by intermediate applications (Portals for instance), they are |
79
|
|
|
|
|
|
|
called proxy. |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
This AuthCAS Perl module provides required subroutines to validate and retrieve CAS tickets. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=cut |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
my @ISA = qw(Exporter); |
86
|
|
|
|
|
|
|
my @EXPORT = qw($errors); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my $errors; |
89
|
|
|
|
|
|
|
|
90
|
2
|
|
|
2
|
|
10
|
use Carp; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
3809
|
|
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=pod |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 new |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
my $cas = new AuthCAS( |
97
|
|
|
|
|
|
|
casUrl => 'https://cas.myserver', |
98
|
|
|
|
|
|
|
CAFile => '/etc/httpd/conf/ssl.crt/ca-bundle.crt', |
99
|
|
|
|
|
|
|
); |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
The C constructor lets you create a new B object. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=over |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=item casUrl - REQUIRED |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=item CAFile |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=item CAPath |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=item loginPath - '/login' |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=item logoutPath - '/logout' |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=item serviceValidatePath - '/serviceValidate' |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=item proxyPath - '/proxy' |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=item proxyValidatePath - '/proxyValidate' |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=item SSL_version - unset |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Sets the version of the SSL protocol used to transmit data. If the default causes connection issues, setting it to 'SSLv3' may help. |
124
|
|
|
|
|
|
|
see the documentation for L for more information |
125
|
|
|
|
|
|
|
see L for more details. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=back |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Returns a new B or dies on error. |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=cut |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub new { |
134
|
2
|
|
|
2
|
1
|
629
|
my ( $pkg, %param ) = @_; |
135
|
|
|
|
|
|
|
my $cas_server = { |
136
|
|
|
|
|
|
|
url => $param{'casUrl'}, |
137
|
|
|
|
|
|
|
CAFile => $param{'CAFile'}, |
138
|
|
|
|
|
|
|
CAPath => $param{'CAPath'}, |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
loginPath => $param{'loginPath'} || '/login', |
141
|
|
|
|
|
|
|
logoutPath => $param{'logoutPath'} || '/logout', |
142
|
|
|
|
|
|
|
serviceValidatePath => $param{'serviceValidatePath'} |
143
|
|
|
|
|
|
|
|| '/serviceValidate', |
144
|
|
|
|
|
|
|
proxyPath => $param{'proxyPath'} || '/proxy', |
145
|
|
|
|
|
|
|
proxyValidatePath => $param{'proxyValidatePath'} || '/proxyValidate', |
146
|
|
|
|
|
|
|
SSL_version => $param{SSL_version}, |
147
|
2
|
|
50
|
|
|
36
|
}; |
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
148
|
|
|
|
|
|
|
|
149
|
2
|
|
|
|
|
3
|
bless $cas_server, $pkg; |
150
|
|
|
|
|
|
|
|
151
|
2
|
|
|
|
|
5
|
return $cas_server; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=pod |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=head2 get_errors |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
Return module errors |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=cut |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub get_errors { |
163
|
0
|
|
|
0
|
1
|
0
|
return $errors; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=pod |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=head2 proxyMode |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
Use the CAS object as a proxy |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=over |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=item pgtFile |
176
|
|
|
|
|
|
|
=item pgtCallbackUrl |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=back |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=cut |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub proxyMode { |
184
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
185
|
0
|
|
|
|
|
0
|
my %param = @_; |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
|
|
0
|
$self->{'pgtFile'} = $param{'pgtFile'}; |
188
|
0
|
|
|
|
|
0
|
$self->{'pgtCallbackUrl'} = $param{'pgtCallbackUrl'}; |
189
|
0
|
|
|
|
|
0
|
$self->{'proxy'} = 1; |
190
|
|
|
|
|
|
|
|
191
|
0
|
|
|
|
|
0
|
return 1; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
## Escape dangerous chars in URLS |
195
|
|
|
|
|
|
|
sub _escape_chars { |
196
|
5
|
|
|
5
|
|
4
|
my $s = shift; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
## Escape chars |
199
|
|
|
|
|
|
|
## !"#$%&'()+,:;<=>?[] AND accented chars |
200
|
|
|
|
|
|
|
## escape % first |
201
|
|
|
|
|
|
|
# foreach my $i (0x25,0x20..0x24,0x26..0x2c,0x3a..0x3f,0x5b,0x5d,0x80..0x9f,0xa0..0xff) { |
202
|
5
|
|
|
|
|
8
|
foreach my $i (0x26) { |
203
|
5
|
|
|
|
|
13
|
my $hex_i = sprintf "%lx", $i; |
204
|
5
|
|
|
|
|
27
|
$s =~ s/\x$hex_i/%$hex_i/g; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
5
|
|
|
|
|
12
|
return $s; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=pod |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head2 dump_var |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=cut |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub dump_var { |
218
|
0
|
|
|
0
|
1
|
0
|
my ( $var, $level, $fd ) = @_; |
219
|
|
|
|
|
|
|
|
220
|
0
|
0
|
|
|
|
0
|
if ( ref($var) ) { |
221
|
0
|
0
|
|
|
|
0
|
if ( ref($var) eq 'ARRAY' ) { |
|
|
0
|
|
|
|
|
|
222
|
0
|
|
|
|
|
0
|
foreach my $index ( 0 .. $#{$var} ) { |
|
0
|
|
|
|
|
0
|
|
223
|
0
|
|
|
|
|
0
|
print $fd "\t" x $level . $index . "\n"; |
224
|
0
|
|
|
|
|
0
|
&dump_var( $var->[$index], $level + 1, $fd ); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
elsif ( ref($var) eq 'HASH' ) { |
228
|
0
|
|
|
|
|
0
|
foreach my $key ( sort keys %{$var} ) { |
|
0
|
|
|
|
|
0
|
|
229
|
0
|
|
|
|
|
0
|
print $fd "\t" x $level . '_' . $key . '_' . "\n"; |
230
|
0
|
|
|
|
|
0
|
&dump_var( $var->{$key}, $level + 1, $fd ); |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
else { |
235
|
0
|
0
|
|
|
|
0
|
if ( defined $var ) { |
236
|
0
|
|
|
|
|
0
|
print $fd "\t" x $level . "'$var'" . "\n"; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
else { |
239
|
0
|
|
|
|
|
0
|
print $fd "\t" x $level . "UNDEF\n"; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
## Parse an HTTP URL |
245
|
|
|
|
|
|
|
sub _parse_url { |
246
|
3
|
|
|
3
|
|
3
|
my $url = shift; |
247
|
|
|
|
|
|
|
|
248
|
3
|
|
|
|
|
5
|
my ( $host, $port, $path ); |
249
|
|
|
|
|
|
|
|
250
|
3
|
50
|
|
|
|
18
|
if ( $url =~ /^(https?):\/\/([^:\/]+)(:(\d+))?(.*)$/ ) { |
251
|
3
|
|
|
|
|
8
|
$host = $2; |
252
|
3
|
|
|
|
|
4
|
$path = $5; |
253
|
3
|
50
|
|
|
|
12
|
if ( $1 eq 'http' ) { |
|
|
50
|
|
|
|
|
|
254
|
0
|
|
0
|
|
|
0
|
$port = $4 || 80; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
elsif ( $1 eq 'https' ) { |
257
|
3
|
|
100
|
|
|
13
|
$port = $4 || 443; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
else { |
260
|
0
|
|
|
|
|
0
|
$errors = sprintf "Unknown protocol '%s'\n", $1; |
261
|
0
|
|
|
|
|
0
|
return undef; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
else { |
265
|
0
|
|
|
|
|
0
|
$errors = sprintf "Unable to parse URL '%s'\n", $url; |
266
|
0
|
|
|
|
|
0
|
return undef; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
3
|
|
|
|
|
8
|
return ( $host, $port, $path ); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
## Simple XML parser |
273
|
|
|
|
|
|
|
sub _parse_xml { |
274
|
0
|
|
|
0
|
|
0
|
my $data = shift; |
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
0
|
my %xml_struct; |
277
|
|
|
|
|
|
|
|
278
|
0
|
|
|
|
|
0
|
while ( $data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) { |
279
|
0
|
|
|
|
|
0
|
my ( $new_tag, $new_data ) = ( $1, $3 ); |
280
|
0
|
|
|
|
|
0
|
chomp $new_data; |
281
|
0
|
|
|
|
|
0
|
$new_data =~ s/^[\s\n]+//m; |
282
|
0
|
|
|
|
|
0
|
$data =~ s/^<$new_tag(\s+[^\s>]+)*>([\s\S\n]*)(<\/$new_tag>)//m; |
283
|
0
|
|
|
|
|
0
|
$data =~ s/^[\s\n]+//m; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
## Check if data still includes XML tags |
286
|
0
|
|
|
|
|
0
|
my $struct; |
287
|
0
|
0
|
|
|
|
0
|
if ( $new_data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) { |
288
|
0
|
|
|
|
|
0
|
$struct = &_parse_xml($new_data); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
else { |
291
|
0
|
|
|
|
|
0
|
$struct = $new_data; |
292
|
|
|
|
|
|
|
} |
293
|
0
|
|
|
|
|
0
|
push @{ $xml_struct{$new_tag} }, $struct; |
|
0
|
|
|
|
|
0
|
|
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
0
|
|
|
|
|
0
|
return \%xml_struct; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=pod |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=head2 getServerLoginURL($service) |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
Returns a URL that you can redirect the browser to, which includes the URL to return to |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
TODO: it escapes the return URL, but I've noticed some issues with more complicated URL's |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
=cut |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
sub getServerLoginURL { |
310
|
2
|
|
|
2
|
1
|
9
|
my $self = shift; |
311
|
2
|
|
|
|
|
3
|
my $service = shift; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
return |
314
|
|
|
|
|
|
|
$self->{'url'} |
315
|
2
|
|
|
|
|
9
|
. $self->{'loginPath'} |
316
|
|
|
|
|
|
|
. '?service=' |
317
|
|
|
|
|
|
|
. &_escape_chars($service); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
=pod |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
=head2 getServerLoginGatewayURL($service) |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
Returns non-blocking login URL |
325
|
|
|
|
|
|
|
ie: if user is logged in, return the ticket, otherwise do not prompt for login |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
=cut |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
sub getServerLoginGatewayURL { |
330
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
331
|
0
|
|
|
|
|
0
|
my $service = shift; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
return |
334
|
|
|
|
|
|
|
$self->{'url'} |
335
|
0
|
|
|
|
|
0
|
. $self->{'loginPath'} |
336
|
|
|
|
|
|
|
. '?service=' |
337
|
|
|
|
|
|
|
. &_escape_chars($service) |
338
|
|
|
|
|
|
|
. '&gateway=1'; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=pod |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=head2 getServerLogoutURL($service) |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
Return logout URL |
346
|
|
|
|
|
|
|
After logout user is redirected back to the application |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
=cut |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
sub getServerLogoutURL { |
351
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
352
|
0
|
|
|
|
|
0
|
my $service = shift; |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
return |
355
|
|
|
|
|
|
|
$self->{'url'} |
356
|
0
|
|
|
|
|
0
|
. $self->{'logoutPath'} |
357
|
|
|
|
|
|
|
. '?service=' |
358
|
|
|
|
|
|
|
. &_escape_chars($service) |
359
|
|
|
|
|
|
|
. '&gateway=1'; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
=pod |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=head2 getServerServiceValidateURL($service, $ticket, $pgtUrl) |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
Returns |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
=cut |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub getServerServiceValidateURL { |
371
|
3
|
|
|
3
|
1
|
3
|
my $self = shift; |
372
|
3
|
|
|
|
|
3
|
my $service = shift; |
373
|
3
|
|
|
|
|
4
|
my $ticket = shift; |
374
|
3
|
|
|
|
|
2
|
my $pgtUrl = shift; |
375
|
|
|
|
|
|
|
|
376
|
3
|
|
|
|
|
7
|
my $query_string = |
377
|
|
|
|
|
|
|
'service=' . &_escape_chars($service) . '&ticket=' . $ticket; |
378
|
3
|
50
|
|
|
|
13
|
if ( defined $pgtUrl ) { |
379
|
0
|
|
|
|
|
0
|
$query_string .= '&pgtUrl=' . &_escape_chars($pgtUrl); |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
## URL was /validate with CAS 1.0 |
383
|
|
|
|
|
|
|
return |
384
|
|
|
|
|
|
|
$self->{'url'} |
385
|
3
|
|
|
|
|
14
|
. $self->{'serviceValidatePath'} . '?' |
386
|
|
|
|
|
|
|
. $query_string; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
=pod |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=head2 getServerProxyURL($targetService, $pgt) |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
Returns |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
=cut |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub getServerProxyURL { |
398
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
399
|
0
|
|
|
|
|
0
|
my $targetService = shift; |
400
|
0
|
|
|
|
|
0
|
my $pgt = shift; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
return |
403
|
|
|
|
|
|
|
$self->{'url'} |
404
|
0
|
|
|
|
|
0
|
. $self->{'proxyPath'} |
405
|
|
|
|
|
|
|
. '?targetService=' |
406
|
|
|
|
|
|
|
. &_escape_chars($targetService) . '&pgt=' |
407
|
|
|
|
|
|
|
. &_escape_chars($pgt); |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=pod |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=head2 getServerProxyValidateURL($service, $ticket) |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
Returns |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=cut |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub getServerProxyValidateURL { |
419
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
420
|
0
|
|
|
|
|
0
|
my $service = shift; |
421
|
0
|
|
|
|
|
0
|
my $ticket = shift; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
return |
424
|
|
|
|
|
|
|
$self->{'url'} |
425
|
0
|
|
|
|
|
0
|
. $self->{'proxyValidatePath'} |
426
|
|
|
|
|
|
|
. '?service=' |
427
|
|
|
|
|
|
|
. &_escape_chars($service) |
428
|
|
|
|
|
|
|
. '&ticket=' |
429
|
|
|
|
|
|
|
. &_escape_chars($ticket); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
=pod |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
=head2 validateST($service, $ticket) |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
Validate a Service Ticket |
438
|
|
|
|
|
|
|
Also used to get a PGT |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
Returns the login that created the ticket, if the ticket is valid for that $service URL |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
returns undef if the ticket is not valid. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=cut |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub validateST { |
448
|
5
|
|
|
5
|
1
|
14
|
my $self = shift; |
449
|
5
|
|
|
|
|
3
|
my $service = shift; |
450
|
5
|
|
|
|
|
7
|
my $ticket = shift; |
451
|
|
|
|
|
|
|
|
452
|
5
|
100
|
|
|
|
11
|
if (!defined($service)) { |
453
|
1
|
|
|
|
|
3
|
$errors = 'Need a service url to validate ticket.'; |
454
|
1
|
|
|
|
|
6
|
return undef; |
455
|
|
|
|
|
|
|
} |
456
|
4
|
100
|
|
|
|
10
|
if (!defined($ticket)) { |
457
|
1
|
|
|
|
|
2
|
$errors = 'No ticket to validate.'; |
458
|
1
|
|
|
|
|
4
|
return undef; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
3
|
|
|
|
|
4
|
my $pgtUrl = $self->{'pgtCallbackUrl'}; |
462
|
|
|
|
|
|
|
|
463
|
3
|
|
|
|
|
8
|
my $xml = |
464
|
|
|
|
|
|
|
$self->callCAS( |
465
|
|
|
|
|
|
|
$self->getServerServiceValidateURL( $service, $ticket, $pgtUrl ) ); |
466
|
|
|
|
|
|
|
|
467
|
3
|
50
|
|
|
|
19
|
if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'} ) |
468
|
|
|
|
|
|
|
{ |
469
|
|
|
|
|
|
|
$errors = sprintf "Failed to validate Service Ticket %s : %s\n", |
470
|
|
|
|
|
|
|
$ticket, |
471
|
0
|
|
|
|
|
0
|
$xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'}[0]; |
472
|
0
|
|
|
|
|
0
|
return undef; |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
my $user = |
476
|
|
|
|
|
|
|
$xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0] |
477
|
3
|
|
|
|
|
12
|
{'cas:user'}[0]; |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
## If in Proxy mode, also retreave a PGT |
480
|
3
|
50
|
|
|
|
10
|
if ( $self->{'proxy'} ) { |
481
|
0
|
|
|
|
|
0
|
my $pgtIou; |
482
|
0
|
0
|
|
|
|
0
|
if ( |
483
|
|
|
|
|
|
|
defined $xml->{'cas:serviceResponse'}[0] |
484
|
|
|
|
|
|
|
{'cas:authenticationSuccess'}[0]{'cas:proxyGrantingTicket'} ) |
485
|
|
|
|
|
|
|
{ |
486
|
|
|
|
|
|
|
$pgtIou = |
487
|
|
|
|
|
|
|
$xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0] |
488
|
0
|
|
|
|
|
0
|
{'cas:proxyGrantingTicket'}[0]; |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
0
|
0
|
|
|
|
0
|
unless ( defined $self->{'pgtFile'} ) { |
492
|
0
|
|
|
|
|
0
|
$errors = sprintf "pgtFile not defined\n"; |
493
|
0
|
|
|
|
|
0
|
return undef; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
## Check stored PGT |
497
|
0
|
0
|
|
|
|
0
|
unless ( open STORE, $self->{'pgtFile'} ) { |
498
|
0
|
|
|
|
|
0
|
$errors = sprintf "Unable to read %s\n", $self->{'pgtFile'}; |
499
|
0
|
|
|
|
|
0
|
return undef; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
0
|
|
|
|
|
0
|
my $pgtId; |
503
|
0
|
|
|
|
|
0
|
while () { |
504
|
0
|
0
|
|
|
|
0
|
if (/^$pgtIou\s+(.+)$/) { |
505
|
0
|
|
|
|
|
0
|
$pgtId = $1; |
506
|
0
|
|
|
|
|
0
|
last; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
0
|
|
|
|
|
0
|
$self->{'pgtId'} = $pgtId; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
3
|
|
|
|
|
39
|
return ($user); |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
=pod |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=head2 validatePT($service, $ticket) |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
Validate a Proxy Ticket |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
Returns the login that created the ticket, if the ticket is valid for that $service URL, |
523
|
|
|
|
|
|
|
and a list of Proxies used. |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
user returned == undef if its not a valid ticket |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=cut |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
sub validatePT { |
530
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
531
|
0
|
|
|
|
|
0
|
my $service = shift; |
532
|
0
|
|
|
|
|
0
|
my $ticket = shift; |
533
|
|
|
|
|
|
|
|
534
|
0
|
0
|
|
|
|
0
|
if (!defined($service)) { |
535
|
0
|
|
|
|
|
0
|
$errors = 'Need a service url to validate ticket.'; |
536
|
0
|
|
|
|
|
0
|
return undef; |
537
|
|
|
|
|
|
|
} |
538
|
0
|
0
|
|
|
|
0
|
if (!defined($ticket)) { |
539
|
0
|
|
|
|
|
0
|
$errors = 'No ticket to validate.'; |
540
|
0
|
|
|
|
|
0
|
return undef; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
0
|
|
|
|
|
0
|
my $xml = |
544
|
|
|
|
|
|
|
$self->callCAS( $self->getServerProxyValidateURL( $service, $ticket ) ); |
545
|
|
|
|
|
|
|
|
546
|
0
|
0
|
|
|
|
0
|
if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'} ) |
547
|
|
|
|
|
|
|
{ |
548
|
|
|
|
|
|
|
$errors = sprintf "Failed to validate Proxy Ticket %s : %s\n", $ticket, |
549
|
0
|
|
|
|
|
0
|
$xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'}[0]; |
550
|
0
|
|
|
|
|
0
|
return undef; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
my $user = |
554
|
|
|
|
|
|
|
$xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0] |
555
|
0
|
|
|
|
|
0
|
{'cas:user'}[0]; |
556
|
|
|
|
|
|
|
|
557
|
0
|
|
|
|
|
0
|
my @proxies; |
558
|
0
|
0
|
|
|
|
0
|
if ( |
559
|
|
|
|
|
|
|
defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0] |
560
|
|
|
|
|
|
|
{'cas:proxies'} ) |
561
|
|
|
|
|
|
|
{ |
562
|
|
|
|
|
|
|
@proxies = |
563
|
0
|
|
|
|
|
0
|
@{ $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0] |
564
|
0
|
|
|
|
|
0
|
{'cas:proxies'}[0]{'cas:proxy'} }; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
0
|
|
|
|
|
0
|
return ( $user, @proxies ); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
=pod |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
=head2 callCAS($url) |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
## Access a CAS URL and parses received XML |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
Returns |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
=cut |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
sub callCAS { |
581
|
3
|
|
|
3
|
1
|
3
|
my $self = shift; |
582
|
3
|
|
|
|
|
3
|
my $url = shift; |
583
|
|
|
|
|
|
|
|
584
|
3
|
|
|
|
|
8
|
my ( $host, $port, $path ) = &_parse_url($url); |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
my $xml = get_https2( |
587
|
|
|
|
|
|
|
$host, $port, $path, |
588
|
|
|
|
|
|
|
{ |
589
|
|
|
|
|
|
|
'cafile' => $self->{'CAFile'}, |
590
|
|
|
|
|
|
|
'capath' => $self->{'CAPath'}, |
591
|
3
|
|
|
|
|
15
|
'SSL_version' => $self->{'SSL_version'} |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
); |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
#use Data::Dumper; die '--'.$#$xml.': '.Dumper($xml); |
596
|
|
|
|
|
|
|
|
597
|
3
|
50
|
33
|
|
|
18
|
unless ($xml && $#$xml >= 0) { |
598
|
3
|
|
|
|
|
339
|
warn $errors; |
599
|
3
|
|
|
|
|
16
|
return undef; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
## Skip HTTP header fields |
603
|
0
|
|
|
|
|
0
|
my $line = shift @$xml; |
604
|
0
|
|
|
|
|
0
|
while ( $line !~ /^\s*$/ ) { |
605
|
0
|
|
|
|
|
0
|
$line = shift @$xml; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
return &_parse_xml( join( '', @$xml ) ); |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=pod |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
=head2 storePGT($pgtIou, $pgtId) |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
=cut |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
sub storePGT { |
618
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
619
|
0
|
|
|
|
|
0
|
my $pgtIou = shift; |
620
|
0
|
|
|
|
|
0
|
my $pgtId = shift; |
621
|
|
|
|
|
|
|
|
622
|
0
|
0
|
|
|
|
0
|
unless ( open STORE, ">>$self->{'pgtFile'}" ) { |
623
|
0
|
|
|
|
|
0
|
$errors = sprintf "Unable to write to %s\n", $self->{'pgtFile'}; |
624
|
0
|
|
|
|
|
0
|
return undef; |
625
|
|
|
|
|
|
|
} |
626
|
0
|
|
|
|
|
0
|
printf STORE "%s\t%s\n", $pgtIou, $pgtId; |
627
|
0
|
|
|
|
|
0
|
close STORE; |
628
|
|
|
|
|
|
|
|
629
|
0
|
|
|
|
|
0
|
return 1; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
=pod |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
=head2 retrievePT($service) |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
Returns |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
=cut |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
sub retrievePT { |
641
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
642
|
0
|
|
|
|
|
0
|
my $service = shift; |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
my $xml = |
645
|
0
|
|
|
|
|
0
|
$self->callCAS( $self->getServerProxyURL( $service, $self->{'pgtId'} ) ); |
646
|
|
|
|
|
|
|
|
647
|
0
|
0
|
|
|
|
0
|
if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:proxyFailure'} ) { |
648
|
|
|
|
|
|
|
$errors = sprintf "Failed to get PT : %s\n", |
649
|
0
|
|
|
|
|
0
|
$xml->{'cas:serviceResponse'}[0]{'cas:proxyFailure'}[0]; |
650
|
0
|
|
|
|
|
0
|
return undef; |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
0
|
0
|
|
|
|
0
|
if ( |
654
|
|
|
|
|
|
|
defined $xml->{'cas:serviceResponse'}[0]{'cas:proxySuccess'}[0] |
655
|
|
|
|
|
|
|
{'cas:proxyTicket'} ) |
656
|
|
|
|
|
|
|
{ |
657
|
|
|
|
|
|
|
return $xml->{'cas:serviceResponse'}[0]{'cas:proxySuccess'}[0] |
658
|
0
|
|
|
|
|
0
|
{'cas:proxyTicket'}[0]; |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
0
|
|
|
|
|
0
|
return undef; |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
=pod |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
=head2 get_https2 |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
request a document using https, return status and content |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
Sven suspects this is intended to be private. |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
Returns |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
=cut |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
sub get_https2 { |
677
|
3
|
|
|
3
|
1
|
4
|
my $host = shift; |
678
|
3
|
|
|
|
|
3
|
my $port = shift; |
679
|
3
|
|
|
|
|
4
|
my $path = shift; |
680
|
|
|
|
|
|
|
|
681
|
3
|
|
|
|
|
2
|
my $ssl_data = shift; |
682
|
|
|
|
|
|
|
|
683
|
3
|
|
|
|
|
5
|
my $trusted_ca_file = $ssl_data->{'cafile'}; |
684
|
3
|
|
|
|
|
4
|
my $trusted_ca_path = $ssl_data->{'capath'}; |
685
|
|
|
|
|
|
|
|
686
|
3
|
100
|
66
|
|
|
150
|
if ( ( $trusted_ca_file && !( -r $trusted_ca_file ) ) |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
687
|
|
|
|
|
|
|
|| ( $trusted_ca_path && !( -d $trusted_ca_path ) ) ) |
688
|
|
|
|
|
|
|
{ |
689
|
1
|
|
50
|
|
|
9
|
$errors = sprintf |
|
|
|
50
|
|
|
|
|
690
|
|
|
|
|
|
|
"error : incorrect access to cafile ".($trusted_ca_file||'')." or capath ".($trusted_ca_path||'')."\n"; |
691
|
1
|
|
|
|
|
3
|
return undef; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
2
|
50
|
|
|
|
155
|
unless ( eval "require IO::Socket::SSL" ) { |
695
|
0
|
|
|
|
|
0
|
$errors = sprintf |
696
|
|
|
|
|
|
|
"Unable to use SSL library, IO::Socket::SSL required, install IO-Socket-SSL (CPAN) first\n"; |
697
|
0
|
|
|
|
|
0
|
return undef; |
698
|
|
|
|
|
|
|
} |
699
|
2
|
|
|
|
|
64667
|
require IO::Socket::SSL; |
700
|
|
|
|
|
|
|
|
701
|
2
|
50
|
|
|
|
74
|
unless ( eval "require LWP::UserAgent" ) { |
702
|
0
|
|
|
|
|
0
|
$errors = sprintf |
703
|
|
|
|
|
|
|
"Unable to use LWP library, LWP::UserAgent required, install LWP (CPAN) first\n"; |
704
|
0
|
|
|
|
|
0
|
return undef; |
705
|
|
|
|
|
|
|
} |
706
|
2
|
|
|
|
|
29067
|
require LWP::UserAgent; |
707
|
|
|
|
|
|
|
|
708
|
2
|
|
|
|
|
3
|
my $ssl_socket; |
709
|
|
|
|
|
|
|
|
710
|
2
|
|
|
|
|
16
|
my %ssl_options = ( |
711
|
|
|
|
|
|
|
SSL_use_cert => 0, |
712
|
|
|
|
|
|
|
PeerAddr => $host, |
713
|
|
|
|
|
|
|
PeerPort => $port, |
714
|
|
|
|
|
|
|
Proto => 'tcp', |
715
|
|
|
|
|
|
|
Timeout => '5' |
716
|
|
|
|
|
|
|
); |
717
|
|
|
|
|
|
|
|
718
|
2
|
50
|
|
|
|
6
|
$ssl_options{'SSL_ca_file'} = $trusted_ca_file if ($trusted_ca_file); |
719
|
2
|
50
|
|
|
|
7
|
$ssl_options{'SSL_ca_path'} = $trusted_ca_path if ($trusted_ca_path); |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
## If SSL_ca_file or SSL_ca_path => verify peer certificate |
722
|
2
|
50
|
33
|
|
|
14
|
$ssl_options{'SSL_verify_mode'} = 0x01 |
723
|
|
|
|
|
|
|
if ( $trusted_ca_file || $trusted_ca_path ); |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
$ssl_options{'SSL_version'} = $ssl_data->{'SSL_version'} |
726
|
2
|
50
|
|
|
|
10
|
if defined( $ssl_data->{'SSL_version'} ); |
727
|
|
|
|
|
|
|
|
728
|
2
|
|
|
|
|
28
|
$ssl_socket = new IO::Socket::SSL(%ssl_options); |
729
|
|
|
|
|
|
|
|
730
|
2
|
50
|
|
|
|
17922
|
unless ($ssl_socket) { |
731
|
2
|
|
|
|
|
13
|
$errors = sprintf "error %s unable to connect https://%s:%s/\n", |
732
|
|
|
|
|
|
|
&IO::Socket::SSL::errstr, $host, $port; |
733
|
2
|
|
|
|
|
43
|
return undef; |
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
|
736
|
0
|
|
|
|
|
|
my $request = "GET $path HTTP/1.0\r\nHost: $host\r\n\r\n"; |
737
|
0
|
|
|
|
|
|
print $ssl_socket "$request"; |
738
|
|
|
|
|
|
|
|
739
|
0
|
|
|
|
|
|
my @result; |
740
|
0
|
|
|
|
|
|
while ( my $line = $ssl_socket->getline ) { |
741
|
0
|
|
|
|
|
|
push @result, $line; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
0
|
|
|
|
|
|
$ssl_socket->close( SSL_no_shutdown => 1 ); |
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
|
|
|
return \@result; |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
=pod |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
=head1 SEE ALSO |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
JA-SIG Central Authentication Service L |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
was Yale Central Authentication Service L |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
phpCAS L |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
=head1 COPYRIGHT |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
Copyright (C) 2003, 2005,2006,2007,2009 Olivier Salaun - Comité Réseau des Universités L |
762
|
|
|
|
|
|
|
2012 Sven Dowideit - L |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
766
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
=head1 AUTHORS |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
Olivier Salaun |
771
|
|
|
|
|
|
|
Sven Dowideit |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
=cut |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
1; |
776
|
|
|
|
|
|
|
|