File Coverage

blib/lib/File/VirusScan/Engine/Daemon/FPROT/V4.pm
Criterion Covered Total %
statement 32 110 29.0
branch 2 60 3.3
condition 1 14 7.1
subroutine 10 12 83.3
pod 2 2 100.0
total 47 198 23.7


line stmt bran cond sub pod time code
1             package File::VirusScan::Engine::Daemon::FPROT::V4;
2 1     1   101161 use strict;
  1         10  
  1         23  
3 1     1   7 use warnings;
  1         2  
  1         21  
4 1     1   4 use Carp;
  1         3  
  1         45  
5              
6 1     1   356 use File::VirusScan::Engine::Daemon;
  1         2  
  1         9  
7 1     1   41 use vars qw( @ISA );
  1         2  
  1         54  
8             @ISA = qw( File::VirusScan::Engine::Daemon );
9              
10 1     1   398 use IO::Socket::INET;
  1         10757  
  1         5  
11 1     1   431 use Cwd 'abs_path';
  1         2  
  1         38  
12 1     1   546 use HTML::TokeParser;
  1         8758  
  1         29  
13 1     1   370 use File::VirusScan::Result;
  1         2  
  1         851  
14              
15             sub new
16             {
17 6     6 1 13654 my ($class, $conf) = @_;
18              
19 6 100       14 if(!$conf->{host}) {
20 1         16 croak "Must supply a 'host' config value for $class";
21             }
22              
23             my $self = {
24             host => $conf->{host},
25 5   50     23 base_port => $conf->{base_port} || 10200
26             };
27              
28 5         21 return bless $self, $class;
29             }
30              
31             sub scan
32             {
33 0     0 1   my ($self, $path) = @_;
34              
35 0           my $abs = abs_path($path);
36 0 0 0       if ($abs && $abs ne $path) {
37 0           $path = $abs;
38             }
39              
40 0           my @files = eval { $self->list_files($path) };
  0            
41 0 0         if($@) {
42 0           return File::VirusScan::Result->error($@);
43             }
44              
45 0           foreach my $file_path (@files) {
46 0           my $result = $self->_scan($file_path);
47              
48 0 0         if(!$result->is_clean()) {
49 0           return $result;
50             }
51             }
52              
53             }
54              
55             # TODO FIXME
56             # This is unbelievably ugly code, but as I have no way of testing it
57             # against an F-PROT daemon, it's been ported nearly verbatim from
58             # MIMEDefang. It is in desperate need of cleanup!
59             sub _scan
60             {
61 0     0     my ($self, $item) = @_;
62              
63 0           my $host = $self->{host};
64 0           my $baseport = $self->{base_port};
65              
66             # Default error message when reaching end of function
67 0           my $errmsg = "Could not connect to F-Prot Daemon at $host:$baseport";
68              
69             # Try 5 ports in order to find an active scanner; they may
70             # change the port when they find and spawn an updated demon
71             # executable
72 0           SEARCH_DEMON: foreach my $port ($baseport .. ($baseport + 4)) {
73              
74             # TODO: Timeout value?
75             # TODO: Why aren't we using a HTTP client instead of
76             # rolling our own HTTP?
77 0           my $sock = IO::Socket::INET->new(
78             PeerAddr => $host,
79             PeerPort => $port
80             );
81              
82 0 0         next if !defined $sock;
83              
84             # The arguments (following the '?' sign in the HTTP
85             # request) are the same as for the command line F-Prot,
86             # the additional -remote-dtd suppresses the unuseful
87             # XML DTD prefix
88 0           my @args = qw( -dumb -archive -packed -remote-dtd );
89 0           my $uri = "$item?" . join('%20', @args);
90 0 0         if(!$sock->print("GET $uri HTTP/1.0\n\n")) {
91 0           my $err = $!;
92 0           $sock->close;
93 0           return File::VirusScan::Result->error("Could not write to socket: $err");
94             }
95              
96 0 0         if(!$sock->flush) {
97 0           my $err = $!;
98 0           $sock->close;
99 0           return File::VirusScan::Result->error("Could not flush socket: $err");
100             }
101              
102             # Fetch HTTP Header
103             ## Maybe dropped, if no validation checks are to be made
104 0           while (my $output = $sock->getline) {
105 0 0         if($output =~ /^\s*$/) {
    0          
    0          
106 0           last; # End of headers
107             #### Below here: Validating the protocol
108             #### If the protocol is not recognized, it's assumed that the
109             #### endpoint is not an F-Prot demon, hence,
110             #### the next port is probed.
111             } elsif($output =~ /^HTTP(.*)/) {
112 0           my $h = $1;
113 0 0         next SEARCH_DEMON unless $h =~ m!/1\.0\s+200\s!;
114             } elsif($output =~ /^Server:\s*(\S*)/) {
115 0 0         next SEARCH_DEMON if $1 !~ /^fprotd/;
116             }
117             }
118              
119             # Parsing XML results
120 0           my $xml = HTML::TokeParser->new($sock);
121 0           my $t = $xml->get_tag('fprot-results');
122 0 0         unless ($t) { # This is an essential tag --> assume a broken demon
123 0           $errmsg = 'Demon did not return tag';
124 0           last SEARCH_DEMON;
125             }
126              
127 0 0         if($t->[1]{'version'} ne '1.0') {
128 0           $errmsg = "Incompatible F-Protd results version: " . $t->[1]{'version'};
129 0           last SEARCH_DEMON;
130             }
131              
132 0           my $curText; # temporarily accumulated information
133 0           my $virii = ''; # name(s) of virus(es) found
134 0           my $code; # overall exit code
135 0           my $msg = ''; # accumulated message of virus scanner
136 0           while ($t = $xml->get_token) {
137 0           my $tag = $t->[1];
138 0 0         if($t->[0] eq 'S') { # Start tag
    0          
139             # Accumulate the information temporarily
140             # into $curText until the tag is found
141 0           my $text = $xml->get_trimmed_text;
142              
143             # $tag 'filename' of no use in MIMEDefang
144 0 0 0       if($tag eq 'name') {
    0 0        
    0          
    0          
145 0 0         $virii .= (length $virii ? " " : "") . $text;
146 0           $curText .= "Found the virus: '$text'\n";
147             } elsif($tag eq 'accuracy' || $tag eq 'disinfectable' || $tag eq 'message') {
148 0           $curText .= "\t$tag: $text\n";
149             } elsif($tag eq 'error') {
150 0           $msg .= "\nError: $text\n";
151             } elsif($tag eq 'summary') {
152 0 0         $code = $t->[2]{'code'} if defined $t->[2]{'code'};
153             }
154             } elsif($t->[0] eq 'E') { # End tag
155 0 0         if($tag eq 'detected') {
    0          
156              
157             # move the cached information to the
158             # accumulated message
159 0 0         $msg .= "\n$curText" if $curText;
160 0           undef $curText;
161             } elsif($tag eq 'fprot-results') {
162 0           last; # security check
163             }
164             }
165             }
166 0           $sock->close;
167              
168             ## Check the exit code (man f-protd)
169             ## NOTE: These codes are different from the ones of the command line version!
170             # 0 Not scanned, unable to handle the object.
171             # 1 Not scanned due to an I/O error.
172             # 2 Not scanned, as the scanner ran out of memory.
173             # 3 X The object is not of a type the scanner knows. This
174             # may either mean it was misidentified or that it is
175             # corrupted.
176             # 4 X The object was valid, but encrypted and could not
177             # be scanned.
178             # 5 Scanning of the object was interrupted.
179             # 7 X The object was identified as an "innocent" object.
180             # 9 X The object was successfully scanned and nothing was
181             # found.
182             # 11 The object is infected.
183             # 13 The object was disinfected.
184 0 0         unless (defined $code) {
185 0           $errmsg = "No summary code found";
186 0           last SEARCH_DEMON;
187             }
188              
189             # I/O error, unable to handle, out of mem,
190             # any filesystem error less than zero,
191             # interrupted
192 0 0 0       if($code < 3 || $code == 5) {
193             #w
194             ## assume this a temporary failure
195 0           $errmsg = "Scan error #$code: $msg";
196 0           last SEARCH_DEMON;
197             }
198              
199 0 0         if($code > 10) { # infected; (disinfected: Should never happen!)
200 0           my $virus_name = '';
201 0 0         if(length $virii) {
    0          
202 0           $virus_name = $virii;
203             } elsif($msg =~ /^\tmessage:\s+(\S.*)/m) {
204 0           $virus_name = $1;
205             } else {
206              
207             # no virus name found, log message returned by fprot
208 0           $virus_name = 'unknown-FPROTD-virus';
209             }
210              
211 0           return File::VirusScan::Result->virus($virus_name);
212             }
213             ###### These codes are left to be handled:
214             # 3 X The object is not of a type the scanner knows. This
215             # may either mean it was misidentified or that it is
216             # corrupted.
217             # 4 X The object was valid, but encrypted and could not
218             # be scanned.
219             # 7 X The object was identified as an "innocent" object.
220             # 9 X The object was successfully scanned and nothing was
221              
222             # 9 is trival; 7 is probably trival
223             # 4 & 3 we can't do anything really, because if the attachement
224             # is some unknown archive format, the scanner wouldn't had known
225             # this issue anyway, hence, I consider it "clean"
226              
227 0           return File::VirusScan::Result->clean();
228             } # End SEARCH_DEMON
229              
230             # Could not connect to daemon or some error occured during the
231             # communication with it
232 0           $errmsg =~ s/\s*\.*\s*\n+\s*/\. /g;
233 0           return File::VirusScan::Result->error($errmsg);
234             }
235              
236             1;
237             __END__