Re: lastest uribl plugin

I was excited to see someone playing with my plugin so I worked some
tonight on integrating the changes in the modified plugin that Ed posted. 
I've attached the very latest iteration with *some* of the changes, and a
diff showing which I've applied.  I have some questions on the remaining
differences, if anyone (especially Ed) has the time and inclination to
discuss then great, otherwise I'll probably just use my best judgement and
post another iteration with all the changes integrated that make sense to
me.

Quoting the remaining diff of what I have *not* yet integrated:

> -require 'Qpsmtpd/tld_lists.pl';
> +# use Data::Dumper;
> +require '/home/smtpd/qpsmtpd/plugins/lib/tld_lists.pl';

I assume this change is specific to your local installation

> +$Data::Dumper::Terse = 1;          # don't output names where feasible
> +$Data::Dumper::Indent = 0;
>
>  our ( %firstlevel_tlds, %uribl_secondlevel_tlds, %uribl_thirdlevel_tlds,
>                          %surbl_secondlevel_tlds, %surbl_thirdlevel_tlds );
> @@ -234,6 +238,8 @@ for ( [ 2  => 'sc' ], [ 4  => 'ws' ], [
>      $z->{label} = "$z->{label} ($descr)";
>      delete $z->{masks};
>  }
> +#print "Dump #2";
> +#print Dumper($zones);

I assume this Data::Dumper stuff is leftover debug cruft

> -        push @lists, { label => "$list->{label} ($extra)",
> +        push @lists, { label => "$list->{label}",
>                          action => $z->{masks}->{$_}->{action} ||
$z->{action} };

This code is drastically changed now, I'm pretty sure in the latest
iteration this change isn't needed any longer

>  sub scan_mime_body {
>      my ( $self, $part ) = @_;
> +    $self->log(LOGDEBUG, "uribl: Scanning Mime Body");

scan_mime_body() is now a recursive sub (I think it was a bug that it
wasn't before...), so this logging could get out of hand.  How about:
@@ -770,8 +770,13 @@
         $self->{check_headers} = 'all' ? $txn->header->tags
                                        : split /,/, $self->{check_headers}
         if $self->{check_headers};
-    $txn->notes('mime_body') ? $self->scan_mime_body(
$txn->notes('mime_body') )
-                             : $self->scan_body( $txn );
+    if ( $txn->notes('mime_body') ) {
+        $self->log(LOGDEBUG, "uribl: Scanning MIME Body");
+        $self->scan_mime_body( $txn->notes('mime_body') )
+    } else {
+        $self->log(LOGDEBUG, "uribl: Scanning Plain Text Body");
+        $self->scan_body( $txn );
+    }
     if ( ! $self->{started_queries} and ! $self->{shortened} ) {
         $self->log(LOGINFO, "uribl: No URIs found in mail");
         return 0;

> -    return unless $part->effective_type ~~ [qw( text/plain text/html )];
> +    return unless $part->effective_type =~ [qw( text/plain text/html )];
> +    $self->log(LOGDEBUG, "uribl: Scanning Mime Body - text-html");

I don't think you really wanted '=~ [...]'; '~~ [...]' is a perl 5.10
smart match, I'm not really sure *what* '=~ [...]' would come to.  Perhaps
for the sake of < 5.10, it should lose the smart match and become
something like:

my $type = $part->effective_type;
return if $type ne 'text/plain' and $type ne 'text/html';
$self->log(LOGDEBUG, "uribl: Scanning MIME $type part");

> @@ -489,7 +497,27 @@ sub scan_body {
>      $self->log(LOGDEBUG, "uribl: Scanning Plain Text Body");
>      $txn->body_resetpos;
>      my $line;
> -    $self->find_uris($line) while ( $line = $txn->body_getline );
> +    my @qp_continuations;
> +
> +    while ( $line = $txn->body_getline ) {
> +        chomp $line;
> +        if ( $line =~ /(.*)=$/ ) {
> +            push @qp_continuations, $1;
> +            next;
> +        } elsif ( @qp_continuations ) {
> +            $line = join('', @qp_continuations, $1);
> +            @qp_continuations = ();
> +        }
> +
> +        $self->find_uris($line);
> +    }
> +
> +    if ( @qp_continuations ) {
> +        $self->log(LOGINFO, "uribl: WARNING: scan_body exiting with
line continuations left.  Bad Email?");
> +        $line = join('', @qp_continuations, $line);
> +        @qp_continuations = ();
> +        $self->find_uris($line);
> +    }
>  }

Just to clarify -- is this needed for scan_body() to even work?  Is it
tested? (we have hardly tested scan_body() since we basically always have
a mime_body)

> @@ -576,20 +604,19 @@ sub find_uris { # used by async plugin
>                               )
>                             //xo ) {
>                  # parameterized redirect
> -                my $addr = $1;
> +                $addr = $1;
>                  next if $addr =~ /@/;
> -                my $rev;

I understand what you're doing here, trying to re-use the existing $addr
and $rev rather than using new localized variables... I'd suggest keeping
the localized variables though, so that if anything is ever added after
this for loop, $addr and $rev aren't tainted.  Perhaps the localized vars
should be renamed to, say, $redir_addr and $redir_rev for the sake of
clarity?

> -                my $extra_host;
>                  if ( my $host = hostname( $addr ) ) {
>                      $addr = $host;
>                      # dash and underscore are allowed anywhere in
subdomains, but the dash seems to
>                      # also be commonly used as a delimiter in
parameterized redirects
> -                    $extra_host = hostname( $host ) if $host =~ s/^-.+-//;
> +                    my $extra_host = hostname( $host ) if $host =~
s/^-.+-//;

Notice that 'my $extra_host' here is scoped within the 'if' block, and
will immediately go out of scope...

>                  } else {
>                      ( $addr, $rev ) = ip( $addr );
>                  }
>                  next unless $addr;
>                  my ( $path ) = $p =~ /^\/(.+)([hH][tT][tT][pP])?/;
> +                my $extra_host;

I think you probably want to leave the $extra_host declaration where it
was, even if you get rid of the $addr and $rev localization.  As it
stands, $extra_host will never be anything but undef for all intents and
purposes.

> +    # Check if we should run or not
> +    my $options = $txn->notes('plug_options');
> +    return DECLINED if $self->qp->connection->notes('whitelisthost');
> +    return DECLINED if $txn->notes('whitelistsender');

Is this to do with your local installation, or is this standard QP stuff
that I've lost touch with?

> -    $self->log(LOGINFO, sprintf( "lookups: %2d zone, %2d A, %2d NS, %2d
shortener"
> -                               . "   matches: %2d   time: %.6f",
> -                                 ( map {
$self->{queries_completed}->{$_} }
> -                                   qw( uri a ns shortener ) ),
> -                                 scalar @{ $self->{matches} || [] },
> -                                 time() - $self->{start_time} ));
> +#    $self->log(LOGINFO, sprintf( "lookups: %2d zone, %2d A, %2d NS,
%2d shortener"
> +#                               . "   matches: %2d   time: %.6f",
> +#                                 ( map {
$self->{queries_completed}->{$_} }
> +#                                   qw( uri a ns shortener ) ),
> +#                                 scalar @{ $self->{matches} || [] },
> +#                                 time() - $self->{start_time} ));

Perhaps this should be LOGDEBUG?

-Jared

--- uribl	2011-01-20 00:37:12.331973003 -0600
+++ /home/jaredj/svn/trunk/dc-smtpd/plugins/uribl	2011-01-20 00:25:39.591973003 -0600
@@ -424,7 +424,8 @@
     for ( 2 .. $#h + 1 ) {
         my $subhost = join( '.', @h[ -$_ .. -1 ] );
         next unless exists $self->{whitelist_zones}->{$subhost};
-        $self->log(LOGINFO, "Skipping whitelist URI domain '$hostname' ('$subhost' whitelisted)");
+        $self->log(LOGINFO, "uribl: Skipping whitelist URI domain '$hostname'"
+                          . " ('$subhost' whitelisted)");
         return 1;
     }
     return 0;
@@ -453,11 +454,11 @@
     my $key = "$q->{zone}|$querystring|$type";
     return if exists $self->{queries}->{$key};
     $self->{queries}->{$key} = undef;
-    $self->log(LOGDEBUG,"Looking up $type record for '$querystring'");
+    $self->log(LOGDEBUG,"uribl: Looking up $type record for '$querystring'");
     eval { $self->{dns}->add( $cb, $querystring, $type );
            $self->{started_queries}++ };
     return 1 unless $@;
-    $self->log(LOGERROR, "Couldn't open socket for $type record '$querystring': $@");
+    $self->log(LOGERROR, "uribl: Couldn't open socket for $type record '$querystring': $@");
     return 0;
 }
 
@@ -472,7 +473,7 @@
         # Get a list of one or more masks that were hit in a given zone
         # (or the zone itself if no mask was configured)
         my @l = $self->evaluate( $z, $address ) or next;
-        $self->log(LOGDEBUG, "match in $z");
+        $self->log(LOGDEBUG, "uribl: match in $z");
         $lists{ $_->{label} } = $_ for @l;
         $q->{a} ||= $address;
     }
@@ -568,6 +569,7 @@
 
 sub scan_body {
     my ( $self, $txn ) = @_;
+    $self->log(LOGDEBUG, "uribl: Scanning Plain Text Body");
     $txn->body_resetpos;
     my $line;
     my @qp_continuations;
@@ -643,7 +645,7 @@
         # itself, but we'll try to resolve URL it points to
         if ( $self->{resolve_shortened_uris} and exists $shorteners{$addr} ) {
             if ( $path and ! exists $self->{shortened}->{"$addr|$path"} ) {
-                $self->log(LOGDEBUG, "Found shortened URI $addr/$path");
+                $self->log(LOGDEBUG, "uribl: Found shortened URI $addr/$path");
                 $self->{shortened}->{"$addr|$path"} = { host => $addr, path => $path };
             }
         } elsif ( ! exists $self->{pending}->{$addr} ) {
@@ -691,7 +693,7 @@
                 for ( $addr, $extra_host ? $extra_host : () ) {
                     if ( $self->{resolve_shortened_uris} and exists $shorteners{$addr} ) {
                         if ( $path and ! exists $self->{shortened}->{"$_|$path"} ) {
-                            $self->log(LOGDEBUG, "Found shortend URI $_/$path");
+                            $self->log(LOGDEBUG, "uribl: Found shortend URI $_/$path");
                             $self->{shortened}->{"$_|$path"} = { host => $_, path => $path };
                         }
                     } elsif ( ! exists $self->{pending}->{$_} ) {
@@ -771,7 +773,7 @@
     $txn->notes('mime_body') ? $self->scan_mime_body( $txn->notes('mime_body') )
                              : $self->scan_body( $txn );
     if ( ! $self->{started_queries} and ! $self->{shortened} ) {
-        $self->log(LOGINFO, "No URIs found in mail");
+        $self->log(LOGINFO, "uribl: No URIs found in mail");
         return 0;
     }
     return 1;
@@ -780,7 +782,7 @@
 sub data_handler { # NOT used by async plugin
     my ( $self, $txn ) = @_;
     $self->cleanup();
-    return NEXT unless $self->scan_message( $txn );
+    return DECLINED unless $self->scan_message( $txn );
     my @r;
     eval {
         local $SIG{ALRM} = sub { die "Timed out after $self->{global_timeout} seconds!\n"; };
@@ -789,17 +791,17 @@
         @r = $self->check_results;
         # Resolving shortned URIs is more expensive than regular queries;
         # don't bother if we already found a reason to reject
-        if ( $r[0] == NEXT and $self->resolve_shortened_uris ) {
+        if ( $r[0] == DECLINED and $self->resolve_shortened_uris ) {
             $self->{dns}->await() if $self->{dns};
             @r = $self->check_results;
         }
     };
     alarm 0;
     if ( $@ ) {
-        $self->log(LOGERROR, $@);
+        $self->log(LOGERROR, "uribl: $@");
         @r = $self->check_results unless @r;
     }
-    $self->log(LOGINFO, sprintf( "lookups: %2d zone, %2d TXT, %2d A, %2d NS, %2d shortener"
+    $self->log(LOGINFO, sprintf( "uribl: lookups: %2d zone, %2d TXT, %2d A, %2d NS, %2d shortener"
                                . "   matches: %2d   time: %.6f",
                                  ( map { $self->{queries_completed}->{$_} }
                                    qw( uri txt a ns shortener ) ),
@@ -814,7 +816,8 @@
     for ( grep { exists $broken_shorteners{$_} }
           map { $lookup->{$_}->{host} }
           keys %$lookup ) {
-        $self->log(LOGNOTICE, "Can't look up unsupported URI shortener $lookup->{$_}->{host}");
+        $self->log(LOGNOTICE, "uribl: Can't look up unsupported URI shortener"
+                            . " $lookup->{$_}->{host}");
         delete $lookup->{$_};
     }
     return unless %$lookup;
@@ -848,7 +851,8 @@
                     next unless m{^Location: http://(?:[wW]{3}\.)?([a-zA-Z0-9.-]+)};
                     my $addr = $1;
                     $found = 1;
-                    $self->log(LOGDEBUG, "Sending query from shortened URI (via $L->{host}): $1");
+                    $self->log(LOGDEBUG, "uribl: Sending query from shortened URI"
+                                       . " (via $L->{host}): $1");
                     if ( $addr =~ /[^\d.]/ ) { # hostname
                         $self->send_queries( $addr );
                     } else { # IP address
@@ -858,7 +862,8 @@
                     push @uribl_queries_sent, $addr;
                     last;
                 }
-                $self->log(LOGNOTICE, "Couldn't resolve shortened URI $L->{host}/$L->{path}")
+                $self->log(LOGNOTICE, "uribl: Couldn't resolve shortened URI"
+                                    . " $L->{host}/$L->{path}")
                     unless $found;
                 $receive->remove($sock);
                 delete $sockets->{$sock};
@@ -876,7 +881,7 @@
     while ( my $q = shift @{ $self->{matches} || [] } ) {
         for ( @{ $q->{lists} } ) {
             my $desc = "$q->{name} found in $_->{label}";
-            $self->log(LOGWARN, $desc);
+            $self->log(LOGWARN, "uribl: $desc");
             $desc .= ": $q->{txt}" if $q->{txt};
             if ( $_->{action} eq 'add-header' ) {
                 $txn->header->add('X-URIBL-Match', $desc);
@@ -887,6 +892,6 @@
             }
         }
     }
-    return NEXT;
+    return DECLINED;
 }