1
# $Id: SubDomain.pm 509 2007-03-30 17:04:04Z jmichael-at-suse-de $
3
# ----------------------------------------------------------------------
4
# Copyright (c) 2006 Novell, Inc. All Rights Reserved.
6
# This program is free software; you can redistribute it and/or
7
# modify it under the terms of version 2 of the GNU General Public
8
# License as published by the Free Software Foundation.
10
# This program is distributed in the hope that it will be useful,
11
# but WITHOUT ANY WARRANTY; without even the implied warranty of
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
# GNU General Public License for more details.
15
# You should have received a copy of the GNU General Public License
16
# along with this program; if not, contact Novell, Inc.
18
# To contact Novell about this file by physical or electronic mail,
19
# you may find current contact information at www.novell.com.
20
# ----------------------------------------------------------------------
22
package Immunix::SubDomain;
28
use Cwd qw(cwd realpath);
35
use Immunix::Severity;
38
our @ISA = qw(Exporter);
49
$running_under_genprof
94
our $confdir = "/etc/apparmor";
96
our $running_under_genprof = 0;
101
our $unimplemented_warning = 0;
103
# keep track of if we're running under yast or not - default to text mode
104
our $UI_Mode = "text";
108
# initialize Term::ReadLine if it's available
111
require Term::ReadLine;
112
import Term::ReadLine;
113
$term = new Term::ReadLine 'AppArmor';
116
# initialize the local poo
117
setlocale(LC_MESSAGES, "");
118
textdomain("apparmor-utils");
120
# where do we get our log messages from?
122
if (-f "/var/log/audit/audit.log") {
123
$filename = "/var/log/audit/audit.log";
124
} elsif (-f "/etc/slackware-version") {
125
$filename = "/var/log/syslog";
127
$filename = "/var/log/messages";
130
our $profiledir = "/etc/apparmor.d";
132
# we keep track of the included profile fragments with %include
135
my %existing_profiles;
137
our $ldd = "/usr/bin/ldd";
138
our $parser = "/sbin/subdomain_parser";
139
$parser = "/sbin/apparmor_parser" if -f "/sbin/apparmor_parser";
148
our @custom_includes;
150
# these are globs that the user specifically entered. we'll keep track of
151
# them so that if one later matches, we'll suggest it again.
154
### THESE VARIABLES ARE USED WITHIN LOGPROF
157
our %sd; # we keep track of the original profiles in %sd
168
our %helpers; # we want to preserve this one between passes
170
my %variables; # variables in config files
172
### THESE VARIABLES ARE USED WITHIN LOGPROF
177
print DEBUG "$message\n" if $DEBUGGING;
181
use POSIX qw(:termios_h);
183
my ($term, $oterm, $echo, $noecho, $fd_stdin);
185
$fd_stdin = fileno(STDIN);
187
$term = POSIX::Termios->new();
188
$term->getattr($fd_stdin);
189
$oterm = $term->getlflag();
191
$echo = ECHO | ECHOK | ICANON;
192
$noecho = $oterm & ~$echo;
195
$term->setlflag($noecho);
196
$term->setcc(VTIME, 1);
197
$term->setattr($fd_stdin, TCSANOW);
201
$term->setlflag($oterm);
202
$term->setcc(VTIME, 0);
203
$term->setattr($fd_stdin, TCSANOW);
209
sysread(STDIN, $key, 1);
214
# set things up to log extra info if they want...
215
if ($ENV{LOGPROF_DEBUG}) {
217
open(DEBUG, ">/tmp/logprof_debug_$$.log");
218
my $oldfd = select(DEBUG);
227
# reset the terminal state
230
$DEBUGGING && debug "Exiting...";
232
# close the debug log if necessary
233
close(DEBUG) if $DEBUGGING;
236
# returns true if the specified program contains references to LD_PRELOAD or
237
# LD_LIBRARY_PATH to give the PX/UX code better suggestions
238
sub check_for_LD_XXX ($) {
241
return undef unless -f $file;
243
# limit our checking to programs/scripts under 10k to speed things up a bit
245
return undef unless ($size && $size < 10000);
248
if (open(F, $file)) {
250
$found = 1 if /LD_(PRELOAD|LIBRARY_PATH)/;
258
sub fatal_error ($) {
261
my $details = "$message\n";
265
# we'll include the stack backtrace if we're debugging...
266
$details = Carp::longmess($message);
268
# write the error to the log
269
print DEBUG $details;
272
# we'll just shoot ourselves in the head if it was one of the yast
273
# interface functions that ran into an error. it gets really ugly if
274
# the yast frontend goes away and we try to notify the user of that
275
# problem by trying to send the yast frontend a pretty dialog box
276
my $caller = (caller(1))[3];
277
exit 1 if $caller =~ /::(Send|Get)Data(To|From)Yast$/;
279
# tell the user what the hell happened
280
UI_Important($details);
282
# make sure the frontend exits cleanly...
285
# die a horrible flaming death
291
# set up the yast connection if we're running under yast...
292
if ($ENV{YAST_IS_RUNNING}) {
294
# load the yast module if available.
295
eval { require ycp; };
301
# let the frontend know that we're starting
303
type => "initial_handshake",
304
status => "backend_starting"
307
# see if the frontend is just starting up also...
308
my ($ypath, $yarg) = GetDataFromYast();
310
&& (ref($yarg) eq "HASH")
311
&& ($yarg->{type} eq "initial_handshake")
312
&& ($yarg->{status} eq "frontend_starting"))
315
# something's broken, die a horrible, painful death
316
fatal_error "Yast frontend is out of sync from backend agent.";
319
# the yast connection seems to be working okay
330
if ($UI_Mode eq "yast") {
331
SendDataToYast({ type => "final_shutdown" });
332
my ($ypath, $yarg) = GetDataFromYast();
336
sub check_for_subdomain () {
338
my ($support_subdomainfs, $support_securityfs);
339
if (open(MOUNTS, "/proc/filesystems")) {
341
$support_subdomainfs = 1 if m/subdomainfs/;
342
$support_securityfs = 1 if m/securityfs/;
347
my $sd_mountpoint = "";
348
if (open(MOUNTS, "/proc/mounts")) {
350
if ($support_subdomainfs) {
351
$sd_mountpoint = $1 if m/^\S+\s+(\S+)\s+subdomainfs\s/;
352
} elsif ($support_securityfs) {
353
if (m/^\S+\s+(\S+)\s+securityfs\s/) {
354
if (-e "$1/apparmor") {
355
$sd_mountpoint = "$1/apparmor";
356
} elsif (-e "$1/subdomain") {
357
$sd_mountpoint = "$1/subdomain";
365
# make sure that subdomain is actually mounted there
366
$sd_mountpoint = undef unless -f "$sd_mountpoint/profiles";
368
return $sd_mountpoint;
374
foreach my $dir (split(/:/, $ENV{PATH})) {
375
return "$dir/$file" if -x "$dir/$file";
381
# we need to convert subdomain regexps to perl regexps
382
sub convert_regexp ($) {
385
# escape regexp-special characters we don't support
386
$regexp =~ s/(?<!\\)(\+|\$)/\\$1/g;
388
# escape . characters
389
$regexp =~ s/(?<!\\)\./SDPROF_INTERNAL_DOT/g;
391
# convert ** globs to match anything
392
$regexp =~ s/(?<!\\)\*\*/.SDPROF_INTERNAL_GLOB/g;
394
# convert * globs to match anything at current path level
395
$regexp =~ s/(?<!\\)\*/[^\/]SDPROF_INTERNAL_GLOB/g;
397
# convert ? globs to match a single character at current path level
398
$regexp =~ s/(?<!\\)\?/[^\/]/g;
400
# convert {foo,baz} to (foo|baz)
401
$regexp =~ y/\{\}\,/\(\)\|/ if $regexp =~ /\{.*\,.*\}/;
403
# twiddle the escaped * chars back
404
$regexp =~ s/SDPROF_INTERNAL_GLOB/\*/g;
406
# twiddle the escaped . chars back
407
$regexp =~ s/SDPROF_INTERNAL_DOT/\\./g;
412
sub get_full_path ($) {
413
my $originalpath = shift;
415
my $path = $originalpath;
417
# keep track so we can break out of loops
420
# if we don't have any directory foo, look in the current dir
421
$path = cwd() . "/$path" if $path !~ m/\//;
423
# beat symlinks into submission
426
if ($linkcount++ > 64) {
427
fatal_error "Followed too many symlinks resolving $originalpath";
430
# split out the directory/file components
431
if ($path =~ m/^(.*)\/(.+)$/) {
432
my ($dir, $file) = ($1, $2);
434
# figure out where the link is pointing...
435
my $link = readlink($path);
436
if ($link =~ /^\//) {
437
# if it's an absolute link, just replace it
440
# if it's relative, let abs_path handle it
441
$path = $dir . "/$link";
447
my ($dir, $file) = $path =~ m/^(.*)\/(.+)$/;
448
$path = realpath($dir) . "/$file";
450
$path = realpath($path);
456
sub findexecutable ($) {
461
$fqdbin = get_full_path($bin);
465
my $which = which($bin);
467
$fqdbin = get_full_path($which);
472
unless ($fqdbin && -e $fqdbin) {
481
my $fqdbin = findexecutable($bin)
482
or fatal_error(sprintf(gettext('Can\'t find %s.'), $bin));
485
return unless -f $fqdbin;
487
UI_Info(sprintf(gettext('Setting %s to complain mode.'), $fqdbin));
489
my $filename = getprofilefilename($fqdbin);
490
setprofileflags($filename, "complain");
496
my $fqdbin = findexecutable($bin)
497
or fatal_error(sprintf(gettext('Can\'t find %s.'), $bin));
500
return unless -f $fqdbin;
502
UI_Info(sprintf(gettext('Setting %s to enforce mode.'), $fqdbin));
504
my $filename = getprofilefilename($fqdbin);
505
setprofileflags($filename, "");
512
if (open(FILE, $file)) {
521
my ($program, @args) = @_;
529
$pid = open(KID_TO_READ, "-|");
530
unless (defined $pid) {
531
fatal_error "can't fork: $!";
535
while (<KID_TO_READ>) {
543
open(STDERR, ">&STDOUT")
544
|| fatal_error "can't dup stdout to stderr";
545
exec($program, @args) || fatal_error "can't exec program: $!";
551
return ($ret, @output);
558
my ($ret, @ldd) = get_output($ldd, $file);
561
for my $line (@ldd) {
562
last if $line =~ /not a dynamic executable/;
563
last if $line =~ /cannot read header/;
564
last if $line =~ /statically linked/;
566
# avoid new kernel 2.6 poo
567
next if $line =~ /linux-(gate|vdso(32|64)).so/;
569
if ($line =~ /^\s*\S+ => (\/\S+)/) {
571
} elsif ($line =~ /^\s*(\/\S+)/) {
580
sub handle_binfmt ($$) {
581
my ($profile, $fqdbin) = @_;
584
my @reqs = get_reqs($fqdbin);
586
while (my $library = shift @reqs) {
588
$library = get_full_path($library);
590
push @reqs, get_reqs($library) unless $reqs{$library}++;
592
# does path match anything pulled in by includes in original profile?
593
my $combinedmode = matchincludes($profile, $library);
595
# if we found any matching entries, do the modes match?
596
next if $combinedmode;
598
$library = globcommon($library);
600
next unless $library;
602
$profile->{path}->{$library} = "mr";
611
# findexecutable() might fail if we're running on a different system
612
# than the logs were collected on. ugly. we'll just hope for the best.
613
my $fqdbin = findexecutable($bin) || $bin;
615
# try to make sure we have a full path in case findexecutable failed
616
return unless $fqdbin =~ /^\//;
619
return if -d $fqdbin;
623
include => { "abstractions/base" => 1 },
624
path => { $fqdbin => "mr" }
627
# if the executable exists on this system, pull in extra dependencies
629
my $hashbang = head($fqdbin);
630
if ($hashbang =~ /^#!\s*(\S+)/) {
631
my $interpreter = get_full_path($1);
632
$profile->{path}->{$interpreter} = "ix";
633
if ($interpreter =~ /perl/) {
634
$profile->{include}->{"abstractions/perl"} = 1;
635
} elsif ($interpreter =~ m/\/bin\/(bash|sh)/) {
636
$profile->{include}->{"abstractions/bash"} = 1;
638
$profile = handle_binfmt($profile, $interpreter);
640
$profile = handle_binfmt($profile, $fqdbin);
644
# stick the profile into our data structure.
645
$sd{$fqdbin}{$fqdbin} = $profile;
647
# instantiate the required infrastructure hats for this changehat app
648
for my $hatglob (keys %required_hats) {
649
if ($fqdbin =~ /$hatglob/) {
650
for my $hat (split(/\s+/, $required_hats{$hatglob})) {
651
$sd{$fqdbin}{$hat} = { flags => "complain" };
656
if (-f "$profiledir/tunables/global") {
657
my $file = getprofilefilename($fqdbin);
659
unless (exists $variables{$file}) {
660
$variables{$file} = {};
662
$variables{$file}{"#tunables/global"} = 1; # sorry
665
# write out the profile...
666
writeprofile($fqdbin);
669
sub getprofilefilename ($) {
672
my $filename = $profile;
673
$filename =~ s/\///; # strip leading /
674
$filename =~ s/\//./g; # convert /'s to .'s
676
return "$profiledir/$filename";
679
sub setprofileflags ($$) {
680
my $filename = shift;
681
my $newflags = shift;
683
if (open(PROFILE, "$filename")) {
684
if (open(NEWPROFILE, ">$filename.new")) {
686
if (m/^\s*("??\/.+?"??)\s+(flags=\(.+\)\s+)*\{\s*$/) {
687
my ($binary, $flags) = ($1, $2);
690
$_ = "$binary flags=($newflags) {\n";
694
} elsif (m/^(\s*\^\S+)\s+(flags=\(.+\)\s+)*\{\s*$/) {
695
my ($hat, $flags) = ($1, $2);
698
$_ = "$hat flags=($newflags) {\n";
706
rename("$filename.new", "$filename");
712
sub profile_exists($) {
713
my $program = shift || return 0;
715
# if it's already in the cache, return true
716
return 1 if $existing_profiles{$program};
718
# if the profile exists, mark it in the cache and return true
719
my $profile = getprofilefilename($program);
721
$existing_profiles{$program} = 1;
725
# couldn't find a profile, so we'll return false
729
##########################################################################
730
# Here are the console/yast interface functions
735
$DEBUGGING && debug "UI_Info: $UI_Mode: $text";
737
if ($UI_Mode eq "text") {
740
ycp::y2milestone($text);
744
sub UI_Important ($) {
747
$DEBUGGING && debug "UI_Important: $UI_Mode: $text";
749
if ($UI_Mode eq "text") {
752
SendDataToYast({ type => "dialog-error", message => $text });
753
my ($path, $yarg) = GetDataFromYast();
761
$DEBUGGING && debug "UI_YesNo: $UI_Mode: $text $default";
764
if ($UI_Mode eq "text") {
766
my $yes = gettext("(Y)es");
767
my $no = gettext("(N)o");
769
# figure out our localized hotkeys
770
my $usrmsg = "PromptUser: " . gettext("Invalid hotkey for");
771
$yes =~ /\((\S)\)/ or fatal_error "$usrmsg '$yes'";
773
$no =~ /\((\S)\)/ or fatal_error "$usrmsg '$no'";
777
if ($default eq "y") {
778
print "\n[$yes] / $no\n";
780
print "\n$yes / [$no]\n";
782
$ans = getkey() || (($default eq "y") ? $yeskey : $nokey);
784
# convert back from a localized answer to english y or n
785
$ans = (lc($ans) eq $yeskey) ? "y" : "n";
788
SendDataToYast({ type => "dialog-yesno", question => $text });
789
my ($ypath, $yarg) = GetDataFromYast();
790
$ans = $yarg->{answer} || $default;
797
sub UI_YesNoCancel ($$) {
801
$DEBUGGING && debug "UI_YesNoCancel: $UI_Mode: $text $default";
804
if ($UI_Mode eq "text") {
806
my $yes = gettext("(Y)es");
807
my $no = gettext("(N)o");
808
my $cancel = gettext("(C)ancel");
810
# figure out our localized hotkeys
811
my $usrmsg = "PromptUser: " . gettext("Invalid hotkey for");
812
$yes =~ /\((\S)\)/ or fatal_error "$usrmsg '$yes'";
814
$no =~ /\((\S)\)/ or fatal_error "$usrmsg '$no'";
816
$cancel =~ /\((\S)\)/ or fatal_error "$usrmsg '$cancel'";
817
my $cancelkey = lc($1);
819
$ans = "XXXINVALIDXXX";
820
while ($ans !~ /^(y|n|c)$/) {
822
if ($default eq "y") {
823
print "\n[$yes] / $no / $cancel\n";
824
} elsif ($default eq "n") {
825
print "\n$yes / [$no] / $cancel\n";
827
print "\n$yes / $no / [$cancel]\n";
833
# convert back from a localized answer to english y or n
835
if ($ans eq $yeskey) {
837
} elsif ($ans eq $nokey) {
839
} elsif ($ans eq $cancelkey) {
848
SendDataToYast({ type => "dialog-yesnocancel", question => $text });
849
my ($ypath, $yarg) = GetDataFromYast();
850
$ans = $yarg->{answer} || $default;
857
sub UI_GetString ($$) {
861
$DEBUGGING && debug "UI_GetString: $UI_Mode: $text $default";
864
if ($UI_Mode eq "text") {
867
$string = $term->readline($text, $default);
878
type => "dialog-getstring",
882
my ($ypath, $yarg) = GetDataFromYast();
883
$string = $yarg->{string};
892
$DEBUGGING && debug "UI_GetFile: $UI_Mode";
895
if ($UI_Mode eq "text") {
898
print "$f->{description}\n";
904
$f->{type} = "dialog-getfile";
907
my ($ypath, $yarg) = GetDataFromYast();
908
if ($yarg->{answer} eq "okay") {
909
$filename = $yarg->{filename};
917
CMD_ALLOW => "(A)llow",
918
CMD_DENY => "(D)eny",
919
CMD_ABORT => "Abo(r)t",
920
CMD_FINISHED => "(F)inish",
921
CMD_INHERIT => "(I)nherit",
922
CMD_PROFILE => "(P)rofile",
923
CMD_PROFILE_CLEAN => "(P)rofile Clean Exec",
924
CMD_UNCONFINED => "(U)nconfined",
925
CMD_UNCONFINED_CLEAN => "(U)nconfined Clean Exec",
927
CMD_GLOB => "(G)lob",
928
CMD_GLOBEXT => "Glob w/(E)xt",
929
CMD_ADDHAT => "(A)dd Requested Hat",
930
CMD_USEDEFAULT => "(U)se Default Hat",
931
CMD_SCAN => "(S)can system log for SubDomain events",
932
CMD_HELP => "(H)elp",
935
sub UI_PromptUser ($) {
939
if ($UI_Mode eq "text") {
941
($cmd, $arg) = Text_PromptUser($q);
945
$q->{type} = "wizard";
948
my ($ypath, $yarg) = GetDataFromYast();
950
$cmd = $yarg->{selection} || "CMD_ABORT";
951
$arg = $yarg->{selected};
957
##########################################################################
958
# here are the interface functions to send data back and forth between
959
# the yast frontend and the perl backend
961
# this is super ugly, but waits for the next ycp Read command and sends data
962
# back to the ycp front end.
967
$DEBUGGING && debug "SendDataToYast: Waiting for YCP command";
970
$DEBUGGING && debug "SendDataToYast: YCP: $_";
971
my ($ycommand, $ypath, $yargument) = ycp::ParseCommand($_);
973
if ($ycommand && $ycommand eq "Read") {
976
my $debugmsg = Data::Dumper->Dump([$data], [qw(*data)]);
977
debug "SendDataToYast: Sending--\n$debugmsg";
985
$DEBUGGING && debug "SendDataToYast: Expected 'Read' but got-- $_";
990
# if we ever break out here, something's horribly wrong.
991
fatal_error "SendDataToYast: didn't receive YCP command before connection died";
994
# this is super ugly, but waits for the next ycp Write command and grabs
995
# whatever the ycp front end gives us
997
sub GetDataFromYast {
999
$DEBUGGING && debug "GetDataFromYast: Waiting for YCP command";
1002
$DEBUGGING && debug "GetDataFromYast: YCP: $_";
1003
my ($ycmd, $ypath, $yarg) = ycp::ParseCommand($_);
1006
my $debugmsg = Data::Dumper->Dump([$yarg], [qw(*data)]);
1007
debug "GetDataFromYast: Received--\n$debugmsg";
1010
if ($ycmd && $ycmd eq "Write") {
1012
ycp::Return("true");
1013
return ($ypath, $yarg);
1016
$DEBUGGING && debug "GetDataFromYast: Expected 'Write' but got-- $_";
1020
# if we ever break out here, something's horribly wrong.
1021
fatal_error "GetDataFromYast: didn't receive YCP command before connection died";
1024
##########################################################################
1025
# this is the hideously ugly function that descends down the flow/event
1026
# trees that we've generated by parsing the logfile
1028
sub handlechildren {
1029
my $profile = shift;
1033
my @entries = @$root;
1034
for my $entry (@entries) {
1035
fatal_error "$entry is not a ref" if not ref($entry);
1037
if (ref($entry->[0])) {
1038
handlechildren($profile, $hat, $entry);
1041
my @entry = @$entry;
1042
my $type = shift @entry;
1044
if ($type eq "fork") {
1045
my ($pid, $p, $h) = @entry;
1047
if ( ($p !~ /null(-complain)*-profile/)
1048
&& ($h !~ /null(-complain)*-profile/))
1054
$profilechanges{$pid} = $profile;
1056
} elsif ($type eq "unknown_hat") {
1057
my ($pid, $p, $h, $sdmode, $uhat) = @entry;
1059
if ($p !~ /null(-complain)*-profile/) {
1063
if ($sd{$profile}{$uhat}) {
1068
# figure out what our default hat for this application is.
1070
for my $hatglob (keys %defaulthat) {
1071
$defaulthat = $defaulthat{$hatglob}
1072
if $profile =~ /$hatglob/;
1075
# keep track of previous answers for this run...
1076
my $context = $profile;
1077
$context .= " -> ^$uhat";
1078
my $ans = $transitions{$context} || "";
1083
push @{ $q->{headers} }, gettext("Profile"), $profile;
1085
push @{ $q->{headers} }, gettext("Default Hat"), $defaulthat;
1087
push @{ $q->{headers} }, gettext("Requested Hat"), $uhat;
1089
$q->{functions} = [];
1090
push @{ $q->{functions} }, "CMD_ADDHAT";
1091
push @{ $q->{functions} }, "CMD_USEDEFAULT" if $defaulthat;
1092
push @{ $q->{functions} }, "CMD_DENY";
1093
push @{ $q->{functions} }, "CMD_ABORT";
1094
push @{ $q->{functions} }, "CMD_FINISHED";
1096
$q->{default} = ($sdmode eq "PERMITTING") ? "CMD_ADDHAT" : "CMD_DENY";
1101
($ans, $arg) = UI_PromptUser($q);
1103
$transitions{$context} = $ans;
1106
# ugh, there's a bug here. if they pick "abort" or "finish"
1107
# and then say "well, no, I didn't really mean that", we need
1108
# to ask the question again, but we currently go on to the
1110
if ($ans eq "CMD_ADDHAT") {
1112
$sd{$profile}{$hat}{flags} = $sd{$profile}{$profile}{flags};
1113
} elsif ($ans eq "CMD_USEDEFAULT") {
1115
} elsif ($ans eq "CMD_DENY") {
1117
} elsif ($ans eq "CMD_ABORT") {
1118
my $ans = UI_YesNo(gettext("Are you sure you want to abandon this set of profile changes and exit?"), "n");
1120
UI_Info(gettext("Abandoning all changes."));
1124
} elsif ($ans eq "CMD_FINISHED") {
1125
my $ans = UI_YesNo(gettext("Are you sure you want to save the current set of profile changes and exit?"), "n");
1127
UI_Info(gettext("Saving all changes."));
1130
# XXX - BUGBUG - this is REALLY nasty, but i'm in
1136
} elsif ($type eq "capability") {
1137
my ($pid, $p, $h, $prog, $sdmode, $capability) = @entry;
1139
if ( ($p !~ /null(-complain)*-profile/)
1140
&& ($h !~ /null(-complain)*-profile/))
1146
# print "$pid $profile $hat $prog $sdmode capability $capability\n";
1148
next unless $profile && $hat;
1150
$prelog{$sdmode}{$profile}{$hat}{capability}{$capability} = 1;
1151
} elsif (($type eq "path") || ($type eq "exec")) {
1152
my ($pid, $p, $h, $prog, $sdmode, $mode, $detail) = @entry;
1154
if ( ($p !~ /null(-complain)*-profile/)
1155
&& ($h !~ /null(-complain)*-profile/))
1161
next unless $profile && $hat;
1163
my $domainchange = ($type eq "exec") ? "change" : "nochange";
1165
# escape special characters that show up in literal paths
1166
$detail =~ s/(\[|\]|\+|\*|\{|\})/\\$1/g;
1168
# we need to give the Execute dialog if they're requesting x
1169
# access for something that's not a directory - we'll force
1170
# a "ix" Path dialog for directories
1172
my $exec_target = $detail;
1173
if ($mode =~ s/x//g) {
1174
if (-d $exec_target) {
1181
if ($mode eq "link") {
1183
if ($detail =~ m/^from (.+) to (.+)$/) {
1184
my ($path, $target) = ($1, $2);
1186
my $frommode = "lr";
1187
if (defined $prelog{$sdmode}{$profile}{$hat}{path}{$path}) {
1188
$frommode .= $prelog{$sdmode}{$profile}{$hat}{path}{$path};
1190
$frommode = collapsemode($frommode);
1191
$prelog{$sdmode}{$profile}{$hat}{path}{$path} = $frommode;
1194
if (defined $prelog{$sdmode}{$profile}{$hat}{path}{$target}) {
1195
$tomode .= $prelog{$sdmode}{$profile}{$hat}{path}{$target};
1197
$tomode = collapsemode($tomode);
1198
$prelog{$sdmode}{$profile}{$hat}{path}{$target} = $tomode;
1200
# print "$pid $profile $hat $prog $sdmode $path:$frommode -> $target:$tomode\n";
1207
if (defined $prelog{$sdmode}{$profile}{$hat}{path}{$path}) {
1208
$mode .= $prelog{$sdmode}{$profile}{$hat}{path}{$path};
1209
$mode = collapsemode($mode);
1212
$prelog{$sdmode}{$profile}{$hat}{path}{$path} = $mode;
1214
# print "$pid $profile $hat $prog $sdmode $mode $path\n";
1219
my $context = $profile;
1220
$context .= "^$hat" if $profile ne $hat;
1221
$context .= " -> $exec_target";
1222
my $ans = $transitions{$context} || "";
1224
my ($combinedmode, $cm, @m);
1226
# does path match any regexps in original profile?
1227
($cm, @m) = rematchfrag($sd{$profile}{$hat}, $exec_target);
1228
$combinedmode .= $cm if $cm;
1230
# does path match anything pulled in by includes in
1232
($cm, @m) = matchincludes($sd{$profile}{$hat}, $exec_target);
1233
$combinedmode .= $cm if $cm;
1236
if (contains($combinedmode, "ix")) {
1237
$ans = "CMD_INHERIT";
1239
} elsif (contains($combinedmode, "px")) {
1240
$ans = "CMD_PROFILE";
1242
} elsif (contains($combinedmode, "ux")) {
1243
$ans = "CMD_UNCONFINED";
1245
} elsif (contains($combinedmode, "Px")) {
1246
$ans = "CMD_PROFILE_CLEAN";
1248
} elsif (contains($combinedmode, "Ux")) {
1249
$ans = "CMD_UNCONFINED_CLEAN";
1252
my $options = $qualifiers{$exec_target} || "ipu";
1254
# force "ix" as the only option when the profiled
1255
# program executes itself
1256
$options = "i" if $exec_target eq $profile;
1258
# we always need deny...
1261
# figure out what our default option should be...
1264
&& -e getprofilefilename($exec_target))
1266
$default = "CMD_PROFILE";
1267
} elsif ($options =~ /i/) {
1268
$default = "CMD_INHERIT";
1270
$default = "CMD_DENY";
1273
# ugh, this doesn't work if someone does an ix before
1274
# calling this particular child process. at least
1275
# it's only a hint instead of mandatory to get this
1277
my $parent_uses_ld_xxx = check_for_LD_XXX($profile);
1279
my $severity = $sevdb->rank($exec_target, "x");
1281
# build up the prompt...
1284
push @{ $q->{headers} }, gettext("Profile"), combine_name($profile, $hat);
1285
if ($prog && $prog ne "HINT") {
1286
push @{ $q->{headers} }, gettext("Program"), $prog;
1288
push @{ $q->{headers} }, gettext("Execute"), $exec_target;
1289
push @{ $q->{headers} }, gettext("Severity"), $severity;
1291
$q->{functions} = [];
1293
my $prompt = "\n$context\n";
1294
push @{ $q->{functions} }, "CMD_INHERIT"
1296
push @{ $q->{functions} }, "CMD_PROFILE"
1298
push @{ $q->{functions} }, "CMD_UNCONFINED"
1300
push @{ $q->{functions} }, "CMD_DENY";
1301
push @{ $q->{functions} }, "CMD_ABORT";
1302
push @{ $q->{functions} }, "CMD_FINISHED";
1304
$q->{default} = $default;
1306
$options = join("|", split(//, $options));
1311
while ($ans !~ m/^CMD_(INHERIT|PROFILE|PROFILE_CLEAN|UNCONFINED|UNCONFINED_CLEAN|DENY)$/) {
1312
($ans, $arg) = UI_PromptUser($q);
1314
# check for Abort or Finish
1315
if ($ans eq "CMD_ABORT") {
1316
my $ans = UI_YesNo(gettext("Are you sure you want to abandon this set of profile changes and exit?"), "n");
1317
$DEBUGGING && debug "back from abort yesno";
1319
UI_Info(gettext("Abandoning all changes."));
1323
} elsif ($ans eq "CMD_FINISHED") {
1324
my $ans = UI_YesNo(gettext("Are you sure you want to save the current set of profile changes and exit?"), "n");
1326
UI_Info(gettext("Saving all changes."));
1329
# XXX - BUGBUG - this is REALLY nasty,
1330
# but i'm in a hurry...
1333
} elsif ($ans eq "CMD_PROFILE") {
1334
my $px_default = "n";
1335
my $px_mesg = gettext("Should AppArmor sanitize the environment when\nswitching profiles?\n\nSanitizing the environment is more secure,\nbut some applications depend on the presence\nof LD_PRELOAD or LD_LIBRARY_PATH.");
1336
if ($parent_uses_ld_xxx) {
1337
$px_mesg = gettext("Should AppArmor sanitize the environment when\nswitching profiles?\n\nSanitizing the environment is more secure,\nbut this application appears to use LD_PRELOAD\nor LD_LIBRARY_PATH and clearing these could\ncause functionality problems.");
1339
my $ynans = UI_YesNo($px_mesg, $px_default);
1340
if ($ynans eq "y") {
1341
$ans = "CMD_PROFILE_CLEAN";
1343
} elsif ($ans eq "CMD_UNCONFINED") {
1344
my $ynans = UI_YesNo(sprintf(gettext("Launching processes in an unconfined state is a very\ndangerous operation and can cause serious security holes.\n\nAre you absolutely certain you wish to remove all\nAppArmor protection when executing \%s?"), $exec_target), "n");
1345
if ($ynans eq "y") {
1346
my $ynans = UI_YesNo(gettext("Should AppArmor sanitize the environment when\nrunning this program unconfined?\n\nNot sanitizing the environment when unconfining\na program opens up significant security holes\nand should be avoided if at all possible."), "y");
1347
if ($ynans eq "y") {
1348
$ans = "CMD_UNCONFINED_CLEAN";
1355
$transitions{$context} = $ans;
1357
# if we're inheriting, things'll bitch unless we have r
1358
if ($ans eq "CMD_INHERIT") {
1360
} elsif ($ans eq "CMD_PROFILE") {
1362
} elsif ($ans eq "CMD_UNCONFINED") {
1364
} elsif ($ans eq "CMD_PROFILE_CLEAN") {
1366
} elsif ($ans eq "CMD_UNCONFINED_CLEAN") {
1370
# skip all remaining events if they say to deny
1372
return if $domainchange eq "change";
1375
unless ($ans eq "CMD_DENY") {
1376
if (defined $prelog{PERMITTING}{$profile}{$hat}{path}{$exec_target}) {
1377
$exec_mode .= $prelog{PERMITTING}{$profile}{$hat}{path}{$exec_target};
1378
$exec_mode = collapsemode($exec_mode);
1380
$prelog{PERMITTING}{$profile}{$hat}{path}{$exec_target} = $exec_mode;
1381
$log{PERMITTING}{$profile} = {};
1382
$sd{$profile}{$hat}{path}{$exec_target} = $exec_mode;
1384
# mark this profile as changed
1385
$changed{$profile} = 1;
1387
if ($ans eq "CMD_INHERIT") {
1388
if ($exec_target =~ /perl/) {
1389
$sd{$profile}{$hat}{include}{"abstractions/perl"} = 1;
1390
} elsif ($detail =~ m/\/bin\/(bash|sh)/) {
1391
$sd{$profile}{$hat}{include}{"abstractions/bash"} = 1;
1393
my $hashbang = head($exec_target);
1394
if ($hashbang =~ /^#!\s*(\S+)/) {
1395
my $interpreter = get_full_path($1);
1396
$sd{$profile}{$hat}{path}->{$interpreter} = "ix";
1397
if ($interpreter =~ /perl/) {
1398
$sd{$profile}{$hat}{include}{"abstractions/perl"} = 1;
1399
} elsif ($interpreter =~ m/\/bin\/(bash|sh)/) {
1400
$sd{$profile}{$hat}{include}{"abstractions/bash"} = 1;
1403
} elsif ($ans =~ /^CMD_PROFILE/) {
1405
# if they want to use px, make sure a profile
1406
# exists for the target.
1407
unless (-e getprofilefilename($exec_target)) {
1408
$helpers{$exec_target} = "enforce";
1409
autodep($exec_target);
1410
reload($exec_target);
1416
# print "$pid $profile $hat EXEC $exec_target $ans $exec_mode\n";
1418
# update our tracking info based on what kind of change
1420
if ($ans eq "CMD_INHERIT") {
1421
$profilechanges{$pid} = $profile;
1422
} elsif ($ans =~ /^CMD_PROFILE/) {
1423
if ($sdmode eq "PERMITTING") {
1424
if ($domainchange eq "change") {
1425
$profile = $exec_target;
1426
$hat = $exec_target;
1427
$profilechanges{$pid} = $profile;
1430
} elsif ($ans =~ /^CMD_UNCONFINED/) {
1431
$profilechanges{$pid} = "unconstrained";
1432
return if $domainchange eq "change";
1440
sub add_to_tree ($@) {
1441
my ($pid, $type, @event) = @_;
1443
unless (exists $pid{$pid}) {
1445
push @log, $arrayref;
1446
$pid{$pid} = $arrayref;
1449
push @{ $pid{$pid} }, [ $type, $pid, @event ];
1452
sub do_logprof_pass {
1453
my $logmark = shift || "";
1455
# zero out the state variables for this pass...
1460
%profilechanges = ();
1467
UI_Info(sprintf(gettext('Reading log entries from %s.'), $filename));
1468
UI_Info(sprintf(gettext('Updating AppArmor profiles in %s.'), $profiledir));
1472
my $seenmark = $logmark ? 0 : 1;
1474
$sevdb = new Immunix::Severity("$confdir/severity.db", gettext("unknown"));
1476
my $stuffed = undef;
1479
# okay, done loading the previous profiles, get on to the good stuff...
1480
open(LOG, $filename)
1481
or fatal_error "Can't read AppArmor logfile $filename: $!";
1482
while (($_ = $stuffed) || ($_ = <LOG>)) {
1487
$seenmark = 1 if /$logmark/;
1489
next unless $seenmark;
1491
# all we care about is subdomain messages
1493
unless (/^.* audit\(/
1494
|| /type=(APPARMOR|UNKNOWN\[1500\]) msg=audit\([\d\.\:]+\):/
1497
# workaround for syslog uglyness.
1498
if (s/(PERMITTING|REJECTING)-SYSLOGFIX/$1/) {
1502
if (m/LOGPROF-HINT unknown_hat (\S+) pid=(\d+) profile=(.+) active=(.+)/) {
1503
my ($uhat, $pid, $profile, $hat) = ($1, $2, $3, $4);
1507
# we want to ignore entries for profiles that don't exist - they're
1508
# most likely broken entries or old entries for deleted profiles
1510
if ( ($profile ne 'null-complain-profile')
1511
&& (!profile_exists($profile)));
1513
add_to_tree($pid, "unknown_hat", $profile, $hat, "PERMITTING", $uhat);
1514
} elsif (m/LOGPROF-HINT (unknown_profile|missing_mandatory_profile) image=(.+) pid=(\d+) profile=(.+) active=(.+)/) {
1515
my ($image, $pid, $profile, $hat) = ($2, $3, $4, $5);
1517
next if $last =~ /PERMITTING x access to $image/;
1520
# we want to ignore entries for profiles that don't exist - they're
1521
# most likely broken entries or old entries for deleted profiles
1523
if ( ($profile ne 'null-complain-profile')
1524
&& (!profile_exists($profile)));
1526
add_to_tree($pid, "exec", $profile, $hat, "HINT", "PERMITTING", "x", $image);
1528
} elsif (m/(PERMITTING|REJECTING) (\S+) access (.+) \((.+)\((\d+)\) profile (.+) active (.+)\)/) {
1529
my ($sdmode, $mode, $detail, $prog, $pid, $profile, $hat) = ($1, $2, $3, $4, $5, $6, $7);
1531
my $domainchange = "nochange";
1534
# we need to try to check if we're doing a domain transition
1535
if ($sdmode eq "PERMITTING") {
1538
} until ((! $stuffed) || ($stuffed =~ /AppArmor|audit/));
1540
if ($stuffed && ($stuffed =~ m/changing_profile/)) {
1541
$domainchange = "change";
1547
# we want to ignore duplicates for things other than executes...
1554
# we want to ignore entries for profiles that don't exist - they're
1555
# most likely broken entries or old entries for deleted profiles
1556
if ( ($profile ne 'null-complain-profile')
1557
&& (!profile_exists($profile)))
1563
# currently no way to stick pipe mediation in a profile, ignore
1564
# any messages like this
1565
next if $detail =~ /to pipe:/;
1567
# strip out extra extended attribute info since we don't currently
1568
# have a way to specify it in the profile and instead just need to
1569
# provide the access to the base filename
1570
$detail =~ s/\s+extended attribute \S+//;
1572
# kerberos code checks to see if the krb5.conf file is world
1573
# writable in a stupid way so we'll ignore any w accesses to
1575
next if (($detail eq "to /etc/krb5.conf") && contains($mode, "w"));
1577
# strip off the (deleted) tag that gets added if it's a deleted file
1578
$detail =~ s/\s+\(deleted\)$//;
1580
# next if (($detail =~ /to \/lib\/ld-/) && ($mode =~ /x/));
1582
$detail =~ s/^to\s+//;
1584
if ($domainchange eq "change") {
1585
add_to_tree($pid, "exec", $profile, $hat, $prog, $sdmode, $mode, $detail);
1587
add_to_tree($pid, "path", $profile, $hat, $prog, $sdmode, $mode, $detail);
1590
} elsif (m/(PERMITTING|REJECTING) (?:mk|rm)dir on (.+) \((.+)\((\d+)\) profile (.+) active (.+)\)/) {
1591
my ($sdmode, $path, $prog, $pid, $profile, $hat) = ($1, $2, $3, $4, $5, $6);
1593
# we want to ignore duplicates for things other than executes...
1594
next if $seen{$&}++;
1598
# we want to ignore entries for profiles that don't exist - they're
1599
# most likely broken entries or old entries for deleted profiles
1601
if ( ($profile ne 'null-complain-profile')
1602
&& (!profile_exists($profile)));
1604
add_to_tree($pid, "path", $profile, $hat, $prog, $sdmode, "w", $path);
1606
} elsif (m/(PERMITTING|REJECTING) xattr (\S+) on (.+) \((.+)\((\d+)\) profile (.+) active (.+)\)/) {
1607
my ($sdmode, $xattr_op, $path, $prog, $pid, $profile, $hat) = ($1, $2, $3, $4, $5, $6, $7);
1609
# we want to ignore duplicates for things other than executes...
1610
next if $seen{$&}++;
1614
# we want to ignore entries for profiles that don't exist - they're
1615
# most likely broken entries or old entries for deleted profiles
1617
if ( ($profile ne 'null-complain-profile')
1618
&& (!profile_exists($profile)));
1621
if ($xattr_op eq "get" || $xattr_op eq "list") {
1623
} elsif ($xattr_op eq "set" || $xattr_op eq "remove") {
1628
add_to_tree($pid, "path", $profile, $hat, $prog, $sdmode, $xattrmode, $path);
1631
} elsif (m/(PERMITTING|REJECTING) attribute \((.*?)\) change to (.+) \((.+)\((\d+)\) profile (.+) active (.+)\)/) {
1632
my ($sdmode, $change, $path, $prog, $pid, $profile, $hat) = ($1, $2, $3, $4, $5, $6, $7);
1634
# we want to ignore duplicates for things other than executes...
1640
# we want to ignore entries for profiles that don't exist - they're
1641
# most likely broken entries or old entries for deleted profiles
1643
if ( ($profile ne 'null-complain-profile')
1644
&& (!profile_exists($profile)));
1646
# kerberos code checks to see if the krb5.conf file is world
1647
# writable in a stupid way so we'll ignore any w accesses to
1649
next if $path eq "/etc/krb5.conf";
1651
add_to_tree($pid, "path", $profile, $hat, $prog, $sdmode, "w", $path);
1653
} elsif (m/(PERMITTING|REJECTING) access to capability '(\S+)' \((.+)\((\d+)\) profile (.+) active (.+)\)/) {
1654
my ($sdmode, $capability, $prog, $pid, $profile, $hat) = ($1, $2, $3, $4, $5, $6);
1661
# we want to ignore entries for profiles that don't exist - they're
1662
# most likely broken entries or old entries for deleted profiles
1664
if ( ($profile ne 'null-complain-profile')
1665
&& (!profile_exists($profile)));
1667
add_to_tree($pid, "capability", $profile, $hat, $prog, $sdmode, $capability);
1669
} elsif (m/Fork parent (\d+) child (\d+) profile (.+) active (.+)/
1670
|| m/LOGPROF-HINT fork pid=(\d+) child=(\d+) profile=(.+) active=(.+)/
1671
|| m/LOGPROF-HINT fork pid=(\d+) child=(\d+)/)
1673
my ($parent, $child, $profile, $hat) = ($1, $2, $3, $4);
1675
$profile ||= "null-complain-profile";
1676
$hat ||= "null-complain-profile";
1680
# we want to ignore entries for profiles that don't exist - they're
1681
# most likely broken entries or old entries for deleted profiles
1683
if ( ($profile ne 'null-complain-profile')
1684
&& (!profile_exists($profile)));
1687
if (exists $pid{$parent}) {
1688
push @{ $pid{$parent} }, $arrayref;
1690
push @log, $arrayref;
1692
$pid{$child} = $arrayref;
1693
push @{$arrayref}, [ "fork", $child, $profile, $hat ];
1695
$DEBUGGING && debug "UNHANDLED: $_";
1700
for my $root (@log) {
1701
handlechildren(undef, undef, $root);
1704
for my $pid (sort { $a <=> $b } keys %profilechanges) {
1705
setprocess($pid, $profilechanges{$pid});
1712
# do the magic foo-foo
1713
for my $sdmode (sort keys %log) {
1715
# let them know what sort of changes we're about to list...
1716
if ($sdmode eq "PERMITTING") {
1717
UI_Info(gettext("Complain-mode changes:"));
1718
} elsif ($sdmode eq "REJECTING") {
1719
UI_Info(gettext("Enforce-mode changes:"));
1722
# if we're not permitting and not rejecting, something's broken.
1723
# most likely the code we're using to build the hash tree of log
1724
# entries - this should never ever happen
1725
fatal_error(sprintf(gettext('Invalid mode found: %s'), $sdmode));
1728
for my $profile (sort keys %{ $log{$sdmode} }) {
1732
# this sorts the list of hats, but makes sure that the containing
1733
# profile shows up in the list first to keep the question order
1736
grep { $_ ne $profile } keys %{ $log{$sdmode}{$profile} };
1737
unshift @hats, $profile
1738
if defined $log{$sdmode}{$profile}{$profile};
1740
for my $hat (@hats) {
1742
# step through all the capabilities first...
1743
for my $capability (sort keys %{ $log{$sdmode}{$profile}{$hat}{capability} }) {
1745
# we don't care about it if we've already added it to the
1747
next if $sd{$profile}{$hat}{capability}{$capability};
1749
my $severity = $sevdb->rank(uc("cap_$capability"));
1753
push @{ $q->{headers} }, gettext("Profile"), combine_name($profile, $hat);
1754
push @{ $q->{headers} }, gettext("Capability"), $capability;
1755
push @{ $q->{headers} }, gettext("Severity"), $severity;
1757
$q->{functions} = [ "CMD_ALLOW", "CMD_DENY", "CMD_ABORT", "CMD_FINISHED" ];
1759
# complain-mode events default to allow - enforce defaults
1761
$q->{default} = ($sdmode eq "PERMITTING") ? "CMD_ALLOW" : "CMD_DENY";
1765
# what did the grand exalted master tell us to do?
1766
my ($ans, $arg) = UI_PromptUser($q);
1768
if ($ans eq "CMD_ALLOW") {
1770
# they picked (a)llow, so...
1772
# stick the capability into the profile
1773
$sd{$profile}{$hat}{capability}{$capability} = 1;
1775
# mark this profile as changed
1776
$changed{$profile} = 1;
1778
# give a little feedback to the user
1779
UI_Info(sprintf(gettext('Adding capability %s to profile.'), $capability));
1780
} elsif ($ans eq "CMD_DENY") {
1781
UI_Info(sprintf(gettext('Denying capability %s to profile.'), $capability));
1782
} elsif ($ans eq "CMD_ABORT") {
1784
# if we're in yast, they've already been asked for
1786
if ($UI_Mode eq "yast") {
1787
UI_Info(gettext("Abandoning all changes."));
1791
my $ans = UI_YesNo(gettext("Are you sure you want to abandon this set of profile changes and exit?"), "n");
1793
UI_Info(gettext("Abandoning all changes."));
1799
} elsif ($ans eq "CMD_FINISHED") {
1801
# if we're in yast, they've already been asked for
1803
if ($UI_Mode eq "yast") {
1804
UI_Info(gettext("Saving all changes."));
1807
# XXX - BUGBUG - this is REALLY nasty, but i'm in
1811
my $ans = UI_YesNo(gettext("Are you sure you want to save the current set of profile changes and exit?"), "n");
1813
UI_Info(gettext("Saving all changes."));
1816
# XXX - BUGBUG - this is REALLY nasty, but i'm in
1825
# and then step through all of the path entries...
1826
for my $path (sort keys %{ $log{$sdmode}{$profile}{$hat}{path} }) {
1828
my $mode = $log{$sdmode}{$profile}{$hat}{path}{$path};
1830
# if we had an access(X_OK) request or some other kind of
1831
# event that generates a "PERMITTING x" syslog entry,
1832
# first check if it was already dealt with by a i/p/x
1833
# question due to a exec(). if not, ask about adding ix
1837
# get rid of the access() markers.
1840
my $combinedmode = "";
1844
# does path match any regexps in original profile?
1845
($cm, @m) = rematchfrag($sd{$profile}{$hat}, $path);
1846
$combinedmode .= $cm if $cm;
1848
# does path match anything pulled in by includes in
1850
($cm, @m) = matchincludes($sd{$profile}{$hat}, $path);
1851
$combinedmode .= $cm if $cm;
1853
if ($combinedmode) {
1854
if ( contains($combinedmode, "ix")
1855
|| contains($combinedmode, "px")
1856
|| contains($combinedmode, "ux")
1857
|| contains($combinedmode, "Px")
1858
|| contains($combinedmode, "Ux"))
1868
# if we had an mmap(PROT_EXEC) request, first check if we
1869
# already have added an ix rule to the profile
1871
my $combinedmode = "";
1874
# does path match any regexps in original profile?
1875
($cm, @m) = rematchfrag($sd{$profile}{$hat}, $path);
1876
$combinedmode .= $cm if $cm;
1878
# does path match anything pulled in by includes in
1880
($cm, @m) = matchincludes($sd{$profile}{$hat}, $path);
1881
$combinedmode .= $cm if $cm;
1883
# ix implies m. don't ask if they want to add an "m"
1884
# rule when we already have a matching ix rule.
1885
if ($combinedmode && contains($combinedmode, "ix")) {
1892
my $combinedmode = "";
1897
# does path match any regexps in original profile?
1898
($cm, @m) = rematchfrag($sd{$profile}{$hat}, $path);
1900
$combinedmode .= $cm;
1904
# does path match anything pulled in by includes in
1906
($cm, @m) = matchincludes($sd{$profile}{$hat}, $path);
1908
$combinedmode .= $cm;
1912
unless ($combinedmode && contains($combinedmode, $mode)) {
1914
my $defaultoption = 1;
1917
# check the path against the available set of include
1921
for my $incname (keys %include) {
1924
# don't suggest it if we're already including it,
1926
next if $sd{$profile}{$hat}{$incname};
1928
# only match includes that can be suggested to
1930
for my $incmatch (@custom_includes) {
1931
$includevalid = 1 if $incname =~ /$incmatch/;
1933
$includevalid = 1 if $incname =~ /abstractions/;
1934
next if ($includevalid == 0);
1936
($cm, @m) = matchinclude($incname, $path);
1937
if ($cm && contains($cm, $mode)) {
1938
unless (grep { $_ eq "/**" } @m) {
1939
push @newincludes, $incname;
1944
# did any match? add them to the option list...
1947
map { "#include <$_>" }
1948
sort(uniq(@newincludes));
1951
# include the literal path in the option list...
1952
push @options, $path;
1954
# match the current path against the globbing list in
1956
my @globs = globcommon($path);
1958
push @matches, @globs;
1961
# suggest any matching globs the user manually entered
1962
for my $userglob (@userglobs) {
1963
push @matches, $userglob
1964
if matchliteral($userglob, $path);
1967
# we'll take the cheesy way and order the suggested
1968
# globbing list by length, which is usually right,
1969
# but not always always
1971
sort { length($b) <=> length($a) }
1972
grep { $_ ne $path }
1974
$defaultoption = $#options + 1;
1976
my $severity = $sevdb->rank($path, $mode);
1983
push @{ $q->{headers} }, gettext("Profile"), combine_name($profile, $hat);
1984
push @{ $q->{headers} }, gettext("Path"), $path;
1986
# merge in any previous modes from this run
1987
if ($combinedmode) {
1988
$combinedmode = collapsemode($combinedmode);
1989
push @{ $q->{headers} }, gettext("Old Mode"), $combinedmode;
1990
$mode = collapsemode("$mode$combinedmode");
1991
push @{ $q->{headers} }, gettext("New Mode"), $mode;
1993
push @{ $q->{headers} }, gettext("Mode"), $mode;
1995
push @{ $q->{headers} }, gettext("Severity"), $severity;
1997
$q->{options} = [@options];
1998
$q->{selected} = $defaultoption - 1;
2000
$q->{functions} = [ "CMD_ALLOW", "CMD_DENY", "CMD_GLOB", "CMD_GLOBEXT", "CMD_NEW", "CMD_ABORT", "CMD_FINISHED" ];
2003
($sdmode eq "PERMITTING")
2009
# if they just hit return, use the default answer
2010
my ($ans, $selected) = UI_PromptUser($q);
2012
if ($ans eq "CMD_ALLOW") {
2015
if ($path =~ m/^#include <(.+)>$/) {
2019
for my $entry (keys %{ $sd{$profile}{$hat}{path} }) {
2021
next if $path eq $entry;
2023
my $cm = matchinclude($inc, $entry);
2025
&& contains($cm, $sd{$profile}{$hat}{path}{$entry}))
2027
delete $sd{$profile}{$hat}{path}{$entry};
2032
# record the new entry
2033
$sd{$profile}{$hat}{include}{$inc} = 1;
2035
$changed{$profile} = 1;
2036
UI_Info(sprintf(gettext('Adding #include <%s> to profile.'), $inc));
2037
UI_Info(sprintf(gettext('Deleted %s previous matching profile entries.'), $deleted)) if $deleted;
2039
if ($sd{$profile}{$hat}{path}{$path}) {
2040
$mode = collapsemode($mode . $sd{$profile}{$hat}{path}{$path});
2044
for my $entry (keys %{ $sd{$profile}{$hat}{path} }) {
2046
next if $path eq $entry;
2048
if (matchregexp($path, $entry)) {
2050
# regexp matches, add it's mode to
2051
# the list to check against
2052
if (contains($mode, $sd{$profile}{$hat}{path}{$entry})) {
2053
delete $sd{$profile}{$hat}{path}{$entry};
2059
# record the new entry
2060
$sd{$profile}{$hat}{path}{$path} = $mode;
2062
$changed{$profile} = 1;
2063
UI_Info(sprintf(gettext('Adding %s %s to profile.'), $path, $mode));
2064
UI_Info(sprintf(gettext('Deleted %s previous matching profile entries.'), $deleted)) if $deleted;
2066
} elsif ($ans eq "CMD_DENY") {
2068
# go on to the next entry without saving this
2071
} elsif ($ans eq "CMD_NEW") {
2072
if ($selected !~ /^#include/) {
2073
$ans = UI_GetString(gettext("Enter new path: "), $selected);
2075
unless (matchliteral($ans, $path)) {
2076
my $ynprompt = gettext("The specified path does not match this log entry:") . "\n\n";
2077
$ynprompt .= " " . gettext("Log Entry") . ": $path\n";
2078
$ynprompt .= " " . gettext("Entered Path") . ": $ans\n\n";
2079
$ynprompt .= gettext("Do you really want to use this path?") . "\n";
2081
# we default to no if they just hit return...
2082
my $key = UI_YesNo($ynprompt, "n");
2084
next if $key eq "n";
2087
# save this one for later
2088
push @userglobs, $ans;
2090
push @options, $ans;
2091
$defaultoption = $#options + 1;
2094
} elsif ($ans eq "CMD_GLOB") {
2096
# do globbing if they don't have an include
2098
unless ($selected =~ /^#include/) {
2099
my $newpath = $selected;
2101
# do we collapse to /* or /**?
2102
if ($newpath =~ m/\/\*{1,2}$/) {
2103
$newpath =~ s/\/[^\/]+\/\*{1,2}$/\/\*\*/;
2105
$newpath =~ s/\/[^\/]+$/\/\*/;
2107
if ($newpath ne $selected) {
2108
push @options, $newpath;
2109
$defaultoption = $#options + 1;
2112
} elsif ($ans eq "CMD_GLOBEXT") {
2114
# do globbing if they don't have an include
2116
unless ($selected =~ /^#include/) {
2117
my $newpath = $selected;
2119
# do we collapse to /*.ext or /**.ext?
2120
if ($newpath =~ m/\/\*{1,2}\.[^\/]+$/) {
2121
$newpath =~ s/\/[^\/]+\/\*{1,2}(\.[^\/]+)$/\/\*\*$1/;
2123
$newpath =~ s/\/[^\/]+(\.[^\/]+)$/\/\*$1/;
2125
if ($newpath ne $selected) {
2126
push @options, $newpath;
2127
$defaultoption = $#options + 1;
2130
} elsif ($ans =~ /\d/) {
2131
$defaultoption = $ans;
2132
} elsif ($ans eq "CMD_ABORT") {
2133
$ans = UI_YesNo(gettext("Are you sure you want to abandon this set of profile changes and exit?"), "n");
2135
UI_Info(gettext("Abandoning all changes."));
2139
} elsif ($ans eq "CMD_FINISHED") {
2140
$ans = UI_YesNo(gettext("Are you sure you want to save the current set of profile changes and exit?"), "n");
2142
UI_Info(gettext("Saving all changes."));
2145
# XXX - BUGBUG - this is REALLY nasty, but
2157
if ($UI_Mode eq "yast") {
2158
if (not $running_under_genprof) {
2160
my $w = { type => "wizard" };
2161
$w->{explanation} = gettext("The profile analyzer has completed processing the log files.\nAll updated profiles will be reloaded");
2162
$w->{functions} = [ "CMD_ABORT", "CMD_FINISHED" ];
2164
my $foo = GetDataFromYast();
2166
my $w = { type => "wizard" };
2167
$w->{explanation} = gettext("No unhandled AppArmor events were found in the system log.");
2168
$w->{functions} = [ "CMD_ABORT", "CMD_FINISHED" ];
2170
my $foo = GetDataFromYast();
2177
# make sure the profile changes we've made are saved to disk...
2178
for my $profile (sort keys %changed) {
2179
writeprofile($profile);
2183
# if they hit "Finish" we need to tell the caller that so we can exit
2184
# all the way instead of just going back to the genprof prompt
2185
return $finishing ? "FINISHED" : "NORMAL";
2188
sub setprocess ($$) {
2189
my ($pid, $profile) = @_;
2191
# don't do anything if the process exited already...
2192
return unless -e "/proc/$pid/attr/current";
2194
return unless open(CURR, "/proc/$pid/attr/current");
2195
my $current = <CURR>;
2199
# only change null profiles
2200
return unless $current =~ /null(-complain)*-profile/;
2202
return unless open(STAT, "/proc/$pid/stat");
2207
return unless $stat =~ /^\d+ \((\S+)\) /;
2210
open(CURR, ">/proc/$pid/attr/current") or return;
2211
print CURR "setprofile $profile";
2215
sub collapselog () {
2216
for my $sdmode (keys %prelog) {
2217
for my $profile (keys %{ $prelog{$sdmode} }) {
2218
for my $hat (keys %{ $prelog{$sdmode}{$profile} }) {
2219
for my $path (keys %{ $prelog{$sdmode}{$profile}{$hat}{path} }) {
2221
my $mode = $prelog{$sdmode}{$profile}{$hat}{path}{$path};
2223
# we want to ignore anything from the log that's already
2225
my $combinedmode = "";
2227
# is it in the original profile?
2228
if ($sd{$profile}{$hat}{path}{$path}) {
2229
$combinedmode .= $sd{$profile}{$hat}{path}{$path};
2232
# does path match any regexps in original profile?
2233
$combinedmode .= rematchfrag($sd{$profile}{$hat}, $path);
2235
# does path match anything pulled in by includes in
2237
$combinedmode .= matchincludes($sd{$profile}{$hat}, $path);
2239
# if we found any matching entries, do the modes match?
2240
unless ($combinedmode && contains($combinedmode, $mode)) {
2242
# merge in any previous modes from this run
2243
if ($log{$sdmode}{$profile}{$hat}{path}{$path}) {
2244
$mode = collapsemode($mode . $log{$sdmode}{$profile}{$hat}{path}{$path});
2247
# record the new entry
2248
$log{$sdmode}{$profile}{$hat}{path}{$path} = collapsemode($mode);
2252
for my $capability (keys %{ $prelog{$sdmode}{$profile}{$hat}{capability} }) {
2254
# if we don't already have this capability in the profile,
2256
unless ($sd{$profile}{$hat}{capability}{$capability}) {
2257
$log{$sdmode}{$profile}{$hat}{capability}{$capability} = 1;
2265
sub profilemode ($) {
2268
my $modifier = ($mode =~ m/[iupUP]/)[0];
2270
$mode =~ s/[iupUPx]//g;
2271
$mode .= $modifier . "x";
2278
sub commonprefix (@) { (join("\0", @_) =~ m/^([^\0]*)[^\0]*(\0\1[^\0]*)*$/)[0] }
2279
sub commonsuffix (@) { reverse(((reverse join("\0", @_)) =~ m/^([^\0]*)[^\0]*(\0\1[^\0]*)*$/)[0]); }
2283
my @result = sort grep { !$seen{$_}++ } @_;
2287
sub collapsemode ($) {
2291
my $new = join "", sort
2292
grep { !$seen{$_}++ } $old =~ m/\G(r|w|l|m|ix|px|ux|Px|Ux)/g;
2297
my ($glob, $single) = @_;
2299
$glob = "" unless defined $glob;
2302
$h{$_}++ for ($glob =~ m/\G(r|w|l|m|ix|px|ux|Px|Ux)/g);
2304
for my $mode ($single =~ m/\G(r|w|l|m|ix|px|ux|Px|Ux)/g) {
2305
return 0 unless $h{$mode};
2311
# isSkippableFile - return true if filename matches something that
2312
# should be skipped (rpm backup files, dotfiles, emacs backup files
2313
sub isSkippableFile($) {
2316
return ($path =~ /(^|\/)\.[^\/]*$/
2317
|| $path =~ /\.rpm(save|new)$/
2321
sub checkIncludeSyntax($) {
2324
if (opendir(SDDIR, $profiledir)) {
2325
my @incdirs = grep { (!/^\./) && (-d "$profiledir/$_") } readdir(SDDIR);
2327
while (my $id = shift @incdirs) {
2328
if (opendir(SDDIR, "$profiledir/$id")) {
2329
for my $path (grep { !/^\./ } readdir(SDDIR)) {
2331
next if isSkippableFile($path);
2332
if (-f "$profiledir/$id/$path") {
2333
my $file = "$id/$path";
2334
$file =~ s/$profiledir\///;
2335
my $err = loadinclude($file, \&printMessageErrorHandler);
2337
push @$errors, $err;
2339
} elsif (-d "$id/$path") {
2340
push @incdirs, "$id/$path";
2350
sub checkProfileSyntax ($) {
2353
# Check the syntax of profiles
2355
opendir(SDDIR, $profiledir)
2356
or fatal_error "Can't read AppArmor profiles in $profiledir.";
2357
for my $file (grep { -f "$profiledir/$_" } readdir(SDDIR)) {
2358
next if isSkippableFile($file);
2359
my $err = readprofile("$profiledir/$file", \&printMessageErrorHandler);
2360
if (defined $err and $err ne 1) {
2361
push @$errors, $err;
2368
sub printMessageErrorHandler ($) {
2369
my $message = shift;
2373
sub readprofiles () {
2374
opendir(SDDIR, $profiledir)
2375
or fatal_error "Can't read AppArmor profiles in $profiledir.";
2376
for my $file (grep { -f "$profiledir/$_" } readdir(SDDIR)) {
2377
next if isSkippableFile($file);
2378
readprofile("$profiledir/$file", \&fatal_error);
2383
sub readprofile ($$) {
2385
my $error_handler = shift;
2386
if (open(SDPROF, "$file")) {
2387
my ($profile, $hat, $in_contained_hat);
2388
my $initial_comment = "";
2392
# we don't care about blank lines
2395
# start of a profile...
2396
if (m/^\s*("??\/.+?"??)\s+(flags=\(.+\)\s+)*\{\s*$/) {
2398
# if we run into the start of a profile while we're already in a
2399
# profile, something's wrong...
2401
return &$error_handler("$profile profile in $file contains syntax errors.");
2404
# we hit the start of a profile, keep track of it...
2407
$in_contained_hat = 0;
2409
# hat is same as profile name if we're not in a hat
2410
($profile, $hat) = split /\^/, $profile;
2412
# deal with whitespace in profile and hat names.
2413
$profile = $1 if $profile =~ /^"(.+)"$/;
2414
$hat = $1 if $hat && $hat =~ /^"(.+)"$/;
2416
# if we run into old-style hat declarations mark the profile as
2417
# changed so we'll write it out as new-style
2418
if ($hat && $hat ne $profile) {
2419
$changed{$profile} = 1;
2424
# keep track of profile flags
2425
if ($flags && $flags =~ /^flags=\((.+)\)\s*$/) {
2427
$sd{$profile}{$hat}{flags} = $flags;
2430
$sd{$profile}{$hat}{netdomain} = [];
2432
# store off initial comment if they have one
2433
$sd{$profile}{$hat}{initial_comment} = $initial_comment
2434
if $initial_comment;
2435
$initial_comment = "";
2437
} elsif (m/^\s*\}\s*$/) { # end of a profile...
2439
# if we hit the end of a profile when we're not in one,
2440
# something's wrong...
2442
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2445
if ($in_contained_hat) {
2447
$in_contained_hat = 0;
2450
# if we're finishing a profile, make sure that any required
2451
# infrastructure hats for this changehat application exist
2452
for my $hatglob (keys %required_hats) {
2453
if ($profile =~ /$hatglob/) {
2454
for my $hat (split(/\s+/, $required_hats{$hatglob})) {
2455
unless ($sd{$profile}{$hat}) {
2456
$sd{$profile}{$hat} = {};
2458
# if we had to auto-instantiate a hat, we
2459
# want to write out an updated version of
2461
$changed{$profile} = 1;
2467
# mark that we're outside of a profile now...
2469
$initial_comment = "";
2472
} elsif (m/^\s*capability\s+(\S+)\s*,\s*$/) { # capability entry
2474
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2477
my $capability = $1;
2478
$sd{$profile}{$hat}{capability}{$capability} = 1;
2480
} elsif (/^\s*(\$\{?[[:alpha:]][[:alnum:]_]*\}?)\s*=\s*(true|false)\s*$/i) { # boolean definition
2481
} elsif (/^\s*(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\+=\s*(.+)\s*$/) { # variable additions
2482
} elsif (/^\s*(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*=\s*(.+)\s*$/) { # variable definitions
2483
} elsif (m/^\s*if\s+(not\s+)?(\$\{?[[:alpha:]][[:alnum:]_]*\}?)\s*\{\s*$/) { # conditional -- boolean
2484
} elsif (m/^\s*if\s+(not\s+)?defined\s+(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\{\s*$/) { # conditional -- variable defined
2485
} elsif (m/^\s*if\s+(not\s+)?defined\s+(\$\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\{\s*$/) { # conditional -- boolean defined
2486
} elsif (m/^\s*([\"\@\/].*)\s+(\S+)\s*,\s*$/) { # path entry
2488
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2491
my ($path, $mode) = ($1, $2);
2493
# strip off any trailing spaces.
2496
$path = $1 if $path =~ /^"(.+)"$/;
2498
# make sure they don't have broken regexps in the profile
2499
my $p_re = convert_regexp($path);
2500
eval { "foo" =~ m/^$p_re$/; };
2502
return &$error_handler(sprintf(gettext('Profile %s contains invalid regexp %s.'), $file, $path));
2505
$sd{$profile}{$hat}{path}{$path} = $mode;
2507
} elsif (m/^\s*#include <(.+)>\s*$/) { # include stuff
2511
$sd{$profile}{$hat}{include}{$include} = 1;
2513
unless (exists $variables{$file}) {
2514
$variables{$file} = {};
2516
$variables{$file}{ "#" . $include } = 1; # sorry
2518
my $ret = loadinclude($include, $error_handler);
2519
return $ret if ($ret != 0);
2521
} elsif (/^\s*(tcp_connect|tcp_accept|udp_send|udp_receive)/) {
2523
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2526
# XXX - BUGBUGBUG - don't strip netdomain entries
2528
unless ($sd{$profile}{$hat}{netdomain}) {
2529
$sd{$profile}{$hat}{netdomain} = [];
2532
# strip leading spaces and trailing comma
2536
# keep track of netdomain entries...
2537
push @{ $sd{$profile}{$hat}{netdomain} }, $_;
2539
} elsif (m/^\s*\^(\"?.+?)\s+(flags=\(.+\)\s+)*\{\s*$/) {
2542
# if we hit the start of a contained hat when we're not
2543
# in a profile something is wrong...
2545
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2548
$in_contained_hat = 1;
2550
# we hit the start of a hat inside the current profile
2554
# deal with whitespace in hat names.
2555
$hat = $1 if $hat =~ /^"(.+)"$/;
2557
# keep track of profile flags
2558
if ($flags && $flags =~ /^flags=\((.+)\)\s*$/) {
2560
$sd{$profile}{$hat}{flags} = $flags;
2563
$sd{$profile}{$hat}{path} = {};
2564
$sd{$profile}{$hat}{netdomain} = [];
2566
# store off initial comment if they have one
2567
$sd{$profile}{$hat}{initial_comment} = $initial_comment
2568
if $initial_comment;
2569
$initial_comment = "";
2571
} elsif (/^\s*\#/) {
2573
# we only currently handle initial comments
2576
# ignore vim syntax highlighting lines
2577
next if /^\s*\# vim:syntax/;
2579
# ignore Last Modified: lines
2580
next if /^\s*\# Last Modified:/;
2581
$initial_comment .= "$_\n";
2585
# we hit something we don't understand in a profile...
2586
return &$error_handler(sprintf(gettext('%s contains syntax errors.'), $file));
2590
# if we're still in a profile when we hit the end of the file, it's bad
2592
return &$error_handler("Reached the end of $file while we were still inside the $profile profile.");
2597
$DEBUGGING && debug "readprofile: can't read $file - skipping";
2602
my $dangerous = shift;
2604
if ($dangerous =~ m/^"(.+)"$/) {
2607
$dangerous =~ s/((?<!\\))"/$1\\"/g;
2608
if ($dangerous =~ m/(\s|^$|")/) {
2609
$dangerous = "\"$dangerous\"";
2615
sub writeheader ($$$$) {
2616
my ($fh, $profile, $hat, $indent) = @_;
2618
# deal with whitespace in profile names...
2620
$p = "\"$p\"" if $p =~ /\s/;
2622
if ($sd{$profile}{$hat}{flags}) {
2623
print $fh "$p flags=($sd{$profile}{$hat}{flags}) {\n";
2629
sub writeincludes ($$$$) {
2630
my ($fh, $profile, $hat, $indent) = @_;
2632
# dump out the includes
2633
if (exists $sd{$profile}{$hat}{include}) {
2634
for my $include (sort keys %{ $sd{$profile}{$hat}{include} }) {
2635
print $fh "$indent #include <$include>\n";
2637
print $fh "\n" if keys %{ $sd{$profile}{$hat}{include} };
2641
sub writecapabilities ($$$$) {
2642
my ($fh, $profile, $hat, $indent) = @_;
2644
# dump out the capability entries...
2645
if (exists $sd{$profile}{$hat}{capability}) {
2646
for my $capability (sort keys %{ $sd{$profile}{$hat}{capability} }) {
2647
print $fh "$indent capability $capability,\n";
2649
print $fh "\n" if keys %{ $sd{$profile}{$hat}{capability} };
2653
sub writenetdomain ($$$$) {
2654
my ($fh, $profile, $hat, $indent) = @_;
2656
# dump out the netdomain entries...
2657
if (exists $sd{$profile}{$hat}{netdomain}) {
2658
for my $nd (sort @{ $sd{$profile}{$hat}{netdomain} }) {
2659
print $fh "$indent $nd,\n";
2661
print $fh "\n" if @{ $sd{$profile}{$hat}{netdomain} };
2665
sub writepaths ($$$$) {
2666
my ($fh, $profile, $hat, $indent) = @_;
2668
if (exists $sd{$profile}{$hat}{path}) {
2669
for my $path (sort keys %{ $sd{$profile}{$hat}{path} }) {
2670
my $mode = $sd{$profile}{$hat}{path}{$path};
2672
# strip out any fake access() modes that might have slipped through
2675
# deal with whitespace in path names
2676
if ($path =~ /\s/) {
2677
print $fh "$indent \"$path\" $mode,\n";
2679
print $fh "$indent $path $mode,\n";
2685
sub writepiece ($$) {
2686
my ($sdprof, $profile) = @_;
2688
writeheader($sdprof, $profile, $profile, "");
2689
writeincludes($sdprof, $profile, $profile, "");
2690
writecapabilities($sdprof, $profile, $profile, "");
2691
writenetdomain($sdprof, $profile, $profile, "");
2692
writepaths($sdprof, $profile, $profile, "");
2694
for my $hat (grep { $_ ne $profile } sort keys %{ $sd{$profile} }) {
2696
# deal with whitespace in profile names...
2698
$h = "\"$h\"" if $h =~ /\s/;
2700
if ($sd{$profile}{$hat}{flags}) {
2701
print $sdprof "\n ^$h flags=($sd{$profile}{$hat}{flags}) {\n";
2703
print $sdprof "\n ^$h {\n";
2706
writeincludes($sdprof, $profile, $hat, " ");
2707
writecapabilities($sdprof, $profile, $hat, " ");
2708
writenetdomain($sdprof, $profile, $hat, " ");
2709
writepaths($sdprof, $profile, $hat, " ");
2711
print $sdprof " }\n";
2714
print $sdprof "}\n";
2717
sub writeprofile ($) {
2718
my $profile = shift;
2720
UI_Info(sprintf(gettext('Writing updated profile for %s.'), $profile));
2722
my $filename = getprofilefilename($profile);
2724
open(SDPROF, ">$filename")
2725
or fatal_error "Can't write new AppArmor profile $filename: $!";
2727
# stick in a vim mode line to turn on AppArmor syntax highlighting
2728
print SDPROF "# vim:syntax=apparmor\n";
2730
# keep track of when the file was last updated
2731
print SDPROF "# Last Modified: " . localtime(time) . "\n";
2733
# print out initial comment
2734
if ($sd{$profile}{$profile}{initial_comment}) {
2735
$sd{$profile}{$profile}{initial_comment} =~ s/\\n/\n/g;
2736
print SDPROF $sd{$profile}{$profile}{initial_comment};
2740
# dump variables defined in this file
2741
if ($variables{$filename}) {
2742
for my $var (sort keys %{ $variables{$filename} }) {
2743
if ($var =~ m/^@/) {
2744
my @values = sort @{ $variables{$filename}{$var} };
2745
@values = map { escape($_) } @values;
2746
my $values = join(" ", @values);
2747
print SDPROF "$var = ";
2748
print SDPROF $values;
2749
} elsif ($var =~ m/^\$/) {
2750
print SDPROF "$var = ";
2751
print SDPROF ${ $variables{$filename}{$var} };
2752
} elsif ($var =~ m/^\#/) {
2755
print SDPROF "#include <$inc>";
2763
writepiece(\*SDPROF, $profile);
2768
sub getprofileflags {
2769
my $filename = shift;
2771
my $flags = "enforce";
2773
if (open(PROFILE, "$filename")) {
2775
if (m/^\s*\/\S+\s+(flags=\(.+\)\s+)*{\s*$/) {
2778
$flags =~ s/flags=\((.+)\)/$1/;
2789
my ($sd_regexp, $literal) = @_;
2791
my $p_regexp = convert_regexp($sd_regexp);
2793
# check the log entry against our converted regexp...
2794
my $matches = eval { $literal =~ /^$p_regexp$/; };
2796
# doesn't match if we've got a broken regexp
2805
# don't try to reload profile if AppArmor is not running
2806
return unless check_for_subdomain();
2808
# don't reload the profile if the corresponding executable doesn't exist
2809
my $fqdbin = findexecutable($bin) or return;
2811
my $filename = getprofilefilename($fqdbin);
2813
system("/bin/cat '$filename' | $parser -I$profiledir -r >/dev/null 2>&1");
2818
my $error_handler = shift;
2820
# don't bother loading it again if we already have
2821
return 0 if $include{$which};
2823
my @loadincludes = ($which);
2824
while (my $incfile = shift @loadincludes) {
2826
# load the include from the directory we found earlier...
2827
open(INCLUDE, "$profiledir/$incfile")
2828
or fatal_error "Can't find include file $incfile: $!";
2833
if (/^\s*(\$\{?[[:alpha:]][[:alnum:]_]*\}?)\s*=\s*(true|false)\s*$/i) {
2834
# boolean definition
2835
} elsif (/^\s*(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\+=\s*(.+)\s*$/) {
2836
# variable additions
2837
} elsif (/^\s*(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*=\s*(.+)\s*$/) {
2838
# variable definitions
2839
} elsif (m/^\s*if\s+(not\s+)?(\$\{?[[:alpha:]][[:alnum:]_]*\}?)\s*\{\s*$/) {
2840
# conditional -- boolean
2841
} elsif (m/^\s*if\s+(not\s+)?defined\s+(@\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\{\s*$/) {
2842
# conditional -- variable defined
2843
} elsif (m/^\s*if\s+(not\s+)?defined\s+(\$\{?[[:alpha:]][[:alnum:]_]+\}?)\s*\{\s*$/) {
2844
# conditional -- boolean defined
2845
} elsif (m/^\s*\}\s*$/) {
2846
# end of a profile or conditional
2847
} elsif (m/^\s*([\"\@\/].*)\s+(\S+)\s*,\s*$/) {
2850
my ($path, $mode) = ($1, $2);
2852
# strip off any trailing spaces.
2855
$path = $1 if $path =~ /^"(.+)"$/;
2857
# make sure they don't have broken regexps in the profile
2858
my $p_re = convert_regexp($path);
2859
eval { "foo" =~ m/^$p_re$/; };
2861
return &$error_handler(sprintf(gettext('Include file %s contains invalid regexp %s.'), $incfile, $path));
2864
$include{$incfile}{path}{$path} = $mode;
2865
} elsif (/^\s*capability\s+(.+)\s*,\s*$/) {
2867
my $capability = $1;
2868
$include{$incfile}{capability}{$capability} = 1;
2870
} elsif (/^\s*#include <(.+)>\s*$/) {
2873
my $newinclude = $1;
2874
push @loadincludes, $newinclude unless $include{$newinclude};
2875
$include{$incfile}{include}{$newinclude} = 1;
2877
} elsif (/^\s*(tcp_connect|tcp_accept|udp_send|udp_receive)/) {
2880
# we don't care about blank lines or comments
2884
# we hit something we don't understand in a profile...
2885
return &$error_handler(sprintf(gettext('Include file %s contains syntax errors or is not a valid #include file.'), $incfile));
2895
my ($frag, $path) = @_;
2897
my $combinedmode = "";
2900
for my $entry (keys %{ $frag->{path} }) {
2902
my $regexp = convert_regexp($entry);
2904
# check the log entry against our converted regexp...
2905
if ($path =~ /^$regexp$/) {
2907
# regexp matches, add it's mode to the list to check against
2908
$combinedmode .= $frag->{path}{$entry};
2909
push @matches, $entry;
2913
return wantarray ? ($combinedmode, @matches) : $combinedmode;
2917
my ($frag, $path) = @_;
2919
my $combinedmode = "";
2922
# scan the include fragments for this profile looking for matches
2923
my @includelist = keys %{ $frag->{include} };
2924
while (my $include = shift @includelist) {
2925
loadinclude($include, \&fatal_error);
2926
my ($cm, @m) = rematchfrag($include{$include}, $path);
2928
$combinedmode .= $cm;
2932
# check if a literal version is in the current include fragment
2933
if ($include{$include}{path}{$path}) {
2934
$combinedmode .= $include{$include}{path}{$path};
2937
# if this fragment includes others, check them too
2938
if (keys %{ $include{$include}{include} }) {
2939
push @includelist, keys %{ $include{$include}{include} };
2943
return wantarray ? ($combinedmode, @matches) : $combinedmode;
2947
my ($incname, $path) = @_;
2949
my $combinedmode = "";
2952
# scan the include fragments for this profile looking for matches
2953
my @includelist = ($incname);
2954
while (my $include = shift @includelist) {
2955
my ($cm, @m) = rematchfrag($include{$include}, $path);
2957
$combinedmode .= $cm;
2961
# check if a literal version is in the current include fragment
2962
if ($include{$include}{path}{$path}) {
2963
$combinedmode .= $include{$include}{path}{$path};
2966
# if this fragment includes others, check them too
2967
if (keys %{ $include{$include}{include} }) {
2968
push @includelist, keys %{ $include{$include}{include} };
2972
if ($combinedmode) {
2973
return wantarray ? ($combinedmode, @matches) : $combinedmode;
2983
if (open(LPCONF, "$confdir/logprof.conf")) {
2989
if (m/^\[(\S+)\]/) {
2991
} elsif (m/^\s*(\S+)\s*=\s*(.+)\s*$/) {
2992
my ($key, $value) = ($1, $2);
2993
if ($which eq "defaulthat") {
2994
$defaulthat{$key} = $value;
2995
} elsif ($which eq "qualifiers") {
2996
$qualifiers{$key} = $value;
2997
} elsif ($which eq "globs") {
2998
$globmap{$key} = $value;
2999
} elsif ($which eq "required_hats") {
3000
$required_hats{$key} = $value;
3002
} elsif (m/^\s*(\S+)\s*$/) {
3004
if ($which eq "custom_includes") {
3005
push @custom_includes, $val;
3014
if (opendir(SDDIR, $profiledir)) {
3015
my @incdirs = grep { (!/^\./) && (-d "$profiledir/$_") } readdir(SDDIR);
3018
while (my $id = shift @incdirs) {
3019
if (opendir(SDDIR, "$profiledir/$id")) {
3020
for my $path (readdir(SDDIR)) {
3022
next if isSkippableFile($path);
3023
if (-f "$profiledir/$id/$path") {
3024
my $file = "$id/$path";
3025
$file =~ s/$profiledir\///;
3026
loadinclude($file, \&fatal_error);
3027
} elsif (-d "$id/$path") {
3028
push @incdirs, "$id/$path";
3037
sub globcommon ($) {
3042
# glob library versions in both foo-5.6.so and baz.so.9.2 form
3043
if ($path =~ m/[\d\.]+\.so$/ || $path =~ m/\.so\.[\d\.]+$/) {
3044
my $libpath = $path;
3045
$libpath =~ s/[\d\.]+\.so$/*.so/;
3046
$libpath =~ s/\.so\.[\d\.]+$/.so.*/;
3047
push @globs, $libpath if $libpath ne $path;
3050
for my $glob (keys %globmap) {
3051
if ($path =~ /$glob/) {
3052
my $globbedpath = $path;
3053
$globbedpath =~ s/$glob/$globmap{$glob}/g;
3054
push @globs, $globbedpath if $globbedpath ne $path;
3059
return sort { length($b) <=> length($a) } uniq(@globs);
3061
my @list = sort { length($b) <=> length($a) } uniq(@globs);
3062
return $list[$#list];
3066
# this is an ugly, nasty function that attempts to see if one regexp
3067
# is a subset of another regexp
3068
sub matchregexp ($$) {
3069
my ($new, $old) = @_;
3071
# bail out if old pattern has {foo,bar,baz} stuff in it
3072
return undef if $old =~ /\{.*(\,.*)*\}/;
3074
# are there any regexps at all in the old pattern?
3075
if ($old =~ /\[.+\]/ or $old =~ /\*/ or $old =~ /\?/) {
3077
# convert {foo,baz} to (foo|baz)
3078
$new =~ y/\{\}\,/\(\)\|/ if $new =~ /\{.*\,.*\}/;
3080
# \001 == SD_GLOB_RECURSIVE
3081
# \002 == SD_GLOB_SIBLING
3083
$new =~ s/\*\*/\001/g;
3084
$new =~ s/\*/\002/g;
3086
$old =~ s/\*\*/\001/g;
3087
$old =~ s/\*/\002/g;
3089
# strip common prefix
3090
my $prefix = commonprefix($new, $old);
3093
# make sure we don't accidentally gobble up a trailing * or **
3094
$prefix =~ s/(\001|\002)$//;
3095
$new =~ s/^$prefix//;
3096
$old =~ s/^$prefix//;
3099
# strip common suffix
3100
my $suffix = commonsuffix($new, $old);
3103
# make sure we don't accidentally gobble up a leading * or **
3104
$suffix =~ s/^(\001|\002)//;
3105
$new =~ s/$suffix$//;
3106
$old =~ s/$suffix$//;
3109
# if we boiled the differences down to a ** in the new entry, it matches
3110
# whatever's in the old entry
3111
return 1 if $new eq "\001";
3113
# if we've paired things down to a * in new, old matches if there are no
3114
# slashes left in the path
3115
return 1 if ($new eq "\002" && $old =~ /^[^\/]+$/);
3117
# we'll bail out if we have more globs in the old version
3118
return undef if $old =~ /\001|\002/;
3120
# see if we can match * globs in new against literal elements in old
3121
$new =~ s/\002/[^\/]*/g;
3123
return 1 if $old =~ /^$new$/;
3127
my $new_regexp = convert_regexp($new);
3129
# check the log entry against our converted regexp...
3130
return 1 if $old =~ /^$new_regexp$/;
3137
sub combine_name($$) { return ($_[0] eq $_[1]) ? $_[0] : "$_[0]^$_[1]"; }
3138
sub split_name ($) { my ($p, $h) = split(/\^/, $_[0]); $h ||= $p; ($p, $h); }
3140
##########################
3142
# prompt_user($headers, $functions, $default, $options, $selected);
3145
# a required arrayref made up of "key, value" pairs in the order you'd
3146
# like them displayed to user
3149
# a required arrayref of the different options to display at the bottom
3150
# of the prompt like "(A)llow", "(D)eny", and "Ba(c)on". the character
3151
# contained by ( and ) will be used as the key to select the specified
3155
# a required character which is the default "key" to enter when they
3159
# an optional arrayref of the choices like the glob suggestions to be
3160
# presented to the user
3163
# specifies which option is currently selected
3165
# when prompt_user() is called without an $options list, it returns a
3166
# single value which is the key for the specified "function".
3168
# when prompt_user() is called with an $options list, it returns an array
3169
# of two elements, the key for the specified function as well as which
3170
# option was currently selected
3171
#######################################################################
3173
sub Text_PromptUser ($) {
3174
my $question = shift;
3176
my @headers = (@{ $question->{headers} });
3177
my @functions = (@{ $question->{functions} });
3179
my $default = $question->{default};
3180
my $options = $question->{options};
3181
my $selected = $question->{selected};
3183
my $helptext = $question->{helptext};
3185
push @functions, "CMD_HELP" if $helptext;
3189
for my $cmd (@functions) {
3191
# make sure we know about this particular command
3192
my $cmdmsg = "PromptUser: " . gettext("Unknown command") . " $cmd";
3193
fatal_error $cmdmsg unless $CMDS{$cmd};
3195
# grab the localized text to use for the menu for this command
3196
my $menutext = gettext($CMDS{$cmd});
3198
# figure out what the hotkey for this menu item is
3199
my $menumsg = "PromptUser: " . gettext("Invalid hotkey in") . " '$menutext'";
3200
$menutext =~ /\((\S)\)/ or fatal_error $menumsg;
3202
# we want case insensitive comparisons so we'll force things to
3206
# check if we're already using this hotkey for this prompt
3207
my $hotkeymsg = "PromptUser: " . gettext("Duplicate hotkey for") . " $cmd: $menutext";
3208
fatal_error $hotkeymsg if $keys{$key};
3210
# keep track of which command they're picking if they hit this hotkey
3213
if ($default && $default eq $cmd) {
3214
$menutext = "[$menutext]";
3217
push @menu_items, $menutext;
3220
# figure out the key for the default option
3222
if ($default && $CMDS{$default}) {
3223
my $defaulttext = gettext($CMDS{$default});
3225
# figure out what the hotkey for this menu item is
3226
my $defmsg = "PromptUser: " . gettext("Invalid hotkey in default item") . " '$defaulttext'";
3227
$defaulttext =~ /\((\S)\)/ or fatal_error $defmsg;
3229
# we want case insensitive comparisons so we'll force things to
3231
$default_key = lc($1);
3233
my $defkeymsg = "PromptUser: " . gettext("Invalid default") . " $default";
3234
fatal_error $defkeymsg unless $keys{$default_key};
3239
while (my $header = shift @poo) {
3240
my $value = shift @poo;
3241
$widest = length($header) if length($header) > $widest;
3245
my $format = '%-' . $widest . "s \%s\n";
3247
my $function_regexp = '^(';
3248
$function_regexp .= join("|", keys %keys);
3249
$function_regexp .= '|\d' if $options;
3250
$function_regexp .= ')$';
3252
my $ans = "XXXINVALIDXXX";
3253
while ($ans !~ /$function_regexp/i) {
3255
# build up the prompt...
3258
while (my $header = shift @poo) {
3259
my $value = shift @poo;
3260
$prompt .= sprintf($format, "$header:", $value);
3264
for (my $i = 0; $options->[$i]; $i++) {
3265
my $f = ($selected == $i) ? ' [%d - %s]' : ' %d - %s ';
3266
$prompt .= sprintf("$f\n", $i + 1, $options->[$i]);
3270
$prompt .= join(" / ", @menu_items);
3273
# get their input...
3276
# pick the default if they hit return...
3277
$ans = $default_key if ord($ans) == 10;
3279
# ugly code to handle escape sequences so you can up/down in the list
3280
if (ord($ans) == 27) {
3282
if (ord($ans) == 91) {
3284
if (ord($ans) == 65) {
3286
if ($selected > 0) {
3294
} elsif (ord($ans) == 66) {
3296
if ($selected <= scalar(@$options)) {
3297
$ans = $selected + 2;
3311
if ($options && ($ans =~ /^\d$/)) {
3312
if ($ans > 0 && $ans <= scalar(@$options)) {
3313
$selected = $ans - 1;
3318
if ($keys{$ans} && $keys{$ans} eq "CMD_HELP") {
3319
print "\n$helptext\n";
3324
# pull our command back from our hotkey map
3325
$ans = $keys{$ans} if $keys{$ans};
3328
# die "ERROR: not looking for array when options passed" unless wantarray;
3330
return ($ans, $options->[$selected]);
3332
return ($ans, $selected);
3336
# die "ERROR: looking for list when options not passed" if wantarray;
3342
$ldd = which("ldd") or fatal_error "Can't find ldd.";
3345
unless (-x $parser) {
3346
$parser = which("apparmor_parser") || which("subdomain_parser")
3347
or fatal_error "Can't find apparmor_parser.";
added
removed
utils/SubDomain.pm
