Merge pull request #211 from waterkip/GH-move-logic

waterkip · web-flow · commit eb5f293785c0 · 2024-04-19T22:09:02.000-04:00
Add in_response_to to Role::ProtocolMessage
diff --git a/lib/Net/SAML2/Binding/SOAP.pm b/lib/Net/SAML2/Binding/SOAP.pm
@@ -12,21 +12,22 @@ 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';
 
 # ABSTRACT: SOAP binding for SAML
 
 =head1 SYNOPSIS
 
-  my $soap = Net::SAML2::Binding::SOAP->new(
-    url => $idp_url,
-    key => $key,
-    cert => $cert,
-    idp_cert => $idp_cert,
-  );
+    my $soap = Net::SAML2::Binding::SOAP->new(
+        url      => $idp_url,
+        key      => $key,
+        cert     => $cert,
+        idp_cert => $idp_cert,
+    );
 
-  my $response = $soap->request($req);
+    my $response = $soap->request($req);
 
 Note that LWP::UserAgent maybe used which means that environment variables
 may affect the use of https see:
@@ -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);
diff --git a/lib/Net/SAML2/Protocol/Artifact.pm b/lib/Net/SAML2/Protocol/Artifact.pm
@@ -1,5 +1,3 @@
-use strict;
-use warnings;
 package Net::SAML2::Protocol::Artifact;
 # VERSION
 
@@ -39,7 +37,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 +98,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 +111,6 @@ sub new_from_xml {
         $response       ? (response        => $response)        : (),
         $logoutresponse ? (logout_response => $logoutresponse)  : (),
     );
-
-    return $self;
 }
 
 =head2 response
@@ -140,18 +135,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
diff --git a/lib/Net/SAML2/Protocol/LogoutRequest.pm b/lib/Net/SAML2/Protocol/LogoutRequest.pm
@@ -16,12 +16,12 @@ with 'Net::SAML2::Role::ProtocolMessage';
 
 =head1 SYNOPSIS
 
-  my $logout_req = Net::SAML2::Protocol::LogoutRequest->new(
-    issuer      => $issuer,
-    destination => $destination,
-    nameid      => $nameid,
-    session     => $session,
-  );
+    my $logout_req = Net::SAML2::Protocol::LogoutRequest->new(
+        issuer      => $issuer,
+        destination => $destination,
+        nameid      => $nameid,
+        session     => $session,
+    );
 
 =head1 METHODS
 
diff --git a/lib/Net/SAML2/Protocol/LogoutResponse.pm b/lib/Net/SAML2/Protocol/LogoutResponse.pm
@@ -1,11 +1,10 @@
-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';
@@ -18,12 +17,17 @@ Net::SAML2::Protocol::LogoutResponse - the SAML2 LogoutResponse object
 
 =head1 SYNOPSIS
 
-  my $logout_req = Net::SAML2::Protocol::LogoutResponse->new(
-    issuer      => $issuer,
-    destination => $destination,
-    status      => $status,
-    response_to => $response_to,
-  );
+    my $logout_req = Net::SAML2::Protocol::LogoutResponse->new(
+        issuer      => $issuer,
+        destination => $destination,
+        status      => $status,
+        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
 
@@ -37,27 +41,63 @@ 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<sub_status>
 
-=item B<response_to>
+The sub status
 
-request ID we're responding to
+=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 +126,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 +157,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 +173,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>
diff --git a/lib/Net/SAML2/Role/ProtocolMessage.pm b/lib/Net/SAML2/Role/ProtocolMessage.pm
@@ -1,18 +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);
+use URN::OASIS::SAML2 qw(:status);
 
 =head1 NAME
 
@@ -66,6 +67,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 +119,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;
diff --git a/t/21-artifact-response.t b/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;
