apparmor/parser/tst/gen-xtrans.pl

#!/usr/bin/perl

use strict;
use Locale::gettext;
use POSIX;

setlocale(LC_MESSAGES, "");

my $prefix="simple_tests/generated_x";
my $prefix_leading="simple_tests/generated_perms_leading";
my $prefix_safe="simple_tests/generated_perms_safe";

my @trans_types = ("p", "P", "c", "C", "u", "i");
my @modifiers = ("i", "u");
my %trans_modifiers = (
    "p" => \@modifiers,
    "P" => \@modifiers,
    "c" => \@modifiers,
    "C" => \@modifiers,
    );

my @targets = ("", "target", "target2");
my @null_target = ("");

my %named_trans = (
    "p" => \@targets,
    "P" => \@targets,
    "c" => \@targets,
    "C" => \@targets,
    "u" => \@null_target,
    "i" => \@null_target,
    );

my %safe_map = (
    "p" => "unsafe",
    "P" => "safe",
    "c" => "unsafe",
    "C" => "safe",
    "u" => "",
    "i" => "",
    );

my %invert_safe = (
    "safe" => "unsafe",
    "unsafe" => "safe",
    );

# audit qualifier disabled for now it really shouldn't affect the conflict
# test but it may be worth checking every once in awhile
#my @qualifiers = ("", "owner", "audit", "audit owner");
my @qualifiers = ("", "owner");

my $count = 0;

gen_conflicting_x();
gen_overlap_re_exact();
gen_dominate_re_re();
gen_ambiguous_re_re();
gen_leading_perms("exact", "/bin/cat", "/bin/cat");
gen_leading_perms("exact-re", "/bin/*", "/bin/*");
gen_leading_perms("overlap", "/*", "/bin/cat");
gen_leading_perms("dominate", "/**", "/*");
gen_leading_perms("ambiguous", "/a*", "/*b");
gen_safe_perms("exact", "PASS", "", "/bin/cat", "/bin/cat");
gen_safe_perms("exact-re", "PASS", "", "/bin/*", "/bin/*");
gen_safe_perms("overlap", "PASS", "", "/*", "/bin/cat");
gen_safe_perms("dominate", "PASS", "", "/**", "/*");
gen_safe_perms("ambiguous", "PASS", "", "/a*", "/*b");
gen_safe_perms("exact", "FAIL", "inv", "/bin/cat", "/bin/cat");
gen_safe_perms("exact-re", "FAIL", "inv", "/bin/*", "/bin/*");
gen_safe_perms("overlap", "PASS", "inv", "/*", "/bin/cat");
gen_safe_perms("dominate", "FAIL", "inv", "/**", "/*");
gen_safe_perms("ambiguous", "FAIL", "inv", "/a*", "/*b");

print "Generated $count xtransition interaction tests\n";

sub gen_list {
    my @output;
    foreach my $trans (@trans_types) {
	if ($trans_modifiers{$trans}) {
	    foreach my $mod (@{$trans_modifiers{$trans}}) {
		push @output, "${trans}${mod}x";
	    }
	}
	push @output, "${trans}x";
    }
    return @output;
}

sub print_rule($$$$$$) {
    my ($file, $leading, $qual, $name, $perm, $target) = @_;
    if ($leading) {
	print $file "\t${qual} ${perm} ${name}";
    } else {
	print $file "\t${qual} ${name} ${perm}";
    }
    if ($target ne "") {
	print $file " -> $target";
    }
    print $file ",\n";
}

sub gen_file($$$$$$$$$$$$) {
    my ($name, $xres, $leading1, $qual1, $rule1, $perm1, $target1, $leading2, $qual2, $rule2, $perm2, $target2) = @_;

#    print "$xres $rule1 $perm1 $target1 $rule2 $perm2 $target2\n";

    my $file;
    unless (open $file, ">$name") {
	print("couldn't open $name\n");
	exit 1;
    }

    print $file "#\n";
    print $file "#=DESCRIPTION ${name}\n";
    print $file "#=EXRESULT ${xres}\n";
    print $file "#\n";
    print $file "/usr/bin/foo {\n";
    print_rule($file, $leading1, $qual1, $rule1, $perm1, $target1);
    print_rule($file, $leading2, $qual2, $rule2, $perm2, $target2);
    print $file "}\n";
    close($file);

    $count++;
}

