Refactor Stanford naming policy, add new file patterns

Refactor the Wallet::Policy::Stanford module to pull some of the
constants out, and then add data and support in the naming policy
for the new file object naming scheme.

Change-Id: Iba0c24c119ce529a1d3fd8cd3332335c4433df09
Reviewed-on: https://gerrit.stanford.edu/756
Reviewed-by: Russ Allbery <rra@stanford.edu>
Tested-by: Russ Allbery <rra@stanford.edu>

1 files changed, 142 insertions, 34 deletions

diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm
index 906f6ba..640c43c 100644
--- a/perl/Wallet/Policy/Stanford.pm
+++ b/perl/Wallet/Policy/Stanford.pm
@@ -30,6 +30,59 @@ BEGIN {
 }
 
 ##############################################################################
+# Configuration
+##############################################################################
+
+# These variables are all declared as globals so that they can be overridden
+# from wallet.conf if desirable.
+
+# The domain to append to hostnames to fully-qualify them.
+our $DOMAIN = 'stanford.edu';
+
+# Groups for file object naming.  This default is entirely Stanford-specific,
+# even more so than the rest of this file.
+our @GROUPS = qw(apps crcsg gsb idg sysadmin sulair vast);
+
+# File object types.  Each type can have one or more parameters: whether it is
+# host-based (host), whether it takes a qualifier after the host or service
+# (extra), and whether that qualifier is mandatory (need_extra).
+our %FILE_TYPES = (
+    config            => {            extra => 1, need_extra => 1 },
+    db                => {            extra => 1, need_extra => 1 },
+    'gpg-key'         => { },
+    htpasswd          => { host => 1, extra => 1, need_extra => 1 },
+    password          => {            extra => 1, need_extra => 1 },
+    'password-ipmi'   => { host => 1 },
+    'password-root'   => { host => 1 },
+    'password-tivoli' => { host => 1 },
+    properties        => {            extra => 1 },
+    'ssh-dsa'         => { host => 1 },
+    'ssh-rsa'         => { host => 1 },
+    'ssl-key'         => { host => 1, extra => 1 },
+    'ssl-keystore'    => {            extra => 1 },
+    'ssl-pkcs12'      => {            extra => 1 },
+    'tivoli-key'      => { host => 1 },
+);
+
+# Host-based file object types for the legacy file object naming scheme.
+our @FILE_HOST_LEGACY = qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
+
+# File object types for the legacy file object naming scheme.
+our @FILE_TYPES_LEGACY = qw(config db gpg-key htpasswd password properties
+  ssh-rsa ssh-dsa ssl-key ssl-keystore ssl-pkcs12 tivoli-key);
+
+# Host-based Kerberos principal prefixes.
+our @KEYTAB_HOST = qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop
+  postgres sieve smtp webauth xmpp);
+
+# The Kerberos realm, used when forming principals for krb5 ACLs.
+our $REALM = 'stanford.edu';
+
+# A file listing principal names that should be required to use a root
+# instance to autocreate any objects.
+our $ROOT_REQUIRED = '/etc/remctl/acl/its-idg';
+
+##############################################################################
 # Implementation
 ##############################################################################
 
