Implement Attribute Consuming Service with requested attributes for SP metadata creation

lib/Net/SAML2.pm

@@ -10,6 +10,8 @@ require 5.012;
 # entities
 use Net::SAML2::IdP;
 use Net::SAML2::SP;
+use Net::SAML2::RequestedAttribute;
+use Net::SAML2::AttributeConsumingService;
 
 # bindings
 use Net::SAML2::Binding::Redirect;

lib/Net/SAML2/AttributeConsumingService.pm

@@ -0,0 +1,106 @@
+package Net::SAML2::AttributeConsumingService;
+use Moose;
+use XML::Generator;
+use URN::OASIS::SAML2 qw(URN_METADATA NS_METADATA);
+
+# ABSTRACT: An attribute consuming service object
+
+has namespace => (
+    is      => 'ro',
+    isa     => 'ArrayRef',
+    default => sub { return [NS_METADATA() => URN_METADATA()] },
+);
+
+has service_name => (
+    is       => 'ro',
+    isa      => 'Str',
+    required => 1,
+);
+
+has service_description => (
+    is        => 'ro',
+    isa       => 'Str',
+    predicate => '_has_service_description',
+);
+
+has index => (
+    is       => 'ro',
+    isa      => 'Str',
+    required => 1,
+);
+
+has default => (
+    is      => 'ro',
+    isa     => 'Bool',
+    default => 0,
+);
+
+has attributes => (
+    is      => 'ro',
+    isa     => 'ArrayRef[Net::SAML2::RequestedAttribute]',
+    traits  => ['Array'],
+    default => sub { [] },
+    handles => { add_attribute => 'push', },
+);
+
+has _xml_gen => (
+    is       => 'ro',
+    isa      => 'XML::Generator',
+    default  => sub { return XML::Generator->new() },
+    init_arg => undef,
+);
+
+
+sub to_xml {
+    my $self = shift;
+
+    die "Unable to create attribute consuming service, we require attributes"
+      unless @{ $self->attributes };
+
+    my $xml = $self->_xml_gen();
+
+    return $xml->AttributeConsumingService(
+        $self->namespace,
+        {
+            index     => $self->index,
+            isDefault => $self->default,
+        },
+        $xml->ServiceName($self->namespace, undef, $self->service_name),
+        $self->_has_service_description ? $xml->ServiceDescription($self->namespace, undef, $self->service_description) : (),
+        map { $_->to_xml } @{ $self->attributes },
+    );
+}
+
+__PACKAGE__->meta->make_immutable;
+
+__END__
+
+=head1 DESCRIPTION
+
+=head1 SYNOPSIS
+
+  use Net::SAML2::AttributeConsumingService;
+
+  my $service = Net::SAML2::AttributeConsumingService->new(
+    # required
+    service_name => 'My Service Name',
+    index => 1,
+
+    #optional
+    service_description => 'My Service description',
+
+    # defaults to:
+    namespace => 'md',
+    default => 0,
+  );
+  my $fragment = $service->to_xml;
+
+=head1 METHODS
+
+=head2 to_xml
+
+Create an XML fragment for this object
+
+=head2 add_attributes
+
+Add a way to add requested attributes

lib/Net/SAML2/RequestedAttribute.pm

@@ -0,0 +1,107 @@
+package Net::SAML2::RequestedAttribute;
+use Moose;
+use XML::Generator;
+use URN::OASIS::SAML2 qw(URN_METADATA NS_METADATA);
+
+# ABSTRACT: RequestedAttribute class
+
+has name => (
+  is => 'ro',
+  isa => 'Str',
+  required => 1,
+);
+
+has namespace => (
+  is => 'ro',
+  isa => 'ArrayRef',
+  default => sub { return [NS_METADATA() => URN_METADATA() ] },
+);
+
+has required => (
+  is => 'ro',
+  isa => 'Bool',
+  default => 0,
+);
+
+has friendly_name => (
+  is => 'ro',
+  isa => 'Str',
+  predicate => '_has_friendly',
+);
+
+
+has name_format => (
+  is => 'ro',
+  isa => 'Str',
+  predicate => '_has_name_format',
+);
+
+has _xml_gen => (
+  is => 'ro',
+  isa => 'XML::Generator',
+  default => sub { return XML::Generator->new() },
+  init_arg => undef,
+);
+
+sub to_xml {
+  my $self = shift;
+
+  my %attrs = $self->_build_attributes;
+
+  my $x = $self->_xml_gen();
+
+  return $x->RequestedAttribute($self->namespace, \%attrs);
+
+}
+
+sub _build_attributes {
+  my $self = shift;
+
+  my %attrs = (
+    $self->required ? (isRequired => 1) : (),
+    Name => $self->name,
+    $self->_has_friendly ? (FriendlyName => $self->friendly_name) : (),
+  );
+  return %attrs;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+__END__
+
+=head1 DESCRIPTION
+
+=head1 SYNOPSIS
+
+  use Net::SAML2::RequestedAttribute;
+
+  my $attr = Net::SAML2::RequestedAttribute->new(
+    # required
+    name => 'Some:urn',
+
+    # defaults to:
+    namespace => 'md',
+
+    # optional
+    friendly_name => 'foo',
+    required => 1,
+  );
+
+  my $fragment = $var->to_xml();
+
+=head1 METHODS
+
+=head2 to_xml
+
+Create an XML fragment
+
+=head2 _build_attributes
+
+A requested attribute can hold other attributes than the ones specified in the
+XSD of L<https://docs.oasis-open.org/security/saml/v2.0/saml-schema-assertion-2.0.xsd>.
+
+This method allows to override the attributes for the RequestedAttribute node
+where you can add/remove/replace or change the order of the attributes. In
+other OO frameworks this method would have been protected or common
+(Object::Pad/Corrina).
+

lib/Net/SAML2/SP.pm

@@ -176,6 +176,9 @@ has 'slo_url_redirect' => (isa => 'Str', is => 'ro', required => 0);
 has 'acs_url_post'     => (isa => 'Str', is => 'ro', required => 0);
 has 'acs_url_artifact' => (isa => 'Str', is => 'ro', required => 0);
 
+has 'attribute_consuming_service' =>
+  (isa => 'Net::SAML2::AttributeConsumingService', is => 'ro', predicate => 'has_attribute_consuming_service');
+
 has '_cert_text' => (isa => 'Str', is => 'ro', init_arg => undef, builder => '_build_cert_text', lazy => 1);
 
 has '_encryption_key_text' => (isa => 'Str', is => 'ro', init_arg => undef, builder => '_build_encryption_key_text', lazy => 1);
@@ -588,6 +591,7 @@ sub generate_metadata {
             $self->_generate_single_logout_service($x),
 
             $self->_generate_assertion_consumer_service($x),
+            $self->has_attribute_consuming_service ? $self->attribute_consuming_service->to_xml : (),
 
         ),
         $x->Organization(

t/02-create-sp.t

@@ -441,4 +441,50 @@ use URN::OASIS::SAML2 qw(:bindings :urn);
     );
 }
 
