Merge pull request #2 from jonrober/master

Changes so far for 1.3

1 files changed, 126 insertions, 18 deletions

diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
index a392476..86e204e 100644
--- a/perl/lib/Wallet/Policy/Stanford.pm
+++ b/perl/lib/Wallet/Policy/Stanford.pm
@@ -25,8 +25,8 @@ our (@EXPORT_OK, $VERSION);
 # against circular module loading (not that we load any modules, but
 # consistency is good).
 BEGIN {
-    $VERSION   = '1.00';
-    @EXPORT_OK = qw(default_owner verify_name);
+    $VERSION   = '1.01';
+    @EXPORT_OK = qw(default_owner verify_name is_for_host);
 }
 
 ##############################################################################
@@ -66,8 +66,9 @@ our %FILE_TYPE = (
     'password-root'   => { host => 1 },
     'password-tivoli' => { host => 1 },
     properties        => {            extra => 1 },
-    'ssh-dsa'         => { host => 1 },
-    'ssh-rsa'         => { host => 1 },
+    'ssh-dsa'         => { host => 1, extra => 1 },
+    'ssh-rsa'         => { host => 1, extra => 1 },
+    'ssl-chain'       => { host => 1, extra => 1 },
     'ssl-key'         => { host => 1, extra => 1 },
     'ssl-keypair'     => { host => 1, extra => 1 },
     'ssl-keystore'    => {            extra => 1 },
@@ -75,6 +76,29 @@ our %FILE_TYPE = (
     'tivoli-key'      => { host => 1 },
 );
 
+# Password object types.  Most of these mimic file object types (which should
+# be gradually phased out).
+our %PASSWORD_TYPE = (
+    'ipmi'            => { host => 1 },
+    'root'            => { host => 1 },
+    'tivoli'          => { host => 1 },
+    'system'          => { host => 1, extra => 1, need_extra => 1 },
+    'app'             => { host => 1, extra => 1, need_extra => 1 },
+    'service'         => {            extra => 1, need_extra => 1 },
+);
+
+# Mappings that let us determine the host for a host-based object, if any.
+our %HOST_FOR = (
+    'keytab'     => \&_host_for_keytab,
+    'file'       => \&_host_for_file,
+    'password'   => \&_host_for_password,
+    'duo'        => \&_host_for_duo,
+    'duo-pam'    => \&_host_for_duo,
+    'duo-radius' => \&_host_for_duo,
+    'duo-ldap'   => \&_host_for_duo,
+    'duo-rdp'    => \&_host_for_duo,
+);
+
 # 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);
 
@@ -144,6 +168,17 @@ sub _host_for_file_legacy {
     return $host;
 }
 
+# Map a password object name to a hostname.  Returns undef if this password
+# object name doesn't map to a hostname.
+sub _host_for_password {
+    my ($name) = @_;
+
+    # Parse the name and check whether this is a host-based object.
+    my ($type, $host) = split('/', $name);
+    return if !$PASSWORD_TYPE{$type}{host};
+    return $host;
+}
+
 # Map a file object name to a hostname.  Returns undef if this file object
 # name doesn't map to a hostname.
 sub _host_for_file {
@@ -181,6 +216,23 @@ sub _host_for_duo {
     return $name;
 }
 
+# Take a object type and name, along with a host name, and use these to
+# decide if the given object is host-based and matches the given host.
+sub is_for_host {
+    my ($type, $name, $host) = @_;
+
+    # If we have a possible host mapping, get the host and see if it matches.
+    if (defined($HOST_FOR{$type})) {
+        my $object_host = $HOST_FOR{$type}->($name);
+        return 0 unless $object_host;
+        if ($host eq $object_host) {
+            return 1;
+        }
+    }
+
+    return 0;
+}
+
 # The default owner of host-based objects should be the host keytab and the
 # NetDB ACL for that host, with one twist.  If the creator of a new node is
 # using a root instance, we want to require everyone managing that node be
@@ -188,20 +240,9 @@ sub _host_for_duo {
 sub default_owner {
     my ($type, $name) = @_;
 
-    # How to determine the host for host-based objects.
-    my %host_for = (
-        'keytab'     => \&_host_for_keytab,
-        'file'       => \&_host_for_file,
-        'duo'        => \&_host_for_duo,
-        'duo-pam'    => \&_host_for_duo,
-        'duo-radius' => \&_host_for_duo,
-        'duo-ldap'   => \&_host_for_duo,
-        'duo-rdp'    => \&_host_for_duo,
-    );
-
     # If we have a possible host mapping, see if we can use that.
-    if (defined($host_for{$type})) {
-        my $host = $host_for{$type}->($name);
+    if (defined($HOST_FOR{$type})) {
+        my $host = $HOST_FOR{$type}->($name);
         if ($host) {
             my $acl_name = "host/$host";
             my @acl;
@@ -242,7 +283,7 @@ sub default_owner {
 # hostnames, limit the acceptable characters for service/* keytabs, and
 # enforce our naming constraints on */cgi principals.
 #
-# Also use this function to require that IDG staff always do implicit object
+# Also use this function to require that ACS staff always do implicit object
 # creation using a */root instance.
 sub verify_name {
     my ($type, $name, $user) = @_;
@@ -363,6 +404,8 @@ sub verify_name {
                 return "missing component in $name";
             }
             return;
+
+
         } else {
             # Legacy naming scheme.
             my %groups = map { $_ => 1 } @GROUPS_LEGACY;
@@ -380,6 +423,71 @@ sub verify_name {
         }
     }
 
+    # Check password object naming conventions.
+    if ($type eq 'password') {
+        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 ($PASSWORD_TYPE{$type} && $PASSWORD_TYPE{$type}{host}) {
+                my ($host, $extra) = @name;
+                if ($host !~ m{ [.] }xms) {
+                    return "host name $host is not fully qualified";
+                }
+                if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+                    return "extraneous component at end of $name";
+                }
+                if (!defined($extra) && $PASSWORD_TYPE{$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 (!$ACL_FOR_GROUP{$group}) {
+                return "unknown group $group";
+            }
+
+            # Check the type.  Be sure it's not host-based.
+            if (!$PASSWORD_TYPE{$type}) {
+                return "unknown type $type";
+            }
+            if ($PASSWORD_TYPE{$type}{host}) {
+                return "bad name for host-based file type $type";
+            }
+
+            # Check the extra data.
+            if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+                return "extraneous component at end of $name";
+            }
+            if (!defined($extra) && $PASSWORD_TYPE{$type}{need_extra}) {
+                return "missing component in $name";
+            }
+            return;
+        }
+    }
+
     # Check the naming conventions for all Duo object types.  The object
     # should simply be the host name for now.
     if ($type =~ m{^duo(-\w+)?$}) {