RFC 8058 One-Click Unsubscribe

src/cgi/wwsympa.fcgi.in

@@ -167,13 +167,11 @@ our %comm = (
     'signoff'        => 'do_signoff',
     'auto_signoff'   => 'do_auto_signoff',
     'family_signoff' => 'do_family_signoff',
-    #'family_signoff_request' => 'do_family_signoff_request',
-    #XXX'multiple_signoff'    => 'do_multiple_signoff',
-    #'sigrequest' => 'do_sigrequest',
-    'sigindex' => 'do_sigindex',
-    'decl_add' => 'do_decl_add',
-    'decl_del' => 'do_decl_del',
-    'my'       => 'do_my',
+    'oneclick'       => 'do_oneclick',
+    'sigindex'       => 'do_sigindex',
+    'decl_add'       => 'do_decl_add',
+    'decl_del'       => 'do_decl_del',
+    'my'             => 'do_my',
     #'which' => 'do_which',
     'lists'            => 'do_lists',
     'lists_categories' => 'do_lists_categories',
@@ -418,13 +416,12 @@ our %action_args = (
     'show_cert'     => [],
     'subscribe'     => ['list'],
     #'subrequest' => ['list','email'],
-    'subindex'       => ['list'],
-    'decl_add'       => ['list'],
-    'signoff'        => ['list'],
-    'auto_signoff'   => ['list'],
-    'family_signoff' => ['family'],
-    #'family_signoff_request' => ['family', 'email'],
-    #'sigrequest'             => ['list',   'email'],
+    'subindex'           => ['list'],
+    'decl_add'           => ['list'],
+    'signoff'            => ['list'],
+    'auto_signoff'       => ['list'],
+    'family_signoff'     => ['family'],
+    'oneclick'           => ['list', 'id'],
     'sigindex'           => ['list'],
     'decl_del'           => ['list'],
     'set'                => ['list', 'email', 'reception', 'gecos'],
@@ -590,6 +587,7 @@ our %required_args = (
         ['param.list', 'param.user.email', 'message_template', 'content'],
     'modindex'      => ['param.list',       'param.user.email'],
     'docindex'      => ['param.list',       'param.user.email'],
+    'oneclick'      => ['param.list',       'id'],
     'pref'          => ['param.user.email'],
     'purge_list'    => ['param.user.email', 'selected_lists'],
     'rebuildallarc' => ['param.user.email'],
@@ -1986,12 +1984,14 @@ sub get_parameters {
     if ($ENV{'REQUEST_METHOD'} eq 'GET') {
         _split_params($ENV{'PATH_INFO'});
     } elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
-        ## POST
-
         if ($in{'javascript_action'}) {
-            ## because of incompatibility javascript
+            #FIXME needed?
             $in{'action'} = $in{'javascript_action'};
         }
+        if (0 == index $ENV{'PATH_INFO'}, '/oneclick/') {
+            _split_params($ENV{'PATH_INFO'});
+        }
+
         foreach my $p (keys %in) {
             $log->syslog('debug2', 'POST key %s value %s', $p, $in{$p})
                 unless ($p =~ /passwd/);
@@ -5784,6 +5784,32 @@ sub do_signoff {
 #OBSOLETED: Now an alias of 'signoff'.
 #sub do_sigrequest;
 
+sub do_oneclick {
+    wwslog('info', '(%s)', $in{'id'});
+
+    my $email = $list->get_oneclick_email($in{'id'})
+        if $ENV{REQUEST_METHOD} eq 'POST'
+        and ($in{'List-Unsubscribe'} // '') eq 'One-Click';
+    unless ($email) {
+        # Maybe not a One-Click signal or id has been expired.
+        # Redirect to normal signoff.
+        $log->syslog('err', 'No user found.  Illegal or expired request');
+        $param->{'redirect_to'} =
+            Sympa::get_url($list, 'signoff', authority => 'local');
+        return 1;
+    }
+
+    my $spindle = Sympa::Spindle::ProcessRequest->new(
+        context          => $list,
+        action           => 'signoff',
+        sender           => $email,
+        email            => $email,
+        scenario_context => {skip => 1},
+    );
+
+    return 'home';
+}
+
 ## Update of password
 sub do_setpasswd {
     wwslog('info', '');

src/lib/Sympa/DatabaseDriver.pm

@@ -54,6 +54,10 @@ sub AS_BLOB {
     return ();
 }
 
+sub md5_func {
+    die 'not yet implemented.';
+}
+
 1;
 __END__
 
@@ -624,6 +628,14 @@ Overridden by inherited classes.
 
 See L</AS_DOUBLE> for more details.
 
+=item md5_func ( $expression, ... )
+
+I<Required>.
+Given expressions, returns a SQL expression calculating MD5 digest of
+concatenated those expressions.  Among them, NULL values should be ignored
+and numeric values should be converted to textual type before concatenation.
+Value of the SQL expression should be lowercase 32 hexadigits.
+
 =back
 
 =head2 Utility method

src/lib/Sympa/DatabaseDriver/MySQL.pm

@@ -492,6 +492,13 @@ sub AS_DOUBLE {
     return ();
 }
 
+sub md5_func {
+    shift;
+
+    return sprintf q{MD5(CONCAT(%s))}, join ', ',
+        map { sprintf q{COALESCE(%s, '')}, $_ } @_;
+}
+
 1;
 __END__
 

src/lib/Sympa/DatabaseDriver/ODBC.pm

@@ -66,6 +66,15 @@ sub AS_DOUBLE {
     return ();
 }
 
+sub md5_func {
+    shift;
+
+    #FIXME: This may work only on Microsoft SQL Server 2005 or later.
+    return sprintf q{CONVERT(VARCHAR(32), HashBytes('MD5', CONCAT(%s)), 2)},
+        join ', ', map { sprintf q{IFNULL(%s, '')}, $_ } @_;
+
+}
+
 1;
 __END__
 

src/lib/Sympa/DatabaseDriver/Oracle.pm

@@ -572,6 +572,13 @@ sub AS_BLOB {
     return ();
 }
 
+sub md5_func {
+    shift;
+
+    return sprintf q{LOWER(RAWTOHEX(STANDARD_HASH(%s, 'MD5')))},
+        join ' || ', map { sprintf 'TO_CHAR(%s)', $_ } @_;
+}
+
 1;
 __END__
 

src/lib/Sympa/DatabaseDriver/PostgreSQL.pm

@@ -670,6 +670,12 @@ sub AS_BLOB {
     return ();
 }
 
+sub md5_func {
+    shift;
+
+    return sprintf 'MD5(CONCAT(%s))', join ', ', @_;
+}
+
 1;
 __END__
 

src/lib/Sympa/DatabaseDriver/SQLite.pm

@@ -30,6 +30,7 @@ package Sympa::DatabaseDriver::SQLite;
 use strict;
 use warnings;
 use DBI qw();
+use Digest::MD5;
 use English qw(-no_match_vars);
 use POSIX qw();
 
@@ -66,6 +67,15 @@ sub connect {
     # Create a temoprarhy view "dual" for portable SQL statements.
     $self->__dbh->do(q{CREATE TEMPORARY VIEW dual AS SELECT 'X' AS dummy;});
 
+    # Create a function MD5().
+    $self->__dbh->func(
+        'md5', -1,
+        sub {
+            Digest::MD5::md5_hex(grep {defined} @_);
+        },
+        'create_function'
+    );
+
     return 1;
 }
 
@@ -610,6 +620,12 @@ sub AS_BLOB {
     return ();
 }
 
+sub md5_func {
+    shift;
+
+    return sprintf 'md5(%s)', join ', ', @_;
+}
+
 # Private methods
 
 # Get raw type of column

src/lib/Sympa/List.pm

@@ -32,6 +32,7 @@ use warnings;
 use Digest::MD5 qw();
 use English qw(-no_match_vars);
 use IO::Scalar;
+use MIME::Base64;
 use POSIX qw();
 use Storable qw();
 
@@ -2768,6 +2769,50 @@ sub get_resembling_members {
 #DEPRECATED.  Merged into get_resembling_members().
 #sub find_list_member_by_pattern_no_object;
 
+my $oneclick_expiration = 7;
+
+sub get_oneclick_email {
+    my $self = shift;
+    my $id   = shift;
+
+    return undef unless $id;
+    my ($day, $hash) = $id =~ m{\A(\d*)-(.*)\z};
+    my $hex = unpack "H*", MIME::Base64::decode_base64url($hash);
+    my $today = int(time / 86400);
+    return undef
+        unless 32 == length $hex
+        and $day
+        and $day + 0 <= $today
+        and $today <= $day + $oneclick_expiration;
+
+    my $sdm    = Sympa::DatabaseManager->instance;
+    my %revmap = reverse _map_list_member_cols();
+
+    my $cond = sprintf '%s = %s', $sdm->quote($hex),
+        $sdm->md5_func(@revmap{qw(date email)}, $sdm->quote($day));
+    my @u = grep { $_ and length($_->{email} // '') }
+        $self->get_members('member', othercondition => $cond);
+
+    if (1 < scalar @u) {
+        $log->syslog('err', 'Multiple users found.  Ignore request');
+        return undef;
+    }
+
+    return @u ? $u[0]->{email} : undef;
+}
+
+sub oneclick_id {
+    my $self  = shift;
+    my $email = shift;
+
+    my $user = $self->get_list_member($email) or return undef;
+
+    my $day = int(time / 86400);
+    return sprintf '%s-%s', $day,
+        MIME::Base64::encode_base64url(
+        Digest::MD5::md5($user->{date} // '', $user->{email}, $day));
+}
+
 sub get_info {
     my $self = shift;
 
@@ -5836,6 +5881,24 @@ sub add_list_header {
         );
         $message->add_header('List-Help',
             join ', ', map { sprintf '<%s>', $_ } @urls);
+    } elsif ($field eq 'unsubscribe' and $options{oneclick}) {
+        if ($wwsympa_url
+            and my $id = $self->oneclick_id($options{oneclick})) {
+            my @urls = (
+                Sympa::get_url($self, 'oneclick', paths => [$id]),
+                Sympa::Tools::Text::mailtourl(
+                    Sympa::get_address($self, 'sympa'),
+                    query => {subject => sprintf('SIG %s', $self->{'name'})}
+                )
+            );
+            # Overwrite existing fields to prevent forgery.
+            $message->delete_header('List-Unsubscribe-Post');
+            $message->delete_header('List-Unsubscribe');
+            $message->add_header('List-Unsubscribe-Post',
+                'List-Unsubscribe=One-Click');
+            $message->add_header('List-Unsubscribe',
+                join ', ', map { sprintf '<%s>', $_ } @urls);
+        }
     } elsif ($field eq 'unsubscribe') {
         my @urls = (
             ($wwsympa_url ? (Sympa::get_url($self, 'signoff')) : ()),
@@ -5874,6 +5937,8 @@ sub add_list_header {
         );
     } elsif ($field eq 'archive') {
         if ($wwsympa_url and $self->is_web_archived()) {
+            # Replace existing field(s).  See RFC 2369 section 4.
+            $message->delete_header('List-Archive');
             $message->add_header('List-Archive',
                 sprintf('<%s>', Sympa::get_url($self, 'arc')));
         } else {
@@ -5893,6 +5958,7 @@ sub add_list_header {
                 my @now = localtime time;
                 $arc = sprintf '%04d-%02d', 1900 + $now[5], $now[4] + 1;
             }
+            # Existing field(s) shouldn't be overwritten.  See RFC 5064, 2.2.
             $message->add_header(
                 'Archived-At',
                 sprintf(

src/lib/Sympa/Message.pm

@@ -512,6 +512,9 @@ sub dkim_sign {
         $log->syslog('err', 'Can\'t create Mail::DKIM::Signer');
         return undef;
     }
+    # For One-Click Unsubscribe.
+    $dkim->extended_headers({'List-Unsubscribe-Post' => 1});
+
     # $new_body will store the body as fed to Mail::DKIM to reuse it
     # when returning the message as string.  Line terminators must be
     # normalized with CRLF.

src/lib/Sympa/Spindle/ProcessOutgoing.pm

@@ -280,6 +280,16 @@ sub _twist {
                 $return_path = Sympa::get_address($robot, 'owner');
             }
 
+            # If message is personalized and DKIM signature is available,
+            # Add One-Click Unsubscribe header field.
+            if (    $new_message->{shelved}{merge}
+                and $new_message->{shelved}{dkim_sign}
+                and $dkim
+                and grep { 'unsubscribe' eq $_ }
+                @{$list->{'admin'}{'rfc2369_header_fields'}}) {
+                $list->add_list_header($new_message, 'unsubscribe',
+                    oneclick => $rcpt);
+            }
             if (    $new_message->{shelved}{merge}
                 and $new_message->{shelved}{merge} ne 'footer') {
                 unless ($new_message->personalize($list, $rcpt)) {

src/lib/Sympa/Spindle/TransformOutgoing.pm

@@ -118,6 +118,13 @@ sub _twist {
     $list->add_list_header($message, 'id');
 
     ## Add RFC 2369 header fields
+    # At first, delete fields of parent list.  See RFC 2369, section 4.
+    foreach my $h (
+        qw(List-Help List-Subscribe List-Unsubscribe List-Owner
+        List-Unsubscribe-Post)
+    ) {
+        $message->delete_header($h);
+    }
     foreach my $field (
         @{  Sympa::Robot::list_params($list->{'domain'})
                 ->{'rfc2369_header_fields'}->{'format'}