+{
+    my $consuming_index = Net::SAML2::AttributeConsumingService->new(
+        service_name => 'Net::SAML2 testsuite',
+        index        => 1,
+        attributes   => [
+            Net::SAML2::RequestedAttribute->new(
+                friendly_name => 'foo',
+                name          => 'urn:foo:bar',
+                name_format   => 'xx',
+                required      => 1,
+            ),
+        ],
+    );
+
+    my $sp = net_saml2_sp(attribute_consuming_service => $consuming_index,);
+
+    my $xpath = get_xpath(
+        $sp->metadata,
+        md => URN_METADATA,
+        ds => URN_SIGNATURE,
+    );
+
+    my $node = get_single_node_ok($xpath, '//md:SPSSODescriptor');
+    my $acs  = get_single_node_ok($node,  '//md:AttributeConsumingService');
+
+    is($acs->getAttribute('index'),     1, ".. index is 1");
+    is($acs->getAttribute('isDefault'), 0, "Not the default");
+
+
+    my @child = $acs->childNodes();
+    is(@child,              2,                "Have 2 children");
+    is($child[0]->nodeName, "md:ServiceName", "Service name node found");
+    is(
+        $child[0]->textContent,
+        'Net::SAML2 testsuite',
+        ".. with the correct value"
+    );
+
+    is($child[1]->nodeName, "md:RequestedAttribute",
+        "Requested attribute found");
+    is($child[1]->getAttribute('FriendlyName'),
+        'foo', ".. with the correct friendly name");
+    is($child[1]->getAttribute('Name'),       'urn:foo:bar', ".. and name");
+    is($child[1]->getAttribute('isRequired'), '1', ".. and requiredness");
+}
+
 done_testing;

t/27-requested-attribute.t

@@ -0,0 +1,75 @@
+package Test::Net::SAML2::RequestedAttribute;
+use Moose;
+
+extends 'Net::SAML2::RequestedAttribute';
+
+around _build_attributes => sub {
+  my $orig = shift;
+  my $self = shift;
+
+  my %attrs = $self->$orig();
+
+  $attrs{Some} = 'Other';
+
+  return %attrs;
+};
+
+package main;
+
+use strict;
+use warnings;
+use Test::Lib;
+use Test::Net::SAML2;
+use URN::OASIS::SAML2 qw(URN_METADATA);
+
+my $requested_attribute = Net::SAML2::RequestedAttribute->new(
+  name => 'some:urn:here'
+);
+
+my $xpath = get_xpath(
+    $requested_attribute->to_xml,
+    md => URN_METADATA,
+);
+
+my $node = get_single_node_ok($xpath, '/md:RequestedAttribute');
+is($node->getAttribute('Name'), 'some:urn:here', ".. with the correct name");
+ok(!$node->getAttribute('isRequired'), ".. and isn't required");
+ok(!$node->getAttribute('FriendlyName'), ".. and w/out friendly name");
+ok(!$node->getAttribute('Some'), ".. and w/out additional attribute");
+
+$requested_attribute = Net::SAML2::RequestedAttribute->new(
+    name          => 'some:urn:here',
+    required      => 1,
+    friendly_name => 'My main man',
+);
+
+$xpath = get_xpath(
+    $requested_attribute->to_xml,
+    md => URN_METADATA,
+);
+
+$node = get_single_node_ok($xpath, '/md:RequestedAttribute');
+is($node->getAttribute('Name'), 'some:urn:here', ".. with the correct name");
+ok($node->getAttribute('isRequired'), ".. and is required");
+is($node->getAttribute('FriendlyName'),
+    "My main man", ".. and w/ friendly name");
+ok(!$node->getAttribute('Some'), ".. and w/out additional attribute");
+
+use Test::Net::SAML2::RequestedAttribute;
+
+$requested_attribute = Test::Net::SAML2::RequestedAttribute->new(
+  name => 'some:urn:here',
+);
+
+$xpath = get_xpath(
+    $requested_attribute->to_xml,
+    md => URN_METADATA,
+);
+
+$node = get_single_node_ok($xpath, '/md:RequestedAttribute');
+is($node->getAttribute('Name'), 'some:urn:here', ".. with the correct name");
+is($node->getAttribute('Some'),
+    "Other", ".. and w/ additional attribute");
+
+
+done_testing;