@@ -40,7 +93,7 @@ BEGIN {
 # pose a security problem.
 #
 # On any failure, just return an empty ACL to use the default.
-sub acl_has_netdb_root {
+sub _acl_has_netdb_root {
     my ($name) = @_;
     my $schema = eval { Wallet::Schema->connect };
     return unless ($schema and not $@);
@@ -52,19 +105,19 @@ sub acl_has_netdb_root {
     return;
 }
 
-# Map a file object name to a hostname and return it.  Returns undef if this
-# file object name doesn't map to a hostname.
-sub _host_for_file {
+# Map a file object name to a hostname for the legacy file object naming
+# scheme and return it.  Returns undef if this file object name doesn't map to
+# a hostname.
+sub _host_for_file_legacy {
     my ($name) = @_;
-    my %allowed = map { $_ => 1 }
-        qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
+    my %allowed = map { $_ => 1 } @FILE_HOST_LEGACY;
     my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')';
     if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) {
         return;
     }
     my $host = $1;
     if ($host !~ /\./) {
-        $host .= '.stanford.edu';
+        $host .= q{.} . $DOMAIN;
     }
     return $host;
 }
@@ -73,14 +126,12 @@ sub _host_for_file {
 # keytab principal name doesn't map to a hostname.
 sub _host_for_keytab {
     my ($name) = @_;
-    my %allowed = map { $_ => 1 }
-        qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop postgres
-           sieve smtp webauth xmpp);
+    my %allowed = map { $_ => 1 } @KEYTAB_HOST;
     return unless $name =~ m,/,;
     my ($service, $host) = split ('/', $name, 2);
     return unless $allowed{$service};
     if ($host !~ /\./) {
-        $host .= '.stanford.edu';
+        $host .= q{.} . $DOMAIN;
     }
     return $host;
 }
@@ -91,22 +142,21 @@ sub _host_for_keytab {
 # using root instances by default.
 sub default_owner {
     my ($type, $name) = @_;
-    my $realm = 'stanford.edu';
     my %host_for = (
         keytab => \&_host_for_keytab,
-        file   => \&_host_for_file,
+        file   => \&_host_for_file_legacy,
     );
     return unless defined $host_for{$type};
     my $host = $host_for{$type}->($name);
     return unless $host;
     my $acl_name = "host/$host";
     my @acl;
-    if ($ENV{REMOTE_USER} =~ m,/root, or acl_has_netdb_root ($acl_name)) {
+    if ($ENV{REMOTE_USER} =~ m,/root, or _acl_has_netdb_root ($acl_name)) {
         @acl = ([ 'netdb-root', $host ],
-                [ 'krb5', "host/$host\@$realm" ]);
+                [ 'krb5', "host/$host\@$REALM" ]);
     } else {
         @acl = ([ 'netdb', $host ],
-                [ 'krb5', "host/$host\@$realm" ]);
+                [ 'krb5', "host/$host\@$REALM" ]);
     }
     return ($acl_name, @acl);
 }
@@ -119,11 +169,8 @@ sub default_owner {
 # creation using a */root instance.
 sub verify_name {
     my ($type, $name, $user) = @_;
-    my %host = map { $_ => 1 }
-        qw(HTTP afpserver cifs ftp http host ident imap ipp ldap lpr nfs pop
-           postgres sieve smtp uniengd webauth xmpp);
     my %staff;
-    if (open (STAFF, '<', '/etc/remctl/acl/its-idg')) {
+    if (open (STAFF, '<', $ROOT_REQUIRED)) {
         local $_;
         while (<STAFF>) {
             s/^\s+//;
@@ -141,6 +188,7 @@ sub verify_name {
 
     # Check keytab naming conventions.
     if ($type eq 'keytab') {
+        my %host = map { $_ => 1 } @KEYTAB_HOST;
         if ($name !~ m,^[a-zA-Z0-9_-]+/[a-z0-9.-]+$,) {
             return "invalid principal name $name";
         }
@@ -169,20 +217,80 @@ sub verify_name {
 
     # Check file object naming conventions.
     if ($type eq 'file') {
-        my %groups = map { $_ => 1 }
-            qw(apps crcsg gsb idg sysadmin sulair vast);
-        my %types  = map { $_ => 1 }
-            qw(config db gpg-key htpasswd password properties ssh-rsa ssh-dsa
-               ssl-key ssl-keystore ssl-pkcs12 tivoli-key);
-        if ($name !~ m,^[a-zA-Z0-9_.-]+$,) {
-            return "invalid file object $name";
-        }
-        my $group_regex = '(?:' . join ('|', sort keys %groups) . ')';
-        my $type_regex  = '(?:' . join ('|', sort keys %types)  . ')';
-        if ($name !~ /^$group_regex-/) {
-            return "no recognized owning group in $name";
-        } elsif ($name !~ /^$group_regex-.*-$type_regex(-.*)?$/) {
-            return "invalid file object name $name";
+        my %groups = map { $_ => 1 } @GROUPS;
+        if ($name =~ m{ / }xms) {
+            my @name = split('/', $name);
+
+            # Names have between two and four components and all must be
+            # non-empty.
+            if (@name > 4) {
+                return "too many components in $name";
+            }
+            if (@name < 2) {
+                return "too few components in $name";
+            }
+            if (grep { $_ eq q{} } @name) {
+                return "empty component in $name";
+            }
+
+            # All objects start with the type.  First check if this is a
+            # host-based type.
+            my $type = shift @name;
+            if ($FILE_TYPES{$type} && $FILE_TYPES{$type}{host}) {
+                my ($host, $extra) = @name;
+                if ($host !~ m{ [.] }xms) {
+                    return "host name $host is not fully qualified";
+                }
+                if (defined($extra) && !$FILE_TYPES{$type}{extra}) {
+                    return "extraneous component at end of $name";
+                }
+                if (!defined($extra) && $FILE_TYPES{$type}{need_extra}) {
+                    return "missing component in $name";
+                }
+                return;
+            }
+
+            # Otherwise, the name is group-based.  There be at least two
+            # remaining components.
+            if (@name < 2) {
+                return "too few components in $name";
+            }
+            my ($group, $service, $extra) = @name;
+
+            # Check the group.
+            if (!$groups{$group}) {
+                return "unknown group $group";
+            }
+
+            # Check the type.  Be sure it's not host-based.
+            if (!$FILE_TYPES{$type}) {
+                return "unknown type $type";
+            }
+            if ($FILE_TYPES{$type}{host}) {
+                return "bad name for host-based file type $type";
+            }
+
+            # Check the extra data.
+            if (defined($extra) && !$FILE_TYPES{$type}{extra}) {
+                return "extraneous component at end of $name";
+            }
+            if (!defined($extra) && $FILE_TYPES{$type}{need_extra}) {
+                return "missing component in $name";
+            }
+            return;
+        } else {
+            # Legacy naming scheme.
+            my %types  = map { $_ => 1 } @FILE_TYPES_LEGACY;
+            if ($name !~ m,^[a-zA-Z0-9_.-]+$,) {
+                return "invalid file object $name";
+            }
+            my $group_regex = '(?:' . join ('|', sort keys %groups) . ')';
+            my $type_regex  = '(?:' . join ('|', sort keys %types)  . ')';
+            if ($name !~ /^$group_regex-/) {
+                return "no recognized owning group in $name";
+            } elsif ($name !~ /^$group_regex-.*-$type_regex(-.*)?$/) {
+                return "invalid file object name $name";
+            }
         }
     }