Merge pull request #158 from waterkip/attribute-id-typechecking

Add XsdID as a type for id attribute type checking

Author: waterkip

lib/Net/SAML2/Role/ProtocolMessage.pm

@@ -12,6 +12,7 @@ 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
 
@@ -28,7 +29,7 @@ implementation.
 =cut
 
 has id => (
-    isa     => 'Str',
+    isa     => XsdID,
     is      => 'ro',
     builder => "_build_id"
 );

lib/Net/SAML2/Types.pm

@@ -9,13 +9,28 @@ use strict;
 use Types::Serialiser;
 use MooseX::Types -declare => [
     qw(
+        XsdID
         SAMLRequestType
         signingAlgorithm
     )
 ];
 
 use MooseX::Types::Moose qw(Str Int Num Bool ArrayRef HashRef Item);
 
+=head2 XsdID
+
+The type xsd:ID is used for an attribute that uniquely identifies an element in an XML document. An xsd:ID value must be an NCName. This means that it must start with a letter or underscore, and can only contain letters, digits, underscores, hyphens, and periods.
+
+=cut
+
+subtype XsdID, as Str,
+    where {
+        return 0 unless $_ =~ /^[a-zA-Z_]/;
+        return 0 if $_ =~ /[^a-zA-Z0-9_\.\-]/;
+        return 1;
+    },
+    message { "'$_' is not a valid xsd:ID" };
+
 =head2 SAMLRequestType
 
 Enum which consists of two options: SAMLRequest and SAMLResponse

t/22-types.t

@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+use Test::Lib;
+use Test::Net::SAML2;
+use Net::SAML2::Types qw(XsdID SAMLRequestType signingAlgorithm);
+
+subtest 'XsdID' => sub {
+    my @xsdidok = qw(thisiscorrect _so_it_this THISTOO _YES this.-123.correct);
+    foreach (@xsdidok) {
+        ok(XsdID->check($_), "$_ is correct as an xsd:ID");
+    }
+
+    ok(!XsdID->check("1abc"), "... and this is not a correct xsd:ID");
+    like(
+        XsdID->get_message("1abc"),
+        qr/is not a valid xsd:ID/,
+        ".. with the correct error message"
+    );
+
+    ok(!XsdID->check('asb#'), "... not an allowed character");
+
+};
+
+subtest 'SAMLRequestType' => sub {
+
+    foreach (qw(SAMLRequest SAMLResponse)) {
+        ok(SAMLRequestType->check($_), "$_ is correct SAMLRequestType");
+    }
+    ok(!SAMLRequestType->check("foo"), ".. and this is not");
+    like(
+        SAMLRequestType->get_message("foo"),
+        qr/is not a SAML Request type/,
+        ".. with the correct error message"
+    );
+};
+
+subtest 'signingAlgorithm' => sub {
+
+    foreach (qw(sha244 sha256 sha384 sha512 sha1)) {
+        ok(signingAlgorithm->check($_), "$_ is correct signingAlgorithm");
+    }
+
+    ok(!signingAlgorithm->check("shafake"), ".. and this is not");
+    like(
+        signingAlgorithm->get_message("shafake"),
+        qr/is not a supported signingAlgorithm/,
+        ".. with the correct error message"
+    );
+};
+
+done_testing;