← Back to branch summary

~kosova/+junk/tuxfamily-twiki

« back to all changes in this revision

Viewing changes to foswiki/lib/Foswiki/Net.pm

  • Committer: James Michael DuPont
  • Date: 2009-07-18 19:58:49 UTC
  • Revision ID: jamesmikedupont@gmail.com-20090718195849-vgbmaht2ys791uo2
added foswiki

Show diffs side-by-side

added added

removed removed

Lines of Context:
foswiki/lib/Foswiki/Net.pm
 
1
# See bottom of file for license and copyright information
 
2
 
 
3
=begin TML
 
4
 
 
5
---+ package Foswiki::Net
 
6
 
 
7
Object that brokers access to network resources.
 
8
 
 
9
=cut
 
10
 
 
11
# This module is used by configure, and as such must *not* 'use Foswiki',
 
12
# or any other module that uses it. Always run configure to test after
 
13
# changing the module.
 
14
 
 
15
package Foswiki::Net;
 
16
 
 
17
use strict;
 
18
use Assert;
 
19
use Error qw( :try );
 
20
 
 
21
our $LWPAvailable;
 
22
our $noHTTPResponse; # if set, forces local impl of HTTP::Response
 
23
 
 
24
# note that the session is *optional*
 
25
sub new {
 
26
    my ( $class, $session ) = @_;
 
27
    my $this = bless( { session => $session }, $class );
 
28
 
 
29
    $this->{mailHandler} = undef;
 
30
 
 
31
    return $this;
 
32
}
 
33
 
 
34
=begin TML
 
35
 
 
36
---++ ObjectMethod finish()
 
37
Break circular references.
 
38
 
 
39
=cut
 
40
 
 
41
# Note to developers; please undef *all* fields in the object explicitly,
 
42
# whether they are references or not. That way this method is "golden
 
43
# documentation" of the live fields in the object.
 
44
sub finish {
 
45
    my $this = shift;
 
46
    undef $this->{mailHandler};
 
47
    undef $this->{HELLO_HOST};
 
48
    undef $this->{MAIL_HOST};
 
49
    undef $this->{session};
 
50
}
 
51
 
 
52
=begin TML
 
53
 
 
54
---+++ getExternalResource( $url ) -> $response
 
55
 
 
56
Get whatever is at the other end of a URL (using an HTTP GET request). Will
 
57
only work for encrypted protocols such as =https= if the =LWP= CPAN module is
 
58
installed.
 
59
 
 
60
Note that the =$url= may have an optional user and password, as specified by
 
61
the relevant RFC. Any proxy set in =configure= is honoured.
 
62
 
 
63
The =$response= is an object that is known to implement the following subset of
 
64
the methods of =LWP::Response=. It may in fact be an =LWP::Response= object,
 
65
but it may also not be if =LWP= is not available, so callers may only assume
 
66
the following subset of methods is available:
 
67
| =code()= |
 
68
| =message()= |
 
69
| =header($field)= |
 
70
| =content()= |
 
71
| =is_error()= |
 
72
| =is_redirect()= |
 
73
 
 
74
Note that if LWP is *not* available, this function:
 
75
   1 can only really be trusted for HTTP/1.0 urls. If HTTP/1.1 or another
 
76
     protocol is required, you are *strongly* recommended to =require LWP=.
 
77
   1 Will not parse multipart content
 
78
 
 
79
In the event of the server returning an error, then =is_error()= will return
 
80
true, =code()= will return a valid HTTP status code
 
81
as specified in RFC 2616 and RFC 2518, and =message()= will return the
 
82
message that was received from
 
83
the server. In the event of a client-side error (e.g. an unparseable URL)
 
84
then =is_error()= will return true and =message()= will return an explanatory
 
85
message. =code()= will return 400 (BAD REQUEST).
 
86
 
 
87
Note: Callers can easily check the availability of other HTTP::Response methods
 
88
as follows:
 
