[49] | 1 | # Perl fragment for spitting out the browse pane of dnsbl.cgi and for browse.cgi
|
---|
| 2 | # Module-ized because it's apparently (next to) impossible to do a C-style
|
---|
| 3 | # "#include <file>", and this doesn't fit well into the main DNSBL module.
|
---|
| 4 | ##
|
---|
| 5 | # $Id: DNSBL.pm 48 2014-12-09 21:29:34Z kdeugau $
|
---|
| 6 | # Copyright 2014 Kris Deugau <kdeugau@deepnet.cx>
|
---|
| 7 | #
|
---|
| 8 | # This program is free software: you can redistribute it and/or modify
|
---|
| 9 | # it under the terms of the GNU General Public License as published by
|
---|
| 10 | # the Free Software Foundation, either version 3 of the License, or
|
---|
| 11 | # (at your option) any later version.
|
---|
| 12 | #
|
---|
| 13 | # This program is distributed in the hope that it will be useful,
|
---|
| 14 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
|
---|
| 15 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
---|
| 16 | # GNU General Public License for more details.
|
---|
| 17 | #
|
---|
| 18 | # You should have received a copy of the GNU General Public License
|
---|
| 19 | # along with this program. If not, see <http://www.gnu.org/licenses/>.
|
---|
| 20 | ##
|
---|
| 21 |
|
---|
| 22 | package DNSBLweb;
|
---|
| 23 |
|
---|
[66] | 24 | use strict;
|
---|
| 25 | use warnings;
|
---|
| 26 |
|
---|
[49] | 27 | use Exporter;
|
---|
| 28 | use HTML::Template;
|
---|
| 29 | use NetAddr::IP;
|
---|
| 30 |
|
---|
| 31 | use DNSBL;
|
---|
| 32 |
|
---|
| 33 | sub retlvl {
|
---|
| 34 | my %ipseen;
|
---|
| 35 | my $dbh = shift;
|
---|
| 36 | my $dnsbl = shift;
|
---|
| 37 | my $lvl = shift;
|
---|
| 38 | if ($lvl > $DNSBL::maxlvl) {
|
---|
| 39 | warn "$lvl past max ".$DNSBL::maxlvl.", breaking off\n";
|
---|
| 40 | return;
|
---|
| 41 | }
|
---|
[57] | 42 | my $ret = '';
|
---|
[49] | 43 |
|
---|
| 44 | my %args = @_;
|
---|
[54] | 45 | $args{ipseen} = \%ipseen if !defined($args{ipseen});
|
---|
[49] | 46 | my $ip;
|
---|
| 47 | if ($args{ip}) {
|
---|
| 48 | $ip = $args{ip};
|
---|
| 49 | } else {
|
---|
| 50 | $ip = '0/0';
|
---|
| 51 | }
|
---|
| 52 | my $ipcidr = new NetAddr::IP $ip;
|
---|
[57] | 53 | if (!$args{block}) {
|
---|
| 54 | # Safety net - Don't try to return the entire dataset if we were only passed an IP that
|
---|
| 55 | # is not in a known block
|
---|
| 56 | ($args{block}) = $dbh->selectrow_array("SELECT block FROM blocks WHERE block >> ? AND level=0", undef, $ip);
|
---|
| 57 | return '' if !$args{block};
|
---|
| 58 | }
|
---|
| 59 | my $pblock = $args{block} || '0/0';
|
---|
[49] | 60 |
|
---|
[66] | 61 | my $basesql = "SELECT b.block,o.orgname,b.listme,o.listme,b.comments,o.comments,b.exclude ".
|
---|
[49] | 62 | "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
|
---|
| 63 | "WHERE b.block <<=";
|
---|
| 64 | my $allsth = $dbh->prepare($basesql."? AND b.level=? ORDER BY block");
|
---|
| 65 | my $sthiplist = $dbh->prepare("SELECT * FROM iplist WHERE ip <<= ? ORDER BY ip");
|
---|
| 66 | $allsth->execute($pblock,$lvl);
|
---|
[66] | 67 | while (my ($block,$org,$listmeb,$listmeo,$bcomments,$ocomments,$bexclude) = $allsth->fetchrow_array) {
|
---|
[49] | 68 | my $tmpl = new HTML::Template(filename => "browse-block.tmpl");
|
---|
| 69 | my $blockcidr = new NetAddr::IP $block;
|
---|
| 70 | $tmpl->param(lvlclass => "lvl$lvl".($dnsbl->autolist_block($block) ? " auto$lvl" : '').
|
---|
| 71 | ( $ipcidr->within($blockcidr) ? ' inhere' : ''));
|
---|
[66] | 72 | # exclude takes precedence over listme
|
---|
| 73 | $tmpl->param(netclass => ($bexclude ? 'exclude' : ($listmeb ? "b$lvl".'list' : '')));
|
---|
[49] | 74 | $tmpl->param(net => $block);
|
---|
| 75 | $tmpl->param(orgclass => ($listmeo ? "b$lvl".'org' : ''));
|
---|
| 76 | $tmpl->param(org => $org);
|
---|
| 77 | $tmpl->param(bcomment => $bcomments) if $bcomments;
|
---|
| 78 | $tmpl->param(ocomment => $ocomments) if $ocomments;
|
---|
| 79 | $tmpl->param(indent => ' 'x$lvl);
|
---|
[54] | 80 | $tmpl->param(subs => DNSBLweb::retlvl($dbh, $dnsbl, $lvl+1, block => $block, ip => $ip, ipseen => $args{ipseen}));
|
---|
[49] | 81 | $sthiplist->execute($block);
|
---|
| 82 | my @iprows;
|
---|
| 83 | while (my @data4 = $sthiplist->fetchrow_array) {
|
---|
[54] | 84 | next if $args{ipseen}->{$data4[0]};
|
---|
[49] | 85 | my %iprow;
|
---|
[66] | 86 | my @ipclass;
|
---|
[49] | 87 | $iprow{ip} = $data4[0];
|
---|
| 88 | $iprow{ipcount} = $data4[1];
|
---|
| 89 | $iprow{indent} = ' 'x$lvl;
|
---|
[66] | 90 | push @ipclass, 'repeater' if $ip eq $data4[0];
|
---|
| 91 | push @ipclass, 'exclude' if $data4[5];
|
---|
| 92 | $iprow{ipclass} = join(' ', @ipclass);
|
---|
| 93 | # ip | count | s4list | added | parent | exclude
|
---|
[49] | 94 | push @iprows, \%iprow;
|
---|
[54] | 95 | $args{ipseen}->{$data4[0]} = 1;
|
---|
[49] | 96 | }
|
---|
| 97 | $tmpl->param(iplist => \@iprows);
|
---|
| 98 | $ret .= $tmpl->output;
|
---|
| 99 | }
|
---|
| 100 | return $ret;
|
---|
| 101 | }
|
---|
| 102 |
|
---|
| 103 | # because Perl.
|
---|
| 104 | 1;
|
---|