rt/lib/RT/Interface/Email.pm

   1 # $Header: /home/cvs/cvsroot/freeside/rt/lib/RT/Interface/Email.pm,v 1.1 2002-08-12 06:17:08 ivan Exp $
   2 # RT is (c) 1996-2001 Jesse Vincent <jesse@fsck.com>
   3
   4 package RT::Interface::Email;
   5
   6 use strict;
   7 use Mail::Address;
   8 use MIME::Entity;
   9
  10 BEGIN {
  11     use Exporter ();
  12     use vars qw ($VERSION  @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  13
  14     # set the version for version checking
  15     $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
  16
  17     @ISA         = qw(Exporter);
  18
  19     # your exported package globals go here,
  20     # as well as any optionally exported functions
  21     @EXPORT_OK   = qw(&CleanEnv
  22                       &LoadConfig
  23                       &DBConnect
  24                       &GetCurrentUser
  25                       &GetMessageContent
  26                       &CheckForLoops
  27                       &CheckForSuspiciousSender
  28                       &CheckForAutoGenerated
  29                       &ParseMIMEEntityFromSTDIN
  30                       &ParseTicketId
  31                       &MailError
  32                       &ParseCcAddressesFromHead
  33                       &ParseSenderAddressFromHead
  34                       &ParseErrorsToAddressFromHead
  35               &ParseAddressFromHeader
  36
  37
  38                       &debug);
  39 }
  40
  41 =head1 NAME
  42
  43   RT::Interface::CLI - helper functions for creating a commandline RT interface
  44
  45 =head1 SYNOPSIS
  46
  47   use lib "!!RT_LIB_PATH!!";
  48   use lib "!!RT_ETC_PATH!!";
  49
  50   use RT::Interface::Email  qw(CleanEnv LoadConfig DBConnect
  51                               );
  52
  53   #Clean out all the nasties from the environment
  54   CleanEnv();
  55
  56   #Load etc/config.pm and drop privs
  57   LoadConfig();
  58
  59   #Connect to the database and get RT::SystemUser and RT::Nobody loaded
  60   DBConnect();
  61
  62
  63   #Get the current user all loaded
  64   my $CurrentUser = GetCurrentUser();
  65
  66 =head1 DESCRIPTION
  67
  68
  69 =begin testing
  70
  71 ok(require RT::TestHarness);
  72 ok(require RT::Interface::Email);
  73
  74 =end testing
  75
  76
  77 =head1 METHODS
  78
  79 =cut
  80
  81
  82 =head2 CleanEnv
  83
  84 Removes some of the nastiest nasties from the user\'s environment.
  85
  86 =cut
  87
  88 sub CleanEnv {
  89     $ENV{'PATH'} = '/bin:/usr/bin';    # or whatever you need
  90     $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'};
  91     $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
  92     $ENV{'ENV'} = '' if defined $ENV{'ENV'};
  93     $ENV{'IFS'} = '' if defined $ENV{'IFS'};
  94 }
  95
  96
  97
  98 =head2 LoadConfig
  99
 100 Loads RT's config file and then drops setgid privileges.
 101
 102 =cut
 103
 104 sub LoadConfig {
 105
 106     #This drags in  RT's config.pm
 107     use config;
 108
 109 }
 110
 111
 112
 113 =head2 DBConnect
 114
 115   Calls RT::Init, which creates a database connection and then creates $RT::Nobody
 116   and $RT::SystemUser
 117
 118 =cut
 119
 120
 121 sub DBConnect {
 122     use RT;
 123     RT::Init();
 124 }
 125
 126
 127
 128 # {{{ sub debug
 129
 130 sub debug {
 131     my $val = shift;
 132     my ($debug);
 133     if ($val) {
 134         $RT::Logger->debug($val."\n");
 135         if ($debug) {
 136             print STDERR "$val\n";
 137         }
 138     }
 139     if ($debug) {
 140         return(1);
 141     }
 142 }
 143
 144 # }}}
 145
 146
 147 # {{{ sub CheckForLoops
 148
 149 sub CheckForLoops  {
 150     my $head = shift;
 151
 152     #If this instance of RT sent it our, we don't want to take it in
 153     my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
 154     chomp ($RTLoop); #remove that newline
 155     if ($RTLoop eq "$RT::rtname") {
 156         return (1);
 157     }
 158
 159     # TODO: We might not trap the case where RT instance A sends a mail
 160     # to RT instance B which sends a mail to ...
 161     return (undef);
 162 }
 163
 164 # }}}
 165
 166 # {{{ sub CheckForSuspiciousSender
 167
 168 sub CheckForSuspiciousSender {
 169     my $head = shift;
 170
 171     #if it's from a postmaster or mailer daemon, it's likely a bounce.
 172
 173     #TODO: better algorithms needed here - there is no standards for
 174     #bounces, so it's very difficult to separate them from anything
 175     #else.  At the other hand, the Return-To address is only ment to be
 176     #used as an error channel, we might want to put up a separate
 177     #Return-To address which is treated differently.
 178
 179     #TODO: search through the whole email and find the right Ticket ID.
 180
 181     my ($From, $junk) = ParseSenderAddressFromHead($head);
 182
 183     if (($From =~ /^mailer-daemon/i) or
 184         ($From =~ /^postmaster/i)){
 185         return (1);
 186
 187     }
 188
 189     return (undef);
 190
 191 }
 192
 193 # }}}
 194
 195 # {{{ sub CheckForAutoGenerated
 196 sub CheckForAutoGenerated {
 197     my $head = shift;
 198
 199     my $Precedence = $head->get("Precedence") || "" ;
 200     if ($Precedence =~ /^(bulk|junk)/i) {
 201         return (1);
 202     }
 203     else {
 204         return (0);
 205     }
 206 }
 207
 208 # }}}
 209
 210 # {{{ sub ParseMIMEEntityFromSTDIN
 211
 212 sub ParseMIMEEntityFromSTDIN {
 213
 214     # Create a new parser object:
 215
 216     my $parser = new MIME::Parser;
 217
 218     # {{{ Config $parser to store large attacments in temp dir
 219
 220     ## TODO: Does it make sense storing to disk at all?  After all, we
 221     ## need to put each msg as an in-core scalar before saving it to
 222     ## the database, don't we?
 223
 224     ## At the same time, we should make sure that we nuke attachments
 225     ## Over max size and return them
 226
 227     ## TODO: Remove the temp dir when we don't need it any more.
 228
 229     my $AttachmentDir = File::Temp::tempdir (TMPDIR => 1, CLEANUP => 1);
 230
 231     # Set up output directory for files:
 232     $parser->output_dir("$AttachmentDir");
 233
 234     #If someone includes a message, don't extract it
 235     $parser->extract_nested_messages(0);
 236
 237
 238     # Set up the prefix for files with auto-generated names:
 239     $parser->output_prefix("part");
 240
 241     # If content length is <= 20000 bytes, store each msg as in-core scalar;
 242     # Else, write to a disk file (the default action):
 243
 244     $parser->output_to_core(20000);
 245
 246     # }}} (temporary directory)
 247
 248     #Ok. now that we're set up, let's get the stdin.
 249     my $entity;
 250     unless ($entity = $parser->read(\*STDIN)) {
 251         die "couldn't parse MIME stream";
 252     }
 253     #Now we've got a parsed mime object.
 254
 255     # Get the head, a MIME::Head:
 256     my $head = $entity->head;
 257
 258
 259     # Unfold headers that are have embedded newlines
 260     $head->unfold;
 261
 262     # TODO - information about the charset is lost here!
 263     $head->decode;
 264
 265     return ($entity, $head);
 266
 267 }
 268 # }}}
 269
 270 # {{{ sub ParseTicketId
 271
 272 sub ParseTicketId {
 273     my $Subject = shift;
 274     my ($Id);
 275
 276     if ($Subject =~ s/\[$RT::rtname \#(\d+)\]//i) {
 277         $Id = $1;
 278         $RT::Logger->debug("Found a ticket ID. It's $Id");
 279         return($Id);
 280     }
 281     else {
 282         return(undef);
 283     }
 284 }
 285 # }}}
 286
 287 # {{{ sub MailError
 288 sub MailError {
 289     my %args = (To => $RT::OwnerEmail,
 290                 Bcc => undef,
 291                 From => $RT::CorrespondAddress,
 292                 Subject => 'There has been an error',
 293                 Explanation => 'Unexplained error',
 294                 MIMEObj => undef,
 295                 LogLevel => 'crit',
 296                 @_);
 297
 298
 299     $RT::Logger->log(level => $args{'LogLevel'},
 300                      message => $args{'Explanation'}
 301                     );
 302     my $entity = MIME::Entity->build( Type  =>"multipart/mixed",
 303                                       From => $args{'From'},
 304                                       Bcc => $args{'Bcc'},
 305                                       To => $args{'To'},
 306                                       Subject => $args{'Subject'},
 307                                       'X-RT-Loop-Prevention' => $RT::rtname,
 308                                     );
 309
 310     $entity->attach(  Data => $args{'Explanation'}."\n");
 311
 312     my $mimeobj = $args{'MIMEObj'};
 313     if ($mimeobj) {
 314         $mimeobj->sync_headers();
 315         $entity->add_part($mimeobj);
 316     }
 317
 318     if ($RT::MailCommand eq 'sendmailpipe') {
 319         open (MAIL, "|$RT::SendmailPath $RT::SendmailArguments") || return(0);
 320         print MAIL $entity->as_string;
 321         close(MAIL);
 322     }
 323     else {
 324         $entity->send($RT::MailCommand, $RT::MailParams);
 325     }
 326 }
 327
 328 # }}}
 329
 330 # {{{ sub GetCurrentUser
 331
 332 sub GetCurrentUser  {
 333     my $head = shift;
 334     my $entity = shift;
 335     my $ErrorsTo = shift;
 336
 337     my %UserInfo = ();
 338
 339     #Suck the address of the sender out of the header
 340     my ($Address, $Name) = ParseSenderAddressFromHead($head);
 341
 342     #This will apply local address canonicalization rules
 343     $Address = RT::CanonicalizeAddress($Address);
 344
 345     #If desired, synchronize with an external database
 346
 347     my $UserFoundInExternalDatabase = 0;
 348
 349     # Username is the 'Name' attribute of the user that RT uses for things
 350     # like authentication
 351     my $Username = undef;
 352     if ($RT::LookupSenderInExternalDatabase) {
 353         ($UserFoundInExternalDatabase, %UserInfo) =
 354           RT::LookupExternalUserInfo($Address, $Name);
 355
 356        $Address = $UserInfo{'EmailAddress'};
 357        $Username = $UserInfo{'Name'};
 358     }
 359
 360     my $CurrentUser = RT::CurrentUser->new();
 361
 362     # First try looking up by a username, if we got one from the external
 363     # db lookup. Next, try looking up by email address. Failing that,
 364     # try looking up by users who have this user's email address as their
 365     # username.
 366
 367     if ($Username) {
 368         $CurrentUser->LoadByName($Username);
 369     }
 370
 371     unless ($CurrentUser->Id) {
 372         $CurrentUser->LoadByEmail($Address);
 373     }
 374
 375     #If we can't get it by email address, try by name.
 376     unless ($CurrentUser->Id) {
 377         $CurrentUser->LoadByName($Address);
 378     }
 379
 380
 381     unless ($CurrentUser->Id) {
 382         #If we couldn't load a user, determine whether to create a user
 383
 384         # {{{ If we require an incoming address to be found in the external
 385         # user database, reject the incoming message appropriately
 386         if ( $RT::LookupSenderInExternalDatabase &&
 387              $RT::SenderMustExistInExternalDatabase &&
 388              !$UserFoundInExternalDatabase) {
 389
 390             my $Message = "Sender's email address was not found in the user database.";
 391
 392             # {{{  This code useful only if you've defined an AutoRejectRequest template
 393
 394             require RT::Template;
 395             my $template = new RT::Template($RT::Nobody);
 396             $template->Load('AutoRejectRequest');
 397             $Message = $template->Content || $Message;
 398
 399             # }}}
 400
 401             MailError( To => $ErrorsTo,
 402                        Subject => "Ticket Creation failed: user could not be created",
 403                        Explanation => $Message,
 404                        MIMEObj => $entity,
 405                        LogLevel => 'notice'
 406                      );
 407
 408             return($CurrentUser);
 409
 410         }
 411         # }}}
 412
 413         else {
 414             my $NewUser = RT::User->new($RT::SystemUser);
 415
 416             my ($Val, $Message) =
 417               $NewUser->Create(Name => ($Username || $Address),
 418                                EmailAddress => $Address,
 419                                RealName => "$Name",
 420                                Password => undef,
 421                                Privileged => 0,
 422                                Comments => 'Autocreated on ticket submission'
 423                               );
 424
 425             unless ($Val) {
 426
 427                 # Deal with the race condition of two account creations at once
 428                 #
 429                 if ($Username) {
 430                     $NewUser->LoadByName($Username);
 431                 }
 432
 433                 unless ($NewUser->Id) {
 434                     $NewUser->LoadByEmail($Address);
 435                 }
 436
 437                 unless ($NewUser->Id) {
 438                     MailError( To => $ErrorsTo,
 439                                Subject => "User could not be created",
 440                                Explanation => "User creation failed in mailgateway: $Message",
 441                                MIMEObj => $entity,
 442                                LogLevel => 'crit'
 443                              );
 444                 }
 445             }
 446         }
 447
 448         #Load the new user object
 449         $CurrentUser->LoadByEmail($Address);
 450
 451         unless ($CurrentUser->id) {
 452             $RT::Logger->warning("Couldn't load user '$Address'.".  "giving up");
 453                 MailError( To => $ErrorsTo,
 454                            Subject => "User could not be loaded",
 455                            Explanation => "User  '$Address' could not be loaded in the mail gateway",
 456                            MIMEObj => $entity,
 457                            LogLevel => 'crit'
 458                          );
 459
 460         }
 461     }
 462
 463     return ($CurrentUser);
 464
 465 }
 466 # }}}
 467
 468 # {{{ ParseCcAddressesFromHead
 469
 470 =head2 ParseCcAddressesFromHead HASHREF
 471
 472 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 473 Returns a list of all email addresses in the To and Cc
 474 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
 475 email address  and anything that the configuration sub RT::IsRTAddress matches.
 476
 477 =cut
 478
 479 sub ParseCcAddressesFromHead {
 480     my %args = ( Head => undef,
 481                  QueueObj => undef,
 482                  CurrentUser => undef,
 483                  @_ );
 484
 485     my (@Addresses);
 486
 487     my @ToObjs = Mail::Address->parse($args{'Head'}->get('To'));
 488     my @CcObjs = Mail::Address->parse($args{'Head'}->get('Cc'));
 489
 490     foreach my $AddrObj (@ToObjs, @CcObjs) {
 491         my $Address = $AddrObj->address;
 492         $Address = RT::CanonicalizeAddress($Address);
 493         next if ($args{'CurrentUser'}->EmailAddress =~ /^$Address$/i);
 494         next if ($args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i);
 495         next if ($args{'QueueObj'}->CommentAddress =~ /^$Address$/i);
 496         next if (RT::IsRTAddress($Address));
 497
 498         push (@Addresses, $Address);
 499     }
 500     return (@Addresses);
 501 }
 502
 503
 504 # }}}
 505
 506 # {{{ ParseSenderAdddressFromHead
 507
 508 =head2 ParseSenderAddressFromHead
 509
 510 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
 511 of the From (evaluated in order of Reply-To:, From:, Sender)
 512
 513 =cut
 514
 515 sub ParseSenderAddressFromHead {
 516     my $head = shift;
 517     #Figure out who's sending this message.
 518     my $From = $head->get('Reply-To') ||
 519       $head->get('From') ||
 520         $head->get('Sender');
 521     return (ParseAddressFromHeader($From));
 522 }
 523 # }}}
 524
 525 # {{{ ParseErrorsToAdddressFromHead
 526
 527 =head2 ParseErrorsToAddressFromHead
 528
 529 Takes a MIME::Header object. Return a single value : user@host
 530 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
 531
 532 =cut
 533
 534 sub ParseErrorsToAddressFromHead {
 535     my $head = shift;
 536     #Figure out who's sending this message.
 537
 538     foreach my $header ('Errors-To' , 'Reply-To', 'From', 'Sender' ) {
 539         # If there's a header of that name
 540         my $headerobj = $head->get($header);
 541         if ($headerobj) {
 542                 my ($addr, $name ) = ParseAddressFromHeader($headerobj);
 543                 # If it's got actual useful content...
 544                 return ($addr) if ($addr);
 545         }
 546     }
 547 }
 548 # }}}
 549
 550 # {{{ ParseAddressFromHeader
 551
 552 =head2 ParseAddressFromHeader ADDRESS
 553
 554 Takes an address from $head->get('Line') and returns a tuple: user@host, friendly name
 555
 556 =cut
 557
 558
 559 sub ParseAddressFromHeader{
 560     my $Addr = shift;
 561
 562     my @Addresses = Mail::Address->parse($Addr);
 563
 564     my $AddrObj = $Addresses[0];
 565
 566     unless (ref($AddrObj)) {
 567         return(undef,undef);
 568     }
 569
 570     my $Name =  ($AddrObj->phrase || $AddrObj->comment || $AddrObj->address);
 571
 572
 573     #Lets take the from and load a user object.
 574     my $Address = $AddrObj->address;
 575
 576     return ($Address, $Name);
 577 }
 578 # }}}
 579
 580
 581 1;