89
 
 
90
<verbatim>
 
91
my $response = Foswiki::Func::getExternalResource($url);
 
92
if (!$response->is_error() && $response->isa('HTTP::Response')) {
 
93
    ... other methods of HTTP::Response may be called
 
94
} else {
 
95
    ... only the methods listed above may be called
 
96
}
 
97
</verbatim>
 
98
 
 
99
=cut
 
100
 
 
101
sub getExternalResource {
 
102
    my ( $this, $url ) = @_;
 
103
 
 
104
    my $protocol;
 
105
    if ( $url =~ m!^([a-z]+):! ) {
 
106
        $protocol = $1;
 
107
    }
 
108
    else {
 
109
        require Foswiki::Net::HTTPResponse;
 
110
        return new Foswiki::Net::HTTPResponse("Bad URL: $url");
 
111
    }
 
112
 
 
113
    # Don't remove $LWPAvailable; it is required to disable LWP when unit
 
114
    # testing
 
115
    unless ( defined $LWPAvailable ) {
 
116
        eval 'use LWP';
 
117
        $LWPAvailable = ($@) ? 0 : 1;
 
118
    }
 
119
    if ($LWPAvailable) {
 
120
        return _GETUsingLWP( $this, $url );
 
121
    }
 
122
 
 
123
    # Fallback mechanism
 
124
    if ( $protocol ne 'http' ) {
 
125
        require Foswiki::Net::HTTPResponse;
 
126
        return new Foswiki::Net::HTTPResponse(
 
127
            "LWP not available for handling protocol: $url");
 
128
    }
 
129
 
 
130
    my $response;
 
131
    try {
 
132
        $url =~ s!^\w+://!!;    # remove protocol
 
133
        my ( $user, $pass );
 
134
        if ( $url =~ s!([^/\@:]+)(?::([^/\@:]+))?@!! ) {
 
135
            ( $user, $pass ) = ( $1, $2 || '' );
 
136
        }
 
137
 
 
138
        unless ( $url =~ s!([^:/]+)(?::([0-9]+))?!! ) {
 
139
            die "Bad URL: $url";
 
140
        }
 
141
        my ( $host, $port ) = ( $1, $2 || 80 );
 
142
 
 
143
        require Socket;
 
144
        import Socket qw(:all);
 
145
 
 
146
        $url = '/' unless ($url);
 
147
        my $req = "GET $url HTTP/1.0\r\n";
 
148
 
 
149
        $req .= "Host: $host:$port\r\n";
 
150
        if ($user) {
 
151
 
 
152
            # Use MIME::Base64 at run-time if using outbound proxy with
 
153
            # authentication
 
154
            require MIME::Base64;
 
155
            import MIME::Base64();
 
156
            my $base64 = encode_base64( "$user:$pass", "\r\n" );
 
157
            $req .= "Authorization: Basic $base64";
 
158
        }
 
159
 
 
160
        # SMELL: Reference to Foswiki variables used for compatibility
 
161
        my ( $proxyHost, $proxyPort );
 
162
        if ( $this->{session} && $this->{session}->{prefs} ) {
 
163
            my $prefs = $this->{session}->{prefs};
 
164
            $proxyHost = $prefs->getPreferencesValue('PROXYHOST');
 
165
            $proxyPort = $prefs->getPreferencesValue('PROXYPORT');
 
166
        }
 
167
        $proxyHost ||= $Foswiki::cfg{PROXY}{HOST};
 
168
        $proxyPort ||= $Foswiki::cfg{PROXY}{PORT};
 
169
        if ( $proxyHost && $proxyPort ) {
 
170
            $req  = "GET http://$host:$port$url HTTP/1.0\r\n";
 
171
            $host = $proxyHost;
 
172
            $port = $proxyPort;
 
173
        }
 
174
 
 
175
        '$Rev: 4272 (2009-06-21) $' =~ /([0-9]+)/;
 
176
        my $revstr = $1;
 
177
 
 
178
        $req .= 'User-Agent: Foswiki::Net/' . $revstr . "\r\n";
 
179
        $req .= "\r\n\r\n";
 
180
 
 
181
        my ( $iaddr, $paddr, $proto );
 
182
        $iaddr = inet_aton($host);
 
183
        die "Could not find IP address for $host" unless $iaddr;
 
184
 
 
185
        $paddr = sockaddr_in( $port, $iaddr );
 
186
        $proto = getprotobyname('tcp');
 
187
        unless ( socket( *SOCK, &PF_INET, &SOCK_STREAM, $proto ) ) {
 
188
            die "socket failed: $!";
 
189
        }
 
190
        unless ( connect( *SOCK, $paddr ) ) {
 
191
            die "connect failed: $!";
 
192
        }
 
193
        select SOCK;
 
194
        $| = 1;
 
195
        local $/ = undef;
 
196
        print SOCK $req;
 
197
        my $result = '';
 
198
        $result = <SOCK>;
 
199
        unless ( close(SOCK) ) {
 
200
            die "close faied: $!";
 
201
        }
 
202
        select STDOUT;
 
203
 
 
204
        # No LWP, but may have HTTP::Response which would make life easier
 
205
        # (it has a much more thorough parser)
 
206
        eval 'require HTTP::Response';
 
207
        if ($@ || $noHTTPResponse) {
 
208
 
 
209
            # Nope, no HTTP::Response, have to do things the hard way :-(
 
210
            require Foswiki::Net::HTTPResponse;
 
211
            $response = Foswiki::Net::HTTPResponse->parse($result);
 
212
        }
 
213
        else {
 
214
            $response = HTTP::Response->parse($result);
 
215
        }
 
216
    }
 
217
    catch Error::Simple with {
 
218
        require Foswiki::Net::HTTPResponse;
 
219
        $response = new Foswiki::Net::HTTPResponse(shift);
 
220
    };
 
221
    return $response;
 
222
}
 
223
 
 
224
sub _GETUsingLWP {
 
225
    my ( $this, $url ) = @_;
 
226
 
 
227
    my ( $user, $pass );
 
228
    if ( $url =~ s!([^/\@:]+)(?::([^/\@:]+))?@!! ) {
 
229
        ( $user, $pass ) = ( $1, $2 );
 
230
    }
 
231
    my $request;
 
232
    require HTTP::Request;
 
233
    $request = HTTP::Request->new( GET => $url );
 
234
    '$Rev: 4272 (2009-06-21) $' =~ /([0-9]+)/;
 
235
    my $revstr = $1;
 
236
    $request->header( 'User-Agent' => 'Foswiki::Net/'
 
237
          . $revstr
 
238
          . " libwww-perl/$LWP::VERSION" );
 
239
    require Foswiki::Net::UserCredAgent;
 
240
    my $ua = new Foswiki::Net::UserCredAgent( $user, $pass );
 
241
    my $response = $ua->request($request);
 
242
    return $response;
 
243
}
 
244
 
 
245
# pick a default mail handler
 
246
sub _installMailHandler {
 
247
    my $this    = shift;
 
248
    my $handler = 0;       # Not undef
 
249
    if ( $this->{session} && $this->{session}->{prefs} ) {
 
250
        my $prefs = $this->{session}->{prefs};
 
251
        $this->{MAIL_HOST}  = $prefs->getPreferencesValue('SMTPMAILHOST');
 
252
        $this->{HELLO_HOST} = $prefs->getPreferencesValue('SMTPSENDERHOST');
 
253
    }
 
254
 
 
255
    $this->{MAIL_HOST}  ||= $Foswiki::cfg{SMTP}{MAILHOST};
 
256
    $this->{HELLO_HOST} ||= $Foswiki::cfg{SMTP}{SENDERHOST};
 
257
 
 
258
    if ( $this->{MAIL_HOST} ) {
 
259
 
 
260
        # See Codev.RegisterFailureInsecureDependencyCygwin for why
 
261
        # this must be untainted
 
262
        # SMELL: That topic tells me nothing - AFAICT this untaint is not
 
263
        # required.
 
264
        require Foswiki::Sandbox;
 
265
        $this->{MAIL_HOST} =
 
266
          Foswiki::Sandbox::untaintUnchecked( $this->{MAIL_HOST} );
 
267
        eval {    # May fail if Net::SMTP not installed
 
268
            require Net::SMTP;
 
269
        };
 
270
        if ($@) {
 
271
            $this->{session}->logger->log('warning', "SMTP not available: $@")
 
272
              if ( $this->{session} );
 
273
        }
 
274
        else {
 
275
            $handler = \&_sendEmailByNetSMTP;
 
276
        }
 
277
    }
 
278
 
 
279
    if ( !$handler && $Foswiki::cfg{MailProgram} ) {
 
280
        $handler = \&_sendEmailBySendmail;
 
281
    }
 
282
 
 
283
    $this->setMailHandler($handler) if $handler;
 
284
}
 
