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