#!/usr/bin/perl
our $ID = q$Id$;
#
# wallet-backend -- Wallet server for storing and retrieving secure data.
#
# Written by Russ Allbery <rra@stanford.edu>
# Copyright 2007 Board of Trustees, Leland Stanford Jr. University
#
# See LICENSE for licensing terms.

##############################################################################
# Declarations and site configuration
##############################################################################

use strict;
use DBI;
use Sys::Syslog qw(openlog syslog);
use Wallet::Server;

# Set to zero to suppress syslog logging, which is used only for testing.  Set
# to a reference to a string to append messages to that string instead.
our $SYSLOG;
$SYSLOG = 0 unless defined $SYSLOG;

##############################################################################
# Logging
##############################################################################

# Initialize logging.
sub log_init {
    if (ref $SYSLOG) {
        $$SYSLOG = '';
    } elsif ($SYSLOG) {
        openlog ('wallet-backend', 'pid', 'auth');
    }
}

# Get an identity string for the user suitable for including in log messages.
sub identity {
    my $identity = '';
    if ($ENV{REMOTE_USER}) {
        $identity = $ENV{REMOTE_USER};
        my $host = $ENV{REMOTE_HOST} || $ENV{REMOTE_ADDR};
        $identity .= " ($host)" if $host;
    }
    return $identity;
}

# Log an error message to both syslog and to stderr and exit with a non-zero
# status.
sub error {
    my $message = join ('', @_);
    if ($SYSLOG) {
        my $identity = identity;
        my $log;
        if ($identity) {
            $log = "error for $identity: $message";
        } else {
            $log = "error: $message";
        }
        $log =~ s/[^\x20-\x7e]/_/g;
        if (ref $SYSLOG) {
            $$SYSLOG .= "$log\n";
        } else {
            syslog ('err', "%s", $log);
        }
    }
    die "$message\n";
}

# Log a wallet failure message for a given command to both syslog and to
# stderr and exit with a non-zero status.  Takes the message and the command
# that was being run.
sub failure {
    my ($message, @command) = @_;
    if ($SYSLOG) {
        my $log = "command @command from " . identity . " failed: $message";
        $log =~ s/[^\x20-\x7e]/_/g;
        if (ref $SYSLOG) {
            $$SYSLOG .= "$log\n";
        } else {
            syslog ('err', "%s", $log);
        }
    }
    die "$message\n";
}

# Log a wallet success message for a given command.
sub success {
    my (@command) = @_;
    if ($SYSLOG) {
        my $log = "command @command from " . identity . " succeeded";
        $log =~ s/[^\x20-\x7e]/_/g;
        if (ref $SYSLOG) {
            $$SYSLOG .= "$log\n";
        } else {
            syslog ('info', "%s", $log);
        }
    }
}

##############################################################################
# Parameter checking
##############################################################################

# Check all arguments against a very restricted set of allowed characters and
# to ensure the right number of arguments are taken.  The arguments are the
# number of arguments expected (minimum and maximum), a reference to an array
# of which argument numbers shouldn't be checked, and then the arguments.
#
# This function is probably temporary and will be replaced with something that
# knows more about the syntax of each command and can check more things.
sub check_args {
    my ($min, $max, $exclude, @args) = @_;
    if (@args < $min) {
        error "insufficient arguments";
    } elsif (@args > $max and $max != -1) {
        error "too many arguments";
    }
    my %exclude = map { $_ => 1 } @$exclude;
    for (my $i = 1; $i <= @args; $i++) {
        next if $exclude{$i};
        unless ($args[$i - 1] =~ m,^[\w_/.-]+\z,) {
            error "invalid characters in argument: $args[$i - 1]";
        }
    }
}

##############################################################################
# Implementation
##############################################################################

# Parse and execute a command.  We wrap this in a subroutine call for easier
# testing.
sub command {
    log_init;
    my $user = $ENV{REMOTE_USER} or error "REMOTE_USER not set";
    my $host = $ENV{REMOTE_HOST} || $ENV{REMOTE_ADDR}
        or error "neither REMOTE_HOST nor REMOTE_ADDR set";

    # Instantiate the server object.
    my $server = Wallet::Server->new ($user, $host);

    # Parse command-line options and dispatch to the appropriate calls.
    my ($command, @args) = @_;
    if ($command eq 'acl') {
        my $action = shift @args;
        if ($action eq 'add') {
            check_args (3, 3, [], @args);
            $server->acl_add (@args) or failure ($server->error, @_);
        } elsif ($action eq 'create') {
            check_args (1, 1, [], @args);
            $server->acl_create (@args) or failure ($server->error, @_);
        } elsif ($action eq 'destroy') {
            check_args (1, 1, [], @args);
            $server->acl_destroy (@args) or failure ($server->error, @_);
        } elsif ($action eq 'history') {
            check_args (1, 1, [], @args);
            my $output = $server->acl_history (@args);
            if (defined $output) {
                print $output;
            } else {
                failure ($server->error, @_);
            }
        } elsif ($action eq 'remove') {
            check_args (3, 3, [], @args);
            $server->acl_remove (@args) or failure ($server->error, @_);
        } elsif ($action eq 'rename') {
            check_args (2, 2, [], @args);
            $server->acl_rename (@args) or failure ($server->error, @_);
        } elsif ($action eq 'show') {
            check_args (1, 1, [], @args);
            my $output = $server->acl_show (@args);
            if (defined $output) {
                print $output;
            } else {
                failure ($server->error, @_);
            }
        } else {
            error "unknown command acl $action";
        }
    } elsif ($command eq 'create') {
        check_args (2, 2, [], @args);
        $server->create (@args) or failure ($server->error, @_);
    } elsif ($command eq 'destroy') {
        check_args (2, 2, [], @args);
        $server->destroy (@args) or failure ($server->error, @_);
    } elsif ($command eq 'expires') {
        check_args (2, 4, [], @args);
        if (@args > 2) {
            $server->expires (@args) or failure ($server->error, @_);
        } else {
            my $output = $server->expires (@args);
            if (defined $output) {
                print $output, "\n";
            } elsif (not $server->error) {
                print "No expiration set\n";
            } else {
                failure ($server->error, @_);
            }
        }
    } elsif ($command eq 'flag') {
        my $action = shift @args;
        check_args (3, 3, [], @args);
        if ($action eq 'clear') {
            $server->flag_clear (@args) or failure ($server->error, @_);
        } elsif ($action eq 'set') {
            $server->flag_set (@args) or failure ($server->error, @_);
        } else {
            error "unknown command flag $action";
        }
    } elsif ($command eq 'get') {
        check_args (2, 2, [], @args);
        my $output = $server->get (@args);
        if (defined $output) {
            print $output;
        } else {
            failure ($server->error, @_);
        }
    } elsif ($command eq 'getacl') {
        check_args (3, 3, [], @args);
        my $output = $server->acl (@args);
        if (defined $output) {
            print $output, "\n";
        } elsif (not $server->error) {
            print "No ACL set\n";
        } else {
            failure ($server->error, @_);
        }
    } elsif ($command eq 'getattr') {
        check_args (3, 3, [], @args);
        my @result = $server->attr (@args);
        if (not @result and $server->error) {
            failure ($server->error, @_);
        } elsif (@result) {
            print join ("\n", @result, '');
        }
    } elsif ($command eq 'history') {
        check_args (2, 2, [], @args);
        my $output = $server->history (@args);
        if (defined $output) {
            print $output;
        } else {
            failure ($server->error, @_);
        }
    } elsif ($command eq 'owner') {
        check_args (2, 3, [], @args);
        if (@args > 2) {
            $server->owner (@args) or failure ($server->error, @_);
        } else {
            my $output = $server->owner (@args);
            if (defined $output) {
                print $output, "\n";
            } elsif (not $server->error) {
                print "No owner set\n";
            } else {
                failure ($server->error, @_);
            }
        }
    } elsif ($command eq 'setacl') {
        check_args (4, 4, [], @args);
        $server->acl (@args) or failure ($server->error, @_);
    } elsif ($command eq 'setattr') {
        check_args (4, -1, [], @args);
        $server->attr (@args) or failure ($server->error, @_);
    } elsif ($command eq 'show') {
        check_args (2, 2, [], @args);
        my $output = $server->show (@args);
        if (defined $output) {
            print $output;
        } else {
            failure ($server->error, @_);
        }
    } elsif ($command eq 'store') {
        check_args (3, 3, [3], @args);
        $server->store (@args) or failure ($server->error, @_);
    } else {
        error "unknown command $command";
    }
    success (@_);
}
command (@ARGV);
__END__

##############################################################################
# Documentation
##############################################################################

# The commands section of this document is duplicated from the documentation
# for wallet and should be kept in sync.

=head1 NAME

wallet-backend - Wallet server for storing and retrieving secure data

=head1 SYNOPSIS

B<wallet-backend> I<command> [I<args> ...]

=head1 DESCRIPTION

B<wallet-backend> implements the interface between B<remctld> and the wallet
system.  It is written to run under B<remctld> and expects the authenticated
identity of the remote user in the REMOTE_USER environment variable.  It
uses REMOTE_HOST or REMOTE_ADDR if REMOTE_HOST isn't set for additional
trace information.  It accepts the command from B<remctld> on the command
line, creates a Wallet::Server object, and calls the appropriate methods.