285
 
 
286
=begin TML
 
287
 
 
288
---++ setMailHandler( \&fn )
 
289
 
 
290
   * =\&fn= - reference to a function($) (see _sendEmailBySendmail for proto)
 
291
Install a handler function to take over mail sending from the default
 
292
SMTP or sendmail methods. This is provided mainly for tests that
 
293
need to be told when a mail is sent, without actually sending it. It
 
294
may also be useful in the event that someone needs to plug in an
 
295
alternative mail handling method.
 
296
 
 
297
=cut
 
298
 
 
299
sub setMailHandler {
 
300
    my ( $this, $fnref ) = @_;
 
301
    $this->{mailHandler} = $fnref;
 
302
}
 
303
 
 
304
=begin TML
 
305
 
 
306
---++ ObjectMethod sendEmail ( $text, $retries ) -> $error
 
307
 
 
308
   * =$text= - text of the mail, including MIME headers
 
309
   * =$retries= - number of times to retry the send (default 1)
 
310
 
 
311
Send an email specified as MIME format content.
 
312
Date: ...\nFrom: ...\nTo: ...\nCC: ...\nSubject: ...\n\nMailBody...
 
313
 
 
314
=cut
 
315
 
 
316
sub sendEmail {
 
317
    my ( $this, $text, $retries ) = @_;
 
318
    $retries ||= 1;
 
319
 
 
320
    unless ( $Foswiki::cfg{EnableEmail} ) {
 
321
        return 'Trying to send email while email functionality is disabled';
 
322
    }
 
323
 
 
324
    unless ( defined $this->{mailHandler} ) {
 
325
        _installMailHandler($this);
 
326
    }
 
327
 
 
328
    return 'No mail handler available' unless $this->{mailHandler};
 
329
 
 
330
    # Put in a Date header, mainly for Qmail
 
331
    require Foswiki::Time;
 
332
    my $dateStr = Foswiki::Time::formatTime( time, '$email' );
 
333
    $text = "Date: " . $dateStr . "\n" . $text;
 
334
    my $errors   = '';
 
335
    my $back_off = 1;    # seconds, doubles on each retry
 
336
    while ( $retries-- ) {
 
337
        try {
 
338
            &{ $this->{mailHandler} }( $this, $text );
 
339
            $retries = 0;
 
340
        }
 
341
        catch Error::Simple with {
 
342
            my $e = shift->stringify();
 
343
            $this->{session}->logger->log('warning', $e);
 
344
 
 
345
            # be nasty to errors that we didn't throw. They may be
 
346
            # caused by SMTP or perl, and give away info about the
 
347
            # install that we don't want to share.
 
348
            $e = join( "\n", grep( /^ERROR/, split( /\n/, $e ) ) );
 
349
 
 
350
            unless ( $e =~ /^ERROR/ ) {
 
351
                $e = "Mail could not be sent - please ask your %WIKIWEBMASTER% to look at the Foswiki warning log.";
 
352
            }
 
353
            $errors .= $e . "\n";
 
354
            sleep($back_off);
 
355
            $back_off *= 2;
 
356
            $errors .= "Too many failures sending mail"
 
357
              unless $retries;
 
358
        };
 
359
    }
 
360
 
 
361
    return $errors;
 
362
}
 
