Add in_response_to to Role::ProtocolMessage

This attribute is needed in more than one type, so let's implement it.
Consumers may need to add the required bit.

In addition also add the success() method (although I think we need to
call it is_success).

Signed-off-by: Wesley Schwengle <waterkip@cpan.org>

lib/Net/SAML2/Binding/SOAP.pm

@@ -12,6 +12,7 @@ use XML::LibXML::XPathContext;
 
 use Net::SAML2::XML::Sig;
 use Net::SAML2::XML::Util qw/ no_comments /;
+use Net::SAML2::Util qw/ deprecation_warning /;
 
 with 'Net::SAML2::Role::VerifyXML';
 
@@ -129,14 +130,17 @@ has verify => (
 # expected to be an arrayref to the certificates.  To avoid breaking existing
 # applications this changes the the cert to an arrayref if it is not
 # already an array ref.
+#
+# Please remove the build args logic after 6 months from april 18th 2024
 
 around BUILDARGS => sub {
     my $orig = shift;
     my $self = shift;
 
     my %params = @_;
     if ($params{idp_cert} && ref($params{idp_cert}) ne 'ARRAY') {
-            $params{idp_cert} = [$params{idp_cert}];
+      $params{idp_cert} = [$params{idp_cert}];
+      deprecation_warning("Please use an array ref for idp_cert")
     }
 
     return $self->$orig(%params);

lib/Net/SAML2/Protocol/Artifact.pm

@@ -1,5 +1,3 @@
-use strict;
-use warnings;
 package Net::SAML2::Protocol::Artifact;
 # VERSION
 
@@ -13,10 +11,6 @@ with 'Net::SAML2::Role::ProtocolMessage';
 
 # ABSTRACT: SAML2 artifact object
 
-=head1 NAME
-
-Net::SAML2::Protocol::Artifact - SAML2 artifact object
-
 =head1 SYNOPSIS
 
   my $artifact = Net::SAML2::Protocol::Artifact->new_from_xml(
@@ -39,7 +33,7 @@ Net::SAML2::Protocol::Artifact - SAML2 artifact object
 =cut
 
 has 'issue_instant'   => (isa => DateTime,  is => 'ro', required => 1);
-has 'in_response_to'  => (isa => 'Str',     is => 'ro', required => 1);
+has '+in_response_to'  => (required => 1);
 has 'issuer'          => (isa => 'Str',     is => 'ro', required => 1);
 has 'status'          => (isa => 'Str',     is => 'ro', required => 1);
 has 'logoutresponse_object'  => (
@@ -100,12 +94,11 @@ sub new_from_xml {
     }
 
     my $issue_instant;
-
     if (my $value = $xpath->findvalue('/samlp:ArtifactResponse/@IssueInstant')) {
         $issue_instant = DateTime::Format::XSD->parse_datetime($value);
     }
 
-    my $self = $class->new(
+    return $class->new(
         id             => $xpath->findvalue('/samlp:ArtifactResponse/@ID'),
         in_response_to => $xpath->findvalue('/samlp:ArtifactResponse/@InResponseTo'),
         issue_instant  => $issue_instant,
@@ -114,8 +107,6 @@ sub new_from_xml {
         $response       ? (response        => $response)        : (),
         $logoutresponse ? (logout_response => $logoutresponse)  : (),
     );
-
-    return $self;
 }
 
 =head2 response
@@ -140,18 +131,6 @@ sub logout_response {
     return $self->logoutresponse_object->toString;
 }
 
-=head2 success( )
-
-Returns true if the Response's status is Success.
-
-=cut
-
-sub success {
-    my ($self) = @_;
-    return 1 if $self->status eq $self->status_uri('success');
-    return 0;
-}
-
 =head2 get_response ( )
 
 Returns the LogoutResponse or Response depending on which is defined

lib/Net/SAML2/Protocol/LogoutRequest.pm

@@ -7,7 +7,7 @@ use MooseX::Types::Common::String qw/ NonEmptySimpleStr /;
 use MooseX::Types::URI qw/ Uri /;
 use Net::SAML2::XML::Util qw/ no_comments /;
 use XML::Generator;
-use URN::OASIS::SAML2 qw(:urn);
+use URN::OASIS::SAML2 qw(:urn NAMEID_PERSISTENT);
 use XML::LibXML::XPathContext;
 
 with 'Net::SAML2::Role::ProtocolMessage';
@@ -123,7 +123,7 @@ around BUILDARGS => sub {
     my $self = shift;
     my %args = @_;
 
-    if ($args{nameid_format} && $args{nameid_format} eq 'urn:oasis:names:tc:SAML:2.0:nameidformat:persistent') {
+    if ($args{nameid_format} && $args{nameid_format} eq NAMEID_PERSISTENT()) {
         $args{include_name_qualifier} = 1;
     }
 

lib/Net/SAML2/Protocol/LogoutResponse.pm

@@ -1,21 +1,16 @@
-use strict;
-use warnings;
 package Net::SAML2::Protocol::LogoutResponse;
 # VERSION
 
 use Moose;
 use MooseX::Types::URI qw/ Uri /;
 use Net::SAML2::XML::Util qw/ no_comments /;
+use Net::SAML2::Util qw/ deprecation_warning /;
 use XML::LibXML::XPathContext;
 
 with 'Net::SAML2::Role::ProtocolMessage';
 
 # ABSTRACT: SAML2 LogoutResponse Protocol object
 
-=head1 NAME
-
-Net::SAML2::Protocol::LogoutResponse - the SAML2 LogoutResponse object
-
 =head1 SYNOPSIS
 
   my $logout_req = Net::SAML2::Protocol::LogoutResponse->new(
@@ -25,6 +20,11 @@ Net::SAML2::Protocol::LogoutResponse - the SAML2 LogoutResponse object
     response_to => $response_to,
   );
 
+=head1 DESCRIPTION
+
+This object deals with the LogoutResponse messages from SAML. It implements the
+role L<Net::SAML2::Role::ProtocolMessage>.
+
 =head1 METHODS
 
 =head2 new( ... )
@@ -37,27 +37,61 @@ Arguments:
 
 =item B<issuer>
 
-SP's identity URI
+SP's identity URI (required)
 
 =item B<destination>
 
 IdP's identity URI
 
 =item B<status>
 
-response status
+Response status (required)
 
-=item B<response_to>
+=item B<sub_status>
 
-request ID we're responding to
+The sub status
+
+=item B<in_response_to>
+
+Request ID we're responding to (required);
 
 =back
 
 =cut
 
-has 'status'      => (isa => 'Str', is => 'ro', required => 1);
-has 'substatus'   => (isa => 'Str', is => 'ro', required => 0);
-has 'response_to' => (isa => 'Str', is => 'ro', required => 1);
+has 'status'          => (isa      => 'Str', is => 'ro', required => 1);
+has 'sub_status'      => (isa      => 'Str', is => 'ro', required => 0);
+has '+in_response_to' => (required => 1);
+
+# Remove response_to/substatus after 6 months from now (april 18th 2024)
+around BUILDARGS => sub {
+  my $orig = shift;
+  my $self = shift;
+  my %args = @_;
+
+  if (my $irt = delete $args{response_to}) {
+    $args{in_response_to} = $irt;
+    deprecation_warning("Please use in_response_to instead of response_to");
+  }
+
+  if (my $s = delete $args{substatus}) {
+    $args{sub_status} = $s;
+    deprecation_warning("Please use in_response_to instead of response_to");
+  }
+  return $self->$orig(%args);
+};
+
+sub response_to {
+  my $self = shift;
+  deprecation_warning("Please use in_response_to instead of response_to");
+  return $self->in_response_to;
+}
+
+sub substatus {
+  my $self = shift;
+  deprecation_warning("Please use sub_status instead of substatus");
+  return $self->sub_status;
+}
 
 =head2 new_from_xml( ... )
 
@@ -86,12 +120,12 @@ sub new_from_xml {
 
     my $self = $class->new(
         id          => $xpath->findvalue('/samlp:LogoutResponse/@ID'),
-        response_to => $xpath->findvalue('/samlp:LogoutResponse/@InResponseTo'),
+        in_response_to => $xpath->findvalue('/samlp:LogoutResponse/@InResponseTo'),
         destination => $xpath->findvalue('/samlp:LogoutResponse/@Destination'),
         session     => $xpath->findvalue('/samlp:LogoutResponse/samlp:SessionIndex'),
         issuer      => $xpath->findvalue('/samlp:LogoutResponse/saml:Issuer'),
         status      => $xpath->findvalue('/samlp:LogoutResponse/samlp:Status/samlp:StatusCode/@Value'),
-        substatus   => $xpath->findvalue('/samlp:LogoutResponse/samlp:Status/samlp:StatusCode/samlp:StatusCode/@Value'),
+        sub_status  => $xpath->findvalue('/samlp:LogoutResponse/samlp:Status/samlp:StatusCode/samlp:StatusCode/@Value'),
     );
 
     return $self;
@@ -117,7 +151,7 @@ sub as_xml {
               Version => '2.0',
               IssueInstant => $self->issue_instant,
               Destination => $self->destination,
-              InResponseTo => $self->response_to },
+              InResponseTo => $self->in_response_to },
             $x->Issuer(
                 $saml,
                 $self->issuer,
@@ -133,16 +167,10 @@ sub as_xml {
     );
 }
 
-=head2 success( )
+__PACKAGE__->meta->make_immutable;
 
-Returns true if the Response's status is Success.
+__END__
 
-=cut
+=head1 SEE ALSO
 
-sub success {
-    my ($self) = @_;
-    return 1 if $self->status eq $self->status_uri('success');
-    return 0;
-}
-
-__PACKAGE__->meta->make_immutable;
+=head2 L<Net::SAML2::Roles::ProtocolMessage>

lib/Net/SAML2/Role/ProtocolMessage.pm

@@ -1,23 +1,19 @@
-use strict;
-use warnings;
 package Net::SAML2::Role::ProtocolMessage;
 # VERSION
 
 use Moose::Role;
 
 # ABSTRACT: Common behaviour for Protocol messages
 
+use feature qw(state);
+
 use namespace::autoclean;
 
 use DateTime;
 use MooseX::Types::URI qw/ Uri /;
 use Net::SAML2::Util qw(generate_id);
 use Net::SAML2::Types qw(XsdID);
-
-=head1 NAME
-
-Net::SAML2::Role::ProtocolMessage - the SAML2 ProtocolMessage Role object
-
+use URN::OASIS::SAML2 qw(:status);
 
 =head1 DESCRIPTION
 
@@ -66,6 +62,12 @@ has destination => (
     predicate => 'has_destination',
 );
 
+has in_response_to => (
+    isa       => XsdID,
+    is        => 'ro',
+    predicate => 'has_in_response_to',
+);
+
 sub _build_issue_instant {
     return DateTime->now(time_zone => 'UTC')->strftime('%FT%TZ');
 }
@@ -112,25 +114,34 @@ Legal short names for B<$status> are:
 
 =item C<responder>
 
+=item C<partial>
+
 =back
 
 =cut
 
+
 sub status_uri {
     my ($self, $status) = @_;
 
-    my $statuses = {
-        success   => 'urn:oasis:names:tc:SAML:2.0:status:Success',
-        requester => 'urn:oasis:names:tc:SAML:2.0:status:Requester',
-        responder => 'urn:oasis:names:tc:SAML:2.0:status:Responder',
+    state $statuses = {
+        success   => STATUS_SUCCESS(),
+        requester => STATUS_REQUESTER(),
+        responder => STATUS_RESPONDER(),
         partial   => 'urn:oasis:names:tc:SAML:2.0:status:PartialLogout',
     };
 
-    if (exists $statuses->{$status}) {
-        return $statuses->{$status};
-    }
-
+    return $statuses->{$status} if exists $statuses->{$status};
     return;
 }
 
+sub success {
+    my $self = shift;
+
+    return $self->status eq STATUS_SUCCESS() if $self->can('status');
+    croak(
+        "You haven't implemented the status method, unable to determine success"
+    );
+}
+
 1;

t/21-artifact-response.t

@@ -127,7 +127,13 @@ isa_ok($logout, "Net::SAML2::Protocol::LogoutResponse");
 
 ok($logout->success(), "Logout Response has a Success");
 
-is($logout->response_to, 'NETSAML2_0b499739aa1d76eb80093a068053b8fee62cade60f7dc27826d0f13b19cad16a', "Logout Response InResponseTo - ok");
+is($logout->in_response_to, 'NETSAML2_0b499739aa1d76eb80093a068053b8fee62cade60f7dc27826d0f13b19cad16a', "Logout Response InResponseTo - ok");
+
+{
+  # TODO: Remove once response_to has been eradicated
+  local $SIG{__WARN__} = sub { }; # Suppress the warning in the testsuite
+  is($logout->response_to, $logout->in_response_to, ".. and old method still works");
+}
 
 is($logout->id, 'ID_bfc25851-4da2-4420-8240-9103b77b12dc', "Logout Response Id - ok");
 
@@ -139,6 +145,6 @@ isa_ok($logout, "Net::SAML2::Protocol::LogoutResponse", "from get_response");
 
 ok($logout->success(), "Logout Response has a Success");
 
-is($logout->response_to, 'NETSAML2_0b499739aa1d76eb80093a068053b8fee62cade60f7dc27826d0f13b19cad16a', "Logout Response InResponseTo - ok");
+is($logout->in_response_to, 'NETSAML2_0b499739aa1d76eb80093a068053b8fee62cade60f7dc27826d0f13b19cad16a', "Logout Response InResponseTo - ok");
 
 done_testing;