Server IP : 85.214.239.14 / Your IP : 3.22.42.25 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /usr/share/perl5/Amavis/Unpackers/ |
Upload File : |
# SPDX-License-Identifier: GPL-2.0-or-later package Amavis::Unpackers::MIME; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.412'; @ISA = qw(Exporter); @EXPORT_OK = qw(&mime_decode); } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES); use IO::File qw(O_RDONLY O_WRONLY O_CREAT O_EXCL); use MIME::Parser; use MIME::Words; use Digest::MD5; use Digest::SHA; # use Scalar::Util qw(tainted); use Amavis::Conf qw(:platform c cr ca $TEMPBASE $MAXFILES); use Amavis::Timing qw(section_time); use Amavis::Util qw(snmp_count untaint ll do_log safe_decode safe_decode_latin1 safe_encode safe_encode_utf8_inplace); use Amavis::Unpackers::NewFilename qw(consumed_bytes); use Amavis::Unpackers::OurFiler; use Amavis::Unpackers::Part; # save MIME preamble and epilogue (if nontrivial) as extra (pseudo)parts # sub mime_decode_pre_epi($$$$$) { my($pe_name, $pe_lines, $tempdir, $parent_obj, $placement) = @_; if (defined $pe_lines && @$pe_lines) { do_log(5, "mime_decode_%s: %d lines", $pe_name, scalar(@$pe_lines)); if (@$pe_lines > 5 || "@$pe_lines" !~ m{^[A-Za-z0-9/\@:;,. \t\n_-]*\z}s) { my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$parent_obj,1); $newpart_obj->mime_placement($placement); $newpart_obj->name_declared($pe_name); my $newpart = $newpart_obj->full_name; my $outpart = IO::File->new; # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502] $outpart->open($newpart, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640) or die "Can't create $pe_name file $newpart: $!"; binmode($outpart,':bytes') or die "Can't cancel :utf8 mode: $!"; my $len; for (@$pe_lines) { $outpart->print($_) or die "Can't write $pe_name to $newpart: $!"; $len += length($_); } $outpart->close or die "Error closing $pe_name $newpart: $!"; $newpart_obj->size($len); consumed_bytes($len, "mime_decode_$pe_name", 0, 1); } } } sub ambiguous_content { my $entity = shift; if ($entity->can('ambiguous_content')) { return $entity->ambiguous_content; } else { return unless $entity->is_multipart; my $content_type = $entity->head->get('Content-Type'); if ($content_type && $content_type =~ m{^multipart/\w+(.+)}x) { my ($params, $num) = ($1, 0); while ($params =~ m{\G ; \s+ (?<param>\w+) = (?: \w+ | "(?:\\.|[^"\\])*" )}gx) { $num++ if lc($+{param}) eq 'boundary'; } return $num > 1; } return; } } # traverse MIME::Entity object depth-first, # extracting preambles and epilogues as extra (pseudo)parts, and # filling-in additional information into Amavis::Unpackers::Part objects # sub mime_traverse($$$$$); # prototype sub mime_traverse($$$$$) { my($entity, $tempdir, $parent_obj, $depth, $placement) = @_; mime_decode_pre_epi('preamble', $entity->preamble, $tempdir, $parent_obj, $placement); my($mt, $et) = ($entity->mime_type, $entity->effective_type); my $part; my $head = $entity->head; my $body = $entity->bodyhandle; if (!defined($body)) { # a MIME container only contains parts, no bodypart # create pseudo-part objects for MIME containers (e.g. multipart/* ) $part = Amavis::Unpackers::Part->new(undef,$parent_obj,1); $part->attributes_add('B') if ambiguous_content($entity); # $part->type_short('no-file'); do_log(2, "%s %s Content-Type: %s", $part->base_name, $placement, $mt); } else { # does have a body part (i.e. not a MIME container) # base64 encoding represents line-endings in a canonical CRLF form, so it # must be converted to a local representation for text parts when decoding; # RFC 2045 explicitly prohibits encoding CR and LF of a canonical CRLF pair # in quoted-printable encoding of textual parts, but some mail generating # software ignores this requirement, so we have to normalize line endings # (turn CRLF to \n) for both the base64 and the quoted-printable encodings my $encoding = $head->mime_encoding; my $normalize_line_endings = $mt =~ m{^(?:text|message)(?:/|\z)}i && ($encoding eq 'base64' || $encoding eq 'quoted-printable'); my $digest_ctx; # body-part digester context object, or undef # choose a message digest: MD5: 128 bits, SHA family: 160..512 bits # Use SHA1 for SpamAssassin bayes compatibility! my $digest_algorithm = c('mail_part_digest_algorithm'); if (defined $digest_algorithm) { $digest_ctx = uc $digest_algorithm eq 'MD5' ? Digest::MD5->new : Digest::SHA->new($digest_algorithm); } my $size; my $fn = $body->path; if (!defined $fn) { # body part resides in memory only if (!$digest_ctx) { $size = length($body->as_string); } else { my $buff = $body->as_string; $size = length $buff; $buff =~ s{\015(?=\012|\z)}{}gs if $normalize_line_endings; $digest_ctx->add($buff); } } else { # body part resides on a file my $msg; my $errn = lstat($fn) ? 0 : 0+$!; if ($errn == ENOENT) { $msg = "does not exist" } elsif ($errn) { $msg = "is inaccessible: $!" } elsif (!-r _) { $msg = "is not readable" } elsif (!-f _) { $msg = "is not a regular file" } else { $size = -s _; if ($size == 0) { do_log(4,"mime_traverse: file %s is empty", $fn); } elsif ($digest_ctx) { my $fh = IO::File->new; $fh->open($fn,O_RDONLY) # does a sysopen or die "Can't open file $fn for reading: $!"; $fh->binmode or die "Can't set file $fn to binmode: $!"; my($nbytes,$buff); while ($nbytes=sysread($fh,$buff,32768)) { $buff =~ s{\015(?=\012|\z)}{}gs if $normalize_line_endings; $digest_ctx->add($buff); } defined $nbytes or die "Error reading file $fn: $!"; } } do_log(-1,"WARN: mime_traverse: file %s %s", $fn,$msg) if defined $msg; } consumed_bytes($size, 'mime_decode', 0, 1); # retrieve Amavis::Unpackers::Part object (if any), stashed into head obj $part = Amavis::Unpackers::OurFiler::get_amavisd_part($head); if (defined $part) { $part->size($size); if (defined($size) && $size==0) { $part->type_short('empty'); $part->type_long('empty'); } my $digest; if ($digest_ctx) { $digest = $digest_ctx->hexdigest; # store as a hex digest, followed by Content-Type $part->digest($digest . ':' . lc($mt||'')); } if (ll(2)) { # pretty logging my $filename = $head->recommended_filename; $encoding = 'QP' if $encoding eq 'quoted-printable'; do_log(2, "%s %s Content-Type: %s, %s, size: %d%s%s", $part->base_name, $placement, $mt, $encoding, $size, defined $digest ? ", $digest_algorithm digest: $digest" : '', defined $filename ? ", name: $filename" : ''); } my $old_parent_obj = $part->parent; if ($parent_obj ne $old_parent_obj) { # reparent if necessary ll(5) && do_log(5,"reparenting %s from %s to %s", $part->base_name, $old_parent_obj->base_name, $parent_obj->base_name); my $ch_ref = $old_parent_obj->children; $old_parent_obj->children([grep($_ ne $part, @$ch_ref)]); $ch_ref = $parent_obj->children; push(@$ch_ref,$part); $parent_obj->children($ch_ref); $part->parent($parent_obj); } } } if (defined $part) { $part->mime_placement($placement); $part->type_declared($mt eq $et ? $mt : [$mt, $et]); $part->attributes_add('U','C') if $mt =~ m{/.*encrypted}si || $et =~ m{/.*encrypted}si; my %rn_seen; my @rn; # recommended file names, both raw and RFC 2047 / RFC 2231 decoded for my $attr_name ('content-disposition.filename', 'content-type.name') { my $val_raw = $head->mime_attr($attr_name); next if !defined $val_raw || $val_raw eq ''; my $val_dec = ''; # decoded, represented as native Perl characters eval { my(@chunks) = MIME::Words::decode_mimewords($val_raw); for my $pair (@chunks) { my($data,$encoding) = @$pair; if (!defined $encoding || $encoding eq '') { $val_dec .= safe_decode_latin1($data); # assumes ISO-8859-1 } else { $encoding =~ s/\*[^*]*\z//s; # strip RFC 2231 language suffix $val_dec .= safe_decode($encoding,$data); } } 1; } or do { do_log(3, "mime_traverse: decoding MIME words failed: %s", $@); }; if ($val_dec ne '' && !$rn_seen{$val_dec}) { push(@rn,$val_dec); $rn_seen{$val_dec} = 1; } if (!$rn_seen{$val_raw}) { push(@rn,$val_raw); $rn_seen{$val_raw} = 1; } } $part->name_declared(@rn==1 ? $rn[0] : \@rn) if @rn; my $val = $head->mime_attr('content-type.report-type'); safe_encode_utf8_inplace($val); $part->report_type($val) if defined $val && $val ne ''; } mime_decode_pre_epi('epilogue', $entity->epilogue, $tempdir, $parent_obj, $placement); my $item_num = 0; for my $e ($entity->parts) { # recursive descent $item_num++; mime_traverse($e, $tempdir, $part, $depth+1, "$placement/$item_num"); } } # Break up mime parts, return a MIME::Entity object # sub mime_decode($$$) { my($msg, $tempdir, $parent_obj) = @_; # $msg may be an open file handle, or a file name, or a string ref my $parser = MIME::Parser->new; # File::Temp->new defaults to /tmp or a current directory, ignoring TMPDIR $parser->tmp_dir($TEMPBASE) if $parser->UNIVERSAL::can('tmp_dir'); $parser->filer( Amavis::Unpackers::OurFiler->new("$tempdir/parts", $parent_obj) ); $parser->ignore_errors(1); # also is the default # if bounce killer is enabled, extract_nested_messages must be off, # otherwise we lose headers of attached message/rfc822 or message/global $parser->extract_nested_messages(0); # $parser->extract_nested_messages("NEST"); # parse embedded message/rfc822 # "NEST" complains with "part did not end with expected boundary" when # the outer message is message/partial and the inner message is chopped $parser->extract_uuencode(1); # to enable or not to enable ??? $parser->max_parts($MAXFILES) if defined $MAXFILES && $MAXFILES > 0 && $parser->UNIVERSAL::can('max_parts'); snmp_count('OpsDecByMimeParser'); my $entity; { local($1,$2,$3,$4,$5,$6); # avoid Perl 5.8.* bug, $1 can get tainted ! if (!defined $msg) { $entity = $parser->parse_data(''); } elsif (!ref $msg) { # assume $msg is a file name do_log(4, "Extracting mime components from file %s", $msg); $entity = $parser->parse_open("$tempdir/parts/$msg"); } elsif (ref $msg eq 'SCALAR') { do_log(4, "Extracting mime components from a string"); # parse_data() should be avoided with IO::File 1.09 or older: # it uses a mode '>:' to force a three-argument open(), but a mode # with a colon is only recognized starting with IO::File 1.10, # which comes with perl 5.8.1 IO::File->VERSION(1.10); # required minimal version $entity = $parser->parse_data($msg); # takes a ref to a string } elsif (ref $msg) { # assume an open file handle do_log(4, "Extracting mime components from a file"); $msg->seek(0,0) or die "Can't rewind mail file: $!"; $entity = $parser->parse($msg); } } my $mime_err; my(@mime_errors) = $parser->results->errors; # a list! if (@mime_errors) { # $mime_err = $mime_errors[0]; # only show the first error $mime_err = join('; ',@mime_errors); # show all errors } if (defined $mime_err) { $mime_err=~s/\s+\z//; $mime_err=~s/[ \t\r]*\n+/; /g; $mime_err=~s/\s+/ /g; substr($mime_err,250) = '[...]' if length($mime_err) > 250; do_log(1, "WARN: MIME::Parser %s", $mime_err) if $mime_err ne ''; } elsif (!defined($entity)) { $mime_err = "Unable to parse, perhaps message contains too many parts"; do_log(1, "WARN: MIME::Parser %s", $mime_err); $entity = ''; } mime_traverse($entity, $tempdir, $parent_obj, 0, '1') if $entity; section_time('mime_decode'); ($entity, $mime_err); } 1;