← Back to branch summary

~ubuntu-branches/debian/squeeze/sympa/squeeze

« back to all changes in this revision

Viewing changes to src/Fetch.pm

  • Committer: Bazaar Package Importer
  • Author(s): Christian Perrier
  • Date: 2007-01-20 18:09:28 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20070120180928-0e42mbwg87mlo44y
Tags: 5.2.3-1.2
* Non-maintainer upload to re-fix l10n issues
* As debconf-updatepo was not run in previous versions, the French
  translation was outdated. Hence fix it.
* Remove several duplicate spaces in the debconf templates

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/Fetch.pm
 
1
# Fetch.pm - This module includes functions to fetch remote files
 
2
#
 
3
#<!-- RCS Identication ; $Revision: 1.2 $ ; $Date: 2006/04/11 13:58:03 $ -->
 
4
#
 
5
#
 
6
# Sympa - SYsteme de Multi-Postage Automatique
 
7
# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
 
8
# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
 
9
#
 
10
# This program is free software; you can redistribute it and/or modify
 
11
# it under the terms of the GNU General Public License as published by
 
12
# the Free Software Foundation; either version 2 of the License, or
 
13
# (at your option) any later version.
 
14
#
 
15
# This program is distributed in the hope that it will be useful,
 
16
# but WITHOUT ANY WARRANTY; without even the implied warranty of
 
17
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
18
# GNU General Public License for more details.
 
19
#
 
20
# You should have received a copy of the GNU General Public License
 
21
# along with this program; if not, write to the Free Software
 
22
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
23
 
 
24
package WebAgent;
 
25
 
 
26
use LWP::UserAgent;
 
27
## Good documentation : http://articles.mongueurs.net/magazines/linuxmag57.html
 
28
 
 
29
@ISA = qw (LWP::UserAgent);
 
30
 
 
31
my ($web_user, $web_passwd);
 
32
 
 
33
sub get_basic_credentials {
 
34
    my ( $self, $realm, $uri ) = @_;
 
35
 
 
36
    return ( $web_user, $web_passwd );
 
37
}
 
38
 
 
39
sub set_basic_credentials {
 
40
    ($web_user, $web_passwd ) = @_;
 
41
}
 
42
 
 
43
package Fetch;
 
44
 
 
45
require Exporter;
 
46
@ISA = qw(Exporter);
 
47
@EXPORT = qw();
 
48
 
 
49
use Log;
 
50
 
 
51
# request a document using https, return status and content
 
52
sub get_https{
 
53
        my $host = shift;
 
54
        my $port = shift;
 
55
        my $path = shift;
 
56
        my $client_cert = shift;
 
57
        my $client_key = shift;
 
58
        my $ssl_data= shift;
 
59
 
 
60
        my $key_passwd = $ssl_data->{'key_passwd'};
 
61
        my $trusted_ca_file = $ssl_data->{'cafile'};
 
62
        my $trusted_ca_path = $ssl_data->{'capath'};
 
63
 
 
64
        do_log ('debug','get_https (%s,%s,%s,%s,%s,%s,%s,%s)',$host,$port,$path,$client_cert,$client_key,$key_passwd,$trusted_ca_file,$trusted_ca_path );
 
65
 
 
66
        unless ( -r ($trusted_ca_file) ||  (-d $trusted_ca_path )) {
 
67
            do_log ('err',"error : incorrect access to cafile $trusted_ca_file bor capath $trusted_ca_path");
 
68
            return undef;
 
69
        }
 
70
 
 
71
        unless (eval "require IO::Socket::SSL") {
 
72
            do_log('err',"Unable to use SSL library, IO::Socket::SSL required, install IO-Socket-SSL (CPAN) first");
 
73
            return undef;
 
74
        }
 
75
        require IO::Socket::SSL;
 
76
        
 
77
        unless (eval "require LWP::UserAgent") {
 
78
            do_log('err',"Unable to use LWP library, LWP::UserAgent required, install LWP (CPAN) first");
 
79
            return undef;
 
80
        }
 
81
        require LWP::UserAgent;
 
82
 
 
83
        my $ssl_socket;
 
84
 
 
85
        $ssl_socket = new IO::Socket::SSL(SSL_use_cert => 1,
 
86
                                          SSL_verify_mode => 0x01,
 
87
                                          SSL_cert_file => $client_cert,
 
88
                                          SSL_key_file => $client_key,
 
89
                                          SSL_passwd_cb => sub { return ($key_passwd)},
 
90
                                          SSL_ca_file => $trusted_ca_file,
 
91
                                          SSL_ca_path => $trusted_ca_path,
 
92
                                          PeerAddr => $host,
 
93
                                          PeerPort => $port,
 
94
                                          Proto => 'tcp',
 
95
                                          Timeout => '5'
 
96
                                          );
 
97
        
 
98
        unless ($ssl_socket) {
 
99
            do_log ('err','error %s unable to connect https://%s:%s/',&IO::Socket::SSL::errstr,$host,$port);
 
100
            return undef;
 
101
        }
 
102
        do_log ('debug','connected to https://%s:%s/',&IO::Socket::SSL::errstr,$host,$port);
 
103
 
 
104
        if( ref($ssl_socket) eq "IO::Socket::SSL") {
 
105
           my $subject_name = $ssl_socket->peer_certificate("subject");
 
106
           my $issuer_name = $ssl_socket->peer_certificate("issuer");
 
107
           my $cipher = $ssl_socket->get_cipher();
 
108
           do_log ('debug','ssl peer certificat %s issued by %s. Cipher used %s',$subject_name,$issuer_name,$cipher);
 
109
        }
 
110
 
 
111
        print $ssl_socket "GET $path HTTP/1.0\nHost: $host\n\n";
 
112
 
 
113
        do_log ('debug',"requested GET $path HTTP/1.1");
 
114
        #my ($buffer) = $ssl_socket->getlines;
 
115
        # print STDERR $buffer;
 
116
        #do_log ('debug',"return");
 
117
        #return ;
 
118
 
 
119
        do_log ('debug',"get_https reading answer");
 
120
        my @result;
 
121
        while (my $line = $ssl_socket->getline) {
 
122
            push  @result, $line;
 
123
        } 
 
124
        
 
125
        $ssl_socket->close(SSL_no_shutdown => 1);       
 
126
        do_log ('debug',"disconnected");
 
127
 
 
128
        return (@result);       
 
129
}
 
