Using Dispatch Tables To Improve Application Security

Update: I have changed the title to "Using Dispatch Tables To Improve Application Security" for clarity.

At a previous job, I saw some code that asked the user which function they wanted to run and then executed a subroutine with that name. This code demonstrates why such a practice is bad:

 use strict;
 use warnings;

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub insecure_call {
     no strict 'refs';
     shift->();
 }

 insecure_call('greet');
 insecure_call('inquire');
 insecure_call('bye');
 insecure_call('delete_all_files');

Output:

Hello!
How are you?
Farewell!
*KABOOM*

One solution to this is the dispatch table. With a dispatch table, you define up front which calls are legal for an outsider to make:

 use strict;
 use warnings;

 my %dispatch = (
     greet   => \&greet,
     inquire => \&inquire,
     bye     => \&bye,
 );

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub secure_call {
     my $call = shift;
     if ( ref $dispatch{$call} eq 'CODE' ) {
         $dispatch{$call}->();
     }
     else {
         warn "Invalid call $call";
     }
 }

 secure_call('greet');
 secure_call('inquire');
 secure_call('bye');
 secure_call('delete_all_files');

Output:

Hello!
How are you?
Farewell!
Invalid call delete_all_files at example_2a line 22.

The thing that bugs me about this particular solution (and I'll admit it's minor) is the repetition:

 my %dispatch = (
     greet   => \&greet,
     inquire => \&inquire,
     bye     => \&bye,
 );

To me, this reads like:

To go to greet, type 'greet'.
To go to inquire, type 'inquire'.
To go to bye, type 'bye'.

When it could just be asking "Which function do you wish to use?"

So, we could build the dispatch table dynamically from a list of acceptable calls:

 use strict;
 use warnings;

 my %dispatch;
 my @valid_calls = qw( greet inquire bye );

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub build_dispatch_table {
     no strict 'refs';
     %dispatch = map { $_ => *{$_} } @valid_calls;
 }

 sub secure_call {
     my $call = shift;
     if ( $dispatch{$call} ) {
         $dispatch{$call}->();
     }
     else {
         warn "Invalid call $call\n";
     }
 }

 build_dispatch_table();
 secure_call('greet');
 secure_call('inquire');
 secure_call('bye');
 secure_call('delete_all_files');

 print "\nBut, now this works because of the typeglob *{}\n";

 our @greet = qw( This is an array );
 print "@{$dispatch{greet}}\n";

 print "which annoys me even though it's probably inconsequential\n";

Output:

Hello!
How are you?
Farewell!
Invalid call delete_all_files

But, now this works because of the typeglob *{}
This is an array
which annoys me even though it's probably inconsequential

In addition to the typeglob annoyance, there is still a little repetition there: greet, inquire and bye still appear more than once in the code. I don't actually find this to be a huge deal, but how might we solve those issues? One way is including the code itself in the dispatch table:

 use strict;
 use warnings;

 my %dispatch = (

 # Documentation for greet can go here
 greet =>
     sub {
         my $greeting = shift || 'Howdy!';
         print "$greeting\n";
     },

 # Documentation for inquire can go here
 inquire =>
     sub {
         print "How are you?\n";
     },

 # Documentation for farewell can go here
 farewell =>
     sub {
         print "Bye!\n";
     },


 );

 sub delete_all_files { print "*KABOOM*" }

 sub api {
     my $call = shift;
     if ( $dispatch{$call} ) {
         $dispatch{$call}->(@_);
     }
     else {
         warn "Not executing unknown API call $call\n";
     }
 }

 api('greet','Hello.');
 api('inquire');
 api('farewell');
 api('delete_all_files');

Output:

Hello.
How are you?
Bye!
Not executing unknown API call delete_all_files

One argument against this is it adds visual complexity to the code: it's one more layer that a new developer on the project would need to mentally parse before coming up-to-speed on the code. But, that may be minor, and I think these formatting choices are developer-friendly.

Accepting Input from Multiple Sources

One of the corners I often paint myself into when developing a tool is only accepting one type of input, usually STDIN, the standard input stream, like a pipeline (ex: cat fruit.txt | grep apple) or a redirect (ex: grep apple < fruit.txt)

What inevitably happens is I end up wanting the tool to work like any Unix tool and accept different kinds of input (filenames or arguments on the command line, for example.)

