From 1688e1c4d9497b2da28b0d226c2092bf1bf9edba Mon Sep 17 00:00:00 2001
From: Wesley Schwengle <waterkip@cpan.org>
Date: Thu, 2 Feb 2023 07:59:58 -0400
Subject: [PATCH] Add XsdID as a type for id attribute type checking

Signed-off-by: Wesley Schwengle <waterkip@cpan.org>
---
 lib/Net/SAML2/Role/ProtocolMessage.pm |  3 +-
 lib/Net/SAML2/Types.pm                | 15 ++++++++
 t/22-types.t                          | 51 +++++++++++++++++++++++++++
 3 files changed, 68 insertions(+), 1 deletion(-)
 create mode 100644 t/22-types.t

diff --git a/lib/Net/SAML2/Role/ProtocolMessage.pm b/lib/Net/SAML2/Role/ProtocolMessage.pm
index 36a08ce8..a85b48bf 100644
--- a/lib/Net/SAML2/Role/ProtocolMessage.pm
+++ b/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"
 );
diff --git a/lib/Net/SAML2/Types.pm b/lib/Net/SAML2/Types.pm
index 78f97d94..a5b0d337 100644
--- a/lib/Net/SAML2/Types.pm
+++ b/lib/Net/SAML2/Types.pm
@@ -9,6 +9,7 @@ use strict;
 use Types::Serialiser;
 use MooseX::Types -declare => [
     qw(
+        XsdID
         SAMLRequestType
         signingAlgorithm
     )
@@ -16,6 +17,20 @@ use MooseX::Types -declare => [
 
 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
diff --git a/t/22-types.t b/t/22-types.t
new file mode 100644
index 00000000..de6cdb08
--- /dev/null
+++ b/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;