130
 
 
131
 
 
132
# request a document using https, return status and content
 
133
sub get_https2{
 
134
        my $host = shift;
 
135
        my $port = shift;
 
136
        my $path = shift;
 
137
 
 
138
        my $ssl_data= shift;
 
139
 
 
140
        my $trusted_ca_file = $ssl_data->{'cafile'};
 
141
        $trusted_ca_file ||= $Conf{'cafile'};
 
142
        my $trusted_ca_path = $ssl_data->{'capath'};
 
143
        $trusted_ca_path ||= $Conf{'capath'};
 
144
 
 
145
        do_log ('debug','Fetch::get_https2 (%s,%s,%s,%s,%s)',$host,$port,$path,$trusted_ca_file,$trusted_ca_path );
 
146
 
 
147
        unless ( -r ($trusted_ca_file) ||  (-d $trusted_ca_path )) {
 
148
            do_log ('err',"error : incorrect access to cafile $trusted_ca_file bor capath $trusted_ca_path");
 
149
            return undef;
 
150
        }
 
151
 
 
152
        unless (eval "require IO::Socket::SSL") {
 
153
            do_log('err',"Unable to use SSL library, IO::Socket::SSL required, install IO-Socket-SSL (CPAN) first");
 
154
            return undef;
 
155
        }
 
156
        require IO::Socket::SSL;
 
157
        
 
158
        unless (eval "require LWP::UserAgent") {
 
159
            do_log('err',"Unable to use LWP library, LWP::UserAgent required, install LWP (CPAN) first");
 
160
            return undef;
 
161
        }
 
162
        require LWP::UserAgent;
 
163
 
 
164
        my $ssl_socket;
 
165
 
 
166
        $ssl_socket = new IO::Socket::SSL(SSL_use_cert => 0,
 
167
                                          SSL_verify_mode => 0x01,
 
168
                                          SSL_ca_file => $trusted_ca_file,
 
169
                                          SSL_ca_path => $trusted_ca_path,
 
170
                                          PeerAddr => $host,
 
171
                                          PeerPort => $port,
 
172
                                          Proto => 'tcp',
 
173
                                          Timeout => '5'
 
174
                                          );
 
175
        
 
176
        unless ($ssl_socket) {
 
177
            do_log ('err','error %s unable to connect https://%s:%s/',&IO::Socket::SSL::errstr,$host,$port);
 
178
            return undef;
 
179
        }
 
180
        do_log ('debug',"connected to https://$host:$port/");
 
181
 
 
182
#       if( ref($ssl_socket) eq "IO::Socket::SSL") {
 
183
#          my $subject_name = $ssl_socket->peer_certificate("subject");
 
184
#          my $issuer_name = $ssl_socket->peer_certificate("issuer");
 
185
#          my $cipher = $ssl_socket->get_cipher();
 
186
#          do_log ('debug','ssl peer certificat %s issued by %s. Cipher used %s',$subject_name,$issuer_name,$cipher);
 
187
#       }
 
188
 
 
189
        my $request = "GET $path HTTP/1.0\nHost: $host\n\n";
 
190
        print $ssl_socket "$request\n\n";
 
191
 
 
192
        do_log ('debug',"requesting  $request");
 
193
        #my ($buffer) = $ssl_socket->getlines;
 
194
        # print STDERR $buffer;
 
195
        #do_log ('debug',"return");
 
196
        #return ;
 
197
 
 
198
        do_log ('debug',"get_https reading answer returns :");
 
199
        my @result;
 
200
        while (my $line = $ssl_socket->getline) {
 
201
            do_log ('debug',"$line");
 
202
            push  @result, $line;
 
203
        } 
 
204
        
 
205
        $ssl_socket->close(SSL_no_shutdown => 1);       
 
206
        do_log ('debug',"disconnected");
 
207
 
 
208
        return (@result);       
 
209
}
 
210
 
 
211
 
 
212
 
 
213
#################################################################
 
214
 
 
215
## Packages must return true.
 
216
1;