Add SameSite support to Cookie handling, https://tools.ietf.org/html/…

…draft-west-first-party-cookies-07

lib/CGI/Cookie.pm

@@ -119,13 +119,13 @@ sub new {
   # Ignore mod_perl request object--compatibility with Apache::Cookie.
   shift if ref $params[0]
         && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') };
-  my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly )
+  my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly, $samesite )
    = rearrange(
     [
       'NAME', [ 'VALUE', 'VALUES' ],
       'PATH',   'DOMAIN',
       'SECURE', 'EXPIRES',
-      'MAX-AGE','HTTPONLY'
+      'MAX-AGE','HTTPONLY','SAMESITE'
     ],
     @params
    );
@@ -141,6 +141,7 @@ sub new {
   $self->expires( $expires )   if defined $expires;
   $self->max_age($expires)     if defined $max_age;
   $self->httponly( $httponly ) if defined $httponly;
+  $self->samesite( $samesite ) if defined $samesite;
   return $self;
 }
 
@@ -154,12 +155,13 @@ sub as_string {
     my $value = join "&", map { escape($_) } $self->value;
     my @cookie = ( "$name=$value" );
 
-    push @cookie,"domain=".$self->domain   if $self->domain;
-    push @cookie,"path=".$self->path       if $self->path;
-    push @cookie,"expires=".$self->expires if $self->expires;
-    push @cookie,"max-age=".$self->max_age if $self->max_age;
-    push @cookie,"secure"                  if $self->secure;
-    push @cookie,"HttpOnly"                if $self->httponly;
+    push @cookie,"domain=".$self->domain     if $self->domain;
+    push @cookie,"path=".$self->path         if $self->path;
+    push @cookie,"expires=".$self->expires   if $self->expires;
+    push @cookie,"max-age=".$self->max_age   if $self->max_age;
+    push @cookie,"secure"                    if $self->secure;
+    push @cookie,"HttpOnly"                  if $self->httponly;
+    push @cookie,"SameSite=".$self->samesite if $self->samesite;
 
     return join "; ", @cookie;
 }
@@ -235,13 +237,20 @@ sub path {
     return $self->{'path'};
 }
 
-
 sub httponly { # HttpOnly
     my ( $self, $httponly ) = @_;
     $self->{'httponly'} = $httponly if defined $httponly;
     return $self->{'httponly'};
 }
 
+my %_legal_samesite = ( Strict => 1, Lax => 1 );
+sub samesite { # SameSite
+    my $self = shift;
+    my $samesite = ucfirst lc +shift if @_; # Normalize casing.
+    $self->{'samesite'} = $samesite if $samesite and $_legal_samesite{$samesite};
+    return $self->{'samesite'};
+}
+
 1;
 
 =head1 NAME
@@ -343,6 +352,14 @@ See these URLs for more information:
 	http://msdn.microsoft.com/en-us/library/ms533046.aspx
     http://www.browserscope.org/?category=security&v=top
 
+=item B<6. samesite flag>
+
+Allowed settings are C<Strict> and C<Lax>.
+
+As of June 2016, support is limited to recent releases of Chrome and Opera.
+
+L<https://tools.ietf.org/html/draft-west-first-party-cookies-07>
+
 =back
 
 =head2 Creating New Cookies
@@ -352,7 +369,8 @@ See these URLs for more information:
                              -expires =>  '+3M',
                              -domain  =>  '.capricorn.com',
                              -path    =>  '/cgi-bin/database',
-                             -secure  =>  1
+                             -secure  =>  1,
+                             -samesite=>  "Lax"
 	                    );
 
 Create cookies from scratch with the B<new> method.  The B<-name> and
@@ -388,6 +406,9 @@ cookie only when a cryptographic protocol is in use.
 B<-httponly> if set to a true value, the cookie will not be accessible
 via JavaScript.
 
+B<-samesite> may be C<Lax> or C<Strict> and is an evolving part of the
+standards for cookies. Please refer to current documentation regarding it.
+
 For compatibility with Apache::Cookie, you may optionally pass in
 a mod_perl request object as the first argument to C<new()>. It will
 simply be ignored:

t/cookie.t

@@ -156,7 +156,8 @@ my @test_cookie = (
                -domain  => '.capricorn.com',
                -path    => '/cgi-bin/database',
                -secure  => 1,
-               -httponly=> 1
+               -httponly=> 1,
+               -samesite=> 'Lax'
               );
   is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
   is($c->name   , 'foo',               'name is correct');
@@ -166,6 +167,7 @@ my @test_cookie = (
   is($c->path   , '/cgi-bin/database', 'path is correct');
   ok($c->secure , 'secure attribute is set');
   ok( $c->httponly, 'httponly attribute is set' );
+  is( $c->samesite, 'Lax', 'samesite attribute is correct' );
 
   # now try it with the only two manditory values (should also set the default path)
   $c = CGI::Cookie->new(-name    =>  'baz',
@@ -179,6 +181,7 @@ my @test_cookie = (
   is($c->path, '/',      'path atribute is set to default');
   ok(!defined $c->secure ,       'secure attribute is set');
   ok( !defined $c->httponly, 'httponly attribute is not set' );
+  ok( !$c->samesite, 'samesite attribute is not set' );
 
 # I'm really not happy about the restults of this section.  You pass
 # the new method invalid arguments and it just merilly creates a
@@ -210,7 +213,8 @@ my @test_cookie = (
                -domain  => '.pie-shop.com',
                -path    => '/',
                -secure  => 1,
-               -httponly=> 1
+               -httponly=> 1,
+               -samesite=> 'strict'
               );
 
   my $name = $c->name;
@@ -233,6 +237,9 @@ my @test_cookie = (
   like( $c->as_string, '/HttpOnly/',
     "Stringified cookie contains HttpOnly" );
 
+  like( $c->as_string, '/SameSite=Strict/',
+    "Stringified cookie contains normalized SameSite" );
+
   $c = CGI::Cookie->new(-name    =>  'Hamster-Jam',
             -value   =>  'Tulip',
                );
@@ -254,6 +261,9 @@ my @test_cookie = (
 
   ok( $c->as_string !~ /HttpOnly/,
     "Stringified cookie does not contain HttpOnly" );
+
+  ok( $c->as_string !~ /SameSite/,
+    "Stringified cookie does not contain SameSite" );
 }
 
 #-----------------------------------------------------------------------------
@@ -314,7 +324,8 @@ my @test_cookie = (
                -expires => '+3M',
                -domain  => '.pie-shop.com',
                -path    => '/',
-               -secure  => 1
+               -secure  => 1,
+               -samesite=> "strict"
                );
 
   is($c->name,          'Jam',   'name is correct');
@@ -345,6 +356,10 @@ my @test_cookie = (
   ok($c->secure,     'secure attribute is set');
   ok(!$c->secure(0), 'secure attribute is cleared');
   ok(!$c->secure,    'secure attribute is cleared');
+
+  is($c->samesite,        'Strict',   'SameSite is correct');
+  is($c->samesite('Lax'), 'Lax', 'SameSite is set correctly');
+  is($c->samesite,        'Lax', 'SameSite now returns updated value');
 }
 
 #----------------------------------------------------------------------------
@@ -353,7 +368,7 @@ my @test_cookie = (
 
 MAX_AGE: {
     my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
-    is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
+    is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT', 'expires is correct';
     is $cookie->max_age => undef, 'max-age is undefined when setting expires';
 
     $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );