rt/lib/RT/Attachment.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2016 Best Practical Solutions, LLC
   6 #                                          <sales@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 =head1 SYNOPSIS
  50
  51     use RT::Attachment;
  52
  53 =head1 DESCRIPTION
  54
  55 This module should never be instantiated directly by client code. it's an internal
  56 module which should only be instantiated through exported APIs in Ticket, Queue and other
  57 similar objects.
  58
  59 =head1 METHODS
  60
  61
  62
  63 =cut
  64
  65
  66 package RT::Attachment;
  67 use base 'RT::Record';
  68
  69 sub Table {'Attachments'}
  70
  71
  72
  73
  74 use strict;
  75 use warnings;
  76
  77
  78 use RT::Transaction;
  79 use MIME::Base64;
  80 use MIME::QuotedPrint;
  81 use MIME::Body;
  82 use RT::Util 'mime_recommended_filename';
  83 use URI;
  84
  85 sub _OverlayAccessible {
  86   {
  87     TransactionId   => { 'read'=>1, 'public'=>1, 'write' => 0 },
  88     MessageId       => { 'read'=>1, 'write' => 0 },
  89     Parent          => { 'read'=>1, 'write' => 0 },
  90     ContentType     => { 'read'=>1, 'write' => 0 },
  91     Subject         => { 'read'=>1, 'write' => 0 },
  92     Content         => { 'read'=>1, 'write' => 0 },
  93     ContentEncoding => { 'read'=>1, 'write' => 0 },
  94     Headers         => { 'read'=>1, 'write' => 0 },
  95     Filename        => { 'read'=>1, 'write' => 0 },
  96     Creator         => { 'read'=>1, 'auto'=>1, },
  97     Created         => { 'read'=>1, 'auto'=>1, },
  98   };
  99 }
 100
 101 =head2 Create
 102
 103 Create a new attachment. Takes a paramhash:
 104
 105     'Attachment' Should be a single MIME body with optional subparts
 106     'Parent' is an optional id of the parent attachment
 107     'TransactionId' is the mandatory id of the transaction this attachment is associated with.;
 108
 109 =cut
 110
 111 sub Create {
 112     my $self = shift;
 113     my %args = ( id            => 0,
 114                  TransactionId => 0,
 115                  Parent        => 0,
 116                  Attachment    => undef,
 117                  @_ );
 118
 119     # For ease of reference
 120     my $Attachment = $args{'Attachment'};
 121
 122     # if we didn't specify a ticket, we need to bail
 123     unless ( $args{'TransactionId'} ) {
 124         $RT::Logger->crit( "RT::Attachment->Create couldn't, as you didn't specify a transaction" );
 125         return (0);
 126     }
 127
 128     # If we possibly can, collapse it to a singlepart
 129     $Attachment->make_singlepart;
 130
 131     my $head = $Attachment->head;
 132
 133     # Get the subject
 134     my $Subject = Encode::decode( 'UTF-8', $head->get( 'subject' ) );
 135     $Subject = '' unless defined $Subject;
 136     chomp $Subject;
 137
 138     #Get the Message-ID
 139     my $MessageId = Encode::decode( "UTF-8", $head->get( 'Message-ID' ) );
 140     defined($MessageId) or $MessageId = '';
 141     chomp ($MessageId);
 142     $MessageId =~ s/^<(.*?)>$/$1/o;
 143
 144     #Get the filename
 145     my $Filename = mime_recommended_filename($Attachment);
 146
 147     # remove path part.
 148     $Filename =~ s!.*/!! if $Filename;
 149
 150     my $content;
 151     unless ( $head->get('Content-Length') ) {
 152         my $length = 0;
 153         $length = length $Attachment->bodyhandle->as_string
 154             if defined $Attachment->bodyhandle;
 155         $head->replace( 'Content-Length' => Encode::encode( "UTF-8", $length ) );
 156     }
 157     $head = $head->as_string;
 158
 159     # MIME::Head doesn't support perl strings well and can return
 160     # octets which later will be double encoded in low-level code
 161     $head = Encode::decode( 'UTF-8', $head );
 162
 163     # If a message has no bodyhandle, that means that it has subparts (or appears to)
 164     # and we should act accordingly.
 165     unless ( defined $Attachment->bodyhandle ) {
 166         my ($id) = $self->SUPER::Create(
 167             TransactionId => $args{'TransactionId'},
 168             Parent        => $args{'Parent'},
 169             ContentType   => $Attachment->mime_type,
 170             Headers       => $head,
 171             MessageId     => $MessageId,
 172             Subject       => $Subject,
 173         );
 174
 175         unless ($id) {
 176             $RT::Logger->crit("Attachment insert failed - ". $RT::Handle->dbh->errstr);
 177             my $txn = RT::Transaction->new($self->CurrentUser);
 178             $txn->Load($args{'TransactionId'});
 179             if ( $txn->id ) {
 180                 $txn->Object->_NewTransaction( Type => 'AttachmentError', ActivateScrips => 0, Data => $Filename );
 181             }
 182             return ($id);
 183         }
 184
 185         foreach my $part ( $Attachment->parts ) {
 186             my $SubAttachment = RT::Attachment->new( $self->CurrentUser );
 187             my ($id) = $SubAttachment->Create(
 188                 TransactionId => $args{'TransactionId'},
 189                 Parent        => $id,
 190                 Attachment    => $part,
 191             );
 192             unless ($id) {
 193                 $RT::Logger->crit("Attachment insert failed: ". $RT::Handle->dbh->errstr);
 194                 return ($id);
 195             }
 196         }
 197         return ($id);
 198     }
 199
 200     #If it's not multipart
 201     else {
 202
 203         my ( $encoding, $type, $note_args );
 204         ( $encoding, $content, $type, $Filename, $note_args ) =
 205                 $self->_EncodeLOB( $Attachment->bodyhandle->as_string, $Attachment->mime_type, $Filename, );
 206
 207         my $id = $self->SUPER::Create(
 208             TransactionId   => $args{'TransactionId'},
 209             ContentType     => $type,
 210             ContentEncoding => $encoding,
 211             Parent          => $args{'Parent'},
 212             Headers         => $head,
 213             Subject         => $Subject,
 214             Content         => $content,
 215             Filename        => $Filename,
 216             MessageId       => $MessageId,
 217         );
 218
 219         if ($id) {
 220             if ($note_args) {
 221                 $self->TransactionObj->Object->_NewTransaction( %$note_args );
 222             }
 223         }
 224         else {
 225             $RT::Logger->crit("Attachment insert failed: ". $RT::Handle->dbh->errstr);
 226             my $txn = RT::Transaction->new($self->CurrentUser);
 227             $txn->Load($args{'TransactionId'});
 228             if ( $txn->id ) {
 229                 $txn->Object->_NewTransaction( Type => 'AttachmentError', ActivateScrips => 0, Data => $Filename );
 230             }
 231         }
 232         return $id;
 233     }
 234 }
 235
 236 =head2 TransactionObj
 237
 238 Returns the transaction object asscoiated with this attachment.
 239
 240 =cut
 241
 242 sub TransactionObj {
 243     my $self = shift;
 244
 245     unless ( $self->{_TransactionObj} ) {
 246         $self->{_TransactionObj} = RT::Transaction->new( $self->CurrentUser );
 247         $self->{_TransactionObj}->Load( $self->TransactionId );
 248     }
 249
 250     unless ($self->{_TransactionObj}->Id) {
 251         $RT::Logger->crit(  "Attachment ". $self->id
 252                            ." can't find transaction ". $self->TransactionId
 253                            ." which it is ostensibly part of. That's bad");
 254     }
 255     return $self->{_TransactionObj};
 256 }
 257
 258 =head2 ParentObj
 259
 260 Returns a parent's L<RT::Attachment> object if this attachment
 261 has a parent, otherwise returns undef.
 262
 263 =cut
 264
 265 sub ParentObj {
 266     my $self = shift;
 267     return undef unless $self->Parent;
 268
 269     my $parent = RT::Attachment->new( $self->CurrentUser );
 270     $parent->LoadById( $self->Parent );
 271     return $parent;
 272 }
 273
 274 =head2 Closest
 275
 276 Takes a MIME type as a string or regex.  Returns an L<RT::Attachment> object
 277 for the nearest containing part with a matching L</ContentType>.  Strings must
 278 match exactly and all matches are done case insensitively.  Strings ending in a
 279 C</> must only match the first part of the MIME type.  For example:
 280
 281     # Find the nearest multipart/* container
 282     my $container = $attachment->Closest("multipart/");
 283
 284 Returns undef if no such object is found.
 285
 286 =cut
 287
 288 sub Closest {
 289     my $self = shift;
 290     my $type = shift;
 291     my $part = $self->ParentObj or return undef;
 292
 293     $type = qr/^\Q$type\E$/
 294         unless ref $type eq "REGEX";
 295
 296     while (lc($part->ContentType) !~ $type) {
 297         $part = $part->ParentObj or last;
 298     }
 299
 300     return ($part and $part->id) ? $part : undef;
 301 }
 302
 303 =head2 Children
 304
 305 Returns an L<RT::Attachments> object which is preloaded with
 306 all attachments objects with this attachment's Id as their
 307 C<Parent>.
 308
 309 =cut
 310
 311 sub Children {
 312     my $self = shift;
 313
 314     my $kids = RT::Attachments->new( $self->CurrentUser );
 315     $kids->ChildrenOf( $self->Id );
 316     return($kids);
 317 }
 318
 319 =head2 Siblings
 320
 321 Returns an L<RT::Attachments> object containing all the attachments sharing
 322 the same immediate parent as the current object, excluding the current
 323 attachment itself.
 324
 325 If the current attachment is a top-level part (i.e. Parent == 0) then a
 326 guaranteed empty L<RT::Attachments> object is returned.
 327
 328 =cut
 329
 330 sub Siblings {
 331     my $self = shift;
 332     my $siblings = RT::Attachments->new( $self->CurrentUser );
 333     if ($self->Parent) {
 334         $siblings->ChildrenOf( $self->Parent );
 335         $siblings->Limit( FIELD => 'id', OPERATOR => '!=', VALUE => $self->Id );
 336     } else {
 337         # Ensure emptiness
 338         $siblings->Limit( SUBCLAUSE => 'empty', FIELD => 'id', VALUE => 0 );
 339     }
 340     return $siblings;
 341 }
 342
 343 =head2 Content
 344
 345 Returns the attachment's content. if it's base64 encoded, decode it
 346 before returning it.
 347
 348 =cut
 349
 350 sub Content {
 351     my $self = shift;
 352     return $self->_DecodeLOB(
 353         $self->GetHeader('Content-Type'),  # Includes charset, unlike ->ContentType
 354         $self->ContentEncoding,
 355         $self->_Value('Content', decode_utf8 => 0),
 356     );
 357 }
 358
 359 =head2 OriginalContent
 360
 361 Returns the attachment's content as octets before RT's mangling.
 362 Generally this just means restoring text content back to its
 363 original encoding.
 364
 365 If the attachment has a C<message/*> Content-Type, its children attachments
 366 are reconstructed and returned as a string.
 367
 368 =cut
 369
 370 sub OriginalContent {
 371     my $self = shift;
 372
 373     # message/* content types represent raw messages.  Since we break them
 374     # apart when they come in, we'll reconstruct their child attachments when
 375     # you ask for the OriginalContent of the message/ part.
 376     if ($self->IsMessageContentType) {
 377         # There shouldn't be more than one "subpart" to a message/* attachment
 378         my $child = $self->Children->First;
 379         return $self->Content unless $child and $child->id;
 380         return $child->ContentAsMIME(Children => 1)->as_string;
 381     }
 382
 383     return $self->Content unless RT::I18N::IsTextualContentType($self->ContentType);
 384
 385     my $content = $self->_DecodeLOB(
 386         "application/octet-stream", # Force _DecodeLOB to not decode to characters
 387         $self->ContentEncoding,
 388         $self->_Value('Content', decode_utf8 => 0),
 389     );
 390
 391     my $entity = MIME::Entity->new();
 392     $entity->head->add("Content-Type", $self->GetHeader("Content-Type"));
 393     $entity->bodyhandle( MIME::Body::Scalar->new( $content ) );
 394     my $from = RT::I18N::_FindOrGuessCharset($entity);
 395     $from = 'utf-8' if not $from or not Encode::find_encoding($from);
 396
 397     my $to = RT::I18N::_CanonicalizeCharset(
 398         $self->OriginalEncoding || 'utf-8'
 399     );
 400
 401     local $@;
 402     eval { Encode::from_to($content, $from => $to) };
 403     if ($@) {
 404         $RT::Logger->error("Could not convert attachment from $from to $to: ".$@);
 405     }
 406     return $content;
 407 }
 408
 409 =head2 OriginalEncoding
 410
 411 Returns the attachment's original encoding.
 412
 413 =cut
 414
 415 sub OriginalEncoding {
 416     my $self = shift;
 417     return $self->GetHeader('X-RT-Original-Encoding');
 418 }
 419
 420 =head2 ContentLength
 421
 422 Returns length of L</Content> in bytes.
 423
 424 =cut
 425
 426 sub ContentLength {
 427     my $self = shift;
 428
 429     return undef unless $self->TransactionObj->CurrentUserCanSee;
 430
 431     my $len = $self->GetHeader('Content-Length');
 432     unless ( defined $len ) {
 433         use bytes;
 434         no warnings 'uninitialized';
 435         $len = length($self->Content) || 0;
 436         $self->SetHeader('Content-Length' => $len);
 437     }
 438     return $len;
 439 }
 440
 441 =head2 FriendlyContentLength
 442
 443 Returns L</ContentLength> in bytes, kilobytes, or megabytes as most
 444 appropriate.  The size is suffixed with C<MiB>, C<KiB>, or C<B> and the returned
 445 string is localized.
 446
 447 Returns the empty string if the L</ContentLength> is 0 or undefined.
 448
 449 =cut
 450
 451 sub FriendlyContentLength {
 452     my $self = shift;
 453     my $size = $self->ContentLength;
 454     return '' unless $size;
 455
 456     my $res = '';
 457     if ( $size > 1024*1024 ) {
 458         $res = $self->loc( "[_1]MiB", int( $size / 1024 / 102.4 ) / 10 );
 459     }
 460     elsif ( $size > 1024 ) {
 461         $res = $self->loc( "[_1]KiB", int( $size / 102.4 ) / 10 );
 462     }
 463     else {
 464         $res = $self->loc( "[_1]B", $size );
 465     }
 466     return $res;
 467 }
 468
 469 =head2 ContentAsMIME [Children => 1]
 470
 471 Returns MIME entity built from this attachment.
 472
 473 If the optional parameter C<Children> is set to a true value, the children are
 474 recursively added to the entity.
 475
 476 =cut
 477
 478 sub _EncodeHeaderToMIME {
 479     my ( $self, $header_name, $header_val ) = @_;
 480     if ($header_name =~ /^Content-/i) {
 481         my $params = MIME::Field::ParamVal->parse_params($header_val);
 482         $header_val = delete $params->{'_'};
 483         foreach my $key ( sort keys %$params ) {
 484             my $value = $params->{$key};
 485             if ( $value =~ /[^\x00-\x7f]/ ) { # check for non-ASCII
 486                 $value = q{UTF-8''} . URI->new(
 487                     Encode::encode('UTF-8', $value)
 488                 );
 489                 $value =~ s/(["\\])/\\$1/g;
 490                 $header_val .= qq{; ${key}*="$value"};
 491             }
 492             else {
 493                 $header_val .= qq{; $key="$value"};
 494             }
 495         }
 496     }
 497     elsif ( $header_name =~ /^(?:Resent-)?(?:To|From|B?Cc|Sender|Reply-To)$/i ) {
 498         my @addresses = RT::EmailParser->ParseEmailAddress( $header_val );
 499         foreach my $address ( @addresses ) {
 500             foreach my $field (qw(phrase comment)) {
 501                 my $v = $address->$field() or next;
 502                 $v = RT::Interface::Email::EncodeToMIME( String => $v );
 503                 $address->$field($v);
 504             }
 505         }
 506         $header_val = join ', ', map $_->format, @addresses;
 507     }
 508     else {
 509         $header_val = RT::Interface::Email::EncodeToMIME(
 510             String => $header_val
 511         );
 512     }
 513     return $header_val;
 514 }
 515
 516 sub ContentAsMIME {
 517     my $self = shift;
 518     my %opts = (
 519         Children => 0,
 520         @_
 521     );
 522
 523     my $entity = MIME::Entity->new();
 524     foreach my $header ($self->SplitHeaders) {
 525         my ($h_key, $h_val) = split /:/, $header, 2;
 526         $entity->head->add(
 527             $h_key, $self->_EncodeHeaderToMIME($h_key, $h_val)
 528         );
 529     }
 530
 531     if ($entity->is_multipart) {
 532         if ($opts{'Children'} and not $self->IsMessageContentType) {
 533             my $children = $self->Children;
 534             while (my $child = $children->Next) {
 535                 $entity->add_part( $child->ContentAsMIME(%opts) );
 536             }
 537         }
 538     } else {
 539         # since we want to return original content, let's use original encoding
 540         $entity->head->mime_attr(
 541             "Content-Type.charset" => $self->OriginalEncoding )
 542           if $self->OriginalEncoding;
 543
 544         $entity->bodyhandle(
 545             MIME::Body::Scalar->new( $self->OriginalContent )
 546         );
 547     }
 548
 549     return $entity;
 550 }
 551
 552 =head2 IsMessageContentType
 553
 554 Returns a boolean indicating if the Content-Type of this attachment is a
 555 C<message/> subtype.
 556
 557 =cut
 558
 559 sub IsMessageContentType {
 560     my $self = shift;
 561     return $self->ContentType =~ m{^\s*message/}i ? 1 : 0;
 562 }
 563
 564 =head2 Addresses
 565
 566 Returns a hashref of all addresses related to this attachment.
 567 The keys of the hash are C<From>, C<To>, C<Cc>, C<Bcc>, C<RT-Send-Cc>
 568 and C<RT-Send-Bcc>. The values are references to lists of
 569 L<Email::Address> objects.
 570
 571 =cut
 572
 573 our @ADDRESS_HEADERS = qw(From To Cc Bcc RT-Send-Cc RT-Send-Bcc);
 574
 575 sub Addresses {
 576     my $self = shift;
 577
 578     my %data = ();
 579     my $current_user_address = lc($self->CurrentUser->EmailAddress || '');
 580     foreach my $hdr (@ADDRESS_HEADERS) {
 581         my @Addresses;
 582         my $line = $self->GetHeader($hdr);
 583
 584         foreach my $AddrObj ( Email::Address->parse( $line )) {
 585             my $address = $AddrObj->address;
 586             $address = lc RT::User->CanonicalizeEmailAddress($address);
 587             next if $current_user_address eq $address;
 588             next if RT::EmailParser->IsRTAddress($address);
 589             push @Addresses, $AddrObj ;
 590         }
 591         $data{$hdr} = \@Addresses;
 592     }
 593     return \%data;
 594 }
 595
 596 =head2 NiceHeaders
 597
 598 Returns a multi-line string of the To, From, Cc, Date and Subject headers.
 599
 600 =cut
 601
 602 sub NiceHeaders {
 603     my $self = shift;
 604     my $hdrs = "";
 605     my @hdrs = $self->_SplitHeaders;
 606     while (my $str = shift @hdrs) {
 607         next unless $str =~ /^(To|From|RT-Send-Cc|Cc|Bcc|Date|Subject):/i;
 608         $hdrs .= $str . "\n";
 609         $hdrs .= shift( @hdrs ) . "\n" while ($hdrs[0] =~ /^[ \t]+/);
 610     }
 611     return $hdrs;
 612 }
 613
 614 =head2 Headers
 615
 616 Returns this object's headers as a string.  This method specifically
 617 removes the RT-Send-Bcc: header, so as to never reveal to whom RT sent a Bcc.
 618 We need to record the RT-Send-Cc and RT-Send-Bcc values so that we can actually send
 619 out mail. The mailing rules are separated from the ticket update code by
 620 an abstraction barrier that makes it impossible to pass this data directly.
 621
 622 =cut
 623
 624 sub Headers {
 625     return join("\n", $_[0]->SplitHeaders);
 626 }
 627
 628 =head2 EncodedHeaders
 629
 630 Takes encoding as argument and returns the attachment's headers as octets in encoded
 631 using the encoding.
 632
 633 This is not protection using quoted printable or base64 encoding.
 634
 635 =cut
 636
 637 sub EncodedHeaders {
 638     my $self = shift;
 639     my $encoding = shift || 'utf8';
 640     return Encode::encode( $encoding, $self->Headers );
 641 }
 642
 643 =head2 GetHeader $TAG
 644
 645 Returns the value of the header Tag as a string. This bypasses the weeding out
 646 done in Headers() above.
 647
 648 =cut
 649
 650 sub GetHeader {
 651     my $self = shift;
 652     my $tag = shift;
 653     foreach my $line ($self->_SplitHeaders) {
 654         next unless $line =~ /^\Q$tag\E:\s+(.*)$/si;
 655
 656         #if we find the header, return its value
 657         return ($1);
 658     }
 659
 660     # we found no header. return an empty string
 661     return undef;
 662 }
 663
 664 =head2 DelHeader $TAG
 665
 666 Delete a field from the attachment's headers.
 667
 668 =cut
 669
 670 sub DelHeader {
 671     my $self = shift;
 672     my $tag = shift;
 673
 674     my $newheader = '';
 675     foreach my $line ($self->_SplitHeaders) {
 676         next if $line =~ /^\Q$tag\E:\s+/i;
 677         $newheader .= "$line\n";
 678     }
 679     return $self->__Set( Field => 'Headers', Value => $newheader);
 680 }
 681
 682 =head2 AddHeader $TAG, $VALUE, ...
 683
 684 Add one or many fields to the attachment's headers.
 685
 686 =cut
 687
 688 sub AddHeader {
 689     my $self = shift;
 690
 691     my $newheader = $self->__Value( 'Headers' );
 692     while ( my ($tag, $value) = splice @_, 0, 2 ) {
 693         $value = $self->_CanonicalizeHeaderValue($value);
 694         $newheader .= "$tag: $value\n";
 695     }
 696     return $self->__Set( Field => 'Headers', Value => $newheader);
 697 }
 698
 699 =head2 SetHeader ( 'Tag', 'Value' )
 700
 701 Replace or add a Header to the attachment's headers.
 702
 703 =cut
 704
 705 sub SetHeader {
 706     my $self  = shift;
 707     my $tag   = shift;
 708     my $value = $self->_CanonicalizeHeaderValue(shift);
 709
 710     my $replaced  = 0;
 711     my $newheader = '';
 712     foreach my $line ( $self->_SplitHeaders ) {
 713         if ( $line =~ /^\Q$tag\E:\s+/i ) {
 714             # replace first instance, skip all the rest
 715             unless ($replaced) {
 716                 $newheader .= "$tag: $value\n";
 717                 $replaced = 1;
 718             }
 719         } else {
 720             $newheader .= "$line\n";
 721         }
 722     }
 723
 724     $newheader .= "$tag: $value\n" unless $replaced;
 725     $self->__Set( Field => 'Headers', Value => $newheader);
 726 }
 727
 728 sub _CanonicalizeHeaderValue {
 729     my $self  = shift;
 730     my $value = shift;
 731
 732     $value = '' unless defined $value;
 733     $value =~ s/\s+$//s;
 734     $value =~ s/\r*\n/\n /g;
 735
 736     return $value;
 737 }
 738
 739 =head2 SplitHeaders
 740
 741 Returns an array of this attachment object's headers, with one header
 742 per array entry. Multiple lines are folded.
 743
 744 B<Never> returns C<RT-Send-Bcc> field.
 745
 746 =cut
 747
 748 sub SplitHeaders {
 749     my $self = shift;
 750     return (grep !/^RT-Send-Bcc/i, $self->_SplitHeaders(@_) );
 751 }
 752
 753 =head2 _SplitHeaders
 754
 755 Returns an array of this attachment object's headers, with one header
 756 per array entry. multiple lines are folded.
 757
 758
 759 =cut
 760
 761 sub _SplitHeaders {
 762     my $self = shift;
 763     my $headers = (shift || $self->_Value('Headers'));
 764     my @headers;
 765     # XXX TODO: splitting on \n\w is _wrong_ as it treats \n[ as a valid
 766     # continuation, which it isn't.  The correct split pattern, per RFC 2822,
 767     # is /\n(?=[^ \t]|\z)/.  That is, only "\n " or "\n\t" is a valid
 768     # continuation.  Older values of X-RT-GnuPG-Status contain invalid
 769     # continuations and rely on this bogus split pattern, however, so it is
 770     # left as-is for now.
 771     for (split(/\n(?=\w|\z)/,$headers)) {
 772         push @headers, $_;
 773
 774     }
 775     return(@headers);
 776 }
 777
 778
 779 sub Encrypt {
 780     my $self = shift;
 781
 782     my $txn = $self->TransactionObj;
 783     return (0, $self->loc('Permission Denied')) unless $txn->CurrentUserCanSee;
 784     return (0, $self->loc('Permission Denied'))
 785         unless $txn->TicketObj->CurrentUserHasRight('ModifyTicket');
 786     return (0, $self->loc('Cryptography is disabled'))
 787         unless RT->Config->Get('Crypt')->{'Enable'};
 788     return (0, $self->loc('Attachments encryption is disabled'))
 789         unless RT->Config->Get('Crypt')->{'AllowEncryptDataInDB'};
 790
 791     my $type = $self->ContentType;
 792     if ( $type =~ /^x-application-rt\/[^-]+-encrypted/i ) {
 793         return (1, $self->loc('Already encrypted'));
 794     } elsif ( $type =~ /^multipart\//i ) {
 795         return (1, $self->loc('No need to encrypt'));
 796     }
 797
 798     my $queue = $txn->TicketObj->QueueObj;
 799     my $encrypt_for;
 800     foreach my $address ( grep $_,
 801         $queue->CorrespondAddress,
 802         $queue->CommentAddress,
 803         RT->Config->Get('CorrespondAddress'),
 804         RT->Config->Get('CommentAddress'),
 805     ) {
 806         my %res = RT::Crypt->GetKeysInfo( Key => $address, Type => 'private' );
 807         next if $res{'exit_code'} || !$res{'info'};
 808         %res = RT::Crypt->GetKeysForEncryption( $address );
 809         next if $res{'exit_code'} || !$res{'info'};
 810         $encrypt_for = $address;
 811     }
 812     unless ( $encrypt_for ) {
 813         return (0, $self->loc('No key suitable for encryption'));
 814     }
 815
 816     my $content = $self->Content;
 817     my %res = RT::Crypt->SignEncryptContent(
 818         Content => \$content,
 819         Sign => 0,
 820         Encrypt => 1,
 821         Recipients => [ $encrypt_for ],
 822     );
 823     if ( $res{'exit_code'} ) {
 824         return (0, $self->loc('Encryption error; contact the administrator'));
 825     }
 826
 827     my ($status, $msg) = $self->__Set( Field => 'Content', Value => $content );
 828     unless ( $status ) {
 829         return ($status, $self->loc("Couldn't replace content with encrypted data: [_1]", $msg));
 830     }
 831
 832     $type = qq{x-application-rt\/$res{'Protocol'}-encrypted; original-type="$type"};
 833     $self->__Set( Field => 'ContentType', Value => $type );
 834     $self->SetHeader( 'Content-Type' => $type );
 835
 836     return (1, $self->loc('Successfuly encrypted data'));
 837 }
 838
 839 sub Decrypt {
 840     my $self = shift;
 841
 842     my $txn = $self->TransactionObj;
 843     return (0, $self->loc('Permission Denied')) unless $txn->CurrentUserCanSee;
 844     return (0, $self->loc('Permission Denied'))
 845         unless $txn->TicketObj->CurrentUserHasRight('ModifyTicket');
 846     return (0, $self->loc('Cryptography is disabled'))
 847         unless RT->Config->Get('Crypt')->{'Enable'};
 848
 849     my $type = $self->ContentType;
 850     my $protocol;
 851     if ( $type =~ /^x-application-rt\/([^-]+)-encrypted/i ) {
 852         $protocol = $1;
 853         $protocol =~ s/gpg/gnupg/; # backwards compatibility
 854         ($type) = ($type =~ /original-type="(.*)"/i);
 855         $type ||= 'application/octet-stream';
 856     } else {
 857         return (1, $self->loc('Is not encrypted'));
 858     }
 859
 860     my $queue = $txn->TicketObj->QueueObj;
 861     my @addresses =
 862         $queue->CorrespondAddress,
 863         $queue->CommentAddress,
 864         RT->Config->Get('CorrespondAddress'),
 865         RT->Config->Get('CommentAddress')
 866     ;
 867
 868     my $content = $self->Content;
 869     my %res = RT::Crypt->DecryptContent(
 870         Protocol => $protocol,
 871         Content => \$content,
 872         Recipients => \@addresses,
 873     );
 874     if ( $res{'exit_code'} ) {
 875         return (0, $self->loc('Decryption error; contact the administrator'));
 876     }
 877
 878     my ($status, $msg) = $self->__Set( Field => 'Content', Value => $content );
 879     unless ( $status ) {
 880         return ($status, $self->loc("Couldn't replace content with decrypted data: [_1]", $msg));
 881     }
 882     $self->__Set( Field => 'ContentType', Value => $type );
 883     $self->SetHeader( 'Content-Type' => $type );
 884
 885     return (1, $self->loc('Successfuly decrypted data'));
 886 }
 887
 888 =head2 _Value
 889
 890 Takes the name of a table column.
 891 Returns its value as a string, if the user passes an ACL check
 892
 893 =cut
 894
 895 sub _Value {
 896     my $self  = shift;
 897     my $field = shift;
 898
 899     #if the field is public, return it.
 900     if ( $self->_Accessible( $field, 'public' ) ) {
 901         return ( $self->__Value( $field, @_ ) );
 902     }
 903
 904     return undef unless $self->TransactionObj->CurrentUserCanSee;
 905     return $self->__Value( $field, @_ );
 906 }
 907
 908 # Attachments don't change; by adding this cache config directive,
 909 # we don't lose pathalogically on long tickets.
 910 sub _CacheConfig {
 911     {
 912         'cache_for_sec' => 180,
 913     }
 914 }
 915
 916
 917
 918
 919 =head2 id
 920
 921 Returns the current value of id.
 922 (In the database, id is stored as int(11).)
 923
 924
 925 =cut
 926
 927
 928 =head2 TransactionId
 929
 930 Returns the current value of TransactionId.
 931 (In the database, TransactionId is stored as int(11).)
 932
 933
 934
 935 =head2 SetTransactionId VALUE
 936
 937
 938 Set TransactionId to VALUE.
 939 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 940 (In the database, TransactionId will be stored as a int(11).)
 941
 942
 943 =cut
 944
 945
 946 =head2 Parent
 947
 948 Returns the current value of Parent.
 949 (In the database, Parent is stored as int(11).)
 950
 951
 952
 953 =head2 SetParent VALUE
 954
 955
 956 Set Parent to VALUE.
 957 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 958 (In the database, Parent will be stored as a int(11).)
 959
 960
 961 =cut
 962
 963
 964 =head2 MessageId
 965
 966 Returns the current value of MessageId.
 967 (In the database, MessageId is stored as varchar(160).)
 968
 969
 970
 971 =head2 SetMessageId VALUE
 972
 973
 974 Set MessageId to VALUE.
 975 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 976 (In the database, MessageId will be stored as a varchar(160).)
 977
 978
 979 =cut
 980
 981
 982 =head2 Subject
 983
 984 Returns the current value of Subject.
 985 (In the database, Subject is stored as varchar(255).)
 986
 987
 988
 989 =head2 SetSubject VALUE
 990
 991
 992 Set Subject to VALUE.
 993 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 994 (In the database, Subject will be stored as a varchar(255).)
 995
 996
 997 =cut
 998
 999
1000 =head2 Filename
1001
1002 Returns the current value of Filename.
1003 (In the database, Filename is stored as varchar(255).)
1004
1005
1006
1007 =head2 SetFilename VALUE
1008
1009
1010 Set Filename to VALUE.
1011 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
1012 (In the database, Filename will be stored as a varchar(255).)
1013
1014
1015 =cut
1016
1017
1018 =head2 ContentType
1019
1020 Returns the current value of ContentType.
1021 (In the database, ContentType is stored as varchar(80).)
1022
1023
1024
1025 =head2 SetContentType VALUE
1026
1027
1028 Set ContentType to VALUE.
1029 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
1030 (In the database, ContentType will be stored as a varchar(80).)
1031
1032
1033 =cut
1034
1035
1036 =head2 ContentEncoding
1037
1038 Returns the current value of ContentEncoding.
1039 (In the database, ContentEncoding is stored as varchar(80).)
1040
1041
1042
1043 =head2 SetContentEncoding VALUE
1044
1045
1046 Set ContentEncoding to VALUE.
1047 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
1048 (In the database, ContentEncoding will be stored as a varchar(80).)
1049
1050
1051 =cut
1052
1053
1054 =head2 Content
1055
1056 Returns the current value of Content.
1057 (In the database, Content is stored as longblob.)
1058
1059
1060
1061 =head2 SetContent VALUE
1062
1063
1064 Set Content to VALUE.
1065 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
1066 (In the database, Content will be stored as a longblob.)
1067
1068
1069 =cut
1070
1071
1072 =head2 Headers
1073
1074 Returns the current value of Headers.
1075 (In the database, Headers is stored as longtext.)
1076
1077
1078
1079 =head2 SetHeaders VALUE
1080
1081
1082 Set Headers to VALUE.
1083 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
1084 (In the database, Headers will be stored as a longtext.)
1085
1086
1087 =cut
1088
1089
1090 =head2 Creator
1091
1092 Returns the current value of Creator.
1093 (In the database, Creator is stored as int(11).)
1094
1095
1096 =cut
1097
1098
1099 =head2 Created
1100
1101 Returns the current value of Created.
1102 (In the database, Created is stored as datetime.)
1103
1104
1105 =cut
1106
1107
1108
1109 sub _CoreAccessible {
1110     {
1111
1112         id =>
1113                 {read => 1, sql_type => 4, length => 11,  is_blob => 0,  is_numeric => 1,  type => 'int(11)', default => ''},
1114         TransactionId =>
1115                 {read => 1, write => 1, sql_type => 4, length => 11,  is_blob => 0,  is_numeric => 1,  type => 'int(11)', default => ''},
1116         Parent =>
1117                 {read => 1, write => 1, sql_type => 4, length => 11,  is_blob => 0,  is_numeric => 1,  type => 'int(11)', default => '0'},
1118         MessageId =>
1119                 {read => 1, write => 1, sql_type => 12, length => 160,  is_blob => 0,  is_numeric => 0,  type => 'varchar(160)', default => ''},
1120         Subject =>
1121                 {read => 1, write => 1, sql_type => 12, length => 255,  is_blob => 0,  is_numeric => 0,  type => 'varchar(255)', default => ''},
1122         Filename =>
1123                 {read => 1, write => 1, sql_type => 12, length => 255,  is_blob => 0,  is_numeric => 0,  type => 'varchar(255)', default => ''},
1124         ContentType =>
1125                 {read => 1, write => 1, sql_type => 12, length => 80,  is_blob => 0,  is_numeric => 0,  type => 'varchar(80)', default => ''},
1126         ContentEncoding =>
1127                 {read => 1, write => 1, sql_type => 12, length => 80,  is_blob => 0,  is_numeric => 0,  type => 'varchar(80)', default => ''},
1128         Content =>
1129                 {read => 1, write => 1, sql_type => -4, length => 0,  is_blob => 1,  is_numeric => 0,  type => 'longblob', default => ''},
1130         Headers =>
1131                 {read => 1, write => 1, sql_type => -4, length => 0,  is_blob => 1,  is_numeric => 0,  type => 'longtext', default => ''},
1132         Creator =>
1133                 {read => 1, auto => 1, sql_type => 4, length => 11,  is_blob => 0,  is_numeric => 1,  type => 'int(11)', default => '0'},
1134         Created =>
1135                 {read => 1, auto => 1, sql_type => 11, length => 0,  is_blob => 0,  is_numeric => 0,  type => 'datetime', default => ''},
1136
1137  }
1138 };
1139
1140 sub FindDependencies {
1141     my $self = shift;
1142     my ($walker, $deps) = @_;
1143
1144     $self->SUPER::FindDependencies($walker, $deps);
1145     $deps->Add( out => $self->TransactionObj );
1146 }
1147
1148 sub __DependsOn {
1149     my $self = shift;
1150     my %args = (
1151         Shredder => undef,
1152         Dependencies => undef,
1153         @_,
1154     );
1155     my $deps = $args{'Dependencies'};
1156     my $list = [];
1157
1158     # Nested attachments
1159     my $objs = RT::Attachments->new( $self->CurrentUser );
1160     $objs->Limit(
1161         FIELD => 'Parent',
1162         OPERATOR        => '=',
1163         VALUE           => $self->Id
1164     );
1165     $objs->Limit(
1166         FIELD => 'id',
1167         OPERATOR        => '!=',
1168         VALUE           => $self->Id
1169     );
1170     push( @$list, $objs );
1171
1172     $deps->_PushDependencies(
1173         BaseObject => $self,
1174         Flags => RT::Shredder::Constants::DEPENDS_ON,
1175         TargetObjects => $list,
1176         Shredder => $args{'Shredder'}
1177     );
1178     return $self->SUPER::__DependsOn( %args );
1179 }
1180
1181 RT::Base->_ImportOverlays();
1182
1183 1;