You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775
  1. #
  2. # SpamAssassin SNF4SA Plugin for SNFServer.
  3. #
  4. # This plugin implements a SpamAssassin rule to use SNFServer to test
  5. # whether an email is spam.
  6. #
  7. # Copyright (C) 2009 ARM Research Labs, LLC.
  8. #
  9. # snf4sa.pm
  10. #
  11. # The plugin implements a single evaluation rule, which passes the
  12. # email message through SNFServer. The communication with SNFServer
  13. # is through XCI and a temporary file on disk which contains the email
  14. # message truncated to the frist 64K bytes.
  15. #
  16. package Snf4sa;
  17. use strict;
  18. use Mail::SpamAssassin;
  19. use Mail::SpamAssassin::Plugin;
  20. use Mail::SpamAssassin::PerMsgStatus;
  21. use Mail::SpamAssassin::Logger;
  22. use IO::Socket;
  23. use IO::File;
  24. use File::Temp qw/ tempfile tempdir /;
  25. our @ISA = qw(Mail::SpamAssassin::Plugin);
  26. # Convenience variables and pseudo-constants
  27. my $CRLF = "\x0d\x0a";
  28. # translation table for SNF rule codes
  29. my $rule_code_xlat = {
  30. 0 => 'Standard White Rules',
  31. 20 => 'GBUdb Truncate (superblack)',
  32. 40 => 'GBUdb Caution (suspicious)',
  33. 47 => 'Travel',
  34. 48 => 'Insurance',
  35. 49 => 'Antivirus Push',
  36. 50 => 'Media Theft',
  37. 51 => 'Spamware',
  38. 52 => 'Snake Oil',
  39. 53 => 'Scam Patterns',
  40. 54 => 'Porn/Adult',
  41. 55 => 'Malware & Scumware Greetings',
  42. 56 => 'Ink & Toner',
  43. 57 => 'Get Rich',
  44. 58 => 'Debt & Credit',
  45. 59 => 'Casinos & Gambling',
  46. 60 => 'Ungrouped Black Rules',
  47. 61 => 'Experimental Abstract',
  48. 62 => 'Obfuscation Techniques',
  49. 63 => 'Experimental Received [ip]',
  50. };
  51. sub new {
  52. my ($class, $mailsa) = @_;
  53. $class = ref($class) || $class;
  54. my $self = $class->SUPER::new($mailsa);
  55. bless ($self, $class);
  56. # Name of evaluation rule.
  57. $self->register_eval_rule ("snf4sa_sacheck");
  58. # Use localhost.
  59. $self->{SNF_Host} = "localhost";
  60. # Use default port.
  61. $self->{SNF_Port} = 9001;
  62. # Timeout.
  63. $self->{SNF_Timeout} = 1;
  64. # Directory for files containing emails read by SNFServer.
  65. $self->{Temp_Dir} = '/tmp/snf4sa';
  66. # Maximum email message size (including headers).
  67. $self->{SNF_MaxTempFileSize} = 64 * 1024;
  68. # Key for confidence in mail header inserted by SNFServer.
  69. $self->{GBUdb_ConfidenceKey} = "c=";
  70. # Key for probability in mail header inserted by SNFServer.
  71. $self->{GBUdb_ProbabilityKey} = "p=";
  72. # Key for GBUdb maximum weight in the configuration file.
  73. $self->{GBUdb_MaxWeightKey} = "gbudb_max_weight";
  74. # Key for SNFServer code in configuration file.
  75. $self->{SNF_CodeKey} = "snf_result";
  76. # Key for SA score increment in configuration file.
  77. $self->{SA_DeltaScoreKey} = "sa_score";
  78. # Key for short circuit in configuration file.
  79. $self->{SA_ShortCircuitYesKey} = "short_circuit_yes";
  80. # Key for no short circuit in configuration file.
  81. $self->{SA_ShortCircuitNoKey} = "short_circuit_no";
  82. # Key for plugin score threshold in the configuration file.
  83. $self->{Plugin_score_thresholdKey} = "pre_3.2_plugin_score_threshold";
  84. return $self;
  85. }
  86. # DEBUG/TEST.
  87. #sub extract_metadata {
  88. #
  89. # my ($self, $opts) = @_;
  90. #
  91. # print "***********************\n";
  92. # print "extract_metadata called\n";
  93. # print "***********************\n";
  94. #
  95. # $opts->{msg}->put_metadata("X-Extract-Metadata:", "Test header");
  96. #
  97. #}
  98. # END OF DEBUG/TEST.
  99. sub have_shortcircuited {
  100. my ($self, $options) = @_;
  101. if (defined($options->{permsgstatus}->{shortCircuit})) {
  102. return $options->{permsgstatus}->{shortCircuit};
  103. }
  104. return 0;
  105. }
  106. sub parse_config {
  107. my ($self, $options) = @_;
  108. # DEBUG.
  109. #print "parse_confg. key: $options->{key}\n";
  110. #print "parse_config. line: $options->{line}\n";
  111. #print "parse_config. value: $options->{value}\n";
  112. #END OF DEBUG.
  113. # Process GBUdb_max_weight.
  114. if (lc($options->{key}) eq $self->{GBUdb_MaxWeightKey}) {
  115. # GBUdb maximum weight.
  116. my $tempValue = $options->{value};
  117. # Test that the value was a number.
  118. #$self->log_debug("Found $self->{GBUdb_MaxWeightKey} . " value: $options->{value}, tempValue: $tempValue\n"; # DEBUG.
  119. if ($tempValue =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
  120. # Value was a number. Load and return success.
  121. $options->{conf}->{gbuDbMaxWeight} = $tempValue;
  122. $self->inhibit_further_callbacks();
  123. return 1;
  124. } else {
  125. $self->log_debug("Invalid value for $self->{GBUdb_MaxWeightKey} " .
  126. $tempValue);
  127. }
  128. } elsif (lc($options->{key}) eq $self->{Plugin_score_thresholdKey}) {
  129. # Plugin score threshold.
  130. my $tempValue = $options->{value};
  131. # Test that the value was a number.
  132. #print "Found $self->{Plugin_score_thresholdKey} value: $options->{value}\n"; # DEBUG.
  133. if ($tempValue =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
  134. # Value was a number. Load and return success.
  135. $options->{conf}->{pluginScoreThreshold} = $tempValue;
  136. $self->inhibit_further_callbacks();
  137. return 1;
  138. } else {
  139. $self->log_debug("Invalid value for $self->{Plugin_score_thresholdKey} " .
  140. $tempValue);
  141. }
  142. } elsif (lc($options->{key}) eq $self->{SNF_CodeKey}) {
  143. # Relationship between SNFServer code and SA score delta.
  144. my $snf = $self->parse_snf_sa_mapping($options);
  145. if (defined($snf)) {
  146. my @snfCode = @{$snf->{snfCode}};
  147. #print "snf->{snfCode}: @snfCode\n"; # DEBUG.
  148. #print "snf->{deltaScore}: $snf->{deltaScore}\n"; # DEBUG.
  149. #print "snf->{shortCircuit}: $snf->{shortCircuit}\n"; # DEBUG.
  150. # Save configuration.
  151. foreach my $i (@{$snf->{snfCode}}) {
  152. # Create (or update) an element in the mapping array
  153. # that snfSaMapping is a reference to.
  154. $options->{conf}->{snfSaMapping}->[$i] = {
  155. deltaScore => $snf->{deltaScore},
  156. shortCircuit => $snf->{shortCircuit}
  157. };
  158. }
  159. # DEBUG.
  160. #for (my $i = 0; $i < @{$options->{conf}->{snfSaMapping}}; $i++) {
  161. # if (! defined($options->{conf}->{snfSaMapping}->[$i])) {
  162. # print "No configuration for SNFServer code $i\n";
  163. # next;
  164. # }
  165. # print "SNFServer code: $i, " .
  166. # "deltaScore: " .
  167. # "$options->{conf}->{snfSaMapping}->[$i]->{deltaScore}, " .
  168. # "shortCircuit: " .
  169. # "$options->{conf}->{snfSaMapping}->[$i]->{shortCircuit}\n";
  170. #}
  171. # END OF DEBUG.
  172. # Successfully parsed.
  173. $self->inhibit_further_callbacks();
  174. return 1;
  175. }
  176. }
  177. # Wasn't handled.
  178. return 0;
  179. }
  180. # Parse a snf_result configuration line.
  181. #
  182. # Input--
  183. #
  184. # $line--String containing the snf_result line without the first word.
  185. #
  186. # Returns a reference with the following fields (if no error)--
  187. #
  188. # snfCode--Array of SNFServer result codes that this configuration
  189. # line specifies.
  190. #
  191. # deltaScore--SA score increment for the codes in @snfCode.
  192. #
  193. # shortCircuit--True if a SNFServer code in @snfCode is to
  194. # short-circuit the message scan, false otherwise.
  195. #
  196. # If the line cannot be parsed, the return value is undef.
  197. #
  198. sub parse_snf_sa_mapping
  199. {
  200. my ($self, $options) = @_;
  201. my $value = $options->{value};
  202. my $ret_hash = {
  203. snfCode => undef,
  204. deltaScore => undef,
  205. shortCircuit => undef
  206. };
  207. # SNFServer codes found.
  208. my @snfCode = ();
  209. # Remove leading and trailing whitespace.
  210. $value =~ s/^\s+//;
  211. $value =~ s/\s+$//;
  212. # Convert to lower case.
  213. $value = lc($value);
  214. # Split up by white space.
  215. my @specVal = split(/\s+/, $value);
  216. if (0 == @specVal) {
  217. # No separate words.
  218. $self->log_debug("No separate words found in configuration line '" .
  219. $options->{line} . "'");
  220. return undef;
  221. }
  222. # Convert each SNFServer result specification into an integer.
  223. my $lastSpec;
  224. for ($lastSpec = 0; $lastSpec < @specVal; $lastSpec++) {
  225. # Check for next keyword.
  226. if ($specVal[$lastSpec] eq $self->{SA_DeltaScoreKey}) {
  227. # We've completed the processing of the SNFServer result
  228. # codes.
  229. last;
  230. }
  231. # Get the code values.
  232. my @codeVal = $self->get_code_values($specVal[$lastSpec]);
  233. if (0 == @codeVal) {
  234. # No code values were obtained.
  235. $self->log_debug("Couldn't parse all the SNFServer code values " .
  236. "in configuration line '" .
  237. $options->{line} . "'");
  238. return undef;
  239. }
  240. # Add to the list of codes.
  241. @snfCode = (@snfCode, @codeVal);
  242. }
  243. # Sort the SNFServer result codes and remove duplicates.
  244. @snfCode = sort { $a <=> $b } @snfCode;
  245. my $prev = -1;
  246. my @temp = grep($_ != $prev && (($prev) = $_), @snfCode);
  247. $ret_hash->{snfCode} = \@temp;
  248. # The $specVal[$lastSpec] is $self->{SA_DeltaScoreKey}. Return if
  249. # there aren't enough parameters.
  250. $lastSpec++;
  251. if ($lastSpec >= @specVal) {
  252. # Not enough parameters.
  253. $self->log_debug("Not enough parameters in configuration line '" .
  254. $options->{line} . "'");
  255. return undef;
  256. }
  257. # Extract the SA delta score.
  258. $ret_hash->{deltaScore} = $specVal[$lastSpec];
  259. if (!($ret_hash->{deltaScore} =~
  260. /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/)) {
  261. # SA delta score isn't a number.
  262. $self->log_debug("Value after '" . $self->{SA_DeltaScoreKey} .
  263. "' ($specVal[$lastSpec]) must be a number " .
  264. "in configuration line '" .
  265. $options->{line} . "'");
  266. return undef;
  267. }
  268. # Get short circuit spec.
  269. $lastSpec++;
  270. $ret_hash->{shortCircuit} = 0;
  271. if ( ($lastSpec + 1) == @specVal) {
  272. # A parameter was specified.
  273. my $shortCircuitSpec = $specVal[$lastSpec];
  274. if ($self->{SA_ShortCircuitYesKey} eq $shortCircuitSpec) {
  275. # Specified short-circuit evaluation.
  276. $ret_hash->{shortCircuit} = 1;
  277. } elsif ($self->{SA_ShortCircuitNoKey} ne $shortCircuitSpec) {
  278. # Invalid short-circuit specification.
  279. $self->log_debug("Invalid short-circuit specification: '" .
  280. $specVal[$lastSpec] .
  281. "' in configuration line '" . $options->{line} .
  282. "'. Must be '$self->{SA_ShortCircuitYesKey}' " .
  283. " or '$self->{SA_ShortCircuitNoKey}'.");
  284. return undef;
  285. }
  286. } elsif ($lastSpec != @specVal) {
  287. # Too many parameters were specified.
  288. $self->log_debug("Too many parameters were specified in " .
  289. "configuration line '" . $options->{line} . "'");
  290. return undef;
  291. }
  292. return $ret_hash;
  293. }
  294. sub get_code_values
  295. {
  296. my ($self, $specElement) = @_;
  297. my @snfCode = ();
  298. # Split the specification.
  299. my @codeVal = split(/-/, $specElement);
  300. if (1 == @codeVal) {
  301. if ($specElement =~ /^\d+$/) {
  302. # Found a single code.
  303. $snfCode[0] = 1 * $specElement;
  304. }
  305. } elsif (2 == @codeVal) {
  306. # Check range.
  307. if ( ($codeVal[0] =~ /^\d+$/) && ($codeVal[1] =~ /^\d+$/) ) {
  308. # Found a range of codes.
  309. $codeVal[0] = 1 * $codeVal[0];
  310. $codeVal[1] = 1 * $codeVal[1];
  311. if ($codeVal[0] <= $codeVal[1]) {
  312. # Add these SNF codes.
  313. for (my $i = $codeVal[0]; $i <= $codeVal[1]; $i++) {
  314. push(@snfCode, $i);
  315. }
  316. }
  317. }
  318. }
  319. return @snfCode;
  320. }
  321. # Output a debug message.
  322. #
  323. # Input--
  324. #
  325. # $message--String containing the message to output.
  326. #
  327. sub log_debug
  328. {
  329. my ($self, $message) = @_;
  330. dbg("snf4sa: $message");
  331. }
  332. # Check the message with SNFServer.
  333. sub snf4sa_sacheck {
  334. my ($self, $permsgstatus, $fulltext) = @_;
  335. my $response ='';
  336. my $exitvalue;
  337. # Make sure we have a temp dir
  338. unless(-d $self->{Temp_Dir}) {
  339. mkdir($self->{Temp_Dir});
  340. chmod(0777, $self->{Temp_Dir});
  341. };
  342. # Truncate the message.
  343. my $mailtext = substr( ${$fulltext}, 0, $self->{SNF_MaxTempFileSize});
  344. # create our temp file, $filename will contain the full path
  345. my ($fh, $filename) = tempfile( DIR => $self->{Temp_Dir} );
  346. # spew our mail into the temp file
  347. my $SNF_fh = IO::File->new( $filename, "w" ) ||
  348. die(__PACKAGE__ . ": Unable to create temporary file '" . $filename . "'");
  349. $SNF_fh->print($mailtext) ||
  350. $self->cleanup_die($filename,
  351. __PACKAGE__ . ": Unable to write to temporary file '" .
  352. $filename . "'");
  353. $SNF_fh->close ||
  354. $self->cleanup_die($filename,
  355. __PACKAGE__ . ": Unable to close temporary file '" .
  356. $filename . "'");
  357. # Change permissions.
  358. my $cnt = chmod(0666, $filename) ||
  359. $self->cleanup_die($filename, __PACKAGE__ .
  360. ": Unable to change permissions of temporary file '" .
  361. $filename . "'");
  362. # xci_scan connects to SNFServer with XCI to scan the message
  363. my $SNF_XCI_Return = $self->xci_scan( $filename );
  364. #print "header:\n\n$SNF_XCI_Return->{header}\n\n"; # DEBUG
  365. # Remove the temp file, we are done with it.
  366. unlink($filename);
  367. # Check response from SNFServer.
  368. if (! $SNF_XCI_Return ) {
  369. die(__PACKAGE__ . ": Internal error");
  370. }
  371. # Check for success.
  372. if (! $SNF_XCI_Return->{"success"}) {
  373. die(__PACKAGE__ . ": Error from SNFServer: " .
  374. $SNF_XCI_Return->{"message"});
  375. }
  376. # get the return code and translation
  377. my ( $rc, $rcx ) = ( $SNF_XCI_Return->{"code"},
  378. $rule_code_xlat->{ $SNF_XCI_Return->{"code"} } );
  379. $rc = -1 unless defined $rc; # default values
  380. $rcx = 'Unknown' unless $rcx;
  381. my $rch = $SNF_XCI_Return->{"header"}; # the SNF header(s)
  382. # DEBUG.
  383. # for (my $i = 0; $i < @{$permsgstatus->{main}->{conf}->{snfSaMapping}}; $i++) {
  384. # if (! defined($permsgstatus->{main}->{conf}->{snfSaMapping}->[$i])) {
  385. # print "No configuration for SNFServer code $i\n";
  386. # next;
  387. # }
  388. # print "SNFServer code: $i, " .
  389. # "deltaScore: " .
  390. # "$permsgstatus->{main}->{conf}->{snfSaMapping}->[$i]->{deltaScore}, " .
  391. # "shortCircuit: " .
  392. # "$permsgstatus->{main}->{conf}->{snfSaMapping}->[$i]->{shortCircuit}\n";
  393. # }
  394. # END OF DEBUG.
  395. # Initialize the change in the SA score.
  396. my $deltaScore = 0.0;
  397. # Add the score from the SNFServer return.
  398. if (defined($permsgstatus->{main}->{conf}->{snfSaMapping}->[$rc])) {
  399. $deltaScore +=
  400. $permsgstatus->{main}->{conf}->{snfSaMapping}->[$rc]->{deltaScore};
  401. $permsgstatus->{shortCircuit} =
  402. $permsgstatus->{main}->{conf}->{snfSaMapping}->[$rc]->{shortCircuit};
  403. }
  404. # Perform GBUdb processing.
  405. if (defined($permsgstatus->{main}->{conf}->{gbuDbMaxWeight})) {
  406. #print "gbudbMaxWeight: $permsgstatus->{main}->{conf}->{gbuDbMaxWeight}\n\n"; # DEBUG.
  407. # Calculate the contribution to the scrore from the GBUdb results.
  408. $deltaScore +=
  409. $self->calc_GBUdb($SNF_XCI_Return->{header},
  410. $permsgstatus->{main}->{conf}->{gbuDbMaxWeight});
  411. }
  412. # Add the headers.
  413. $permsgstatus->set_tag("SNFRESULTTAG", "$rc ($rcx)");
  414. $permsgstatus->set_tag("SNFMESSAGESNIFFERSCANRESULT",
  415. $self->extract_header_body($SNF_XCI_Return->{header},
  416. "X-MessageSniffer-Scan-Result"));
  417. $permsgstatus->set_tag("SNFMESSAGESNIFFERRULES",
  418. $self->extract_header_body($SNF_XCI_Return->{header},
  419. "X-MessageSniffer-Rules"));
  420. $permsgstatus->set_tag("SNFGBUDBANALYSIS",
  421. $self->extract_header_body($SNF_XCI_Return->{header},
  422. "X-GBUdb-Analysis"));
  423. # If dynamic scoring isn't supported, this rule fires if the score is
  424. # above the threshold.
  425. if (Mail::SpamAssassin::Version() le "3.2.0") {
  426. my $pluginScoreThreshold = 2.5; # Default value.
  427. if (defined($permsgstatus->{main}->{conf}->{pluginScoreThreshold})) {
  428. $pluginScoreThreshold = $permsgstatus->{main}->{conf}->{pluginScoreThreshold};
  429. }
  430. #print "Before comparison. pluginScoreThreshold: $pluginScoreThreshold deltaScore: $deltaScore\n"; # DEBUG
  431. if ($deltaScore < $pluginScoreThreshold) {
  432. $deltaScore = 0.0;
  433. }
  434. }
  435. # print "After comparison. deltaScore: $deltaScore\n"; # DEBUG
  436. # Submit the score.
  437. if ($deltaScore) {
  438. $permsgstatus->got_hit("SNF4SA", "", score => $deltaScore);
  439. for my $set (0..3) {
  440. $permsgstatus->{conf}->{scoreset}->[$set]->{"SNF4SA"} =
  441. sprintf("%0.3f", $deltaScore);
  442. }
  443. }
  444. # Always return zero, since the score was submitted via got_hit()
  445. # above.
  446. return 0;
  447. }
  448. # Calculate the contribution of the GBUdb scan to the SA score.
  449. #
  450. # Input--
  451. #
  452. # $headers--String containing the headers.
  453. #
  454. # $weight--Weight used to calculate the contribution.
  455. #
  456. # Returns the contribution to the SA score (float).
  457. #
  458. sub calc_GBUdb
  459. {
  460. my ( $self, $headers, $weight ) = @_;
  461. # Split the header into lines.
  462. my @headerLine = split(/\n/, $headers);
  463. # Find the line containing the GBUdb results.
  464. my $line;
  465. foreach $line (@headerLine) {
  466. # Search for the tag.
  467. if ($line =~ /^X-GBUdb-Analysis:/) {
  468. # GBUdb analysis was done. Extract the values.
  469. my $ind0 = index($line, $self->{GBUdb_ConfidenceKey});
  470. my $ind1 = index($line, " ", $ind0 + 2);
  471. if (-1 == $ind0) {
  472. return 0.0;
  473. }
  474. my $c = 1.0 * substr($line, $ind0 + 2, $ind1 - $ind0 - 2);
  475. #print "calc_GBUdb. line: $line\n"; # DEBUG
  476. #print "calc_GBUdb. c: $c, ind0: $ind0, ind1: $ind1\n"; # DEBUG
  477. $ind0 = index($line, $self->{GBUdb_ProbabilityKey});
  478. $ind1 = index($line, " ", $ind0 + 2);
  479. if (-1 == $ind0) {
  480. return 0.0;
  481. }
  482. my $p = 1.0 * substr($line, $ind0 + 2, $ind1 - $ind0 - 2);
  483. #print "calc_GBUdb. p: $p, ind0: $ind0, ind1: $ind1\n"; # DEBUG
  484. # Calculate and return the score.
  485. my $score = abs($p * $c) ** 0.5;
  486. $score *= $weight;
  487. if ($p < 0.0) {
  488. $score *= -1.0;
  489. }
  490. # DEBUG.
  491. #print "calc_GBUdb. p: $p, c: $c, weight: $weight\n";
  492. #print "calc_GBUdb. score: $score\n";
  493. # END OF DEBUG.
  494. return $score;
  495. }
  496. }
  497. }
  498. # Extract the specified header body from a string containing all the
  499. # headers.
  500. #
  501. # Input--
  502. #
  503. # $headers--String containing the headers.
  504. #
  505. # $head--String containing the head of the header to extract.
  506. #
  507. # Returns the body of the header.
  508. #
  509. sub extract_header_body
  510. {
  511. my ( $self, $headers, $head ) = @_;
  512. my $body = "";
  513. if ($headers =~ /$head:(.*)/s) {
  514. my $temp = $1;
  515. $temp =~ /(.*)\nX-(.*)/s;
  516. $body = $1;
  517. }
  518. return $body;
  519. }
  520. # xci_scan( $file )
  521. # returns hashref:
  522. # success : true/false
  523. # code : response code from SNF
  524. # message : scalar message (if any)
  525. sub xci_scan
  526. {
  527. my ( $self, $file ) = @_;
  528. return undef unless $self and $file;
  529. my $ret_hash = {
  530. success => undef,
  531. code => undef,
  532. message => undef,
  533. header => undef,
  534. xml => undef
  535. };
  536. my $xci = $self->connect_socket( $self->{SNF_Host}, $self->{SNF_Port} )
  537. or return $self->err_hash("cannot connect to socket ($!)");
  538. $xci->print("<snf><xci><scanner><scan file='$file' xhdr='yes' /></scanner></xci></snf>\n");
  539. my $rc = $ret_hash->{xml} = $self->socket_response($xci, $file);
  540. $xci->close;
  541. if ( $rc =~ /^<snf><xci><scanner><result code='(\d*)'>/ ) {
  542. $ret_hash->{success} = 1;
  543. $ret_hash->{code} = $1;
  544. $rc =~ /<xhdr>(.*)<\/xhdr>/s and $ret_hash->{header} = $1;
  545. } elsif ( $rc =~ /^<snf><xci><error message='(.*)'/ ) {
  546. $ret_hash->{message} = $1;
  547. } else {
  548. $ret_hash->{message} = "unknown XCI response: $rc";
  549. }
  550. return $ret_hash;
  551. }
  552. # connect_socket( $host, $port )
  553. # returns IO::Socket handle
  554. sub connect_socket
  555. {
  556. my ( $self, $host, $port ) = @_;
  557. return undef unless $self and $host and $port;
  558. my $protoname = 'tcp'; # Proto should default to tcp but it's not expensive to specify
  559. $self->{XCI_Socket} = IO::Socket::INET->new(
  560. PeerAddr => $host,
  561. PeerPort => $port,
  562. Proto => $protoname,
  563. Timeout => $self->{SNF_Timeout} ) or return undef;
  564. $self->{XCI_Socket}->autoflush(1); # make sure autoflush is on -- legacy
  565. return $self->{XCI_Socket}; # return the socket handle
  566. }
  567. # socket_response( $socket_handle )
  568. # returns scalar string
  569. sub socket_response
  570. {
  571. my ( $self, $rs, $file ) = @_;
  572. my $buf = ''; # buffer for response
  573. # blocking timeout for servers who accept but don't answer
  574. eval {
  575. local $SIG{ALRM} = sub { die "timeout\n" }; # set up the interrupt
  576. alarm $self->{SNF_Timeout}; # set up the alarm
  577. while (<$rs>) { # read the socket
  578. $buf .= $_;
  579. }
  580. alarm 0; # reset the alarm
  581. };
  582. # report a blocking timeout
  583. if ( $@ eq "timeout\n" ) {
  584. $self->cleanup_die($file,
  585. __PACKAGE__ . ": Timeout waiting for response from SNFServer");
  586. } elsif ( $@ =~ /alarm.*unimplemented/ ) { # no signals on Win32
  587. while (<$rs>) { # get whatever's left
  588. # in the socket.
  589. $buf .= $_;
  590. }
  591. }
  592. return $buf;
  593. }
  594. # return an error message for xci_scan
  595. sub err_hash
  596. {
  597. my ( $self, $message ) = @_;
  598. return {
  599. success => undef,
  600. code => undef,
  601. message => $message
  602. };
  603. }
  604. sub cleanup_die
  605. {
  606. my ( $self, $file, $message ) = @_;
  607. unlink($file);
  608. die($message);
  609. }
  610. 1;