363
 
 
364
sub _fixLineLength {
 
365
    my ($addrs) = @_;
 
366
 
 
367
    # split up header lines that are too long
 
368
    $addrs =~ s/(.{60}[^,]*,\s*)/$1\n        /go;
 
369
    $addrs =~ s/\n\s*$//gos;
 
370
    return $addrs;
 
371
}
 
372
 
 
373
sub _sendEmailBySendmail {
 
374
    my ( $this, $text ) = @_;
 
375
 
 
376
    # send with sendmail
 
377
    my ( $header, $body ) = split( "\n\n", $text, 2 );
 
378
    $header =~
 
379
s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1.$2.$3._fixLineLength($4)/geois;
 
380
    $text = "$header\n\n$body";    # rebuild message
 
381
 
 
382
    open( MAIL, '|' . $Foswiki::cfg{MailProgram} )
 
383
      || die "ERROR: Can't send mail using Foswiki::cfg{MailProgram}";
 
384
    print MAIL $text;
 
385
    close(MAIL);
 
386
    #SMELL: this is bizzare. on a freeBSD server, I've seen sendmail return 17152
 
387
    #(17152 >> 8) == 67 == EX_NOUSER - however, the mail log says that the error was
 
388
    #EX_TEMPFAIL == 75, and that (as per oreilly book) the email is cued. The email
 
389
    #does reach the user, but they are very confused because they were told that the
 
390
    #rego failed completely.
 
391
    #Sven has ameneded the oops_message for the verify emails to be less positive that
 
392
    #everything has failed, but.
 
393
    die "ERROR: Exit code ".($? << 8)." ($?) from Foswiki::cfg{MailProgram}" if $?;
 
394
}
 
