Bug#359905: PTS: unsubscription fraud possible

[MJ Ray <mjr@phonecoop.coop>]

tag 359905 + patch
stop

Raphael Hertzog <hertzog@debian.org>
> > > The best solution would be be to implement the bounce handler (with
> > > VERP-like headers) but an intermediary solution would be to extract the
> > > unsubscription code into a stand-alone perl script that I can call on
> > > master directly.

Patch for intermediary solution follows. Requires review/test
because my system here isn't compatible. Hope it helps.

By the way, doing lc($address) may be a bug, strictly speaking.
Local parts need not be case-insensitive (but should be).
See RFC 2821 "Simple Mail Transfer Protocol" section 2.4
"General Syntax Principles and Transaction Model"

> > I probably need to understand how mail gets into the system
> > better before I can see how to prepare the bounce handler.
> 
> That's easy to check. Login in master and check
> /org/packages.qa.debian.org/mail/.

I don't understand how that could do per-user bounce headers.

BEGIN PATCH:

Index: bin/control.pl
===================================================================
RCS file: /cvs/qa/pts/bin/control.pl,v
retrieving revision 1.12
diff -u -r1.12 control.pl
--- bin/control.pl	24 Feb 2006 04:05:45 -0000	1.12
+++ bin/control.pl	12 Apr 2006 10:28:03 -0000
@@ -97,13 +97,10 @@
 	my @explanation;
 	($package, @explanation) = map_package($package);
 	push @ans, @explanation;
-	if (unsubscribe($address, $package)) {
-	    push @ans, "$address has been unsubscribed from " .
-		       "$package\@packages.qa.debian.org.\n";
-	} else {
-	    push @ans, "$address is not subscribed, you can't unsubscribe.\n";
-	}
+	$cs->ask_confirmation($address, "UNSUBSCRIBE $package $address",
+			      { "PACKAGE" => $package });
 	$done{"UNSUBSCRIBE $package $address"} = 1;
+	push @ans, "A confirmation mail has been sent to $address.\n";
 	push @ans, "\n";
 	push @cc, $address if ($address ne $email);
 	
@@ -111,16 +108,10 @@
 	my $address = lc($1);
 	$address = $email if (! (defined($address) && $address));
 	my @explanation;
-	push @ans, "All your subscriptions have been terminated :\n";
-	foreach my $package (which($address)) {
-	    if (unsubscribe($address, $package)) {
-		push @ans, "$address has been unsubscribed from " .
-			   "$package\@packages.qa.debian.org.\n";
-	    } else {
-		push @ans, "$address is not subscribed, you can't unsubscribe.\n";
-	    }
-	}
+	$cs->ask_confirmation($address, "UNSUBSCRIBEALL $package $address",
+			      { "PACKAGE" => $package });
 	$done{"UNSUBSCRIBEALL $address"} = 1;
+	push @ans, "A confirmation mail has been sent to $address.\n";
 	push @ans, "\n";
 	push @cc, $address if ($address ne $email);
 	
@@ -128,19 +119,41 @@
 	my $key = $1;
 	next if (defined($done{"CONFIRM $key"})); # Not twice..
 	my $cmd = $cs->confirm($key);
-	if (defined($cmd) && ($cmd =~ /^SUBSCRIBE (\S+) (\S+)/)) {
-	    my ($package, $address) = (lc($1), lc($2));
-	    if (subscribe($address, $package)) {
-		push @ans, "$address has been subscribed to " .
-			   "$package\@packages.qa.debian.org.\n";
-	    } else {
-		push @ans, "$address is already subscribed ...\n";
-	    }
-	    $done{"CONFIRM $key"} = 1;
-	    push @cc, $address if ($address ne $email);
+	if (defined($cmd)) {
+		if ($cmd =~ /^SUBSCRIBE (\S+) (\S+)/) {
+			my ($package, $address) = (lc($1), lc($2));
+			if (subscribe($address, $package)) {
+				push @ans, "$address has been subscribed to " .
+					"$package\@packages.qa.debian.org.\n";
+			} else {
+				push @ans, "$address is already subscribed ...\n";
+			}
+		} elsif ($cmd =~ /^UNSUBSCRIBE (\S+) (\S+)/) {
+			my ($package, $address) = (lc($1), lc($2));
+			if (unsubscribe($address, $package)) {
+				push @ans, "$address has been unsubscribed from " .
+					"$package\@packages.qa.debian.org.\n";
+			} else {
+				push @ans, "$address is not subscribed, you can't unsubscribe.\n";
+			}
+		} elsif ($cmd =~ /^UNSUBSCRIBEALL (\S+) (\S+)/) {
+			my ($package, $address) = (lc($1), lc($2));
+			push @ans, "All your subscriptions have been terminated :\n";
+			foreach my $package (which($address)) {
+				if (unsubscribe($address, $package)) {
+				push @ans, "$address has been unsubscribed from " .
+					"$package\@packages.qa.debian.org.\n";
+				} else {
+					push @ans, "$address is not subscribed, you can't unsubscribe.\n";
+				}
+			}
+		} else {
+			push @ans, "Confirmation failed. Retry with a new command.\n";
+		}
+		$done{"CONFIRM $key"} = 1;
+		push @cc, $address if ($address ne $email);
 	} else {
-	    push @ans, "Confirmation failed. Retry with a new " . 
-		       "subscribe command.\n";
+		push @ans, "Confirmation failed. Retry with a new command.\n";
 	}
 	push @ans, "\n";
 	
Index: bin/unsubscribe.pl
===================================================================
--- bin/unsubscribe.pl	2006-04-12 09:54:01.000000000 +0100
+++ bin/unsubscribe.pl	2006-04-12 11:26:54.000000000 +0100
@@ -0,0 +1,21 @@
+#!/usr/bin/perl -w
+
+# Copyright 2006 MJ Ray <mjr@debian.org>
+# Copyright 2002 RaphaÂ?l Hertzog <hertzog@debian.org>
+# Available under the terms of the General Public License version 2
+# or (at your option) any later version
+
+use lib '/org/packages.qa.debian.org/perl';
+use lib '/home/rhertzog/cvs/pts/perl';
+
+use DB_File;
+
+use strict;
+
+require "common.pl";
+
+print STDERR "Enter address whitespace package on standard input, one per line:\n";
+while (<STDIN>) {
+  my ($address,$package) = split(/\s+/);
+  print "Unsub $address from $package: ".unsubscribe($address,$package)."\n";
+}