lib/TWiki/Net.pm
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/lib/TWiki/Net.pm	Sat Jan 26 15:50:53 2008 +0100
     1.3 @@ -0,0 +1,464 @@
     1.4 +# See bottom of file for license and copyright information
     1.5 +
     1.6 +=begin twiki
     1.7 +
     1.8 +---+ package TWiki::Net
     1.9 +
    1.10 +Object that brokers access to network resources.
    1.11 +
    1.12 +=cut
    1.13 +
    1.14 +# This module is used by configure, and as such must *not* 'use TWiki',
    1.15 +# or any other module that uses it. Always run configure to test after
    1.16 +# changing the module.
    1.17 +
    1.18 +package TWiki::Net;
    1.19 +
    1.20 +use strict;
    1.21 +use Assert;
    1.22 +use Error qw( :try );
    1.23 +
    1.24 +# note that the session is *optional*
    1.25 +sub new {
    1.26 +    my ( $class, $session ) = @_;
    1.27 +    my $this = bless( { session => $session }, $class );
    1.28 +
    1.29 +    $this->{mailHandler} = undef;
    1.30 +
    1.31 +    return $this;
    1.32 +}
    1.33 +
    1.34 +=begin twiki
    1.35 +
    1.36 +---++ ObjectMethod finish()
    1.37 +Break circular references.
    1.38 +
    1.39 +=cut
    1.40 +
    1.41 +# Note to developers; please undef *all* fields in the object explicitly,
    1.42 +# whether they are references or not. That way this method is "golden
    1.43 +# documentation" of the live fields in the object.
    1.44 +sub finish {
    1.45 +    my $this = shift;
    1.46 +    undef $this->{mailHandler};
    1.47 +    undef $this->{HELLO_HOST};
    1.48 +    undef $this->{MAIL_HOST};
    1.49 +    undef $this->{session};
    1.50 +}
    1.51 +
    1.52 +=pod
    1.53 +
    1.54 +---+++ getExternalResource( $url ) -> $response
    1.55 +
    1.56 +Get whatever is at the other end of a URL (using an HTTP GET request). Will
    1.57 +only work for encrypted protocols such as =https= if the =LWP= CPAN module is
    1.58 +installed.
    1.59 +
    1.60 +Note that the =$url= may have an optional user and password, as specified by
    1.61 +the relevant RFC. Any proxy set in =configure= is honoured.
    1.62 +
    1.63 +The =$response= is an object that is known to implement the following subset of
    1.64 +the methods of =LWP::Response=. It may in fact be an =LWP::Response= object,
    1.65 +but it may also not be if =LWP= is not available, so callers may only assume
    1.66 +the following subset of methods is available:
    1.67 +| =code()= |
    1.68 +| =message()= |
    1.69 +| =header($field)= |
    1.70 +| =content()= |
    1.71 +| =is_error()= |
    1.72 +| =is_redirect()= |
    1.73 +
    1.74 +Note that if LWP is *not* available, this function:
    1.75 +   1 can only really be trusted for HTTP/1.0 urls. If HTTP/1.1 or another
    1.76 +     protocol is required, you are *strongly* recommended to =require LWP=.
    1.77 +   1 Will not parse multipart content
    1.78 +
    1.79 +In the event of the server returning an error, then =is_error()= will return
    1.80 +true, =code()= will return a valid HTTP status code
    1.81 +as specified in RFC 2616 and RFC 2518, and =message()= will return the
    1.82 +message that was received from
    1.83 +the server. In the event of a client-side error (e.g. an unparseable URL)
    1.84 +then =is_error()= will return true and =message()= will return an explanatory
    1.85 +message. =code()= will return 400 (BAD REQUEST).
    1.86 +
    1.87 +Note: Callers can easily check the availability of other HTTP::Response methods
    1.88 +as follows:
    1.89 +
    1.90 +<verbatim>
    1.91 +my $response = TWiki::Func::getExternalResource($url);
    1.92 +if (!$response->is_error() && $response->isa('HTTP::Response')) {
    1.93 +    ... other methods of HTTP::Response may be called
    1.94 +} else {
    1.95 +    ... only the methods listed above may be called
    1.96 +}
    1.97 +</verbatim>
    1.98 +
    1.99 +=cut
   1.100 +
   1.101 +sub getExternalResource {
   1.102 +    my ($this, $url) = @_;
   1.103 +
   1.104 +    my $protocol;
   1.105 +    if( $url =~ m!^([a-z]+):! ) {
   1.106 +        $protocol = $1;
   1.107 +    } else {
   1.108 +        require TWiki::Net::HTTPResponse;
   1.109 +        return new TWiki::Net::HTTPResponse("Bad URL: $url");
   1.110 +    }
   1.111 +
   1.112 +    eval "use LWP";
   1.113 +    unless( $@ ) {
   1.114 +       return _GETUsingLWP( $this, $url );
   1.115 +    }
   1.116 +
   1.117 +    # Fallback mechanism
   1.118 +    if( $protocol ne 'http') {
   1.119 +        require TWiki::Net::HTTPResponse;
   1.120 +        return new TWiki::Net::HTTPResponse(
   1.121 +            "LWP not available for handling protocol: $url");
   1.122 +    }
   1.123 +
   1.124 +    my $response;
   1.125 +    try {
   1.126 +        $url =~ s!^\w+://!!; # remove protocol
   1.127 +        my ( $user, $pass );
   1.128 +        if ($url =~ s!([^/\@:]+)(?::([^/\@:]+))?@!!) {
   1.129 +            ( $user, $pass ) = ( $1, $2 || '');
   1.130 +        }
   1.131 +
   1.132 +        unless ($url =~ s!([^:/]+)(?::([0-9]+))?!! ) {
   1.133 +            die "Bad URL: $url";
   1.134 +        }
   1.135 +        my( $host, $port ) = ( $1, $2 || 80);
   1.136 +
   1.137 +        require Socket;
   1.138 +        import Socket qw(:all);
   1.139 +
   1.140 +        $url = '/' unless( $url );
   1.141 +        my $req = "GET $url HTTP/1.0\r\n";
   1.142 +
   1.143 +        $req .= "Host: $host:$port\r\n";
   1.144 +        if( $user ) {
   1.145 +            # Use MIME::Base64 at run-time if using outbound proxy with
   1.146 +            # authentication
   1.147 +            require MIME::Base64;
   1.148 +            import MIME::Base64 ();
   1.149 +            my $base64 = encode_base64( "$user:$pass", "\r\n" );
   1.150 +            $req .= "Authorization: Basic $base64";
   1.151 +        }
   1.152 +
   1.153 +        # SMELL: Reference to TWiki variables used for compatibility
   1.154 +        my ($proxyHost, $proxyPort);
   1.155 +        if ($this->{session} && $this->{session}->{prefs}) {
   1.156 +            my $prefs = $this->{session}->{prefs};
   1.157 +            $proxyHost = $prefs->getPreferencesValue('PROXYHOST');
   1.158 +            $proxyPort = $prefs->getPreferencesValue('PROXYPORT');
   1.159 +        }
   1.160 +        $proxyHost ||= $TWiki::cfg{PROXY}{HOST};
   1.161 +        $proxyPort ||= $TWiki::cfg{PROXY}{PORT};
   1.162 +        if($proxyHost && $proxyPort) {
   1.163 +            $req = "GET http://$host:$port$url HTTP/1.0\r\n";
   1.164 +            $host = $proxyHost;
   1.165 +            $port = $proxyPort;
   1.166 +        }
   1.167 +
   1.168 +	'$Rev: 16278 (22 Jan 2008) $'=~/([0-9]+)/;
   1.169 +	my $revstr=$1;
   1.170 +
   1.171 +        $req .= 'User-Agent: TWiki::Net/'.$revstr."\r\n";
   1.172 +        $req .= "\r\n\r\n";
   1.173 +
   1.174 +        my ( $iaddr, $paddr, $proto );
   1.175 +        $iaddr = inet_aton( $host );
   1.176 +        $paddr = sockaddr_in( $port, $iaddr );
   1.177 +        $proto = getprotobyname( 'tcp' );
   1.178 +        unless( socket( *SOCK, &PF_INET, &SOCK_STREAM, $proto ) ) {
   1.179 +            die "socket failed: $!";
   1.180 +        }
   1.181 +        unless( connect( *SOCK, $paddr ) ) {
   1.182 +            die "connect failed: $!";
   1.183 +        }
   1.184 +        select SOCK; $| = 1;
   1.185 +        local $/ = undef;
   1.186 +        print SOCK $req;
   1.187 +        my $result = '';
   1.188 +        $result = <SOCK>;
   1.189 +        unless( close( SOCK )) {
   1.190 +            die "close faied: $!";
   1.191 +        }
   1.192 +        select STDOUT;
   1.193 +
   1.194 +        # No LWP, but may have HTTP::Response which would make life easier
   1.195 +        # (it has a much more thorough parser)
   1.196 +        eval 'require HTTP::Response';
   1.197 +        if ($@) {
   1.198 +            # Nope, no HTTP::Response, have to do things the hard way :-(
   1.199 +            require TWiki::Net::HTTPResponse;
   1.200 +            $response = TWiki::Net::HTTPResponse->parse($result);
   1.201 +        } else {
   1.202 +            $response = HTTP::Response->parse($result);
   1.203 +        }
   1.204 +    } catch Error::Simple with {
   1.205 +        $response = new TWiki::Net::HTTPResponse(shift);
   1.206 +    };
   1.207 +    return $response;
   1.208 +}
   1.209 +
   1.210 +sub _GETUsingLWP {
   1.211 +    my( $this, $url ) = @_;
   1.212 +
   1.213 +    my ( $user, $pass );
   1.214 +    if ($url =~ s!([^/\@:]+)(?::([^/\@:]+))?@!!) {
   1.215 +        ( $user, $pass ) = ( $1, $2 );
   1.216 +    }
   1.217 +    my $request;
   1.218 +    require HTTP::Request;
   1.219 +    $request = HTTP::Request->new(GET => $url);
   1.220 +    '$Rev: 16278 (22 Jan 2008) $'=~/([0-9]+)/;
   1.221 +    my $revstr=$1;
   1.222 +    $request->header('User-Agent' => 'TWiki::Net/'.$revstr." libwww-perl/$LWP::VERSION");
   1.223 +    require TWiki::Net::UserCredAgent;
   1.224 +    my $ua = new TWiki::Net::UserCredAgent($user, $pass);
   1.225 +    my $response = $ua->request($request);
   1.226 +    return $response;
   1.227 +}
   1.228 +
   1.229 +# pick a default mail handler
   1.230 +sub _installMailHandler {
   1.231 +    my $this = shift;
   1.232 +    my $handler = 0; # Not undef
   1.233 +    if ($this->{session} && $this->{session}->{prefs}) {
   1.234 +        my $prefs = $this->{session}->{prefs};
   1.235 +        $this->{MAIL_HOST}  = $prefs->getPreferencesValue( 'SMTPMAILHOST' );
   1.236 +        $this->{HELLO_HOST} = $prefs->getPreferencesValue( 'SMTPSENDERHOST' );
   1.237 +    }
   1.238 +
   1.239 +    $this->{MAIL_HOST}  ||= $TWiki::cfg{SMTP}{MAILHOST};
   1.240 +    $this->{HELLO_HOST} ||= $TWiki::cfg{SMTP}{SENDERHOST};
   1.241 +
   1.242 +    if( $this->{MAIL_HOST} ) {
   1.243 +        # See Codev.RegisterFailureInsecureDependencyCygwin for why
   1.244 +        # this must be untainted
   1.245 +        require TWiki::Sandbox;
   1.246 +        $this->{MAIL_HOST} =
   1.247 +          TWiki::Sandbox::untaintUnchecked( $this->{MAIL_HOST} );
   1.248 +        eval {	# May fail if Net::SMTP not installed
   1.249 +            require Net::SMTP;
   1.250 +        };
   1.251 +        if( $@ ) {
   1.252 +            $this->{session}->writeWarning( "SMTP not available: $@" )
   1.253 +              if ($this->{session});
   1.254 +        } else {
   1.255 +            $handler = \&_sendEmailByNetSMTP;
   1.256 +        }
   1.257 +    }
   1.258 +
   1.259 +    if( !$handler && $TWiki::cfg{MailProgram} ) {
   1.260 +        $handler = \&_sendEmailBySendmail;
   1.261 +    }
   1.262 +
   1.263 +    $this->setMailHandler( $handler ) if $handler;
   1.264 +}
   1.265 +
   1.266 +=pod
   1.267 +
   1.268 +---++ setMailHandler( \&fn )
   1.269 +
   1.270 +   * =\&fn= - reference to a function($) (see _sendEmailBySendmail for proto)
   1.271 +Install a handler function to take over mail sending from the default
   1.272 +SMTP or sendmail methods. This is provided mainly for tests that
   1.273 +need to be told when a mail is sent, without actually sending it. It
   1.274 +may also be useful in the event that someone needs to plug in an
   1.275 +alternative mail handling method.
   1.276 +
   1.277 +=cut
   1.278 +
   1.279 +sub setMailHandler {
   1.280 +    my( $this, $fnref ) = @_;
   1.281 +    $this->{mailHandler} = $fnref;
   1.282 +}
   1.283 +
   1.284 +=pod
   1.285 +
   1.286 +---++ ObjectMethod sendEmail ( $text, $retries ) -> $error
   1.287 +
   1.288 +   * =$text= - text of the mail, including MIME headers
   1.289 +   * =$retries= - number of times to retry the send (default 1)
   1.290 +
   1.291 +Send an email specified as MIME format content.
   1.292 +Date: ...\nFrom: ...\nTo: ...\nCC: ...\nSubject: ...\n\nMailBody...
   1.293 +
   1.294 +=cut
   1.295 +
   1.296 +sub sendEmail {
   1.297 +    my( $this, $text, $retries ) = @_;
   1.298 +    $retries ||= 1;
   1.299 +   
   1.300 +    unless( $TWiki::cfg{EnableEmail} ) {
   1.301 +        return 'Trying to send email while email functionality is disabled';
   1.302 +    }
   1.303 +
   1.304 +    unless( defined $this->{mailHandler} ) {
   1.305 +        _installMailHandler( $this );
   1.306 +    }
   1.307 +
   1.308 +    return 'No mail handler available' unless $this->{mailHandler};
   1.309 +
   1.310 +    # Put in a Date header, mainly for Qmail
   1.311 +    require TWiki::Time;
   1.312 +    my $dateStr = TWiki::Time::formatTime(time, '$email');
   1.313 +    $text = "Date: " . $dateStr . "\n" . $text;
   1.314 +
   1.315 +    my $errors = '';
   1.316 +    my $back_off = 1; # seconds, doubles on each retry
   1.317 +    while ( $retries-- ) {
   1.318 +        try {
   1.319 +            &{$this->{mailHandler}}( $this, $text );
   1.320 +            $retries = 0;
   1.321 +        } catch Error::Simple with {
   1.322 +            my $e = shift->stringify();
   1.323 +            $this->{session}->writeWarning( $e );
   1.324 +            # be nasty to errors that we didn't throw. They may be
   1.325 +            # caused by SMTP or perl, and give away info about the
   1.326 +            # install that we don't want to share.
   1.327 +            unless( $e =~ /^ERROR/ ) {
   1.328 +                $e = "Mail could not be sent - see TWiki warning log.";
   1.329 +            }
   1.330 +            $errors .= $e."\n";
   1.331 +            sleep( $back_off );
   1.332 +            $back_off *= 2;
   1.333 +            $errors .= "Too many failures sending mail"
   1.334 +              unless $retries;
   1.335 +        };
   1.336 +    }
   1.337 +    return $errors;
   1.338 +}
   1.339 +
   1.340 +sub _fixLineLength {
   1.341 +    my( $addrs ) = @_;
   1.342 +    # split up header lines that are too long
   1.343 +    $addrs =~ s/(.{60}[^,]*,\s*)/$1\n        /go;
   1.344 +    $addrs =~ s/\n\s*$//gos;
   1.345 +    return $addrs;
   1.346 +}
   1.347 +
   1.348 +sub _sendEmailBySendmail {
   1.349 +    my( $this, $text ) = @_;
   1.350 +
   1.351 +    # send with sendmail
   1.352 +    my ( $header, $body ) = split( "\n\n", $text, 2 );
   1.353 +    $header =~ s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1.$2.$3._fixLineLength($4)/geois;
   1.354 +    $text = "$header\n\n$body";   # rebuild message
   1.355 +
   1.356 +    open( MAIL, '|'.$TWiki::cfg{MailProgram} ) ||
   1.357 +      die "ERROR: Can't send mail using TWiki::cfg{MailProgram}";
   1.358 +    print MAIL $text;
   1.359 +    close( MAIL );
   1.360 +    die "ERROR: Exit code $? from TWiki::cfg{MailProgram}" if $?;
   1.361 +}
   1.362 +
   1.363 +sub _sendEmailByNetSMTP {
   1.364 +    my( $this, $text ) = @_;
   1.365 +
   1.366 +    my $from = '';
   1.367 +    my @to = ();
   1.368 +
   1.369 +    my ( $header, $body ) = split( "\n\n", $text, 2 );
   1.370 +    my @headerlines = split( /\r?\n/, $header );
   1.371 +    $header =~ s/\nBCC\:[^\n]*//os;  #remove BCC line from header
   1.372 +    $header =~ s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1 . $2 . $3 . _fixLineLength( $4 )/geois;
   1.373 +    $text = "$header\n\n$body";   # rebuild message
   1.374 +
   1.375 +    # extract 'From:'
   1.376 +    my @arr = grep( /^From: /i, @headerlines );
   1.377 +    if( scalar( @arr ) ) {
   1.378 +        $from = $arr[0];
   1.379 +        $from =~ s/^From:\s*//io;
   1.380 +        $from =~ s/.*<(.*?)>.*/$1/o; # extract "user@host" out of "Name <user@host>"
   1.381 +    }
   1.382 +    unless( $from ) {
   1.383 +        # SMELL: should be a TWiki::inlineAlert
   1.384 +        die "ERROR: Can't send mail, missing 'From:'";
   1.385 +    }
   1.386 +
   1.387 +    # extract @to from 'To:', 'CC:', 'BCC:'
   1.388 +    @arr = grep( /^To: /i, @headerlines );
   1.389 +    my $tmp = '';
   1.390 +    if( scalar( @arr ) ) {
   1.391 +        $tmp = $arr[0];
   1.392 +        $tmp =~ s/^To:\s*//io;
   1.393 +        @arr = split( /,\s*/, $tmp );
   1.394 +        push( @to, @arr );
   1.395 +    }
   1.396 +    @arr = grep( /^CC: /i, @headerlines );
   1.397 +    if( scalar( @arr ) ) {
   1.398 +        $tmp = $arr[0];
   1.399 +        $tmp =~ s/^CC:\s*//io;
   1.400 +        @arr = split( /,\s*/, $tmp );
   1.401 +        push( @to, @arr );
   1.402 +    }
   1.403 +    @arr = grep( /^BCC: /i, @headerlines );
   1.404 +    if( scalar( @arr ) ) {
   1.405 +        $tmp = $arr[0];
   1.406 +        $tmp =~ s/^BCC:\s*//io;
   1.407 +        @arr = split( /,\s*/, $tmp );
   1.408 +        push( @to, @arr );
   1.409 +    }
   1.410 +    if( ! ( scalar( @to ) ) ) {
   1.411 +        # SMELL: should be a TWiki::inlineAlert
   1.412 +        die "ERROR: Can't send mail, missing recipient";
   1.413 +    }
   1.414 +
   1.415 +    return undef unless( scalar @to );
   1.416 +
   1.417 +    # Change SMTP protocol recipient format from 
   1.418 +    # "User Name <userid@domain>" to "userid@domain"
   1.419 +    # for those SMTP hosts that need it just that way.
   1.420 +    foreach (@to) {
   1.421 +        s/^.*<(.*)>$/$1/;
   1.422 +    }
   1.423 +
   1.424 +    my $smtp = 0;
   1.425 +    if( $this->{HELLO_HOST} ) {
   1.426 +        $smtp = Net::SMTP->new( $this->{MAIL_HOST},
   1.427 +                                Hello => $this->{HELLO_HOST},
   1.428 +                                Debug => $TWiki::cfg{SMTP}{Debug} || 0 );
   1.429 +    } else {
   1.430 +        $smtp = Net::SMTP->new( $this->{MAIL_HOST},
   1.431 +                                Debug => $TWiki::cfg{SMTP}{Debug} || 0 );
   1.432 +    }
   1.433 +    my $status = '';
   1.434 +    my $mess = "ERROR: Can't send mail using Net::SMTP. ";
   1.435 +    die $mess."Can't connect to '$this->{MAIL_HOST}'" unless $smtp;
   1.436 +
   1.437 +    if( $TWiki::cfg{SMTP}{Username} ) {
   1.438 +        $smtp->auth($TWiki::cfg{SMTP}{Username}, $TWiki::cfg{SMTP}{Password});
   1.439 +    }
   1.440 +    $smtp->mail( $from ) || die $mess.$smtp->message;
   1.441 +    $smtp->to( @to, { SkipBad => 1 } ) || die $mess.$smtp->message;
   1.442 +    $smtp->data( $text ) || die $mess.$smtp->message;
   1.443 +    $smtp->dataend() || die $mess.$smtp->message;
   1.444 +    $smtp->quit();
   1.445 +}
   1.446 +
   1.447 +1;
   1.448 +__DATA__
   1.449 +
   1.450 +Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
   1.451 +
   1.452 +Copyright (C) 2001-2007 Peter Thoeny, peter@thoeny.org
   1.453 +and TWiki Contributors. All Rights Reserved. TWiki Contributors
   1.454 +are listed in the AUTHORS file in the root of this distribution.
   1.455 +NOTE: Please extend that file, not this notice.
   1.456 +
   1.457 +This program is free software; you can redistribute it and/or
   1.458 +modify it under the terms of the GNU General Public License
   1.459 +as published by the Free Software Foundation; either version 2
   1.460 +of the License, or (at your option) any later version. For
   1.461 +more details read LICENSE in the root of this distribution.
   1.462 +
   1.463 +This program is distributed in the hope that it will be useful,
   1.464 +but WITHOUT ANY WARRANTY; without even the implied warranty of
   1.465 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
   1.466 +
   1.467 +As per the GPL, removal of this notice is prohibited.