#NOTE: currently we don't do px to cx, or cx to px conversion
#      so
# /foo {
#    /* px -> /foo//bar,
#    /* cx -> bar,
#
# will conflict
#
#NOTE: conflict tests don't tests leading permissions or using unsafe keywords
#      It is assumed that there are extra tests to verify 1 to 1 coorispondance
sub gen_files($$$$) {
    my ($name, $rule1, $rule2, $default) = @_;

    my @perms = gen_list();

#    print "@perms\n";

    foreach my $i (@perms) {
	foreach my $t (@{$named_trans{substr($i, 0, 1)}}) {
	    foreach my $q (@qualifiers) {
		foreach my $j (@perms) {
		    foreach my $u (@{$named_trans{substr($j, 0, 1)}}) {
			foreach my $r (@qualifiers) {
			    my $file="${prefix}/${name}-$q$i$t-$r$j$u.sd";
#		    print "$file\n";

		    #override failures when transitions are the same
			    my $xres = ${default};
			    if ($i eq $j && $t eq $u) {
				$xres = "PASS";
			    }


#		    print "foo $xres $rule1 $i $t $rule2 $j $u\n";
			    gen_file($file, $xres, 0, $q, $rule1, $i, $t, 0, $r, $rule2, $j, $u);
			}
		    }
		}
	    }
	}
    }

}

sub gen_conflicting_x {
    gen_files("conflict", "/bin/cat", "/bin/cat", "FAIL");
}

sub gen_overlap_re_exact {

    gen_files("exact", "/bin/cat", "/bin/*", "PASS");
}

# we currently don't support this, once supported change to "PASS"
sub gen_dominate_re_re {
    gen_files("dominate", "/bin/*", "/bin/**", "FAIL");
}

sub gen_ambiguous_re_re {
    gen_files("ambiguous", "/bin/a*", "/bin/*b", "FAIL");
}


# test that rules that lead with permissions don't conflict with
# the same rule using trailing permissions.
sub gen_leading_perms($$$) {
    my ($name, $rule1, $rule2) = @_;

    my @perms = gen_list();

    foreach my $i (@perms) {
	foreach my $t (@{$named_trans{substr($i, 0, 1)}}) {
	    foreach my $q (@qualifiers) {
		my $file="${prefix_leading}/${name}-$q$i$t.sd";
#		    print "$file\n";

		gen_file($file, "PASS", 0, $q, $rule1, $i, $t, 1, $q, $rule2, $i, $t);
	    }
	}
    }
}

# test for rules with leading safe or unsafe keywords.
# check they are equivalent to their counter part,
# or if $invert that they properly conflict with their counterpart
sub gen_safe_perms($$$$$) {
    my ($name, $xres, $invert, $rule1, $rule2) = @_;

    my @perms = gen_list();

    foreach my $i (@perms) {
	foreach my $t (@{$named_trans{substr($i, 0, 1)}}) {
	    foreach my $q (@qualifiers) {
		my $qual = $safe_map{substr($i, 0, 1)};
		if ($invert) {
		    $qual = $invert_safe{$qual};
		}
		if (! $invert || $qual) {
		    my $file="${prefix_safe}/${name}-$invert-$q${qual}-rule-$i$t.sd";
#		    print "$file\n";
		    gen_file($file, $xres, 0, "$q $qual", $rule1, $i, $t, 1, $q, $rule2, $i, $t);
		    $file="${prefix_safe}/${name}-$invert-$q$qual${i}-rule-$t.sd";
		    gen_file($file, $xres, 0, $q, $rule1, $i, $t, 1, "$q $qual", $rule2, $i, $t);
		}

	    }
	}
    }
}