This program is a fairly thin wrapper around Wallet::Server that translates
command strings into method calls and returns the results.  It does check
all arguments except for the <data> argument to the store command and
rejects any argument not matching C<^[\w_/.-]+\z>; in other words, only
alphanumerics, underscore (C<_>), slash (C</>), period (C<.>), and hyphen
(C<->) are permitted in arguments.  This provides some additional security
over and above the checking already done by the rest of the wallet code.

=head1 OPTIONS

B<wallet-backend> takes no traditional options.

=head1 COMMANDS

Most commands are only available to wallet administrators (users on the
C<ADMIN> ACL).  The exceptions are C<get>, C<store>, C<show>, C<destroy>,
C<flag clear>, C<flag set>, C<getattr>, C<setattr>, and C<history>.  All
of those commands have their own ACLs except C<getattr> and C<history>,
which use the C<show> ACL, and C<setattr>, which uses the C<store> ACL.
If the appropriate ACL is set, it alone is checked to see if the user has
access.  Otherwise, C<get>, C<store>, C<show>, C<getattr>, C<setattr>, and
C<history> access is permitted if the user is authorized by the owner ACL
of the object.

Administrators can run any command on any object or ACL except for C<get>
and C<store>.  For C<get> and C<store>, they must still be authorized by
either the appropriate specific ACL or the owner ACL.

If the locked flag is set on an object, no commands can be run on that
object that change data except the C<flags> commands, nor can the C<get>
command be used on that object.  C<show>, C<history>, C<getacl>,
C<getattr>, and C<owner> or C<expires> without an argument can still be
used on that object.

For more information on attributes, see L<ATTRIBUTES>.

=over 4

=item acl add <id> <scheme> <identifier>

Adds an entry with <scheme> and <identifier> to the ACL <id>.  <id> may be
either the name of an ACL or its numeric identifier.

=item acl create <name>

Create a new, empty ACL with name <name>.  When setting an ACL on an
object with a set of entries that don't match an existing ACL, first
create a new ACL with C<acl create>, add the appropriate entries to it
with C<acl add>, and then set the ACL on an object with the C<owner> or
C<setacl> commands.

=item acl destroy <id>

Destroy the ACL <id>.  This ACL must no longer be referenced by any object
or the ACL destruction will fail.  The special ACL named C<ADMIN> cannot
be destroyed.

=item acl history <id>

Display the history of the ACL <id>.  Each change to the ACL (not
including changes to the name of the ACL) will be represented by two
lines.  The first line will have a timestamp of the change followed by a
description of the change, and the second line will give the user who made
the change and the host from which the change was mde.

=item acl remove <id> <scheme> <identifier>

Remove the entry with <scheme> and <identifier> from the ACL <id>.  <id>
may be either the name of an ACL or its numeric identifier.  The last
entry in the special ACL C<ADMIN> cannot be removed to protect against
accidental lockout, but administrators can remove themselves from the
C<ADMIN> ACL and can leave only a non-functioning entry on the ACL.  Use
caution when removing entries from the C<ADMIN> ACL.

=item acl show <id>

Display the name, numeric ID, and entries of the ACL <id>.

=item create <type> <name>

Create a new object of type <type> with name <name>.  With some backends,
this will trigger creation of an entry in an external system as well.
The new object will have no ACLs and no owner set, so usually the
administrator will want to then set an owner with C<owner> so that the
object will be usable.

=item destroy <type> <name>

Destroy the object identified by <type> and <name>.  With some backends,
this will trigger destruction of an object in an external system as well.

=item expires <type> <name> [<date> [<time>]]

If <date> is not given, displays the current expiration of the object
identified by <type> and <name>, or C<No expiration set> if none is set.
The expiration will be displayed in seconds since epoch.

If <date> is given, sets the expiration on the object identified by <type>
and <name> to <date> and (if given) <time>.  <date> must be in the format
C<YYYY-MM-DD> and <time> in the format C<HH:MM:SS>.  If <date> is the empty
string, clears the expiration of the object.

Currently, the expiration of an object is not used.

=item flag clear <type> <name> <flag>

Clears the flag <flag> on the object identified by <type> and <name>.

=item flag set <type> <name> <flag>

Sets the flag <flag> on the object identified by <type> and <name>.
Recognized flags are C<locked>, which prevents all further actions on that
object until the flag is cleared, and C<unchanging>, which tells the object
backend to not generate new data on get but instead return the same data as
previously returned.  The C<unchanging> flag is not meaningful for objects
that do not generate new data on the fly.

