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