src/ferm

   1 #!/usr/bin/perl
   2
   3 #
   4 # ferm, a firewall setup program that makes firewall rules easy!
   5 #
   6 # Copyright (C) 2001-2007 Auke Kok, Max Kellermann
   7 #
   8 # Comments, questions, greetings and additions to this program
   9 # may be sent to <ferm@foo-projects.org>
  10 #
  11
  12 #
  13 # This program is free software; you can redistribute it and/or modify
  14 # it under the terms of the GNU General Public License as published by
  15 # the Free Software Foundation; either version 2 of the License, or
  16 # (at your option) any later version.
  17 #
  18 # This program is distributed in the hope that it will be useful,
  19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 # GNU General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  26 #
  27
  28 # $Id$
  29
  30 BEGIN {
  31     eval { require strict; import strict; };
  32     $has_strict = not $@;
  33     if ($@) {
  34         # we need no vars.pm if there is not even strict.pm
  35         $INC{'vars.pm'} = 1;
  36         *vars::import = sub {};
  37     }
  38
  39     eval { require Getopt::Long; import Getopt::Long; };
  40     $has_getopt = not $@;
  41 }
  42
  43 use vars qw($has_strict $has_getopt);
  44
  45 use vars qw($DATE $VERSION);
  46
  47 # subversion keyword magic
  48 $DATE = '$Date$' =~ m,(\d{4})-(\d\d)-(\d\d), ? $1.$2.$3 : '';
  49
  50 $VERSION = '2.0';
  51 $VERSION .= '~svn' . $DATE;
  52
  53 ## interface variables
  54 # %option = command line and other options
  55 use vars qw(%option);
  56
  57 ## hooks
  58 use vars qw(@pre_hooks @post_hooks);
  59
  60 ## parser variables
  61 # $script: current script file
  62 # @stack = ferm's parser stack containing local variables
  63 # $auto_chain = index for the next auto-generated chain
  64 use vars qw($script %rules @stack $auto_chain);
  65
  66 ## netfilter variables
  67 # %domains = state information about all domains ("ip" and "ip6")
  68 # - initialized: domain initialization is done
  69 # - tools: hash providing the paths of the domain's tools
  70 # - previous: save file of the previous ruleset, for rollback
  71 # - reset: has this domain already been reset?
  72 # - tables{$name}: ferm state information about tables
  73 #   - chains{$chain}: ferm state information about the chains
  74 #     - builtin: whether this is a built-in chain
  75 #     - was_created: custom chain has been created
  76 #     - non_empty: are there rules for this chain?
  77 use vars qw(%domains);
  78
  79 ## constants
  80 use vars qw(%deprecated_keywords %automod);
  81
  82 # keywords from ferm 1.1 which are deprecated, and the new one; these
  83 # are automatically replaced, and a warning is printed
  84 %deprecated_keywords = ();
  85
  86 # support for the deprecated "automod" option. provide a mapping
  87 # between keywords and modules required for that
  88 %automod = ( tos => 'tos',
  89              mark => 'mark',
  90              'mac-source' => 'mac',
  91              limit => 'limit',
  92              'limit-burst' => 'limit',
  93              'iplimit-above' => 'iplimit',
  94              'iplimit-mask' => 'iplimit',
  95              'uid-owner' => 'owner',
  96              'gid-owner' => 'owner',
  97              'pid-owner' => 'owner',
  98              'sid-owner' => 'owner',
  99              'psd-weight-threshold' => 'psd',
 100              'psd-delay-threshold' => 'psd',
 101              'psd-lo-ports-weight' => 'psd',
 102              'psd-hi-ports-weight' => 'psd',
 103              length => 'length',
 104              average => 'random',
 105              every => 'nth',
 106              counter => 'nth',
 107              start => 'nth',
 108              packet => 'nth',
 109              'pkt-type' => 'pkttype',
 110              state => 'state',
 111              'ttl-eq' => 'ttl',
 112              'ttl-gt' => 'ttl',
 113              'ttl-lt' => 'ttl',
 114              timestart => 'time',
 115              timestop => 'time',
 116              days => 'time',
 117              datestart => 'time',
 118              datestop => 'time',
 119            );
 120
 121 # these hashes provide the Netfilter module definitions
 122 use vars qw(%proto_defs %match_defs %target_defs);
 123
 124 #
 125 # This subsubsystem allows you to support (most) new netfilter modules
 126 # in ferm.  Add a call to one of the "add_XY_def()" functions below.
 127 #
 128 # Ok, now about the cryptic syntax: the function "add_XY_def()"
 129 # registers a new module.  There are three kinds of modules: protocol
 130 # module (e.g. TCP, ICMP), match modules (e.g. state, physdev) and
 131 # target modules (e.g. DNAT, MARK).
 132 #
 133 # The first parameter is always the module name which is passed to
 134 # iptables with "-p", "-m" or "-j" (depending on which kind of module
 135 # this is).
 136 #
 137 # After that, you add an encoded string for each option the module
 138 # supports.  This is where it becomes tricky.
 139 #
 140 # foo           defaults to an option with one argument (which may be a ferm
 141 #               array)
 142 #
 143 # foo*0         option without any arguments
 144 #
 145 # foo=s         one argument which must not be a ferm array ('s' stands for
 146 #               'scalar')
 147 #
 148 # to-source=a   one argument, may be a ferm array ('a'='array'); this forces
 149 #               ferm to accept arrays, even in a target declaration; example:
 150 #               to-source (1.2.3.4 5.6.7.8)  translates to:
 151 #               --to-source 1.2.3.4 --to-source 5.6.7.8
 152 #
 153 # ctstate=c     one argument, if it's an array, pass it to iptables as a
 154 #               single comma separated value; example:
 155 #                 ctstate (ESTABLISHED RELATED)  translates to:
 156 #                 --ctstate ESTABLISHED,RELATED
 157 #
 158 # foo=sac       three arguments: scalar, array, comma separated; you may
 159 #               concatenate more than one letter code after the '='
 160 #
 161 # foo&bar       one argument; call the perl function '&bar()' which parses
 162 #               the argument
 163 #
 164 # !foo          negation is allowed and the '!' is written before the keyword
 165 #
 166 # foo!          same as above, but '!' is after the keyword and before the
 167 #               parameters
 168 #
 169 # to:=to-destination    makes "to" an alias for "to-destination"; you have
 170 #                       to add a declaration for option "to-destination"
 171 #
 172
 173 # add a module definition
 174 sub add_def_x {
 175     my $defs = shift;
 176     my $domain_family = shift;
 177     my $name = shift;
 178     die if exists $defs->{$domain_family}{$name};
 179     my $def = $defs->{$domain_family}{$name} = {};
 180     foreach (@_) {
 181         my $keyword = $_;
 182         my $k = {};
 183
 184         my $params = 1;
 185         $params = $1 if $keyword =~ s,\*(\d+)$,,;
 186         $params = $1 if $keyword =~ s,=([acs]+)$,,;
 187         if ($keyword =~ s,&(\S+)$,,) {
 188             $params = eval "\\&$1";
 189             die $@ if $@;
 190         }
 191         $k->{params} = $params if $params;
 192
 193         $k->{negation} = $k->{pre_negation} = 1 if $keyword =~ s,^!,,;
 194         $k->{negation} = 1 if $keyword =~ s,!$,,;
 195
 196         $k->{alias} = $1 if $keyword =~ s,:=(\S+)$,,;
 197
 198         $def->{keywords}{$keyword} = $k;
 199     }
 200
 201     return $def;
 202 }
 203
 204 # add a protocol module definition
 205 sub add_proto_def_x(@) {
 206     add_def_x(\%proto_defs, @_);
 207 }
 208
 209 # add a match module definition
 210 sub add_match_def_x(@) {
 211     add_def_x(\%match_defs, @_);
 212 }
 213
 214 # add a target module definition
 215 sub add_target_def_x(@) {
 216     add_def_x(\%target_defs, @_);
 217 }
 218
 219 sub add_def {
 220     my $defs = shift;
 221     add_def_x($defs, 'ip', @_);
 222 }
 223
 224 # add a protocol module definition
 225 sub add_proto_def(@) {
 226     add_def(\%proto_defs, @_);
 227 }
 228
 229 # add a match module definition
 230 sub add_match_def(@) {
 231     add_def(\%match_defs, @_);
 232 }
 233
 234 # add a target module definition
 235 sub add_target_def(@) {
 236     add_def(\%target_defs, @_);
 237 }
 238
 239 add_proto_def 'dccp', qw(dccp-types!=c dccp-option!);
 240 add_proto_def 'icmp', qw(icmp-type!);
 241 add_proto_def 'icmpv6', qw(icmpv6-type!);
 242 add_proto_def 'sctp', qw(chunk-types!=sc);
 243 add_proto_def 'tcp', qw(tcp-flags!=cc !syn*0 tcp-option! mss);
 244 add_proto_def 'udp', qw();
 245
 246 add_match_def 'account', qw(aaddr=s aname=s ashort*0);
 247 add_match_def 'addrtype', qw(src-type dst-type);
 248 add_match_def 'ah', qw(ahspi! ahlen! ahres*0);
 249 add_match_def 'comment', qw(comment=s);
 250 add_match_def 'condition', qw(condition!);
 251 add_match_def 'connmark', qw(mark);
 252 add_match_def 'conntrack', qw(ctstate=c ctproto ctorigsrc! ctorigdst!),
 253   qw(ctreplsrc! ctrepldst! ctstatus ctexpire=s);
 254 add_match_def 'dscp', qw(dscp dscp-class);
 255 add_match_def 'dst', qw(dst-len!=s dst-opts=c);
 256 add_match_def 'ecn', qw(ecn-tcp-cwr*0 ecn-tcp-ece*0 ecn-ip-ect);
 257 add_match_def 'esp', qw(espspi!);
 258 add_match_def 'eui64';
 259 add_match_def 'frag', qw(fragid! fraglen! fragres*0 fragmore*0 fragfirst*0 fraglast*0);
 260 add_match_def 'fuzzy', qw(lower-limit=s upper-limit=s);
 261 add_match_def 'hbh', qw(hbh-len! hbh-opts=c);
 262 add_match_def 'helper', qw(helper);
 263 add_match_def 'hl', qw(hl-eq! hl-lt=s hl-gt=s);
 264 add_match_def 'length', qw(length!);
 265 add_match_def 'hashlimit', qw(hashlimit=s hashlimit-burst=s hashlimit-mode=s hashlimit-name=s),
 266   qw(hashlimit-htable-size=s hashlimit-htable-max=s),
 267   qw(hashlimit-htable-expire=s hashlimit-htable-gcinterval=s);
 268 add_match_def 'iprange', qw(!src-range !dst-range);
 269 add_match_def 'iplimit', qw(!iplimit-above=s iplimit-mask=s);
 270 add_match_def 'ipv6header', qw(header!=c soft*0);
 271 add_match_def 'limit', qw(limit=s limit-burst=s);
 272 add_match_def 'mac', qw(mac-source!);
 273 add_match_def 'mark', qw(mark);
 274 add_match_def 'multiport', qw(source-ports!&multiport_params),
 275   qw(destination-ports!&multiport_params ports!&multiport_params);
 276 add_match_def 'nth', qw(every counter start packet);
 277 add_match_def 'owner', qw(uid-owner gid-owner pid-owner sid-owner cmd-owner);
 278 add_match_def 'physdev', qw(physdev-in! physdev-out!),
 279   qw(!physdev-is-in*0 !physdev-is-out*0 !physdev-is-bridged*0);
 280 add_match_def 'pkttype', qw(pkt-type),
 281 add_match_def 'policy',
 282   qw(dir pol strict*0 reqid spi proto mode tunnel-src tunnel-dst next*0);
 283 add_match_def 'psd', qw(psd-weight-threshold psd-delay-threshold),
 284   qw(psd-lo-ports-weight psd-hi-ports-weight);
 285 add_match_def 'quota', qw(quota=s);
 286 add_match_def 'random', qw(average);
 287 add_match_def 'realm', qw(realm!);
 288 add_match_def 'recent', qw(name=s !set*0 !rcheck*0 !update*0 !seconds !hitcount rttl*0);
 289 add_match_def 'rt', qw(rt-type! rt-segsleft! rt-len! rt-0-res*0 rt-0-addrs=c rt-0-not-strict*0);
 290 add_match_def 'set', qw(set=sc);
 291 add_match_def 'state', qw(state=c);
 292 add_match_def 'tcpmss', qw(!mss);
 293 add_match_def 'time', qw(timestart=s timestop=s days=c datestart=s datestop=s);
 294 add_match_def 'tos', qw(!tos);
 295 add_match_def 'ttl', qw(ttl-eq ttl-lt=s ttl-gt=s);
 296
 297 add_target_def 'BALANCE', qw(to-destination to:=to-destination);
 298 add_target_def 'CLASSIFY', qw(set-class);
 299 add_target_def 'CONNMARK', qw(set-mark save-mark*0 restore-mark*0 mask);
 300 add_target_def 'DNAT', qw(to-destination to:=to-destination);
 301 add_target_def 'DSCP', qw(set-dscp set-dscp-class);
 302 add_target_def 'ECN', qw(ecn-tcp-remove*0);
 303 add_target_def 'HL', qw(hl-set hl-dec hl-inc);
 304 add_target_def 'LOG', qw(log-level log-prefix),
 305   qw(log-tcp-sequence*0 log-tcp-options*0 log-ip-options*0 log-uid*0);
 306 add_target_def 'MARK', qw(set-mark);
 307 add_target_def 'MASQUERADE', qw(to-ports);
 308 add_target_def 'MIRROR';
 309 add_target_def 'NETMAP', qw(to);
 310 add_target_def 'NFQUEUE', qw(queue-num);
 311 add_target_def 'NOTRACK';
 312 add_target_def 'REDIRECT', qw(to-ports);
 313 add_target_def 'REJECT', qw(reject-with);
 314 add_target_def 'ROUTE', qw(oif iif gw continue*0 tee*0);
 315 add_target_def 'SAME', qw(to nodst*0);
 316 add_target_def 'SET', qw(add-set=sc del-set=sc);
 317 add_target_def 'SNAT', qw(to-source=a to:=to-source);
 318 add_target_def 'TARPIT';
 319 add_target_def 'TCPMSS', qw(set-mss clamp-mss-to-pmtu*0);
 320 add_target_def 'TOS', qw(set-tos);
 321 add_target_def 'TRACE';
 322 add_target_def 'TTL', qw(ttl-set ttl-dec ttl-inc);
 323 add_target_def 'ULOG', qw(ulog-nlgroup ulog-prefix ulog-cprange ulog-qthreshold);
 324
 325 add_match_def_x 'arp', '', qw(source-mac! destination-mac!),
 326   qw(h-length=s opcode=s h-type=s proto-type=s),
 327   qw(mangle-ip-s=s mangle-ip-d=s mangle-mac-s=s mangle-mac-d=s mangle-target=s);
 328 add_match_def_x 'eb', '', qw(logical-in! logical-out!),
 329   # 802.3
 330   qw(802_3-sap! 802_3-type!),
 331   # arp
 332   qw(arp-opcode! arp-htype!=ss arp-ptype!=ss),
 333   qw(arp-ip-src! arp-ip-dst! arp-mac-src! arp-mac-dst!),
 334   # ip
 335   qw(ip-source! ip-destination! ip-tos! ip-protocol! ip-sport! ip-dport!),
 336   # mark_m
 337   qw(mark!),
 338   # pkttype
 339   qw(pkttype-type!),
 340   # stp
 341   qw(stp-type! stp-flags! stp-root-prio! stp-root-addr! stp-root-cost!),
 342   qw(stp-sender-prio! stp-sender-addr! stp-port! stp-msg-age! stp-max-age!),
 343   qw(stp-hello-time! stp-forward-delay!),
 344   # vlan
 345   qw(vlan-id! vlan-prio! vlan-encap!),
 346   # log
 347   qw(log*0 log-level=s log-prefix=s log-ip*0 log-arp*0);
 348
 349 add_target_def_x 'eb', 'arpreply', qw(arpreply-mac arpreply-target);
 350 add_target_def_x 'eb', 'dnat', qw(to-destination dnat-target);
 351 add_target_def_x 'eb', 'mark', qw(set-mark mark-target);
 352 add_target_def_x 'eb', 'redirect', qw(redirect-target);
 353 add_target_def_x 'eb', 'snat', qw(to-source snat-target);
 354
 355 # parameter parser for ipt_multiport
 356 sub multiport_params {
 357     my $fw = shift;
 358
 359     # multiport only allows 15 ports at a time. For this
 360     # reason, we do a little magic here: split the ports
 361     # into portions of 15, and handle these portions as
 362     # array elements
 363
 364     my $proto = find_option($fw, 'proto');
 365     error('To use multiport, you have to specify "proto tcp" or "proto udp" first')
 366       unless defined $proto and grep { /^(?:tcp|udp)$/ } to_array($proto);
 367
 368     my $value = getvalues(undef, undef,
 369                           allow_negation => 1,
 370                           allow_array_negation => 1);
 371     if (ref $value and ref $value eq 'ARRAY') {
 372         my @value = @$value;
 373         my @params;
 374
 375         while (@value) {
 376             push @params, join(',', splice(@value, 0, 15));
 377         }
 378
 379         return @params == 1
 380           ? $params[0]
 381             : \@params;
 382     } else {
 383         return join_value(',', $value);
 384     }
 385 }
 386
 387 # initialize stack: command line definitions
 388 unshift @stack, {};
 389
 390 # Get command line stuff
 391 if ($has_getopt) {
 392     my ($opt_noexec, $opt_flush, $opt_lines, $opt_interactive,
 393         $opt_verbose, $opt_debug,
 394         $opt_location, $opt_clearall, $opt_flushall,
 395         $opt_createchains, $opt_flushchains, $opt_help, $opt_automod,
 396         $opt_version, $opt_use, $opt_test, $opt_fast, $opt_shell,
 397         $opt_domain);
 398
 399     Getopt::Long::Configure('bundling', 'auto_help', 'no_ignore_case',
 400                             'no_auto_abbrev');
 401
 402     sub opt_def {
 403         my ($opt, $value) = @_;
 404         die 'Invalid --def specification'
 405           unless $value =~ /^\$?(\w+)=(.*)$/s;
 406         my ($name, $unparsed_value) = ($1, $2);
 407         my @tokens = tokenize_string($unparsed_value);
 408         my $value = getvalues(\&next_array_token, \@tokens);
 409         die 'Extra tokens after --def'
 410           if @tokens;
 411         $stack[0]{vars}{$name} = $value;
 412     }
 413
 414     GetOptions('noexec|n' => \$opt_noexec,
 415                'flush|F' => \$opt_flush,
 416                'lines|l' => \$opt_lines,
 417                'interactive|i' => \$opt_interactive,
 418                'verbose|v' => \$opt_verbose,
 419                'debug|d' => \$opt_debug,
 420                'location=s' => \$opt_location,
 421                clearall => \$opt_clearall,
 422                flushall => \$opt_flushall,
 423                createchains => \$opt_createchains,
 424                flushchains => \$opt_flushchains,
 425                'help|h' => \$opt_help,
 426                automod => \$opt_automod,
 427                'version|V' => \$opt_version,
 428                'use=s' => \$opt_use,
 429                test => \$opt_test,
 430                remote => \$opt_test,
 431                fast => \$opt_fast,
 432                shell => \$opt_shell,
 433                'domain=s' => \$opt_domain,
 434                'def=s' => \&opt_def,
 435               );
 436
 437     if (defined $opt_help) {
 438         require Pod::Usage;
 439         Pod::Usage::pod2usage(-exitstatus => 0);
 440     }
 441
 442     if (defined $opt_version) {
 443         printversion();
 444         exit 0;
 445     };
 446
 447     $option{'noexec'} = (defined $opt_noexec);
 448     $option{flush} = defined $opt_flush;
 449     $option{'lines'} = (defined $opt_lines);
 450     $option{interactive} = (defined $opt_interactive);
 451     $option{'automod'} = (defined $opt_automod);
 452     $option{test} = (defined $opt_test);
 453
 454     if ($option{test}) {
 455         $option{noexec} = 1;
 456         $option{lines} = 1;
 457     }
 458
 459     delete $option{interactive} if $option{noexec};
 460
 461     mydie('ferm interactive mode not possible: /dev/stdin is not a tty')
 462       if $option{interactive} and not -t STDIN;
 463     mydie('ferm interactive mode not possible: /dev/stderr is not a tty')
 464       if $option{interactive} and not -t STDERR;
 465
 466     $option{fast} = 1 if defined $opt_fast;
 467
 468     if (defined $opt_shell) {
 469         $option{$_} = 1 foreach qw(shell fast lines);
 470     }
 471
 472     $option{domain} = $opt_domain if defined $opt_domain;
 473
 474     print STDERR "Warning: --automod is deprecated\n"
 475       if defined $opt_automod;
 476
 477     print STDERR "Warning: ignoring the obsolete --use/-s option\n"
 478       if defined $opt_use;
 479
 480     print STDERR "Warning: ignoring the obsolete --debug option\n"
 481       if defined $opt_debug;
 482     print STDERR "Warning: ignoring the obsolete --verbose option\n"
 483       if defined $opt_verbose;
 484     print STDERR "Warning: ignoring the obsolete --clearall option\n"
 485       if defined $opt_clearall;
 486     print STDERR "Warning: ignoring the obsolete --flushall option\n"
 487       if defined $opt_flushall;
 488     print STDERR "Warning: ignoring the obsolete --flushchains option\n"
 489       if defined $opt_flushchains;
 490     print STDERR "Warning: ignoring the obsolete --createchains option\n"
 491       if defined $opt_createchains;
 492     print STDERR "Warning: ignoring the obsolete --location option\n"
 493       if defined $opt_location;
 494 } else {
 495     # tiny getopt emulation for microperl
 496     my $filename;
 497     foreach (@ARGV) {
 498         if ($_ eq '--noexec' or $_ eq '-n') {
 499             $option{noexec} = 1;
 500         } elsif ($_ eq '--lines' or $_ eq '-l') {
 501             $option{lines} = 1;
 502         } elsif ($_ eq '--fast') {
 503             $option{fast} = 1;
 504         } elsif ($_ eq '--test') {
 505             $option{noexec} = 1;
 506             $option{lines} = 1;
 507         } elsif ($_ eq '--shell') {
 508             $option{$_} = 1 foreach qw(shell fast lines);
 509         } elsif (/^-/) {
 510             printf STDERR "Usage: ferm [--noexec] [--lines] [--fast] [--shell] FILENAME\n";
 511             exit 1;
 512         } else {
 513             $filename = $_;
 514         }
 515     }
 516     undef @ARGV;
 517     push @ARGV, $filename;
 518 }
 519
 520 unless (@ARGV == 1) {
 521     require Pod::Usage;
 522     Pod::Usage::pod2usage(-exitstatus => 1);
 523 }
 524
 525 if ($has_strict) {
 526     open LINES, ">&STDOUT" if $option{lines};
 527     open STDOUT, ">&STDERR" if $option{shell};
 528 } else {
 529     # microperl can't redirect file handles
 530     *LINES = *STDOUT;
 531
 532     if ($option{fast} and not $option{noexec}) {
 533         print STDERR "Sorry, ferm on microperl does not allow --fast without --noexec\n";
 534         exit 1
 535     }
 536 }
 537
 538 unshift @stack, {};
 539 open_script($ARGV[0]);
 540
 541 # parse all input recursively
 542 enter(0);
 543 die unless @stack == 2;
 544
 545 # check consistency
 546 check();
 547
 548 # execute all generated rules
 549 my $status;
 550
 551 foreach my $cmd (@pre_hooks) {
 552     print LINES "$cmd\n" if $option{lines};
 553     system($cmd) unless $option{noexec};
 554 }
 555
 556 while (my ($domain, $rules) = each %rules) {
 557     my $s = $option{fast} &&
 558       defined $domains{$domain}{tools}{'tables-restore'}
 559       ? execute_fast($domain, rules_to_save($domain, $rules))
 560         : execute_slow($domain, $rules);
 561     $status = $s if defined $s;
 562 }
 563
 564 foreach my $cmd (@post_hooks) {
 565     print "$cmd\n" if $option{lines};
 566     system($cmd) unless $option{noexec};
 567 }
 568
 569 if (defined $status) {
 570     rollback();
 571     exit $status;
 572 }
 573
 574 # ask user, and rollback if there is no confirmation
 575
 576 confirm_rules() or rollback() if $option{interactive};
 577
 578 exit 0;
 579
 580 # end of program execution!
 581
 582
 583 # funcs
 584
 585 sub printversion {
 586     print "ferm $VERSION\n";
 587     print "Copyright (C) 2001-2007 Auke Kok, Max Kellermann\n";
 588     print "This program is free software released under GPLv2.\n";
 589     print "See the included COPYING file for license details.\n";
 590 }
 591
 592
 593 sub mydie {
 594     print STDERR @_;
 595     print STDERR "\n";
 596     exit 1;
 597 }
 598
 599
 600 sub error {
 601     # returns a nice formatted error message, showing the
 602     # location of the error.
 603     my $tabs = 0;
 604     my @lines;
 605     my $l = 0;
 606     my @words = @{$script->{past_tokens}};
 607
 608     for my $w ( 0 .. $#words ) {
 609         if ($words[$w] eq "\x29")
 610             { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
 611         if ($words[$w] eq "\x28")
 612             { $l++ ; $lines[$l] = "    " x $tabs++ ;};
 613         if ($words[$w] eq "\x7d")
 614             { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
 615         if ($words[$w] eq "\x7b")
 616             { $l++ ; $lines[$l] = "    " x $tabs++ ;};
 617         if ( $l > $#lines ) { $lines[$l] = "" };
 618         $lines[$l] .= $words[$w] . " ";
 619         if ($words[$w] eq "\x28")
 620             { $l++ ; $lines[$l] = "    " x $tabs ;};
 621         if (($words[$w] eq "\x29") && ($words[$w+1] ne "\x7b"))
 622             { $l++ ; $lines[$l] = "    " x $tabs ;};
 623         if ($words[$w] eq "\x7b")
 624             { $l++ ; $lines[$l] = "    " x $tabs ;};
 625         if (($words[$w] eq "\x7d") && ($words[$w+1] ne "\x7d"))
 626             { $l++ ; $lines[$l] = "    " x $tabs ;};
 627         if (($words[$w] eq "\x3b") && ($words[$w+1] ne "\x7d"))
 628             { $l++ ; $lines[$l] = "    " x $tabs ;}
 629         if ($words[$w-1] eq "option")
 630             { $l++ ; $lines[$l] = "    " x $tabs ;}
 631     }
 632     my $start = $#lines - 4;
 633     if ($start < 0) { $start = 0 } ;
 634     print STDERR "Error in $script->{filename} line $script->{line}:\n";
 635     for $l ( $start .. $#lines)
 636         { print STDERR $lines[$l]; if ($l != $#lines ) {print STDERR "\n"} ; };
 637     print STDERR "<--\n";
 638     mydie(@_);
 639 }
 640
 641 # print a warning message about code from an input file
 642 sub warning {
 643     print STDERR "Warning in $script->{filename} line $script->{line}: "
 644       . (shift) . "\n";
 645 }
 646
 647 sub initialize_domain {
 648     my $domain = shift;
 649
 650     return if exists $domains{$domain}{initialized};
 651
 652     die "Invalid domain '$domain'\n" unless $domain =~ /^(?:ip6?|arp|eb)$/;
 653
 654     my @tools = qw(tables);
 655     push @tools, qw(tables-save tables-restore)
 656       if $domain =~ /^ip6?$/;
 657
 658     if ($option{test}) {
 659         $domains{$domain}{tools}{$_} = "${domain}$_" foreach @tools;
 660         $domains{$domain}{initialized} = 1;
 661         return;
 662     }
 663
 664     # determine the location of this domain's tools
 665     foreach my $tool (@tools) {
 666         my $path = "/usr/sbin/${domain}${tool}";
 667         $path = "/sbin/${domain}${tool}" unless -x $path;
 668         die "$path not found\n" unless -x $path;
 669         $domains{$domain}{tools}{$tool} = $path;
 670     }
 671
 672     # make tables-save tell us about the state of this domain
 673     # (which tables and chains do exist?), also remember the old
 674     # save data which may be used later by the rollback function
 675     local *SAVE;
 676     if (exists $domains{$domain}{tools}{'tables-save'} and
 677         open(SAVE, "$domains{$domain}{tools}{'tables-save'}|")) {
 678         my $save = '';
 679
 680         my $table_info;
 681         while (<SAVE>) {
 682             $save .= $_;
 683
 684             if (/^\*(\w+)/) {
 685                 my $table = $1;
 686                 $table_info = $domains{$domain}{tables}{$table} ||= {};
 687             } elsif (defined $table_info and /^:(\w+)\s+(\S+)/
 688                      and $2 ne '-') {
 689                 $table_info->{chains}{$1}{builtin} = 1;
 690                 $table_info->{has_builtin} = 1;
 691             }
 692         }
 693
 694         # for rollback
 695         $domains{$domain}{previous} = $save;
 696     }
 697
 698     $domains{$domain}{initialized} = 1;
 699 }
 700
 701 # split the an input string into words and delete comments
 702 sub tokenize_string($) {
 703     my $string = shift;
 704
 705     my @ret;
 706
 707     foreach my $word ($string =~ m/(".*?"|'.*?'|`.*?`|[!,=&\$\%\(\){};]|[-+\w\/\.:]+|@\w+|#)/g) {
 708         last if $word eq '#';
 709         push @ret, $word;
 710     }
 711
 712     return @ret;
 713 }
 714
 715 # shift an array; helper function to be passed to &getvar / &getvalues
 716 sub next_array_token {
 717     my $array = shift;
 718     shift @$array;
 719 }
 720
 721 # read some more tokens from the input file into a buffer
 722 sub prepare_tokens() {
 723     return
 724       unless defined $script;
 725
 726     my $tokens = $script->{tokens};
 727     die unless ref $tokens eq 'ARRAY';
 728
 729     while (@$tokens == 0) {
 730         my $handle = $script->{handle};
 731         my $line = <$handle>;
 732         return unless defined $line;
 733
 734         $script->{line} ++;
 735
 736         my @line = tokenize_string($line);
 737
 738         # the next parser stage eats this
 739         push @$tokens, @line;
 740     }
 741
 742     return 1;
 743 }
 744
 745 # open a ferm sub script
 746 sub open_script($) {
 747     my $filename = shift;
 748
 749     for (my $s = $script; defined $s; $s = $s->{parent}) {
 750         mydie("Circular reference in $script->{filename} line $script->{line}: $filename")
 751           if $s->{filename} eq $filename;
 752     }
 753
 754     local *FILE;
 755     open FILE, "<$filename"
 756       or mydie("Failed to open $filename: $!");
 757     my $handle = *FILE;
 758
 759     $script = { filename => $filename,
 760                 handle => $handle,
 761                 line => 0,
 762                 past_tokens => [],
 763                 tokens => [],
 764                 parent => $script,
 765               };
 766
 767     return $script;
 768 }
 769
 770 # collect script filenames which are being included
 771 sub collect_filenames(@) {
 772     my @ret;
 773
 774     # determine the current script's parent directory for relative
 775     # file names
 776     die unless defined $script;
 777     my $parent_dir = $script->{filename} =~ m,^(.*/),
 778       ? $1 : './';
 779
 780     foreach my $pathname (@_) {
 781         # non-absolute file names are relative to the parent script's
 782         # file name
 783         $pathname = $parent_dir . $pathname
 784           unless $pathname =~ m,^/,;
 785
 786         if ($pathname =~ m,/$,) {
 787             # include all regular files in a directory
 788
 789             error("'$pathname' is not a directory")
 790               unless -d $pathname;
 791
 792             local *DIR;
 793             opendir DIR, $pathname
 794               or error("Failed to open directory '$pathname': $!");
 795             my @names = readdir DIR;
 796             closedir DIR;
 797
 798             # sort those names for a well-defined order
 799             foreach my $name (sort { $a cmp $b } @names) {
 800                 # don't include hidden and backup files
 801                 next if /^\.|~$/;
 802
 803                 my $filename = $pathname . $name;
 804                 push @ret, $filename
 805                   if -f $filename;
 806             }
 807         } elsif ($pathname =~ m,\|$,) {
 808             # run a program and use its output
 809             push @ret, $pathname;
 810         } elsif ($pathname =~ m,^\|,) {
 811             error('This kind of pipe is not allowed');
 812         } else {
 813             # include a regular file
 814
 815             error("'$pathname' is a directory; maybe use trailing '/' to include a directory?")
 816               if -d $pathname;
 817             error("'$pathname' is not a file")
 818               unless -f $pathname;
 819
 820             push @ret, $pathname;
 821         }
 822     }
 823
 824     return @ret;
 825 }
 826
 827 # peek a token from the queue, but don't remove it
 828 sub peek_token() {
 829     # get a token
 830     prepare_tokens();
 831
 832     return
 833       unless defined $script;
 834
 835     my $tokens = $script->{tokens};
 836     die unless ref $tokens eq 'ARRAY';
 837
 838     return
 839       unless @$tokens;
 840
 841     return $tokens->[0];
 842 }
 843
 844 # get a token from the queue
 845 sub next_token() {
 846     prepare_tokens();
 847
 848     return
 849       unless defined $script;
 850
 851     my $tokens = $script->{tokens};
 852     die unless ref $tokens eq 'ARRAY';
 853
 854     return
 855       unless @$tokens;
 856
 857     my $token = shift @$tokens;
 858
 859     # update $script->{past_tokens}
 860     my $past_tokens = $script->{past_tokens};
 861     die unless ref $past_tokens eq 'ARRAY';
 862
 863     if (@$past_tokens and
 864         ($past_tokens->[@$past_tokens - 1] eq '}' or
 865          $past_tokens->[@$past_tokens - 1] eq ';')) {
 866         # now this is tricky: $script->{past_tokens} is used in error
 867         # messages. in the following lines, we filter out everything
 868         # which has become irrelevant for error messages,
 869         # i.e. previous (completed) commands
 870
 871         my $t = pop @$past_tokens;
 872
 873         # track the current level - a '}' means one level up (we are
 874         # going backwards)
 875         my $level = $t eq '}' ? 1 : 0;
 876
 877         while (@$past_tokens and $level >= 0) {
 878             $t = pop @$past_tokens;
 879
 880             if ($level == 0 and ($t eq '}' or $t eq ';')) {
 881                 # don't delete another command
 882                 push @$past_tokens, $t;
 883                 last;
 884             } elsif ($t eq '}') {
 885                 # one level up
 886                 $level++;
 887             } elsif ($t eq '{') {
 888                 # one level down. stop here if we're already at level
 889                 # zero
 890                 if ($level == 0) {
 891                     push @$past_tokens, $t;
 892                     last;
 893                 }
 894
 895                 $level--;
 896             }
 897         }
 898     }
 899
 900     push @$past_tokens, $token;
 901
 902     # return
 903     return $token;
 904 }
 905
 906 # require that another token exists, and that it's not a "special"
 907 # token, e.g. ";" and "{"
 908 sub require_next_token {
 909     my $code = shift || \&next_token;
 910
 911     my $token = &$code(@_);
 912
 913     error('unexpected end of file')
 914       unless defined $token;
 915
 916     error("'$token' not allowed here")
 917       if $token =~ /^[;{}]$/;
 918
 919     return $token;
 920 }
 921
 922 # return the value of a variable
 923 sub variable_value($) {
 924     my $name = shift;
 925
 926     foreach (@stack) {
 927         return $_->{vars}{$name}
 928           if exists $_->{vars}{$name};
 929     }
 930
 931     return $stack[0]{auto}{$name}
 932       if exists $stack[0]{auto}{$name};
 933
 934     return;
 935 }
 936
 937 # determine the value of a variable, die if the value is an array
 938 sub string_variable_value($) {
 939     my $name = shift;
 940     my $value = variable_value($name);
 941
 942     error("variable '$name' must be a string, is an array")
 943       if ref $value;
 944
 945     return $value;
 946 }
 947
 948 # similar to the built-in "join" function, but also handle negated
 949 # values in a special way
 950 sub join_value($$) {
 951     my ($expr, $value) = @_;
 952
 953     unless (ref $value) {
 954         return $value;
 955     } elsif (ref $value eq 'ARRAY') {
 956         return join($expr, @$value);
 957     } elsif (ref $value eq 'negated') {
 958         # bless'negated' is a special marker for negated values
 959         $value = join_value($expr, $value->[0]);
 960         return bless [ $value ], 'negated';
 961     } else {
 962         die;
 963     }
 964 }
 965
 966 # returns the next parameter, which may either be a scalar or an array
 967 sub getvalues {
 968     my ($code, $param) = (shift, shift);
 969     my %options = @_;
 970
 971     my $token = require_next_token($code, $param);
 972
 973     if ($token eq '(') {
 974         # read an array until ")"
 975         my @wordlist;
 976
 977         for (;;) {
 978             $token = getvalues($code, $param,
 979                                parenthesis_allowed => 1,
 980                                comma_allowed => 1);
 981
 982             unless (ref $token) {
 983                 last if $token eq ')';
 984
 985                 if ($token eq ',') {
 986                     warning('Comma within arrays is deprecated, please use only a space');
 987                     next;
 988                 }
 989
 990                 push @wordlist, $token;
 991             } elsif (ref $token eq 'ARRAY') {
 992                 push @wordlist, @$token;
 993             } else {
 994                 error('unknown toke type');
 995             }
 996         }
 997
 998         error('empty array not allowed here')
 999           unless @wordlist or not $options{non_empty};
1000
1001         return @wordlist == 1
1002           ? $wordlist[0]
1003             : \@wordlist;
1004     } elsif ($token =~ /^\`(.*)\`$/s) {
1005         # execute a shell command, insert output
1006         my $command = $1;
1007         my $output = `$command`;
1008         unless ($? == 0) {
1009             if ($? == -1) {
1010                 error("failed to execute: $!");
1011             } elsif ($? & 0x7f) {
1012                 error("child died with signal " . ($? & 0x7f));
1013             } elsif ($? >> 8) {
1014                 error("child exited with status " . ($? >> 8));
1015             }
1016         }
1017
1018         # remove comments
1019         $output =~ s/#.*//mg;
1020
1021         # tokenize
1022         my @tokens = grep { length } split /\s+/s, $output;
1023
1024         my @values;
1025         while (@tokens) {
1026             my $value = getvalues(\&next_array_token, \@tokens);
1027             push @values, to_array($value);
1028         }
1029
1030         # and recurse
1031         return @values == 1
1032           ? $values[0]
1033             : \@values;
1034     } elsif ($token =~ /^\'(.*)\'$/s) {
1035         # single quotes: a string
1036         return $1;
1037     } elsif ($token =~ /^\"(.*)\"$/s) {
1038         # double quotes: a string with escapes
1039         $token = $1;
1040         $token =~ s,\$(\w+),string_variable_value($1),eg;
1041         return $token;
1042     } elsif ($token eq '!') {
1043         error('negation is not allowed here')
1044           unless $options{allow_negation};
1045
1046         $token = getvalues($code, $param);
1047
1048         error('it is not possible to negate an array')
1049           if ref $token and not $options{allow_array_negation};
1050
1051         return bless [ $token ], 'negated';
1052     } elsif ($token eq ',') {
1053         return $token
1054           if $options{comma_allowed};
1055
1056         error('comma is not allowed here');
1057     } elsif ($token eq '=') {
1058         error('equals operator ("=") is not allowed here');
1059     } elsif ($token eq '$') {
1060         my $name = require_next_token($code, $param);
1061         error('variable name expected - if you want to concatenate strings, try using double quotes')
1062           unless $name =~ /^\w+$/;
1063
1064         my $value = variable_value($name);
1065
1066         error("no such variable: \$$name")
1067           unless defined $value;
1068
1069         return $value;
1070     } elsif ($token eq '&') {
1071         error("function calls are not allowed as keyword parameter");
1072     } elsif ($token eq ')' and not $options{parenthesis_allowed}) {
1073         error('Syntax error');
1074     } elsif ($token =~ /^@/) {
1075         if ($token eq '@resolve') {
1076             my @params = get_function_params();
1077             error('Usage: @resolve((hostname ...))')
1078               unless @params == 1;
1079             eval { require Net::DNS; };
1080             error('For the @resolve() function, you need the Perl library Net::DNS')
1081               if $@;
1082             my $type = 'A';
1083             my $resolver = new Net::DNS::Resolver;
1084             my @result;
1085             foreach my $hostname (to_array($params[0])) {
1086                 my $query = $resolver->search($hostname, $type);
1087                 error("DNS query for '$hostname' failed: " . $resolver->errorstring)
1088                   unless $query;
1089                 foreach my $rr ($query->answer) {
1090                     next unless $rr->type eq $type;
1091                     push @result, $rr->address;
1092                 }
1093             }
1094             return \@result;
1095         } else {
1096             error("unknown ferm built-in function");
1097         }
1098     } else {
1099         return $token;
1100     }
1101 }
1102
1103 # returns the next parameter, but only allow a scalar
1104 sub getvar {
1105     my $token = getvalues(@_);
1106
1107     error('array not allowed here')
1108       if ref $token and ref $token eq 'ARRAY';
1109
1110     return $token;
1111 }
1112
1113 sub get_function_params(%) {
1114     my $token = next_token();
1115     error('function name must be followed by "()"')
1116       unless defined $token and $token eq '(';
1117
1118     $token = peek_token();
1119     if ($token eq ')') {
1120         require_next_token;
1121         return;
1122     }
1123
1124     my @params;
1125
1126     while (1) {
1127         if (@params > 0) {
1128             $token = require_next_token();
1129             last
1130               if $token eq ')';
1131
1132             error('"," expected')
1133               unless $token eq ',';
1134         }
1135
1136         push @params, getvalues(undef, undef, @_);
1137     }
1138
1139     return @params;
1140 }
1141
1142 # collect all tokens in a flat array reference until the end of the
1143 # command is reached
1144 sub collect_tokens() {
1145     my @level;
1146     my @tokens;
1147
1148     while (1) {
1149         my $keyword = next_token();
1150         error('unexpected end of file within function/variable declaration')
1151           unless defined $keyword;
1152
1153         if ($keyword =~ /^[\{\(]$/) {
1154             push @level, $keyword;
1155         } elsif ($keyword =~ /^[\}\)]$/) {
1156             my $expected = $keyword;
1157             $expected =~ tr/\}\)/\{\(/;
1158             my $opener = pop @level;
1159             error("unmatched '$keyword'")
1160               unless defined $opener and $opener eq $expected;
1161         } elsif ($keyword eq ';' and @level == 0) {
1162             last;
1163         }
1164
1165         push @tokens, $keyword;
1166
1167         last
1168           if $keyword eq '}' and @level == 0;
1169     }
1170
1171     return \@tokens;
1172 }
1173
1174
1175 # returns the specified value as an array. dereference arrayrefs
1176 sub to_array($) {
1177     my $value = shift;
1178     die unless wantarray;
1179     die if @_;
1180     unless (ref $value) {
1181         return $value;
1182     } elsif (ref $value eq 'ARRAY') {
1183         return @$value;
1184     } else {
1185         die;
1186     }
1187 }
1188
1189 # evaluate the specified value as bool
1190 sub eval_bool($) {
1191     my $value = shift;
1192     die if wantarray;
1193     die if @_;
1194     unless (ref $value) {
1195         return $value;
1196     } elsif (ref $value eq 'ARRAY') {
1197         return @$value > 0;
1198     } else {
1199         die;
1200     }
1201 }
1202
1203 sub is_netfilter_core_target($) {
1204     my $target = shift;
1205     die unless defined $target and length $target;
1206
1207     return $target =~ /^(?:ACCEPT|DROP|RETURN|QUEUE)$/;
1208 }
1209
1210 sub is_netfilter_module_target($$) {
1211     my ($domain_family, $target) = @_;
1212     die unless defined $target and length $target;
1213
1214     return defined $domain_family &&
1215       exists $target_defs{$domain_family} &&
1216         exists $target_defs{$domain_family}{$target};
1217 }
1218
1219 sub is_netfilter_builtin_chain($$) {
1220     my ($table, $chain) = @_;
1221
1222     return grep { $_ eq $chain }
1223       qw(PREROUTING INPUT FORWARD OUTPUT POSTROUTING);
1224 }
1225
1226 # escape the string in a way safe for the shell
1227 sub shell_escape($) {
1228     my $token = shift;
1229
1230     if ($option{fast}) {
1231         # iptables-save/iptables-restore are quite buggy concerning
1232         # escaping and special characters... we're trying our best
1233         # here
1234
1235         $token =~ s,",',g;
1236         $token = '"' . $token . '"'
1237           if $token =~ /[\s\'\\;]/s;
1238     } else {
1239         return $token
1240           if $token =~ /^\`.*\`$/;
1241         $token =~ s/'/\\'/g;
1242         $token = '\'' . $token . '\''
1243           if $token =~ /[\s\"\\;<>|]/s;
1244     }
1245
1246     return $token;
1247 }
1248
1249 # append parameters to a shell command line, with the correct escape
1250 # sequences
1251 sub shell_append($@) {
1252     my $ref = shift;
1253
1254     foreach (@_) {
1255         $$ref .= ' ' . shell_escape($_);
1256     }
1257 }
1258
1259 # append an option to the shell command line, using information from
1260 # the module definition (see %match_defs etc.)
1261 sub shell_append_option($$$$) {
1262     my ($ref, $def, $keyword, $value) = @_;
1263
1264     my @negated;
1265     if (ref $value and ref $value eq 'negated') {
1266         $value = $value->[0];
1267
1268         if (exists $def->{pre_negation}) {
1269             shell_append($ref, '!');
1270         } else {
1271             push @negated, '!';
1272         }
1273     }
1274
1275     unless (defined $value) {
1276         shell_append($ref, "--$keyword");
1277     } elsif (ref $value and ref $value eq 'params') {
1278         shell_append($ref, "--$keyword", @negated, @$value);
1279     } elsif (ref $value and ref $value eq 'ARRAY') {
1280         foreach (@$value) {
1281             shell_append($ref, "--$keyword", $_);
1282         }
1283     } else {
1284         shell_append($ref, "--$keyword", @negated, $value);
1285     }
1286 }
1287
1288 # dereference a bless'negated'
1289 sub extract_negation($) {
1290     local $_ = shift;
1291     ref && ref eq 'negated'
1292       ? ( '!', $_->[0] )
1293         : $_;
1294 }
1295
1296 # reset a netfilter domain: set all policies to ACCEPT, clear all
1297 # rules, delete custom chains
1298 sub reset_domain($) {
1299     my $domain = shift;
1300     my $domain_info = $domains{$domain};
1301
1302     my $path = $domain_info->{tools}{tables};
1303
1304     my @rules;
1305     while (my ($table, $table_info) = each %{$domain_info->{tables}}) {
1306         while (my ($chain, $chain_info) = each %{$table_info->{chains}}) {
1307             next unless $chain_info->{builtin} or
1308               (not $table_info->{has_builtin} and
1309                is_netfilter_builtin_chain($table, $chain));
1310             push @rules, "$path -t $table -P $chain ACCEPT\n";
1311         }
1312
1313         push @rules,
1314           "$path -t $table -F\n", "$path -t $table -X\n";
1315     }
1316
1317     return @rules;
1318 }
1319
1320 # convert an internal rule structure into an iptables call
1321 sub tables($) {
1322     my $rule = shift;
1323     my %rule = %$rule;
1324
1325     my $domain = $rule{domain};
1326     my $domain_info = $domains{$domain};
1327     my $domain_family = $rule{domain_family};
1328
1329     my $table = $rule{table};
1330     my $table_info = $domain_info->{tables}{$table} ||= {};
1331
1332     my $rules = $rules{$domain} ||= [];
1333
1334     my $chain = $rule{chain};
1335     my $chain_info = $table_info->{chains}{$chain} ||= {};
1336
1337     return if $option{flush};
1338
1339     my $action = $rule{action};
1340
1341     my $rr = shell_escape($domain_info->{tools}{tables});
1342     shell_append(\$rr, '-t', $table);
1343
1344     # should we set a policy?
1345     if (exists $chain_info->{set_policy}) {
1346         my $policy = $chain_info->{policy};
1347
1348         push @$rules, "$rr -P $chain $policy\n";
1349
1350         delete $chain_info->{set_policy};
1351     }
1352
1353     # mark this chain as "non-empty" because we will add stuff to
1354     # it now; this flag is later used to check if a custom chain
1355     # referenced by "goto" was actually defined
1356     $chain_info->{non_empty} = 1;
1357
1358     # check if the chain is already defined
1359     unless (exists $chain_info->{was_created} or
1360             is_netfilter_builtin_chain($table, $chain)) {
1361         push @$rules, "$rr -N $chain\n";
1362         $chain_info->{was_created} = 1;
1363     }
1364
1365     # check for unknown jump target
1366     if (defined $action and
1367         $action ne 'NOP' and
1368         not is_netfilter_core_target($action) and
1369         not is_netfilter_module_target($domain_family, $action) and
1370         not exists $table_info->{chains}{$action}{was_created}) {
1371         push @$rules, "$rr -N $action\n";
1372         $table_info->{chains}{$action}{was_created} = 1;
1373     }
1374
1375     # return if this is a policy-only rule
1376     return
1377       unless $rule{has_rule};
1378
1379     shell_append(\$rr, '-A', $chain);
1380
1381     # modules; copy the hash because we might add automatic protocol
1382     # modules later
1383     my %modules;
1384     if (exists $rule{modules}) {
1385         %modules = %{$rule{modules}};
1386         shell_append(\$rr, '-m', $_)
1387           foreach keys %modules;
1388     }
1389
1390     # general iptables options
1391     shell_append(\$rr, '-s', extract_negation $rule{saddr})
1392       if defined $rule{saddr};
1393     shell_append(\$rr, '-d', extract_negation $rule{daddr})
1394       if defined $rule{daddr};
1395
1396     shell_append(\$rr, '-i', extract_negation $rule{interface})
1397       if defined $rule{'interface'};
1398     shell_append(\$rr, '-o', extract_negation $rule{outerface})
1399       if defined $rule{'outerface'};
1400
1401     shell_append(\$rr, '-p', extract_negation $rule{proto})
1402       if defined $rule{proto};
1403
1404     if (defined $rule{'fragment'}) {
1405         shell_append(\$rr, '!')
1406           unless $rule{fragment} eq 'set';
1407
1408         shell_append(\$rr, '-f')
1409     }
1410
1411     if (exists $match_defs{$domain_family} and
1412         exists $match_defs{$domain_family}{''}) {
1413         foreach my $keyword (%{$match_defs{$domain_family}{''}{keywords}}) {
1414             my $value = $rule{"builtin____${keyword}"};
1415             shell_append(\$rr, '--' . $keyword, extract_negation $value)
1416               if defined $value;
1417         }
1418     }
1419
1420     #
1421     # match module options
1422     #
1423
1424     if (defined $rule{proto}) {
1425         my $proto = $rule{proto};
1426         $proto = 'icmpv6' if $proto eq 'ipv6-icmp';
1427
1428         if (exists $proto_defs{$domain_family}{$proto}) {
1429             my $def = $proto_defs{$domain_family}{$proto};
1430             while (my ($keyword, $k) = each %{$def->{keywords}}) {
1431                 my $key = "protocol__${proto}__$keyword";
1432                 next unless exists $rule{$key};
1433                 my $value = $rule->{$key};
1434
1435                 my $module = $proto eq 'icmpv6' ? 'icmp6' : $proto;
1436                 unless (exists $modules{$module}) {
1437                     shell_append(\$rr, '-m', $module);
1438                     $modules{$module} = 1;
1439                 }
1440
1441                 shell_append_option(\$rr, $k, $keyword, $value);
1442             }
1443         }
1444
1445         # special case: --dport and --sport for TCP/UDP
1446         if ($domain_family eq 'ip' and
1447             (exists $rule{dport} or exists $rule{sport}) and
1448             $proto =~ /^(?:tcp|udp|dccp|sctp)$/) {
1449             unless (exists $modules{$proto}) {
1450                 shell_append(\$rr, '-m', $proto);
1451                 $modules{$proto} = 1;
1452             }
1453
1454             shell_append_option(\$rr, { params => 1,
1455                                         negation => 1,
1456                                       }, 'dport', $rule{dport})
1457               if exists $rule{dport};
1458             shell_append_option(\$rr, { params => 1,
1459                                         negation => 1,
1460                                       }, 'sport', $rule{sport})
1461               if exists $rule{sport};
1462         }
1463     }
1464
1465     # modules stored in %match_defs
1466     while (my ($key, $value) = each %rule) {
1467         next unless $key =~ /^module__(\w+)__([-\w]+)$/;
1468         my ($module_name, $keyword) = ($1, $2);
1469
1470         my $def = $match_defs{$rule{domain_family}}{$module_name}{keywords}{$keyword};
1471         die unless defined $def;
1472
1473         shell_append_option(\$rr, $def, $keyword, $value);
1474     }
1475
1476     #
1477     # target options
1478     #
1479
1480     shell_append(\$rr, '-j', $action)
1481       unless $action eq 'NOP';
1482
1483     # targets stored in %target_defs
1484
1485     while (my ($keyword, $value) = each %{$rule{target_options}}) {
1486         my $def = $target_defs{$domain_family}{$action}{keywords}{$keyword};
1487         die unless defined $def;
1488
1489         shell_append_option(\$rr, $def, $keyword, $value);
1490     }
1491
1492     # this line is done
1493     $rr .= "\n";
1494     push @$rules, { rule => $rr,
1495                     script => $rule{script},
1496                   };
1497 };
1498
1499 sub printrule($) {
1500     my $rule = shift;
1501
1502     # prints all rules in a hash
1503     tables($rule);
1504 }
1505
1506
1507 # convert a bunch of internal rule structures in iptables calls,
1508 # unfold arrays during that
1509 sub mkrules($) {
1510     # compile the list hashes into rules
1511     my $fw = shift;
1512
1513     # pack the data in a handy format (list-of-hashes with one kw
1514     # per level, so we can recurse...
1515     my @fr;
1516
1517     foreach my $current (@$fw) {
1518         while (my ($key, $value) = each %$current) {
1519             push @fr, [ $key, $value ];
1520         }
1521     }
1522
1523     sub dofr($@) {
1524         my $rule = shift;
1525         my $current = shift;
1526
1527         my ($key, $value_string) = @$current;
1528
1529         unless (ref $value_string and
1530                 $key ne 'target_options' and
1531                 ref $value_string ne 'params' and
1532                 ref $value_string ne 'negated') {
1533                 # set this one and recurse
1534             $rule->{$key} = $value_string;
1535
1536             if (@_) {
1537                 dofr($rule, @_);
1538             } else {
1539                 printrule($rule);
1540             }
1541
1542             delete $rule->{$key};
1543         } elsif (ref $value_string eq 'ARRAY') {
1544             # recurse for every value
1545             foreach my $value (@$value_string) {
1546                 # set this one and recurse
1547                 $rule->{$key} = $value;
1548
1549                 if (@_) {
1550                     dofr($rule, @_);
1551                 } else {
1552                     printrule($rule);
1553                 }
1554             }
1555
1556             delete $rule->{$key};
1557         } elsif (ref $value_string eq 'HASH') {
1558             # merge hashes
1559             my $old = $rule->{$key};
1560
1561             $rule->{$key} = { ( defined $old
1562                                 ? %$old
1563                                 : ()
1564                               ),
1565                               %$value_string
1566                             };
1567
1568             # recurse
1569             if (@_) {
1570                 dofr($rule, @_);
1571             } else {
1572                 printrule($rule);
1573             }
1574
1575             # restore old value
1576             if (defined $old) {
1577                 $rule->{$key} = $old;
1578             } else {
1579                 delete $rule->{$key};
1580             }
1581         } else {
1582             die ref $value_string;
1583         }
1584     }
1585
1586     dofr({}, @fr);
1587 }
1588
1589 # find an option in the rule stack
1590 sub find_option($$) {
1591     my ($fw, $key) = @_;
1592
1593     my $item = (grep { exists $_->{$key} } reverse @$fw)[0];
1594     return unless defined $item;
1595
1596     return $item->{$key};
1597 }
1598
1599 sub filter_domains($) {
1600     my $domains = shift;
1601     my $result = [];
1602
1603     foreach my $domain (to_array $domains) {
1604         next if exists $option{domain}
1605           and $domain ne $option{domain};
1606
1607         eval {
1608             initialize_domain($domain);
1609         };
1610         error($@) if $@;
1611
1612         push @$result, $domain;
1613     }
1614
1615     return @$result == 1 ? $result->[0] : $result;
1616 }
1617
1618 # parse tokens from builtin match modules
1619 sub parse_builtin_matches($$$$$) {
1620     my ($fw, $current, $domain_family, $keyword, $negated_ref) = @_;
1621
1622     if ($domain_family eq 'ip' and $keyword eq 'addr') {
1623         error("source/destination not declared")
1624           unless exists $current->{side};
1625         warning("'$keyword' is deprecated, please use 's$keyword' or 'd$keyword'");
1626         if ($current->{side} eq 'source') {
1627             $keyword = 's' . $keyword;
1628         } elsif ($current->{side} eq 'destination') {
1629             $keyword = 'd' . $keyword;
1630         }
1631     }
1632
1633     # routing base parameters
1634     if ($keyword =~ /^(?:interface|if)$/) {
1635         $current->{interface} = getvalues(undef, undef, allow_negation => 1);
1636         return 1;
1637     }
1638     if ($keyword =~ /^(?:outerface|of)$/) {
1639         $current->{outerface} = getvalues(undef, undef, allow_negation => 1);
1640         return 1;
1641     }
1642     if ($keyword =~ /^proto(?:col)?$/) {
1643         $current->{proto} = getvalues(undef, undef, allow_negation => 1);
1644         return 1;
1645     }
1646
1647     if ($keyword =~ /^[sd]addr$/) {
1648         $current->{$keyword} = getvalues(undef, undef, allow_negation => 1);
1649         return 1;
1650     }
1651
1652     # miscelleanous switches
1653     if ($domain_family eq 'ip' and $keyword eq 'fragment') {
1654         if ($$negated_ref) {
1655             $current->{$keyword} = 'unset';
1656             undef $$negated_ref;
1657         } else {
1658             $current->{$keyword} = 'set';
1659         }
1660         return 1;
1661     }
1662
1663     # arptables
1664
1665     if (exists $match_defs{$domain_family}) {
1666         parse_option('builtin', $match_defs{$domain_family}, '',
1667                      $fw, $current,
1668                      $keyword, $negated_ref)
1669           and return 1;
1670     }
1671
1672     return;
1673 }
1674
1675 # parse a keyword from a module definition
1676 sub parse_keyword($$$$) {
1677     my ($fw, $def, $keyword, $negated_ref) = @_;
1678
1679     my $params = $def->{params};
1680
1681     my $value;
1682
1683     my $negated;
1684     if ($$negated_ref && exists $def->{pre_negation}) {
1685         $negated = 1;
1686         undef $$negated_ref;
1687     }
1688
1689     unless (defined $params) {
1690         undef $value;
1691     } elsif (ref $params && ref $params eq 'CODE') {
1692         $value = &$params($fw);
1693     } elsif ($params =~ /^[a-z]/) {
1694         if (exists $def->{negation} and not $negated) {
1695             my $token = peek_token();
1696             if ($token eq '!') {
1697                 require_next_token;
1698                 $negated = 1;
1699             }
1700         }
1701
1702         my @params;
1703         foreach my $p (split(//, $params)) {
1704             if ($p eq 's') {
1705                 push @params, getvar();
1706             } elsif ($p eq 'a') {
1707                 push @params, getvalues();
1708             } elsif ($p eq 'c') {
1709                 my @v = to_array getvalues(undef, undef,
1710                                            non_empty => 1);
1711                 push @params, join(',', @v);
1712             } else {
1713                 die;
1714             }
1715         }
1716
1717         $value = @params == 1
1718           ? $params[0]
1719             : bless \@params, 'params';
1720     } elsif ($params == 1) {
1721         if (exists $def->{negation} and not $negated) {
1722             my $token = peek_token();
1723             if ($token eq '!') {
1724                 require_next_token;
1725                 $negated = 1;
1726             }
1727         }
1728
1729         $value = getvalues();
1730
1731         warning("log-prefix is too long; truncating to 29 characters: '$1'")
1732           if $keyword eq 'log-prefix' && $value =~ s,^(.{29}).+$,$1,;
1733     } else {
1734         if (exists $def->{negation} and not $negated) {
1735             my $token = peek_token();
1736             if ($token eq '!') {
1737                 require_next_token;
1738                 $negated = 1;
1739             }
1740         }
1741
1742         $value = bless [ map {
1743             getvar()
1744         } (1..$params) ], 'params';
1745     }
1746
1747     $value = bless [ $value ], 'negated'
1748       if $negated;
1749
1750     return $value;
1751 }
1752
1753 # parse options of a module
1754 sub parse_option($$$$$$$) {
1755     my ($type, $defs, $name, $fw, $current, $keyword, $negated_ref) = @_;
1756
1757     my $def = $defs->{$name};
1758     return unless defined $def;
1759
1760     my $k = $def->{keywords}{$keyword};
1761     return unless defined $k;
1762
1763     $current->{"${type}__${name}__${keyword}"}
1764       = parse_keyword($fw, $k,
1765                       $keyword, $negated_ref);
1766     return 1;
1767 }
1768
1769 # parse options for a protocol module definition
1770 sub parse_protocol_options($$$$$) {
1771     my ($fw, $current, $proto, $keyword, $negated_ref) = @_;
1772
1773     my $domain_family = find_option($fw, 'domain_family');
1774     my $proto_defs = $proto_defs{$domain_family};
1775     return unless defined $proto_defs;
1776
1777     return parse_option('protocol', $proto_defs, $proto, $fw, $current,
1778                         $keyword, $negated_ref);
1779 }
1780
1781 # parse options of a match module
1782 sub parse_match_option($$$$$$) {
1783     my ($match_defs, $name, $fw, $current, $keyword, $negated_ref) = @_;
1784
1785     return parse_option('module', $match_defs, $name, $fw, $current,
1786                         $keyword, $negated_ref);
1787 }
1788
1789 # parse options for a match module definition
1790 sub parse_module_options($$$$$$) {
1791     my ($fw, $current, $modules, $keyword, $negated_ref, $proto) = @_;
1792
1793     my $domain_family = find_option($fw, 'domain_family');
1794     my $match_defs = $match_defs{$domain_family};
1795     return unless defined $match_defs;
1796
1797     # modules stored in %match_defs
1798     foreach my $name (keys %$modules) {
1799         parse_match_option($match_defs, $name, $fw, $current,
1800                            $keyword, $negated_ref)
1801           and do {
1802               # reset hash
1803               keys %$match_defs;
1804               return 1;
1805           }
1806     }
1807
1808     return;
1809 }
1810
1811 # parse options for a target module definition
1812 sub parse_target_options($$$$) {
1813     my ($fw, $current, $target, $keyword) = @_;
1814
1815     my $domain_family = find_option($fw, 'domain_family');
1816     my $target_defs = $target_defs{$domain_family};
1817     return unless defined $target_defs &&
1818       exists $target_defs->{$target}{keywords}{$keyword};
1819
1820     my $k = $target_defs->{$target}{keywords}{$keyword};
1821
1822     while (exists $k->{alias}) {
1823         die if $k->{alias} eq $keyword;
1824         $keyword = $k->{alias};
1825         $k = $target_defs->{$target}{keywords}{$keyword};
1826         die unless defined $k;
1827     }
1828
1829     my $negated_dummy;
1830     $current->{target_options}{$keyword}
1831       = parse_keyword($fw, $k,
1832                       $keyword, \$negated_dummy);
1833
1834     return 1;
1835 }
1836
1837 # the main parser loop: read tokens, convert them into internal rule
1838 # structures
1839 sub enter($@) {
1840     my $lev = shift;  # current recursion depth
1841     my @fw = @_; # fwset in list of hashes
1842
1843     die unless @fw == $lev;
1844
1845     # enter is the core of the firewall setup, it is a
1846     # simple parser program that recognizes keywords and
1847     # retreives parameters to set up the kernel routing
1848     # chains
1849
1850     my $base_level = $script->{base_level} || 0;
1851     die if $base_level > $lev;
1852
1853     my $current = {};
1854     push @fw, $current;
1855
1856     my $domain_family = find_option(\@fw, 'domain_family');
1857
1858     my %modules = map { $_->{modules} ? %{$_->{modules}} : () } @fw;
1859
1860     # read keywords 1 by 1 and dump into parser
1861     while (defined (my $keyword = next_token())) {
1862         # check if the current rule should be negated
1863         my $negated = $keyword eq '!';
1864         if ($negated) {
1865             # negation. get the next word which contains the 'real'
1866             # rule
1867             $keyword = getvar();
1868
1869             error('unexpected end of file after negation')
1870               unless defined $keyword;
1871         }
1872
1873         # the core: parse all data
1874         SWITCH: for ($keyword)
1875         {
1876             # deprecated keyword?
1877             if (exists $deprecated_keywords{$keyword}) {
1878                 my $new_keyword = $deprecated_keywords{$keyword};
1879                 warning("'$keyword' is deprecated, please use '$new_keyword' instead");
1880                 $keyword = $new_keyword;
1881             }
1882
1883             # effectuation operator
1884             if ($keyword eq ';') {
1885                 my $has_rule = find_option(\@fw, 'has_rule');
1886                 my $action = find_option(\@fw, 'action');
1887                 my $policy = find_option(\@fw, 'policy');
1888                 my $chain = find_option(\@fw, 'chain');
1889
1890                 if ($has_rule and not defined $action) {
1891                     # something is wrong when a rule was specifiedd,
1892                     # but no action
1893                     error('No action defined; did you mean "NOP"?');
1894                 }
1895
1896                 error('No chain defined') unless defined $chain;
1897
1898                 $current->{script} = { filename => $script->{filename},
1899                                        line => $script->{line},
1900                                      };
1901
1902                 mkrules(\@fw)
1903                   if $has_rule or defined $policy;
1904
1905                 # and clean up variables set in this level
1906                 %$current = ();
1907
1908                 next;
1909             }
1910
1911             # conditional expression
1912             if ($keyword eq '@if') {
1913                 unless (eval_bool(getvalues)) {
1914                     collect_tokens;
1915                     my $token = peek_token();
1916                     require_next_token() if $token and $token eq '@else';
1917                 }
1918
1919                 next;
1920             }
1921
1922             if ($keyword eq '@else') {
1923                 # hack: if this "else" has not been eaten by the "if"
1924                 # handler above, we believe it came from an if clause
1925                 # which evaluated "true" - remove the "else" part now.
1926                 collect_tokens;
1927                 next;
1928             }
1929
1930             # hooks for custom shell commands
1931             if ($keyword eq 'hook') {
1932                 error('"hook" must be the first token in a command')
1933                   if keys %$current;
1934
1935                 my $position = getvar();
1936                 my $hooks;
1937                 if ($position eq 'pre') {
1938                     $hooks = \@pre_hooks;
1939                 } elsif ($position eq 'post') {
1940                     $hooks = \@post_hooks;
1941                 } else {
1942                     error("Invalid hook position: '$position'");
1943                 }
1944
1945                 push @$hooks, getvar();
1946
1947                 $keyword = next_token();
1948                 error('";" expected after hook declaration')
1949                   unless defined $keyword and $keyword eq ';';
1950
1951                 next;
1952             }
1953
1954             # recursing operators
1955             if ($keyword eq '{') {
1956                 # push stack
1957                 my $old_stack_depth = @stack;
1958
1959                 unshift @stack, { auto => { %{$stack[0]{auto} || {}} } };
1960
1961                 # recurse
1962                 enter($lev + 1, @fw);
1963
1964                 # pop stack
1965                 shift @stack;
1966                 die unless @stack == $old_stack_depth;
1967
1968                 # after a block, the command is finished, clear this
1969                 # level
1970                 %$current = ();
1971
1972                 next;
1973             }
1974
1975             if ($keyword eq '}') {
1976                 error('Unmatched "}"')
1977                   if $lev <= $base_level;
1978
1979                 # consistency check: check if they havn't forgotten
1980                 # the ';' before the last statement
1981                 error('Missing semicolon before "}"')
1982                   if keys %$current;
1983
1984                 # and exit
1985                 return;
1986             }
1987
1988             # include another file
1989             if ($keyword eq '@include' or $keyword eq 'include') {
1990                 my @files = collect_filenames to_array getvalues;
1991                 $keyword = next_token;
1992                 error('Missing ";" - "include FILENAME" must be the last command in a rule')
1993                   unless defined $keyword and $keyword eq ';';
1994
1995                 foreach my $filename (@files) {
1996                     # save old script, open new script
1997                     my $old_script = $script;
1998                     open_script($filename);
1999                     $script->{base_level} = $lev + 1;
2000
2001                     # push stack
2002                     my $old_stack_depth = @stack;
2003
2004                     my $stack = {};
2005
2006                     if (@stack > 0) {
2007                         # include files may set variables for their parent
2008                         $stack->{vars} = ($stack[0]{vars} ||= {});
2009                         $stack->{functions} = ($stack[0]{functions} ||= {});
2010                         $stack->{auto} = { %{ $stack[0]{auto} || {} } };
2011                     }
2012
2013                     unshift @stack, $stack;
2014
2015                     # parse the script
2016                     enter($lev + 1, @fw);
2017
2018                     # pop stack
2019                     shift @stack;
2020                     die unless @stack == $old_stack_depth;
2021
2022                     # restore old script
2023                     $script = $old_script;
2024                 }
2025
2026                 next;
2027             }
2028
2029             # definition of a variable or function
2030             if ($keyword eq '@def' or $keyword eq 'def') {
2031                 error('"def" must be the first token in a command')
2032                   if keys %$current;
2033
2034                 my $type = require_next_token();
2035                 if ($type eq '$') {
2036                     my $name = require_next_token();
2037                     error('invalid variable name')
2038                       unless $name =~ /^\w+$/;
2039
2040                     $keyword = require_next_token();
2041                     error('"=" expected after variable name')
2042                       unless $keyword eq '=';
2043
2044                     my $value = getvalues(undef, undef, allow_negation => 1);
2045
2046                     $keyword = next_token();
2047                     error('";" expected after variable declaration')
2048                       unless defined $keyword and $keyword eq ';';
2049
2050                     $stack[0]{vars}{$name} = $value
2051                       unless exists $stack[-1]{vars}{$name};
2052                 } elsif ($type eq '&') {
2053                     my $name = require_next_token();
2054                     error('invalid function name')
2055                       unless $name =~ /^\w+$/;
2056
2057                     my @params;
2058                     my $token = next_token();
2059                     error('function parameter list or "()" expected')
2060                       unless defined $token and $token eq '(';
2061                     while (1) {
2062                         $token = require_next_token();
2063                         last if $token eq ')';
2064
2065                         if (@params > 0) {
2066                             error('"," expected')
2067                               unless $token eq ',';
2068
2069                             $token = require_next_token();
2070                         }
2071
2072                         error('"$" and parameter name expected')
2073                           unless $token eq '$';
2074
2075                         $token = require_next_token();
2076                         error('invalid function parameter name')
2077                           unless $token =~ /^\w+$/;
2078
2079                         push @params, $token;
2080                     }
2081
2082                     my %function;
2083
2084                     $function{params} = \@params;
2085
2086                     $keyword = require_next_token;
2087                     error('"=" expected')
2088                       unless $keyword eq '=';
2089
2090                     my $tokens = collect_tokens();
2091                     $function{block} = 1 if grep { $_ eq '{' } @$tokens;
2092                     $function{tokens} = $tokens;
2093
2094                     $stack[0]{functions}{$name} = \%function
2095                       unless exists $stack[-1]{functions}{$name};
2096                 } else {
2097                     error('"$" (variable) or "&" (function) expected');
2098                 }
2099
2100                 next;
2101             }
2102
2103             # def references
2104             if ($keyword eq '$') {
2105                 error('variable references are only allowed as keyword parameter');
2106             }
2107
2108             if ($keyword eq '&') {
2109                 my $name = require_next_token;
2110                 error('function name expected')
2111                   unless $name =~ /^\w+$/;
2112
2113                 my $function;
2114                 foreach (@stack) {
2115                     $function = $_->{functions}{$name};
2116                     last if defined $function;
2117                 }
2118                 error("no such function: \&$name")
2119                   unless defined $function;
2120
2121                 my $paramdef = $function->{params};
2122                 die unless defined $paramdef;
2123
2124                 my @params = get_function_params(allow_negation => 1);
2125
2126                 error("Wrong number of parameters for function '\&$name': "
2127                       . @$paramdef . " expected, " . @params . " given")
2128                   unless @params == @$paramdef;
2129
2130                 my %vars;
2131                 for (my $i = 0; $i < @params; $i++) {
2132                     $vars{$paramdef->[$i]} = $params[$i];
2133                 }
2134
2135                 if ($function->{block}) {
2136                     # block {} always ends the current rule, so if the
2137                     # function contains a block, we have to require
2138                     # the calling rule also ends here
2139                     my $token = next_token();
2140                     error("';' expected after block function call '\&$name'")
2141                       unless defined $token and $token eq ';';
2142                 }
2143
2144                 my @tokens = @{$function->{tokens}};
2145                 for (my $i = 0; $i < @tokens; $i++) {
2146                     if ($tokens[$i] eq '$' and $i + 1 < @tokens and
2147                         exists $vars{$tokens[$i + 1]}) {
2148                         my @value = to_array($vars{$tokens[$i + 1]});
2149                         @value = ('(', @value, ')')
2150                           unless @tokens == 1;
2151                         splice(@tokens, $i, 2, @value);
2152                         $i += @value - 2;
2153                     } elsif ($tokens[$i] =~ m,^"(.*)"$,) {
2154                         $tokens[$i] =~ s,\$(\w+),exists $vars{$1} ? $vars{$1} : "\$$1",eg;
2155                     }
2156                 }
2157
2158                 unshift @{$script->{tokens}}, @tokens;
2159
2160                 next;
2161             }
2162
2163             # where to put the rule?
2164             if ($keyword eq 'domain') {
2165                 error('Domain is already specified')
2166                   if exists $current->{domain};
2167
2168                 my $domain = getvalues();
2169                 my $filtered_domain = filter_domains($domain);
2170                 unless (ref $domain) {
2171                     $domain_family = $domain eq 'ip6' ? 'ip' : $domain;
2172                 } elsif (@$domain == 0) {
2173                     $domain_family = 'none';
2174                 } elsif (grep { not /^ip6?$/s } @$domain) {
2175                     error('Cannot combine non-IP domains');
2176                 } else {
2177                     $domain_family = 'ip';
2178                 }
2179                 $current->{domain_family} = $domain_family;
2180
2181                 $current->{domain} = $stack[0]{auto}{DOMAIN} = $filtered_domain;
2182
2183                 next;
2184             }
2185
2186             if ($keyword eq 'table') {
2187                 error('Table is already specified')
2188                   if exists $current->{table};
2189                 $current->{table} = $stack[0]{auto}{TABLE} = getvalues();
2190
2191                 unless (defined find_option(\@fw, 'domain')) {
2192                     $current->{domain} = filter_domains('ip');
2193                     $current->{domain_family} = $domain_family = 'ip';
2194                 }
2195
2196                 next;
2197             }
2198
2199             if ($keyword eq 'chain') {
2200                 error('Chain is already specified')
2201                   if exists $current->{chain};
2202                 $current->{chain} = $stack[0]{auto}{CHAIN} = getvalues();
2203
2204                 # ferm 1.1 allowed lower case built-in chain names
2205                 foreach (ref $current->{chain} ? @{$current->{chain}} : $current->{chain}) {
2206                     error('Please write built-in chain names in upper case')
2207                       if /^(?:input|forward|output|prerouting|postrouting)$/;
2208                 }
2209
2210                 my $domain = find_option(\@fw, 'domain');
2211                 unless (defined find_option(\@fw, 'domain')) {
2212                     $current->{domain} = filter_domains('ip');
2213                     $current->{domain_family} = $domain_family = 'ip';
2214                 }
2215
2216                 $current->{table} = 'filter'
2217                   unless defined find_option(\@fw, 'table');
2218
2219                 next;
2220             }
2221
2222             # policy for built-in chain
2223             if ($keyword eq 'policy') {
2224                 my $domains = find_option(\@fw, 'domain');
2225                 my $tables = find_option(\@fw, 'table');
2226                 my $chains = find_option(\@fw, 'chain');
2227
2228                 error('Chain must be specified')
2229                   unless defined $chains;
2230
2231                 my $policy = uc getvar();
2232                 error("Invalid policy target: $policy")
2233                   unless $policy =~ /^(?:ACCEPT|DROP)$/;
2234
2235                 foreach my $domain (to_array $domains) {
2236                     foreach my $table (to_array $tables) {
2237                         my $chains_info = $domains{$domain}{tables}{$table}{chains} ||= {};
2238
2239                         foreach my $chain (to_array $chains) {
2240                             error("cannot set the policy for non-builtin chain '$chain'")
2241                               unless is_netfilter_builtin_chain($table, $chain);
2242
2243                             if (exists $chains_info->{$chain}{policy}) {
2244                                 warning('policy for this chain is specified for the second time');
2245                             } else {
2246                                 $chains_info->{$chain}{policy} = $policy;
2247                                 $chains_info->{$chain}{set_policy} = 1;
2248                             }
2249                         }
2250                     }
2251                 }
2252
2253                 $current->{policy} = $policy;
2254                 next;
2255             }
2256
2257             # create a subchain
2258             if ($keyword eq '@subchain' or $keyword eq 'subchain') {
2259                 error('No rule specified before "@subchain"')
2260                   unless find_option(\@fw, 'has_rule');
2261
2262                 my $subchain;
2263                 $keyword = next_token();
2264
2265                 if ($keyword =~ /^(["'])(.*)\1$/s) {
2266                     $subchain = $2;
2267                     $keyword = next_token();
2268                 } else {
2269                     $subchain = 'ferm_auto_' . ++$auto_chain;
2270                 }
2271
2272                 error('"{" or chain name expected after "sub"')
2273                   unless $keyword eq '{';
2274
2275                 # create a deep copy of @fw, only containing values
2276                 # which must be in the subchain
2277                 my @fw2;
2278                 foreach my $fw (@fw) {
2279                     my $fw2 = {};
2280                     foreach my $key (qw(domain domain_family table proto)) {
2281                         my $value = $fw->{$key};
2282                         next unless defined $value;
2283                         $value = ref $value
2284                           ? ( ref $value eq 'HASH'
2285                               ? {%$value}
2286                               : [@$value]
2287                             )
2288                             : $value;
2289                         $fw2->{$key} = $value;
2290                     }
2291                     push @fw2, $fw2;
2292                 }
2293
2294                 $fw2[-1]->{chain} = $fw2[-1]->{auto}{CHAIN} = $subchain;
2295
2296                 # enter the block
2297                 enter($lev + 1, @fw2);
2298
2299                 # now handle the parent - it's a jump to the sub chain
2300                 $current->{action} = $subchain;
2301
2302                 $current->{script} = { filename => $script->{filename},
2303                                        line => $script->{line},
2304                                      };
2305
2306                 mkrules(\@fw);
2307
2308                 # and clean up variables set in this level
2309                 %$current = ();
2310
2311                 next;
2312             }
2313
2314             # everything else must be part of a "real" rule, not just
2315             # "policy only"
2316             $current->{has_rule}++;
2317
2318             # choose a side
2319             if ($keyword =~ /^(?:source|src)$/) {
2320                 warning("'$keyword' is deprecated, please use 'saddr' or 'sport'");
2321                 $current->{side} = 'source';
2322                 next;
2323             }
2324
2325             if ($keyword =~ /^(?:destination|dest)$/) {
2326                 warning("'$keyword' is deprecated, please use 'daddr' or 'dport'");
2327                 $current->{side} = 'destination';
2328                 next;
2329             }
2330
2331             # extended parameters:
2332             if ($keyword =~ /^mod(?:ule)?$/) {
2333                 my $domains = find_option(\@fw, 'domain');
2334
2335                 foreach my $module (to_array getvalues) {
2336                     $current->{modules}{$module} = 1;
2337                     $modules{$module} = 1;
2338                 }
2339
2340                 next;
2341             }
2342
2343             parse_builtin_matches(\@fw, $current, $domain_family,
2344                                   $keyword, \$negated)
2345               and next;
2346
2347             ###
2348             # actions
2349             #
2350
2351             # jump action
2352             if (/^(?:goto|jump)$/) {
2353                 error('There can only one action per rule')
2354                   if exists $current->{action};
2355                 warning('Please declare the policy in a separate statement')
2356                   if find_option(\@fw, 'policy');
2357                 $current->{action} = getvar();
2358                 next;
2359             };
2360
2361             # action keywords
2362             if (is_netfilter_core_target($keyword)) {
2363                 error('There can only one action per rule')
2364                   if exists $current->{action};
2365                 warning('Please declare the policy in a separate statement')
2366                   if find_option(\@fw, 'policy');
2367                 $current->{action} = $keyword;
2368                 next;
2369             }
2370
2371             if ($keyword eq 'NOP') {
2372                 error('There can only one action per rule')
2373                   if exists $current->{action};
2374                 warning('Please declare the policy in a separate statement')
2375                   if find_option(\@fw, 'policy');
2376                 $current->{action} = uc $keyword;
2377                 next;
2378             }
2379
2380             if (is_netfilter_module_target($domain_family, $keyword)) {
2381                 error('There can only one action per rule')
2382                   if exists $current->{action};
2383                 warning('Please declare the policy in a separate statement')
2384                   if find_option(\@fw, 'policy');
2385
2386                 if ($keyword eq 'TCPMSS') {
2387                     my $protos = find_option(\@fw, 'proto');
2388                     error('No protocol specified before TCPMSS')
2389                       unless defined $protos;
2390                     foreach my $proto (to_array $protos) {
2391                         error('TCPMSS not available for protocol "$proto"')
2392                           unless $proto eq 'tcp';
2393                     }
2394                 }
2395
2396                 $current->{action} = $keyword;
2397                 next;
2398             }
2399
2400             ###
2401             # protocol specific options
2402             #
2403
2404             my $proto = find_option(\@fw, 'proto');
2405             if (defined $proto and not ref $proto) {
2406                 $proto = 'icmpv6' if $proto eq 'ipv6-icmp';
2407
2408                 parse_protocol_options(\@fw, $current, $proto, $keyword, \$negated)
2409                   and next;
2410             }
2411
2412             # port switches
2413             if ($keyword eq 'port') {
2414                 error("source/destination not declared")
2415                   unless exists $current->{side};
2416                 warning("'$keyword' is deprecated, please use 's$keyword' or 'd$keyword'");
2417                 if ($current->{side} eq 'source') {
2418                     $keyword = 's' . $keyword;
2419                 } elsif ($current->{side} eq 'destination') {
2420                     $keyword = 'd' . $keyword;
2421                 }
2422             }
2423
2424             if ($keyword =~ /^[sd]port$/) {
2425                 error('To use sport or dport, you have to specify "proto tcp" or "proto udp" first')
2426                   unless defined $proto and grep { /^(?:tcp|udp|dccp|sctp)$/ } to_array $proto;
2427
2428                 $current->{$keyword} = getvalues(undef, undef,
2429                                                  allow_negation => 1);
2430                 next;
2431             }
2432
2433             ###
2434             # module specific options
2435             #
2436
2437             if ($option{automod} and exists $automod{$keyword}) {
2438                 # suport the deprecated 'automod' option
2439                 $current->{modules}{$automod{$keyword}} = 1;
2440                 $modules{$automod{$keyword}} = 1;
2441             }
2442
2443             if (keys %modules) {
2444                 parse_module_options(\@fw, $current, \%modules, $keyword, \$negated, $proto)
2445                   and next;
2446             }
2447
2448             ###
2449             # target specific options
2450             #
2451
2452             my $target = find_option(\@fw, 'action');
2453             if (defined $target and
2454                 parse_target_options(\@fw, $current, $target, $keyword)) {
2455                 next;
2456             }
2457
2458             # default
2459             error("Unrecognized keyword: $keyword");
2460         }
2461
2462         # if the rule didn't reset the negated flag, it's not
2463         # supported
2464         error("Doesn't support negation: $keyword")
2465           if $negated;
2466     }
2467
2468     error('Missing "}" at end of file')
2469       if $lev > $base_level;
2470
2471     # consistency check: check if they havn't forgotten
2472     # the ';' before the last statement
2473     error("Missing semicolon before end of file")
2474       if keys %$current;
2475 }
2476
2477 sub check() {
2478     while (my ($domain_name, $domain) = each %domains) {
2479         while (my ($table_name, $table_info) = each %{$domain->{tables}}) {
2480             while (my ($chain_name, $chain) = each %{$table_info->{chains}}) {
2481                 warning("chain $chain_name (domain $domain_name, table $table_name) was referenced, but not declared")
2482                   if $chain->{was_created} and not $chain->{non_empty};
2483             }
2484         }
2485     }
2486 }
2487
2488 sub execute_slow($$) {
2489     my ($domain, $rules) = @_;
2490
2491     my $status;
2492     foreach (reset_domain($domain), @$rules) {
2493         my $script;
2494
2495         if (ref) {
2496             $script = $_->{script};
2497             $_ = $_->{rule};
2498         }
2499
2500         s/^\s+//s;
2501         print LINES $_
2502           if $option{lines};
2503         next if $option{noexec};
2504         next if /^#/;
2505
2506         my $ret = system($_);
2507         unless ($ret == 0) {
2508             if ($? == -1) {
2509                 print STDERR "failed to execute: $!\n";
2510                 exit 1;
2511             } elsif ($? & 0x7f) {
2512                 printf STDERR "child died with signal %d\n", $? & 0x7f;
2513                 $status = 1;
2514             } else {
2515                 print STDERR "(rule declared in $script->{filename}:$script->{line})\n"
2516                   if defined $script;
2517                 $status = $? >> 8;
2518             }
2519         }
2520     }
2521
2522     return $status;
2523 }
2524
2525 sub rules_to_save($$) {
2526     my ($domain, $rules) = @_;
2527
2528     # parse the current ruleset, ignore -X and -F, handle policies and
2529     # custom chains
2530     my %policies;
2531     my %rules;
2532     foreach my $rule (reset_domain($domain), @$rules) {
2533         $rule = $rule->{rule}
2534           if ref $rule;
2535
2536         $rule =~ s/^\S+\s+//;
2537         my $table = $rule =~ s/-t\s+(\w+)\s*//
2538           ? $1 : 'filter';
2539         if ($rule =~ /-P\s+(\S+)\s+(\w+)\s*/) {
2540             $policies{$table}{$1} = $2;
2541         } elsif ($rule =~ /-A\s+(\w+)/) {
2542             push @{$rules{$table}{$1}}, $rule;
2543         } elsif ($rule =~ /-N\s+(\S+)\s*/) {
2544             $policies{$table}{$1} = '-';
2545         }
2546     }
2547
2548     # convert this into an iptables-save text
2549     my $result = "# Generated by ferm $VERSION on " . localtime() . "\n";
2550
2551     foreach my $table (qw(nat filter mangle raw)) {
2552         my $policies = $policies{$table};
2553         my $r = $rules{$table};
2554
2555         next
2556           unless defined $policies or defined $r;
2557
2558         # select table
2559         $result .= '*' . $table . "\n";
2560
2561         # create chains / set policy
2562         if (defined $policies) {
2563             foreach my $chain (sort keys %$policies) {
2564                 my $policy = $policies->{$chain};
2565                 $result .= ":$chain $policy\ [0:0]\n";
2566             }
2567         }
2568
2569         # dump rules
2570         if (defined $r) {
2571             foreach my $chain (sort keys %$r) {
2572                 my $rs = $r->{$chain};
2573                 foreach (@$rs) {
2574                     $result .= $_;
2575                 }
2576             }
2577         }
2578
2579         # do it
2580         $result .= "COMMIT\n";
2581    }
2582
2583     return $result;
2584 }
2585
2586 sub restore_domain($$) {
2587     my ($domain, $save) = @_;
2588
2589     my $path = $domains{$domain}{tools}{'tables-restore'};
2590
2591     local *RESTORE;
2592     open RESTORE, "|$path"
2593       or die "Failed to run $path: $!\n";
2594
2595     print RESTORE $save;
2596
2597     close RESTORE
2598       or die "Failed to run $path\n";
2599 }
2600
2601 sub execute_fast($$) {
2602     my ($domain, $save) = @_;
2603
2604     if ($option{lines}) {
2605         print LINES "$domains{$domain}{tools}{'tables-restore'} <<EOT\n"
2606           if $option{shell};
2607         print LINES $save;
2608         print LINES "EOT\n"
2609           if $option{shell};
2610     }
2611
2612     return if $option{noexec};
2613
2614     eval {
2615         restore_domain($domain, $save);
2616     };
2617     if ($@) {
2618         print STDERR $@;
2619         return 1;
2620     }
2621
2622     return;
2623 }
2624
2625 sub rollback() {
2626     my $error;
2627     foreach my $domain (keys %rules) {
2628         unless (defined $domains{$domain}{tools}{'tables-restore'}) {
2629             print STDERR "Cannot rollback domain '$domain' because there is no ${domain}tables-restore\n";
2630             next;
2631         }
2632
2633         my $reset = '';
2634         while (my ($table, $table_info) = each %{$domains{$domain}{tables}}) {
2635             my $reset_chain = '';
2636             foreach my $chain (keys %{$table_info->{chains}{$table}}) {
2637                 next unless is_netfilter_builtin_chain($table, $chain);
2638                 $reset_chain .= ":${chain} ACCEPT [0:0]\n";
2639             }
2640             $reset .= "*${table}\n${reset_chain}COMMIT\n"
2641               if length $reset_chain;
2642         }
2643
2644         $reset .= $domains{$domain}{previous}
2645           if defined $domains{$domain}{previous};
2646
2647         restore_domain($domain, $reset);
2648     }
2649
2650     print STDERR "\nFirewall rules rolled back.\n" unless $error;
2651     exit 1;
2652 }
2653
2654 sub alrm_handler {
2655     # do nothing, just interrupt a system call
2656 }
2657
2658 sub confirm_rules() {
2659     $SIG{ALRM} = \&alrm_handler;
2660
2661     alarm(5);
2662
2663     print STDERR "\n"
2664       . "ferm has applied the new firewall rules.\n"
2665         . "Please type 'yes' to confirm:\n";
2666     STDERR->flush();
2667
2668     alarm(30);
2669
2670     my $line = '';
2671     STDIN->sysread($line, 3);
2672
2673     eval {
2674         require POSIX;
2675         POSIX::tcflush(*STDIN, 2);
2676     };
2677     print STDERR "$@" if $@;
2678
2679     $SIG{ALRM} = 'DEFAULT';
2680
2681     return $line eq 'yes';
2682 }
2683
2684 # end of ferm
2685
2686 __END__
2687
2688 =head1 NAME
2689
2690 ferm - a firewall rule parser for linux
2691
2692 =head1 SYNOPSIS
2693
2694 B<ferm> I<options> I<inputfiles>
2695
2696 =head1 OPTIONS
2697
2698  -n, --noexec      Do not execute the rules, just simulate
2699  -F, --flush       Flush all netfilter tables managed by ferm
2700  -l, --lines       Show all rules that were created
2701  -i, --interactive Interactive mode: revert if user does not confirm
2702  --remote          Remote mode; ignore host specific configuration.
2703                    This implies --noexec and --lines.
2704  -V, --version     Show current version number
2705  -h, --help        Look at this text
2706  --fast            Generate an iptables-save file, used by iptables-restore
2707  --shell           Generate a shell script which calls iptables-restore
2708  --domain {ip|ip6} Handle only the specified domain
2709  --def '$name=v'   Override a variable
2710
2711 =cut