=item get <type> <name>

Prints to standard output the data associated with the object identified by
<type> and <name>.  This may trigger generation of new data and invalidate
old data for that object depending on the object type.

=item getacl <type> <name> <acl>

Prints the ACL <acl>, which must be one of C<get>, C<store>, C<show>,
C<destroy>, or C<flags>, for the object identified by <type> and <name>.
Prints C<No ACL set> if that ACL isn't set on that object.  Remember that
if the C<get>, C<store>, or C<show> ACLs aren't set, authorization falls
back to checking the owner ACL.  See the C<owner> command for displaying
or setting it.

=item getattr <type> <name> <attr>

Prints the object attribute <attr> for the object identified by <type> and
<name>.  Attributes are used to store backend-specific information for a
particular object type, and <attr> must be an attribute type known to the
underlying object implementation.  The attribute values, if any, are printed
one per line.  If the attribute is not set on this object, nothing is
printed.

=item history <type> <name>

Displays the history for the object identified by <type> and <name>.
This human-readable output will have two lines for each action that
changes the object, plus for any get action.  The first line has the
timestamp of the action and the action, and the second line gives the user
who performed the action and the host from which they performed it.

=item owner <type> <name> [<owner>]

If <owner> is not given, displays the current owner ACL of the object
identified by <type> and <name>, or C<No owner set> if none is set.  The
result will be the name of an ACL.

If <owner> is given, sets the owner of the object identified by <type> and
<name> to <owner>.  If <owner> is the empty string, clears the owner of
the object.

=item setacl <type> <name> <acl> <id>

Sets the ACL <acl>, which must be one of C<get>, C<store>, C<show>,
C<destroy>, or C<flags>, to <id> on the object identified by <type> and
<name>.  If <id> is the empty string, clears that ACL on the object.

=item setattr <type> <name> <attr> <value> [<value> ...]

Sets the object attribute <attr> for the object identified by <type> and
<name>.  Attributes are used to store backend-specific information for a
particular object type, and <attr> must be an attribute type known to the
underlying object implementation.  To clear the attribute for this object,
pass in a <value> of the empty string (C<''>).

=item show <type> <name>

Displays the current object metadata for the object identified by <type>
and <name>.  This human-readable output will show the object type and
name, the owner, any specific ACLs set on the object, the expiration if
any, and the user, remote host, and time when the object was created, last
stored, and last downloaded.

=item store <type> <name> <data>

Stores <data> for the object identified by <type> and <name> for later
retrieval with C<get>.  Not all object types support this.

Currently, <data> is limited to not containing nul characters and may
therefore not be binary data, and is limited by the maximum command line
length of the operating system of the wallet server.  These restrictions
will be lifted in the future.

=back

=head1 ATTRIBUTES

Object attributes store additional properties and configuration
information for objects stored in the wallet.  They are displayed as part
of the object data with C<show>, retrieved with C<getattr>, and set with
C<setattr>.

=head2 Keytab Attributes

Keytab objects support the following attributes:

=over 4

=item enctypes

Restricts the generated keytab to a specific set of encryption types.  The
values of this attribute must be enctype strings recognized by Kerberos
(strings like C<aes256-cts> or C<des-cbc-crc>).  Note that the salt should
not be included; since the salt is irrelevant for keytab keys, it will
always be set to C<normal> by the wallet.

If this attribute is set, the specified enctype list will be passed to ktadd
when get() is called for that keytab.  If it is not set, the default set in
the KDC will be used.

This attribute is ignored if the C<unchanging> flag is set on a keytab.
Keytabs retrieved with C<unchanging> set will contain all keys present in
the KDC for that Kerberos principal and therefore may contain different
enctypes than those requested by this attribute.

=item sync

Sets the external systems to which the key of a given principal is
synchronized.  The only supported value for this attribute is C<kaserver>,
which says to synchronize the key with an AFS Kerberos v4 kaserver.

If this attribute is set on a keytab, whenever the C<get> command is run for
that keytab, the DES key will be extracted from that keytab and set in the
configured AFS kaserver.  The Kerberos v4 principal name will be the same as
the Kerberos v5 principal name except that the components are separated by
C<.> instead of C</>; the second component is truncated after the first C<.>
if the first component is one of C<host>, C<ident>, C<imap>, C<pop>, or
C<smtp>; and the first component is C<rcmd> if the Kerberos v5 principal
component is C<host>.  The principal name must not contain more than two
components.

If this attribute is set, calling C<destroy> will also destroy the
principal from the AFS kaserver, with a principal mapping determined as
above.

=back

=head1 SEE ALSO

Wallet::Server(3), remctld(8)

This program 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