wallet-report: Added report of all host-based objects for host

"wallet-report objects host <hostname>" reports on all objects that
belong to the given host.  This can be used to query things for retiring
systems.

Change-Id: Ib1c8e5978fed141d54ecc8504b56b43c037f9b17

5 files changed, 173 insertions, 20 deletions

diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm
index 76c7ecd..b3e1931 100644
--- a/perl/lib/Wallet/Config.pm
+++ b/perl/lib/Wallet/Config.pm
@@ -792,6 +792,34 @@ keytab objects for particular principals have fully-qualified hostnames:
 Objects that aren't of type C<keytab> or which aren't for a host-based key
 have no naming requirements enforced by this example.
 
+=head1 OBJECT HOST-BASED NAMES
+
+The above demonstrates having a host-based naming convention, where we
+expect one part of an object name to be the name of the host that this
+object is for.  The most obvious examples are those keytab objects
+above, where we want certain keytab names to be in the form of
+<service>/<hostname>.  It's then also useful to provide a Perl function
+named is_for_host which then can be used to tell if a given object is a
+host-based keytab for a specific host.  This function is then called by
+the objects_hostname in Wallet::Report to give a list of all host-based
+objects for a given hostname.  It should return true if the given object
+is a host-based object for the hostname, otherwise false.
+
+An example that matches the same policy as the last verify_name example
+would be:
+
+    sub is_for_host {
+        my ($type, $name, $hostname) = @_;
+        my %host_based = map { $_ => 1 }
+            qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth);
+        return 0 unless $type eq 'keytab';
+        return 0 unless $name =~ m%/%;
+        my ($service, $instance) = split ('/', $name, 2);
+        return 0 unless $host_based{$service};
+        return 1 if $hostname eq $instance;
+        return 0;
+    }
+
 =head1 ACL NAMING ENFORCEMENT
 
 Similar to object names, by default wallet permits administrators to
diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
index 362f098..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);
 }
 
 ##############################################################################
@@ -87,6 +87,18 @@ our %PASSWORD_TYPE = (
     '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);
 
@@ -204,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
@@ -211,21 +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,
-        '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,
-    );
-
     # 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;
diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm
index 4d92d64..fc7bb4d 100644
--- a/perl/lib/Wallet/Report.pm
+++ b/perl/lib/Wallet/Report.pm
@@ -249,7 +249,7 @@ sub objects {
 # Farms out specific statement to another subroutine for specific search
 # types, but each case should return ob_type and ob_name in that order.
 sub objects_history {
-    my ($self, $type, @args) = @_;
+    my ($self, $search_type, @args) = @_;
     undef $self->{error};
 
     # All fields in the order we want to see them.
@@ -284,6 +284,56 @@ sub objects_history {
     return @objects;
 }
 
+# Returns a list of all objects stored in the wallet database in the form of
+# type and name pairs.  On error and for an empty database, the empty list
+# will be returned.  To distinguish between an empty list and an error, call
+# error(), which will return undef if there was no error.  Farms out specific
+# statement to another subroutine for specific search types, but each case
+# should return ob_type and ob_name in that order.
+sub objects_hostname {
+    my ($self, $type, $hostname) = @_;
+    undef $self->{error};
+
+    # Make sure we have a given hostname.
+    if (!$hostname) {
+        $self->error ("object hosts requires one argument to search");
+        return;
+    }
+
+    # If we don't have a way to get host-based object lists, quit.
+    unless (defined &Wallet::Config::is_for_host) {
+        $self->error ('no host-based policy defined');
+        return;
+    }
+
+    # Search on all objects.
+    my %search = ();
+    my %options = (order_by => [ qw/ob_type ob_name/ ],
+                   select   => [ qw/ob_type ob_name/ ]);
+
+    my @objects;
+    my $schema = $self->{schema};
+    eval {
+        my @objects_rs = $schema->resultset('Object')->search (\%search,
+                                                               \%options);
+
+        # Check to see if an object is for the given host and add to list if
+        # so.
+        for my $object_rs (@objects_rs) {
+            my $type = $object_rs->ob_type;
+            my $name = $object_rs->ob_name;
+            next unless &Wallet::Config::is_for_host($type, $name, $hostname);
+            push (@objects, [ $type, $name ]);
+        }
+    };
+    if ($@) {
+        $self->error ("cannot list objects: $@");
+        return;
+    }
+
+    return @objects;
+}
+
 ##############################################################################
 # Type reports
 ##############################################################################
@@ -753,6 +803,24 @@ empty search result, the caller should call error().  error() is
 guaranteed to return the error message if there was an error and undef if
 there was no error.
 
+=item objects_history(TYPE)
+
+Returns a dump of the entire object history table.  The return value is
+a list of references to each field in that table, in the following order:
+
+    oh_on, oh_by, oh_type, oh_name, oh_action, oh_from
+
+=item objects_hostname(TYPE, HOSTNAME)
+
+Returns a list of all host-based objects for a given hostname.  The
+output is identical to the general objects command, but we need to
+separate this out because the way it searches is very different.
+
+Returns the empty list on failure.  To distinguish between this and an
+empty search result, the caller should call error().  error() is
+guaranteed to return the error message if there was an error and undef if
+there was no error.
+
 =item owners(TYPE, NAME)
 
 Returns a list of all ACL lines contained in owner ACLs for objects
diff --git a/perl/t/general/report.t b/perl/t/general/report.t
index a63ab79..170fe29 100755
--- a/perl/t/general/report.t
+++ b/perl/t/general/report.t
@@ -11,7 +11,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 215;
+use Test::More tests => 218;
 
 use Wallet::Admin;
 use Wallet::Report;
@@ -281,6 +281,22 @@ is (scalar (@lines), 1, 'Searching for ACL naming violations finds one');
 is ($lines[0][0], 3, ' and the first has the right ID');
 is ($lines[0][1], 'second', ' and the right name');
 
+# Set a host-based object matching script so that we can test the host report.
+# The deactivation trick isn't needed here.
+package Wallet::Config;
+sub is_for_host {
+    my ($type, $name, $host) = @_;
+    my ($service, $principal) = split ('/', $name, 2);
+    return 0 unless $service && $principal;
+    return 1 if $host eq $principal;
+    return 0;
+}
+package main;
+@lines = $report->objects_hostname ('host', 'admin');
+is (scalar (@lines), 1, 'Searching for host-based objects finds one');
+is ($lines[0][0], 'base', ' and the first has the right type');
+is ($lines[0][1], 'service/admin', ' and the right name');
+
 # Set up a file bucket so that we can create an object we can retrieve.
 system ('rm -rf test-files') == 0 or die "cannot remove test-files\n";
 mkdir 'test-files' or die "cannot create test-files: $!\n";
diff --git a/perl/t/policy/stanford.t b/perl/t/policy/stanford.t
index 555086c..9ed0fa6 100755
--- a/perl/t/policy/stanford.t
+++ b/perl/t/policy/stanford.t
@@ -16,7 +16,7 @@ use 5.008;
 use strict;
 use warnings;
 
-use Test::More tests => 101;
+use Test::More tests => 130;
 
 use lib 't/lib';
 use Util;
@@ -24,7 +24,8 @@ use Util;
 # Load the naming policy module.
 BEGIN {
     use_ok('Wallet::Admin');
-    use_ok('Wallet::Policy::Stanford', qw(default_owner verify_name));
+    use_ok('Wallet::Policy::Stanford',
+           qw(default_owner verify_name is_for_host));
     use_ok('Wallet::Server');
 }
 
@@ -101,6 +102,29 @@ for my $name (@INVALID_FILES) {
     isnt(verify_name('file', $name), undef, "Invalid file $name");
 }
 
+# Now test a few cases for checking to see if a file is host-based.  We don't
+# test the legacy examples because they're more complicated and less obvious.
+for my $name (@VALID_KEYTABS) {
+    my $hostname = 'example.stanford.edu';
+    if ($name =~ m{\b$hostname\b}) {
+        is(is_for_host('keytab', $name, $hostname), 1,
+           "Keytab $name belongs to $hostname");
+    } else {
+        is(is_for_host('keytab', $name, $hostname), 0,
+           "Keytab $name doesn't belong to $hostname");
+    }
+}
+for my $name (@VALID_FILES) {
+    my $hostname = 'example.stanford.edu';
+    if ($name =~ m{\b$hostname\b}) {
+        is(is_for_host('file', $name, $hostname), 1,
+           "File $name belongs to $hostname");
+    } else {
+        is(is_for_host('file', $name, $hostname), 0,
+           "File $name doesn't belong to $hostname");
+    }
+}
+
 # Now we need an actual database.  Use Wallet::Admin to set it up.
 db_setup;
 my $setup = eval { Wallet::Admin->new };