395
 
 
396
sub _sendEmailByNetSMTP {
 
397
    my ( $this, $text ) = @_;
 
398
 
 
399
    my $from = '';
 
400
    my @to   = ();
 
401
 
 
402
    my ( $header, $body ) = split( "\n\n", $text, 2 );
 
403
    my @headerlines = split( /\r?\n/, $header );
 
404
    $header =~ s/\nBCC\:[^\n]*//os;    #remove BCC line from header
 
405
    $header =~
 
406
s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1 . $2 . $3 . _fixLineLength( $4 )/geois;
 
407
    $text = "$header\n\n$body";        # rebuild message
 
408
 
 
409
    # extract 'From:'
 
410
    my @arr = grep( /^From: /i, @headerlines );
 
411
    if ( scalar(@arr) ) {
 
412
        $from = $arr[0];
 
413
        $from =~ s/^From:\s*//io;
 
414
        $from =~
 
415
          s/.*<(.*?)>.*/$1/o;    # extract "user@host" out of "Name <user@host>"
 
416
    }
 
417
    unless ($from) {
 
418
 
 
419
        # SMELL: should be a Foswiki::inlineAlert
 
420
        die "ERROR: Can't send mail, missing 'From:'";
 
421
    }
 
422
 
 
423
    # extract @to from 'To:', 'CC:', 'BCC:'
 
424
    @arr = grep( /^To: /i, @headerlines );
 
425
    my $tmp = '';
 
426
    if ( scalar(@arr) ) {
 
427
        $tmp = $arr[0];
 
428
        $tmp =~ s/^To:\s*//io;
 
429
        @arr = split( /,\s*/, $tmp );
 
430
        push( @to, @arr );
 
431
    }
 
432
    @arr = grep( /^CC: /i, @headerlines );
 
433
    if ( scalar(@arr) ) {
 
434
        $tmp = $arr[0];
 
435
        $tmp =~ s/^CC:\s*//io;
 
436
        @arr = split( /,\s*/, $tmp );
 
437
        push( @to, @arr );
 
438
    }
 
439
    @arr = grep( /^BCC: /i, @headerlines );
 
440
    if ( scalar(@arr) ) {
 
441
        $tmp = $arr[0];
 
442
        $tmp =~ s/^BCC:\s*//io;
 
443
        @arr = split( /,\s*/, $tmp );
 
444
        push( @to, @arr );
 
445
    }
 
446
    if ( !( scalar(@to) ) ) {
 
447
 
 
448
        # SMELL: should be a Foswiki::inlineAlert
 
449
        die "ERROR: Can't send mail, missing recipient";
 
450
    }
 
451
 
 
452
    return undef unless ( scalar @to );
 
453
 
 
454
    # Change SMTP protocol recipient format from
 
455
    # "User Name <userid@domain>" to "userid@domain"
 
456
    # for those SMTP hosts that need it just that way.
 
457
    foreach (@to) {
 
458
        s/^.*<(.*)>$/$1/;
 
459
    }
 
460
 
 
461
    my $smtp = 0;
 
462
    if ( $this->{HELLO_HOST} ) {
 
463
        $smtp = Net::SMTP->new(
 
464
            $this->{MAIL_HOST},
 
465
            Hello => $this->{HELLO_HOST},
 
466
            Debug => $Foswiki::cfg{SMTP}{Debug} || 0
 
467
        );
 
468
    }
 
469
    else {
 
470
        $smtp =
 
471
          Net::SMTP->new( $this->{MAIL_HOST},
 
472
            Debug => $Foswiki::cfg{SMTP}{Debug} || 0 );
 
473
    }
 
474
    my $status = '';
 
475
    my $mess   = "ERROR: Can't send mail using Net::SMTP. ";
 
476
    die $mess . "Can't connect to '$this->{MAIL_HOST}'" unless $smtp;
 
477
 
 
478
    if ( $Foswiki::cfg{SMTP}{Username} ) {
 
479
        $smtp->auth( $Foswiki::cfg{SMTP}{Username}, $Foswiki::cfg{SMTP}{Password} );
 
480
    }
 
481
    $smtp->mail($from) || die $mess . $smtp->message;
 
482
    $smtp->to( @to, { SkipBad => 1 } ) || die $mess . $smtp->message;
 
483
    $smtp->data($text) || die $mess . $smtp->message;
 
484
    $smtp->dataend()   || die $mess . $smtp->message;
 
485
    $smtp->quit();
 
486
}
 
487
 
 
488
1;
 
489
__DATA__
 
490
 
 
491
Module of Foswiki - The Free and Open Source Wiki, http://foswiki.org/, http://Foswiki.org/
 
492
 
 
493
Copyright (C) 2008-2009 Foswiki Contributors. Foswiki Contributors
 
494
are listed in the AUTHORS file in the root of this distribution.
 
495
 
 
496
NOTE: Please extend that file, not this notice.
 
497
Additional copyrights apply to some or all of the code in this
 
498
file as follows:
 
499
 
 
500
Copyright (C) 2001-2007 Peter Thoeny, peter@thoeny.org
 
501
and TWiki Contributors. All Rights Reserved. TWiki Contributors
 
502
are listed in the AUTHORS file in the root of this distribution.
 
503
 
 
504
This program is free software; you can redistribute it and/or
 
505
modify it under the terms of the GNU General Public License
 
506
as published by the Free Software Foundation; either version 2
 
507
of the License, or (at your option) any later version. For
 
508
more details read LICENSE in the root of this distribution.
 
509
 
 
510
This program is distributed in the hope that it will be useful,
 
511
but WITHOUT ANY WARRANTY; without even the implied warranty of
 
512
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
513
 
 
514
As per the GPL, removal of this notice is prohibited.