summaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
Diffstat (limited to 'perl')
-rw-r--r--perl/Wallet/Policy/Stanford.pm237
-rwxr-xr-xperl/t/stanford-naming.t193
2 files changed, 430 insertions, 0 deletions
diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm
new file mode 100644
index 0000000..906f6ba
--- /dev/null
+++ b/perl/Wallet/Policy/Stanford.pm
@@ -0,0 +1,237 @@
+# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy.
+#
+# Written by Russ Allbery <rra@stanford.edu>
+# Copyright 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Policy::Stanford;
+
+use 5.008;
+use strict;
+use warnings;
+
+use base qw(Exporter);
+
+# Declare variables that should be set in BEGIN for robustness.
+our (@EXPORT_OK, $VERSION);
+
+# Set $VERSION and everything export-related in a BEGIN block for robustness
+# 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);
+}
+
+##############################################################################
+# Implementation
+##############################################################################
+
+# Retrieve an existing ACL and check whether it contains a netdb-root member.
+# This is used to check if a default ACL is already present with a netdb-root
+# member so that we can return a default owner that matches. We only ever
+# increase the ACL from netdb to netdb-root, never degrade it, so this doesn't
+# pose a security problem.
+#
+# On any failure, just return an empty ACL to use the default.
+sub acl_has_netdb_root {
+ my ($name) = @_;
+ my $schema = eval { Wallet::Schema->connect };
+ return unless ($schema and not $@);
+ my $acl = eval { Wallet::ACL->new ($name, $schema) };
+ return unless ($acl and not $@);
+ for my $line ($acl->list) {
+ return 1 if $line->[0] eq '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 {
+ my ($name) = @_;
+ my %allowed = map { $_ => 1 }
+ qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
+ my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')';
+ if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) {
+ return;
+ }
+ my $host = $1;
+ if ($host !~ /\./) {
+ $host .= '.stanford.edu';
+ }
+ return $host;
+}
+
+# Map a keytab object name to a hostname and return it. Returns undef if this
+# 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);
+ return unless $name =~ m,/,;
+ my ($service, $host) = split ('/', $name, 2);
+ return unless $allowed{$service};
+ if ($host !~ /\./) {
+ $host .= '.stanford.edu';
+ }
+ return $host;
+}
+
+# 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
+# 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,
+ );
+ 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)) {
+ @acl = ([ 'netdb-root', $host ],
+ [ 'krb5', "host/$host\@$realm" ]);
+ } else {
+ @acl = ([ 'netdb', $host ],
+ [ 'krb5', "host/$host\@$realm" ]);
+ }
+ return ($acl_name, @acl);
+}
+
+# Enforce a naming policy. Host-based keytabs must have fully-qualified
+# 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
+# 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')) {
+ local $_;
+ while (<STAFF>) {
+ s/^\s+//;
+ s/\s+$//;
+ next if m,/root\@,;
+ $staff{$_} = 1;
+ }
+ close STAFF;
+ }
+
+ # Check for a staff member not using their root instance.
+ if (defined ($user) && $staff{$user}) {
+ return 'use a */root instance for wallet object creation';
+ }
+
+ # Check keytab naming conventions.
+ if ($type eq 'keytab') {
+ if ($name !~ m,^[a-zA-Z0-9_-]+/[a-z0-9.-]+$,) {
+ return "invalid principal name $name";
+ }
+ my ($principal, $instance)
+ = ($name =~ m,^([a-zA-Z0-9_-]+)/([a-z0-9.-]+)$,);
+ unless (defined ($principal) && defined ($instance)) {
+ return "invalid principal name $name";
+ }
+ if ($host{$principal} and $principal ne 'http') {
+ if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) {
+ return "host name $instance is not fully qualified";
+ }
+ } elsif ($principal eq 'service') {
+ if ($instance !~ /^[a-z0-9-]+$/) {
+ return "invalid service principal name $name";
+ }
+ } elsif ($instance eq 'cgi') {
+ if ($principal !~ /^[a-z][a-z0-9]{1,7}$/
+ and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) {
+ return "invalid CGI principal name $name";
+ }
+ } else {
+ return "unknown principal type $principal";
+ }
+ }
+
+ # 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";
+ }
+ }
+
+ # Success.
+ return;
+}
+
+1;
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Policy::Stanford - Stanford's wallet naming and ownership policy
+
+=head1 SYNOPSIS
+
+ use Wallet::Policy::Stanford;
+ my ($type, $name, $user) = @_;
+
+ my $error = valid_name($type, $name, $user);
+ my ($name, @acl) = default_owner($type, $name);
+
+=head1 DESCRIPTION
+
+Wallet::Policy::Stanford implements Stanford's wallet naming and ownership
+policy as described in F<docs/stanford-naming> in the wallet distribution.
+It is primarily intended as an example for other sites, but it is used at
+Stanford to implement that policy.
+
+This module provides the default_owner() and verify_name() functions that
+are part of the wallet configuration interface (as documented in
+L<Wallet::Config>). They can be imported directly into a wallet
+configuration file from this module or wrapped to apply additional rules.
+
+=head1 SEE ALSO
+
+Wallet::Config(3)
+
+The L<Stanford policy|http://www.eyrie.org/~eagle/software/wallet/naming.html>
+implemented by this module.
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>
+
+=cut
diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t
new file mode 100755
index 0000000..ec3760a
--- /dev/null
+++ b/perl/t/stanford-naming.t
@@ -0,0 +1,193 @@
+#!/usr/bin/perl
+#
+# Tests for the Stanford naming policy.
+#
+# The naming policy code is included primarily an example for non-Stanford
+# sites, but it's used at Stanford and this test suite is used to verify
+# behavior at Stanford.
+#
+# Written by Russ Allbery <rra@stanford.edu>
+# Copyright 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+use 5.008;
+use strict;
+use warnings;
+
+use Test::More tests => 57;
+
+use lib 't/lib';
+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::Server');
+}
+
+# Various valid keytab names.
+my @VALID_KEYTABS = qw(host/example.stanford.edu HTTP/example.stanford.edu
+ service/example example/cgi class-example01/cgi dept-01example/cgi
+ group-example-01/cgi);
+
+# Various invalid keytab names.
+my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu
+ thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu);
+
+# Various valid file names.
+my @VALID_FILES = qw(apps-example-config-file crcsg-example-db-s_example
+ idg-debian-gpg-key idg-devnull-password-root sulair-accounts-properties
+ idg-accounts-ssl-keystore idg-accounts-ssl-pkcs12
+ crcsg-example-htpasswd-web sulair-example-password-ipmi
+ sulair-example-password-root sulair-example-password-tivoli
+ sulair-example-ssh-dsa sulair-example-ssh-rsa idg-mdm-ssl-key
+ idg-openafs-tivoli-key);
+
+# Various invalid file names.
+my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad);
+
+# Global variables for the wallet server setup.
+my $ADMIN = 'admin@EXAMPLE.COM';
+my $HOST = 'localhost';
+my @TRACE = ($ADMIN, $HOST);
+
+# Start by testing lots of straightforward naming validity.
+for my $name (@VALID_KEYTABS) {
+ is(verify_name('keytab', $name), undef, "Valid keytab $name");
+}
+for my $name (@INVALID_KEYTABS) {
+ isnt(verify_name('keytab', $name), undef, "Invalid keytab $name");
+}
+for my $name (@VALID_FILES) {
+ is(verify_name('file', $name), undef, "Valid file $name");
+}
+for my $name (@INVALID_FILES) {
+ isnt(verify_name('file', $name), undef, "Invalid file $name");
+}
+
+# Now we need an actual database. Use Wallet::Admin to set it up.
+db_setup;
+my $setup = eval { Wallet::Admin->new };
+is($@, q{}, 'Database initialization did not die');
+is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded');
+my $server = eval { Wallet::Server->new(@TRACE) };
+is($@, q{}, 'Server creation did not die');
+
+# Create a host/example.stanford.edu ACL that uses the netdb ACL type.
+is($server->acl_create('host/example.stanford.edu'), 1, 'Created netdb ACL');
+is(
+ $server->acl_add('host/example.stanford.edu', 'netdb',
+ 'example.stanford.edu'),
+ 1,
+ '...with netdb ACL line'
+);
+is(
+ $server->acl_add('host/example.stanford.edu', 'krb5',
+ 'host/example.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+);
+
+# Likewise for host/foo.example.edu with the netdb-root ACL type.
+is($server->acl_create('host/foo.stanford.edu'), 1, 'Created netdb-root ACL');
+is(
+ $server->acl_add('host/foo.stanford.edu', 'netdb-root',
+ 'foo.stanford.edu'),
+ 1,
+ '...with netdb-root ACL line'
+);
+is(
+ $server->acl_add('host/foo.stanford.edu', 'krb5',
+ 'host/foo.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+);
+
+# Now we can test default ACLs. First, without a root instance.
+local $ENV{REMOTE_USER} = $ADMIN;
+is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab'
+);
+is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+);
+is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+);
+
+# Now with a root instance.
+local $ENV{REMOTE_USER} = 'admin/root@stanford.edu';
+is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb-root', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab for /root'
+);
+is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+);
+is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+);
+
+# Check for a type that isn't host-based.
+is(default_owner('keytab', 'service/foo'), undef,
+ 'No default owner for service/foo');
+
+# Check for an unknown object type.
+is(default_owner('unknown', 'foo'), undef,
+ 'No default owner for unknown type');
+
+# Check for legacy autocreation mappings for file objects.
+for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) {
+ my $name = "idg-example-$type";
+ is_deeply(
+ [default_owner('file', $name)],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ "Default owner for file $name",
+ );
+}
+
+# Clean up.
+$setup->destroy;
+unlink 'wallet-db';
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-06 07:00:12 +0000