File Coverage

blib/lib/Mail/SpamAssassin/Plugin/HTTPSMismatch.pm
Criterion Covered Total %
statement 25 62 40.3
branch 0 24 0.0
condition 1 11 9.0
subroutine 7 8 87.5
pod 1 2 50.0
total 34 107 31.7


line stmt bran cond sub pod time code
1             # <@LICENSE>
2             # Licensed to the Apache Software Foundation (ASF) under one or more
3             # contributor license agreements. See the NOTICE file distributed with
4             # this work for additional information regarding copyright ownership.
5             # The ASF licenses this file to you under the Apache License, Version 2.0
6             # (the "License"); you may not use this file except in compliance with
7             # the License. You may obtain a copy of the License at:
8             #
9             # http://www.apache.org/licenses/LICENSE-2.0
10             #
11             # Unless required by applicable law or agreed to in writing, software
12             # distributed under the License is distributed on an "AS IS" BASIS,
13             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14             # See the License for the specific language governing permissions and
15             # limitations under the License.
16             # </@LICENSE>
17              
18             package Mail::SpamAssassin::Plugin::HTTPSMismatch;
19              
20 22     22   158 use Mail::SpamAssassin::Plugin;
  22         51  
  22         701  
21 22     22   127 use Mail::SpamAssassin::Logger;
  22         48  
  22         1549  
22 22     22   163 use Mail::SpamAssassin::Constants qw(:ip);
  22         69  
  22         2686  
23 22     22   219 use strict;
  22         54  
  22         606  
24 22     22   123 use warnings;
  22         59  
  22         1053  
25             # use bytes;
26 22     22   134 use re 'taint';
  22         56  
  22         12734  
27              
28             our @ISA = qw(Mail::SpamAssassin::Plugin);
29              
30             # constructor: register the eval rule
31             sub new {
32 63     63 1 205 my $class = shift;
33 63         167 my $mailsaobject = shift;
34              
35             # some boilerplate...
36 63   33     405 $class = ref($class) || $class;
37 63         405 my $self = $class->SUPER::new($mailsaobject);
38 63         162 bless ($self, $class);
39              
40             # the important bit!
41 63         299 $self->register_eval_rule ("check_https_http_mismatch");
42              
43 63         501 return $self;
44             }
45              
46             # [lt]a href="http://baboz-njeryz.de/"[gt]https://bankofamerica.com/[lt]/a[gt]
47             # ("<" and ">" replaced with "[lt]" and "[gt]" to avoid Kaspersky Desktop AV
48             # false positive ;)
49             sub check_https_http_mismatch {
50 0     0 0   my ($self, $permsgstatus, undef, $minanchors, $maxanchors) = @_;
51              
52 0           my $IP_ADDRESS = IP_ADDRESS;
53              
54 0   0       $minanchors ||= 1;
55              
56 0 0         if (!exists $permsgstatus->{chhm_hit}) {
57 0           $permsgstatus->{chhm_hit} = 0;
58 0           $permsgstatus->{chhm_anchors} = 0;
59              
60 0           foreach my $k ( keys %{$permsgstatus->{html}->{uri_detail}} ) {
  0            
61 0           my %uri_detail = %{$permsgstatus->{html}->{uri_detail}};
  0            
62 0           my $v = ${uri_detail}{$k};
63             # if the URI wasn't used for an anchor tag, or the anchor text didn't
64             # exist, skip this.
65 0 0 0       next unless (exists $v->{anchor_text} && @{$v->{anchor_text}});
  0            
66              
67 0           my $uri;
68 0 0         if ($k =~ m@^https?://([^/:]+)@i) {
69 0           $uri = $1;
70             # Skip IPs since there's another rule to catch that already
71 0 0         if ($uri =~ /^$IP_ADDRESS+$/) {
72 0           undef $uri;
73 0           next;
74             }
75             # want to compare whole hostnames instead of domains?
76             # comment this next section to the blank line.
77 0           $uri = $self->{main}->{registryboundaries}->trim_domain($uri);
78 0 0         undef $uri unless ($self->{main}->{registryboundaries}->is_domain_valid($uri));
79             }
80              
81 0 0         next unless $uri;
82 0 0         $permsgstatus->{chhm_anchors}++ if exists $v->{anchor_text};
83              
84 0           foreach (@{$v->{anchor_text}}) {
  0            
85 0 0         if (m@https://([^/:]+)@i) {
86 0           my $https = $1;
87              
88             # want to compare whole hostnames instead of domains?
89             # comment this next section to the blank line.
90 0 0         if ($https !~ /^$IP_ADDRESS+$/) {
91 0           $https = $self->{main}->{registryboundaries}->trim_domain($https);
92 0 0         undef $https unless ($self->{main}->{registryboundaries}->is_domain_valid($https));
93             }
94 0 0         next unless $https;
95              
96 0           dbg("https_http_mismatch: domains $uri -> $https");
97              
98 0 0         next if $uri eq $https;
99 0           $permsgstatus->{chhm_hit} = 1;
100 0           last;
101             }
102             }
103             }
104 0           dbg("https_http_mismatch: anchors ".$permsgstatus->{chhm_anchors});
105             }
106              
107 0   0       return ( $permsgstatus->{chhm_hit} && $permsgstatus->{chhm_anchors} >= $minanchors && (defined $maxanchors && $permsgstatus->{chhm_anchors} < $maxanchors) );
108             }
109              
110             1;