Finally I got fed up with it and added a function called multi_input() to my library. Here is how it works:

First, the setup:

$ cat >meats
chicken
beef
^D
$ cat >fruits
apple
orange
banana
^D
$ cat >vegetables
carrot
lettuce
broccoli
cauliflower
^D
$ cat >a.out
this is just my
default input file
^D

To illustrate use of the function, I just reverse the input to do something "interesting" with it. The operative code is:

 my $input = multi_input();
 my $reversed = reverse $input;
 print "$input\n";
 print "$reversed\n";

So now I can interact with the tool in a variety of ways, starting with my "usual" way, STDIN:

$ ./reverse.pl < vegetables
current_input_type is: STDIN
carrot
lettuce
broccoli
cauliflower

rewolfiluac
iloccorb
ecuttel
torrac

Or STDIN by way of a pipe (this is the same mechanism in the code, but just to give another example):

$ cat fruits | ./reverse.pl
current_input_type is: STDIN
apple
orange
banana

ananab
egnaro
elppa

Or filenames provided on the command line:

$ ./reverse.pl meats fruits
current_input_type is: FILEARGS
chicken
beef
apple
orange
banana

ananab
egnaro
elppa
feeb
nekcihc

Or input provided on the command line:

$ ./reverse.pl this is not a list of filenames
current_input_type is: ARGS
this is not a list of filenames
semanelif fo tsil a ton si siht

And finally, the ultimate lazy, my default input file a.out:

$ ./reverse.pl
current_input_type is: DEFAULT
this is just my
default input file

elif tupni tluafed
ym tsuj si siht

Here is the full code listing with comments:

 #!/usr/bin/perl

 use strict;
 use warnings;

 use Term::ReadKey; # for ReadMode() below

 sub multi_input {
     my $input = '';
     my $VERBOSE = 1;

     my %INPUT_TYPE = ( # names for self-documenting code
        NONE     => 0,
        ARGS     => 1,
        FILEARGS => 2,
        STDIN    => 3,
        DEFAULT  => 4,
     );
     my %INPUT_LABEL = reverse %INPUT_TYPE; # allow lookup by number

     my $current_input_type = $INPUT_TYPE{NONE};

     # I could have done this all in one "shot" but I wanted to keep the
     # detection of input type separate from the processing of input
     my $char;
     if ( @ARGV ) {
         # Note that a filename typo will result in processing of the command
         # line like it is normal input, but that won't matter in this example.
         if ( -f $ARGV[0] ) {
             $current_input_type = $INPUT_TYPE{FILEARGS};
         }
         else {
             $current_input_type = $INPUT_TYPE{ARGS};
         }
     }
     else {
         # Code from Perl Cookbook. We peek into STDIN stream to see if
         # anything's there. The read still counts, though, so we need to save
         # $char. perldoc Term::ReadKey for information on ReadMode() and
         # ReadKey()
         ReadMode('cbreak');
         if (defined ($char = ReadKey(-1)) ) {
             $current_input_type = $INPUT_TYPE{STDIN};
         }
         else {
             $current_input_type = $INPUT_TYPE{DEFAULT};
         }
         ReadMode('normal');
     }
     warn "current_input_type is: $INPUT_LABEL{$current_input_type}\n"
         if $VERBOSE;

     if ( $current_input_type == $INPUT_TYPE{FILEARGS} ) {
         local $/; # Slurp the whole file in at once, not line-by-line
         for my $file (@ARGV) {
             open(my $ifh, '<', $file) or die "Can't open $file: $!";
             $input .= <$ifh>;
             close($ifh) || warn "close failed: $!";
         }
     }
     elsif ( $current_input_type == $INPUT_TYPE{ARGS} ) {
         $input = join ' ', @ARGV;
     }
     elsif ( $current_input_type == $INPUT_TYPE{STDIN} ) {
             # Slurp all STDIN at once, not line-by-line
             $input = $char . do { local $/; <STDIN> };
     }
     else {
         my $file = "a.out";
         open(my $ifh, '<', $file) or die "Can't open $file: $!";
         $input = do { local $/; <$ifh> };
         close($ifh) || warn "close failed: $!";
     }
     return $input;
 }

 my $input = multi_input();
 my $reversed = reverse $input;
 print "$input\n";
 print "$reversed\n";