4 # ferm, a firewall setup program that makes firewall rules easy!
6 # Copyright (C) 2001-2007 Auke Kok, Max Kellermann
8 # Comments, questions, greetings and additions to this program
9 # may be sent to <ferm@foo-projects.org>
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.
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.
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
31 eval { require strict
; import strict
; };
34 # we need no vars.pm if there is not even strict.pm
36 *vars
::import
= sub {};
41 eval { require Getopt
::Long
; import Getopt
::Long
; };
45 use vars
qw($has_strict $has_getopt);
47 use vars qw($DATE $VERSION);
49 # subversion keyword magic
50 $DATE = '$Date$' =~ m,(\d{4})-(\d\d)-(\d\d), ? $1.$2.$3 : '';
53 $VERSION .= '~svn' . $DATE;
55 ## interface variables
56 # %option = command line and other options
60 use vars qw(@pre_hooks @post_hooks);
63 # $script: current script file
64 # @stack = ferm's parser stack containing local variables
65 # $auto_chain = index for the next auto-generated chain
66 use vars qw($script @stack $auto_chain);
68 ## netfilter variables
69 # %domains = state information about all domains ("ip" and "ip6")
70 # - initialized: domain initialization is done
71 # - tools: hash providing the paths of the domain's tools
72 # - previous: save file of the previous ruleset, for rollback
73 # - reset: has this domain already been reset?
74 # - tables{$name}: ferm state information about tables
75 # - chains{$chain}: ferm state information about the chains
76 # - builtin: whether this is a built-in chain
77 # - was_created: custom chain has been created
78 # - non_empty: are there rules for this chain?
79 use vars qw(%domains);
82 use vars qw(%deprecated_keywords);
84 # keywords from ferm 1.1 which are deprecated, and the new one; these
85 # are automatically replaced, and a warning is printed
86 %deprecated_keywords = ( goto => 'jump',
89 # these hashes provide the Netfilter module definitions
90 use vars qw(%proto_defs %match_defs %target_defs);
93 # This subsubsystem allows you to support (most) new netfilter modules
94 # in ferm. Add a call to one of the "add_XY_def()" functions below.
96 # Ok, now about the cryptic syntax: the function "add_XY_def()"
97 # registers a new module. There are three kinds of modules: protocol
98 # module (e.g. TCP, ICMP), match modules (e.g. state, physdev) and
99 # target modules (e.g. DNAT, MARK).
101 # The first parameter is always the module name which is passed to
102 # iptables with "-p", "-m" or "-j" (depending on which kind of module
105 # After that, you add an encoded string for each option the module
106 # supports. This is where it becomes tricky.
108 # foo defaults to an option with one argument (which may be a ferm
111 # foo*0 option without any arguments
113 # foo=s one argument which must not be a ferm array ('s' stands for
116 # u32=m an array which renders into multiple iptables options in one
119 # ctstate=c one argument, if it's an array, pass it to iptables as a
120 # single comma separated value; example:
121 # ctstate (ESTABLISHED RELATED) translates to:
122 # --ctstate ESTABLISHED,RELATED
124 # foo=sac three arguments: scalar, array, comma separated; you may
125 # concatenate more than one letter code after the '='
127 # foo&bar one argument; call the perl function '&bar()' which parses
130 # !foo negation is allowed and the '!' is written before the keyword
132 # foo! same as above, but '!' is after the keyword and before the
135 # to:=to-destination makes "to" an alias for "to-destination"; you have
136 # to add a declaration for option "to-destination"
139 # add a module definition
142 my $domain_family = shift;
144 die if exists $defs->{$domain_family}{$name};
145 my $def = $defs->{$domain_family}{$name} = {};
151 $params = $1 if $keyword =~ s,\*(\d+)$,,;
152 $params = $1 if $keyword =~ s,=([acs]+|m)$,,;
153 if ($keyword =~ s,&(\S+)$,,) {
154 $params = eval "\\&$1";
157 $k->{params} = $params if $params;
159 $k->{negation} = $k->{pre_negation} = 1 if $keyword =~ s,^!,,;
160 $k->{negation} = 1 if $keyword =~ s,!$,,;
162 $k->{alias} = $1 if $keyword =~ s,:=(\S+)$,,;
164 $def->{keywords}{$keyword} = $k;
170 # add a protocol module definition
171 sub add_proto_def_x(@) {
172 add_def_x(\%proto_defs, @_);
175 # add a match module definition
176 sub add_match_def_x(@) {
177 add_def_x(\%match_defs, @_);
180 # add a target module definition
181 sub add_target_def_x(@) {
182 add_def_x(\%target_defs, @_);
187 add_def_x($defs, 'ip', @_);
190 # add a protocol module definition
191 sub add_proto_def(@) {
192 add_def(\%proto_defs, @_);
195 # add a match module definition
196 sub add_match_def(@) {
197 add_def(\%match_defs, @_);
200 # add a target module definition
201 sub add_target_def(@) {
202 add_def(\%target_defs, @_);
205 add_proto_def 'dccp', qw(dccp-types!=c dccp-option!);
206 add_proto_def
'mh', qw(mh-type!);
207 add_proto_def
'icmp', qw(icmp-type!);
208 add_proto_def
'icmpv6', qw(icmpv6-type! icmp-type:=icmpv6-type);
209 add_proto_def
'sctp', qw(chunk-types!=sc);
210 add_proto_def
'tcp', qw(tcp-flags!=cc !syn*0 tcp-option! mss);
211 add_proto_def
'udp', qw();
215 qw(protocol! proto:=protocol),
216 # --source, --destination
217 qw(source! saddr:=source destination! daddr:=destination),
219 qw(in-interface! interface:=in-interface if:=in-interface),
221 qw(out-interface! outerface:=out-interface of:=out-interface),
224 add_match_def
'account', qw(aaddr=s aname=s ashort*0);
225 add_match_def
'addrtype', qw(src-type dst-type);
226 add_match_def
'ah', qw(ahspi! ahlen! ahres*0);
227 add_match_def
'comment', qw(comment=s);
228 add_match_def
'condition', qw(condition!);
229 add_match_def
'connbytes', qw(!connbytes connbytes-dir connbytes-mode);
230 add_match_def
'connlimit', qw(!connlimit-above connlimit-mask);
231 add_match_def
'connmark', qw(mark);
232 add_match_def
'conntrack', qw(ctstate=c ctproto ctorigsrc! ctorigdst!),
233 qw(ctreplsrc! ctrepldst! ctstatus ctexpire=s);
234 add_match_def
'dscp', qw(dscp dscp-class);
235 add_match_def
'ecn', qw(ecn-tcp-cwr*0 ecn-tcp-ece*0 ecn-ip-ect);
236 add_match_def
'esp', qw(espspi!);
237 add_match_def
'eui64';
238 add_match_def
'fuzzy', qw(lower-limit=s upper-limit=s);
239 add_match_def
'hbh', qw(hbh-len! hbh-opts=c);
240 add_match_def
'helper', qw(helper);
241 add_match_def
'hl', qw(hl-eq! hl-lt=s hl-gt=s);
242 add_match_def
'length', qw(length!);
243 add_match_def
'hashlimit', qw(hashlimit=s hashlimit-burst=s hashlimit-mode=s hashlimit-name=s),
244 qw(hashlimit-htable-size=s hashlimit-htable-max=s),
245 qw(hashlimit-htable-expire=s hashlimit-htable-gcinterval=s);
246 add_match_def
'iprange', qw(!src-range !dst-range);
247 add_match_def
'ipv6header', qw(header!=c soft*0);
248 add_match_def
'limit', qw(limit=s limit-burst=s);
249 add_match_def
'mac', qw(mac-source!);
250 add_match_def
'mark', qw(mark);
251 add_match_def
'multiport', qw(source-ports!&multiport_params),
252 qw(destination-ports!&multiport_params ports!&multiport_params);
253 add_match_def
'nth', qw(every counter start packet);
254 add_match_def
'owner', qw(uid-owner gid-owner pid-owner sid-owner cmd-owner);
255 add_match_def
'physdev', qw(physdev-in! physdev-out!),
256 qw(!physdev-is-in*0 !physdev-is-out*0 !physdev-is-bridged*0);
257 add_match_def
'pkttype', qw(pkt-type),
258 add_match_def
'policy',
259 qw(dir pol strict*0 reqid spi proto mode tunnel-src tunnel-dst next*0);
260 add_match_def
'psd', qw(psd-weight-threshold psd-delay-threshold),
261 qw(psd-lo-ports-weight psd-hi-ports-weight);
262 add_match_def
'quota', qw(quota=s);
263 add_match_def
'random', qw(average);
264 add_match_def
'realm', qw(realm!);
265 add_match_def
'recent', qw(name=s !set*0 !rcheck*0 !update*0 !seconds !hitcount rttl*0);
266 add_match_def
'rt', qw(rt-type! rt-segsleft! rt-len! rt-0-res*0 rt-0-addrs=c rt-0-not-strict*0);
267 add_match_def
'set', qw(set=sc);
268 add_match_def
'state', qw(state=c);
269 add_match_def
'statistic', qw(mode=s probability=s every=s packet=s);
270 add_match_def
'tcpmss', qw(!mss);
271 add_match_def
'time', qw(timestart=s timestop=s days=c datestart=s datestop=s);
272 add_match_def
'tos', qw(!tos);
273 add_match_def
'ttl', qw(ttl-eq ttl-lt=s ttl-gt=s);
274 add_match_def
'u32', qw(u32=m);
276 add_target_def
'BALANCE', qw(to-destination to:=to-destination);
277 add_target_def
'CLASSIFY', qw(set-class);
278 add_target_def
'CONNMARK', qw(set-mark save-mark*0 restore-mark*0 mask);
279 add_target_def
'CONNSECMARK', qw(save*0 restore*0);
280 add_target_def
'DNAT', qw(to-destination to:=to-destination);
281 add_target_def
'DSCP', qw(set-dscp set-dscp-class);
282 add_target_def
'ECN', qw(ecn-tcp-remove*0);
283 add_target_def
'HL', qw(hl-set hl-dec hl-inc);
284 add_target_def
'LOG', qw(log-level log-prefix),
285 qw(log-tcp-sequence*0 log-tcp-options*0 log-ip-options*0 log-uid*0);
286 add_target_def
'MARK', qw(set-mark);
287 add_target_def
'MASQUERADE', qw(to-ports);
288 add_target_def
'MIRROR';
289 add_target_def
'NETMAP', qw(to);
290 add_target_def
'NFLOG', qw(nflog-group nflog-prefix nflog-range nflog-threshold);
291 add_target_def
'NFQUEUE', qw(queue-num);
292 add_target_def
'NOTRACK';
293 add_target_def
'REDIRECT', qw(to-ports);
294 add_target_def
'REJECT', qw(reject-with);
295 add_target_def
'ROUTE', qw(oif iif gw continue*0 tee*0);
296 add_target_def
'SAME', qw(to nodst*0);
297 add_target_def
'SECMARK', qw(selctx);
298 add_target_def
'SET', qw(add-set=sc del-set=sc);
299 add_target_def
'SNAT', qw(to-source=m to:=to-source);
300 add_target_def
'TARPIT';
301 add_target_def
'TCPMSS', qw(set-mss clamp-mss-to-pmtu*0);
302 add_target_def
'TOS', qw(set-tos);
303 add_target_def
'TRACE';
304 add_target_def
'TTL', qw(ttl-set ttl-dec ttl-inc);
305 add_target_def
'ULOG', qw(ulog-nlgroup ulog-prefix ulog-cprange ulog-qthreshold);
307 add_match_def_x
'arp', '',
309 qw(source-ip! destination-ip! saddr:=source-ip daddr:=destination-ip),
311 qw(source-mac! destination-mac!),
313 qw(in-interface! interface:=in-interface if:=in-interface),
315 qw(out-interface! outerface:=out-interface of:=out-interface),
317 qw(h-length=s opcode=s h-type=s proto-type=s),
318 qw(mangle-ip-s=s mangle-ip-d=s mangle-mac-s=s mangle-mac-d=s mangle-target=s);
320 add_match_def_x
'eb', '',
322 qw(protocol! proto:=protocol),
324 qw(in-interface! interface:=in-interface if:=in-interface),
326 qw(out-interface! outerface:=out-interface of:=out-interface),
328 qw(logical-in! logical-out!),
329 # --source, --destination
330 qw(source! saddr:=source destination! daddr:=destination),
332 qw(802_3-sap! 802_3-type!),
334 qw(arp-opcode! arp-htype!=ss arp-ptype!=ss),
335 qw(arp-ip-src! arp-ip-dst! arp-mac-src! arp-mac-dst!),
337 qw(ip-source! ip-destination! ip-tos! ip-protocol! ip-sport! ip-dport!),
343 qw(stp-type! stp-flags! stp-root-prio! stp-root-addr! stp-root-cost!),
344 qw(stp-sender-prio! stp-sender-addr! stp-port! stp-msg-age! stp-max-age!),
345 qw(stp-hello-time! stp-forward-delay!),
347 qw(vlan-id! vlan-prio! vlan-encap!),
349 qw(log*0 log-level=s log-prefix=s log-ip*0 log-arp*0);
351 add_target_def_x
'eb', 'arpreply', qw(arpreply-mac arpreply-target);
352 add_target_def_x
'eb', 'dnat', qw(to-destination dnat-target);
353 add_target_def_x
'eb', 'mark', qw(set-mark mark-target);
354 add_target_def_x
'eb', 'redirect', qw(redirect-target);
355 add_target_def_x
'eb', 'snat', qw(to-source snat-target);
357 # parameter parser for ipt_multiport
358 sub multiport_params
{
361 # multiport only allows 15 ports at a time. For this
362 # reason, we do a little magic here: split the ports
363 # into portions of 15, and handle these portions as
366 my $proto = $fw->{builtin
}{protocol
};
367 error
('To use multiport, you have to specify "proto tcp" or "proto udp" first')
368 unless defined $proto and grep { /^(?:tcp|udp|udplite)$/ } to_array
($proto);
370 my $value = getvalues
(undef, undef,
372 allow_array_negation
=> 1);
373 if (ref $value and ref $value eq 'ARRAY') {
378 push @params, join(',', splice(@value, 0, 15));
385 return join_value
(',', $value);
389 # initialize stack: command line definitions
392 # Get command line stuff
394 my ($opt_noexec, $opt_flush, $opt_lines, $opt_interactive,
395 $opt_verbose, $opt_debug,
397 $opt_version, $opt_test, $opt_fast, $opt_shell,
400 Getopt
::Long
::Configure
('bundling', 'auto_help', 'no_ignore_case',
404 my ($opt, $value) = @_;
405 die 'Invalid --def specification'
406 unless $value =~ /^\$?(\w+)=(.*)$/s;
407 my ($name, $unparsed_value) = ($1, $2);
408 my @tokens = tokenize_string
($unparsed_value);
409 my $value = getvalues
(\
&next_array_token
, \
@tokens);
410 die 'Extra tokens after --def'
412 $stack[0]{vars
}{$name} = $value;
415 local $SIG{__WARN__
} = sub { die $_[0]; };
416 GetOptions
('noexec|n' => \
$opt_noexec,
417 'flush|F' => \
$opt_flush,
418 'lines|l' => \
$opt_lines,
419 'interactive|i' => \
$opt_interactive,
420 'verbose|v' => \
$opt_verbose,
421 'debug|d' => \
$opt_debug,
422 'help|h' => \
$opt_help,
423 'version|V' => \
$opt_version,
425 remote
=> \
$opt_test,
427 shell
=> \
$opt_shell,
428 'domain=s' => \
$opt_domain,
429 'def=s' => \
&opt_def
,
432 if (defined $opt_help) {
434 Pod
::Usage
::pod2usage
(-exitstatus
=> 0);
437 if (defined $opt_version) {
442 $option{'noexec'} = (defined $opt_noexec);
443 $option{flush
} = defined $opt_flush;
444 $option{'lines'} = (defined $opt_lines);
445 $option{interactive
} = (defined $opt_interactive);
446 $option{test
} = (defined $opt_test);
453 delete $option{interactive
} if $option{noexec
};
455 mydie
('ferm interactive mode not possible: /dev/stdin is not a tty')
456 if $option{interactive
} and not -t STDIN
;
457 mydie
('ferm interactive mode not possible: /dev/stderr is not a tty')
458 if $option{interactive
} and not -t STDERR
;
460 $option{fast
} = 1 if defined $opt_fast;
462 if (defined $opt_shell) {
463 $option{$_} = 1 foreach qw(shell fast lines);
466 $option{domain
} = $opt_domain if defined $opt_domain;
468 print STDERR
"Warning: ignoring the obsolete --debug option\n"
469 if defined $opt_debug;
470 print STDERR
"Warning: ignoring the obsolete --verbose option\n"
471 if defined $opt_verbose;
473 # tiny getopt emulation for microperl
476 if ($_ eq '--noexec' or $_ eq '-n') {
478 } elsif ($_ eq '--lines' or $_ eq '-l') {
480 } elsif ($_ eq '--fast') {
482 } elsif ($_ eq '--test') {
486 } elsif ($_ eq '--shell') {
487 $option{$_} = 1 foreach qw(shell fast lines);
489 printf STDERR
"Usage: ferm [--noexec] [--lines] [--fast] [--shell] FILENAME\n";
496 push @ARGV, $filename;
499 unless (@ARGV == 1) {
501 Pod
::Usage
::pod2usage
(-exitstatus
=> 1);
505 open LINES
, ">&STDOUT" if $option{lines
};
506 open STDOUT
, ">&STDERR" if $option{shell
};
508 # microperl can't redirect file handles
511 if ($option{fast
} and not $option{noexec
}) {
512 print STDERR
"Sorry, ferm on microperl does not allow --fast without --noexec\n";
518 open_script
($ARGV[0]);
520 # parse all input recursively
522 die unless @stack == 2;
527 # execute all generated rules
530 foreach my $cmd (@pre_hooks) {
531 print LINES
"$cmd\n" if $option{lines
};
532 system($cmd) unless $option{noexec
};
535 while (my ($domain, $domain_info) = each %domains) {
536 next unless $domain_info->{enabled
};
537 my $s = $option{fast
} &&
538 defined $domain_info->{tools
}{'tables-restore'}
539 ? execute_fast
($domain, $domain_info)
540 : execute_slow
($domain, $domain_info);
541 $status = $s if defined $s;
544 foreach my $cmd (@post_hooks) {
545 print "$cmd\n" if $option{lines
};
546 system($cmd) unless $option{noexec
};
549 if (defined $status) {
554 # ask user, and rollback if there is no confirmation
556 confirm_rules
() or rollback
() if $option{interactive
};
560 # end of program execution!
566 print "ferm $VERSION\n";
567 print "Copyright (C) 2001-2007 Auke Kok, Max Kellermann\n";
568 print "This program is free software released under GPLv2.\n";
569 print "See the included COPYING file for license details.\n";
581 # returns a nice formatted error message, showing the
582 # location of the error.
586 my @words = map { @
$_ } @
{$script->{past_tokens
}};
588 for my $w ( 0 .. $#words ) {
589 if ($words[$w] eq "\x29")
590 { $l++ ; $lines[$l] = " " x
($tabs-- -1) ;};
591 if ($words[$w] eq "\x28")
592 { $l++ ; $lines[$l] = " " x
$tabs++ ;};
593 if ($words[$w] eq "\x7d")
594 { $l++ ; $lines[$l] = " " x
($tabs-- -1) ;};
595 if ($words[$w] eq "\x7b")
596 { $l++ ; $lines[$l] = " " x
$tabs++ ;};
597 if ( $l > $#lines ) { $lines[$l] = "" };
598 $lines[$l] .= $words[$w] . " ";
599 if ($words[$w] eq "\x28")
600 { $l++ ; $lines[$l] = " " x
$tabs ;};
601 if (($words[$w] eq "\x29") && ($words[$w+1] ne "\x7b"))
602 { $l++ ; $lines[$l] = " " x
$tabs ;};
603 if ($words[$w] eq "\x7b")
604 { $l++ ; $lines[$l] = " " x
$tabs ;};
605 if (($words[$w] eq "\x7d") && ($words[$w+1] ne "\x7d"))
606 { $l++ ; $lines[$l] = " " x
$tabs ;};
607 if (($words[$w] eq "\x3b") && ($words[$w+1] ne "\x7d"))
608 { $l++ ; $lines[$l] = " " x
$tabs ;}
609 if ($words[$w-1] eq "option")
610 { $l++ ; $lines[$l] = " " x
$tabs ;}
612 my $start = $#lines - 4;
613 if ($start < 0) { $start = 0 } ;
614 print STDERR
"Error in $script->{filename} line $script->{line}:\n";
615 for $l ( $start .. $#lines)
616 { print STDERR
$lines[$l]; if ($l != $#lines ) {print STDERR
"\n"} ; };
617 print STDERR
"<--\n";
621 # print a warning message about code from an input file
623 print STDERR
"Warning in $script->{filename} line $script->{line}: "
629 return $name if $option{test
};
630 for my $path ('/sbin', split ':', $ENV{PATH
}) {
631 my $ret = "$path/$name";
632 return $ret if -x
$ret;
634 die "$name not found in PATH\n";
637 sub initialize_domain
{
640 return if exists $domains{$domain}{initialized
};
642 die "Invalid domain '$domain'\n" unless $domain =~ /^(?:ip6?|arp|eb)$/;
644 my @tools = qw(tables);
645 push @tools, qw(tables-save tables-restore)
646 if $domain =~ /^ip6?$/;
648 # determine the location of this domain's tools
649 foreach my $tool (@tools) {
650 $domains{$domain}{tools
}{$tool} = find_tool
("${domain}${tool}");
653 # make tables-save tell us about the state of this domain
654 # (which tables and chains do exist?), also remember the old
655 # save data which may be used later by the rollback function
657 if (!$option{test
} &&
658 exists $domains{$domain}{tools
}{'tables-save'} &&
659 open(SAVE
, "$domains{$domain}{tools}{'tables-save'}|")) {
668 $table_info = $domains{$domain}{tables
}{$table} ||= {};
669 } elsif (defined $table_info and /^:(\w+)\s+(\S+)/
671 $table_info->{chains
}{$1}{builtin
} = 1;
672 $table_info->{has_builtin
} = 1;
677 $domains{$domain}{previous
} = $save;
680 $domains{$domain}{initialized
} = 1;
683 # split the an input string into words and delete comments
684 sub tokenize_string
($) {
689 foreach my $word ($string =~ m/(".*?"|'.*?'|`.*?`|[!,=&\$\%\(\){};]|[-+\w\/\
.:]+|@\w
+|#)/g) {
690 last if $word eq '#';
697 # shift an array; helper function to be passed to &getvar / &getvalues
698 sub next_array_token
{
703 # read some more tokens from the input file into a buffer
704 sub prepare_tokens
() {
705 my $tokens = $script->{tokens
};
706 while (@
$tokens == 0) {
707 my $handle = $script->{handle
};
708 my $line = <$handle>;
709 return unless defined $line;
713 my @line = tokenize_string
($line);
715 # the next parser stage eats this
716 push @
$tokens, @line;
722 # open a ferm sub script
724 my $filename = shift;
726 for (my $s = $script; defined $s; $s = $s->{parent
}) {
727 mydie
("Circular reference in $script->{filename} line $script->{line}: $filename")
728 if $s->{filename
} eq $filename;
732 open FILE
, "<$filename"
733 or mydie
("Failed to open $filename: $!");
736 $script = { filename
=> $filename,
747 # collect script filenames which are being included
748 sub collect_filenames
(@
) {
751 # determine the current script's parent directory for relative
753 die unless defined $script;
754 my $parent_dir = $script->{filename
} =~ m
,^(.*/),
757 foreach my $pathname (@_) {
758 # non-absolute file names are relative to the parent script's
760 $pathname = $parent_dir . $pathname
761 unless $pathname =~ m
,^/,;
763 if ($pathname =~ m
,/$,) {
764 # include all regular files in a directory
766 error
("'$pathname' is not a directory")
770 opendir DIR
, $pathname
771 or error
("Failed to open directory '$pathname': $!");
772 my @names = readdir DIR
;
775 # sort those names for a well-defined order
776 foreach my $name (sort { $a cmp $b } @names) {
777 # don't include hidden and backup files
780 my $filename = $pathname . $name;
784 } elsif ($pathname =~ m
,\
|$,) {
785 # run a program and use its output
786 push @ret, $pathname;
787 } elsif ($pathname =~ m
,^\
|,) {
788 error
('This kind of pipe is not allowed');
790 # include a regular file
792 error
("'$pathname' is a directory; maybe use trailing '/' to include a directory?")
794 error
("'$pathname' is not a file")
797 push @ret, $pathname;
804 # peek a token from the queue, but don't remove it
806 return unless prepare_tokens
();
807 return $script->{tokens
}[0];
810 # get a token from the queue
812 return unless prepare_tokens
();
813 my $token = shift @
{$script->{tokens
}};
815 # update $script->{past_tokens}
816 my $past_tokens = $script->{past_tokens
};
818 if (@
$past_tokens > 0) {
819 my $prev_token = $past_tokens->[-1][-1];
820 $past_tokens->[-1] = @
$past_tokens > 1 ?
['{'] : []
821 if $prev_token eq ';';
823 if $prev_token eq '}';
826 push @
$past_tokens, [] if $token eq '{' or @
$past_tokens == 0;
827 push @
{$past_tokens->[-1]}, $token;
833 # require that another token exists, and that it's not a "special"
834 # token, e.g. ";" and "{"
835 sub require_next_token
{
836 my $code = shift || \
&next_token
;
838 my $token = &$code(@_);
840 error
('unexpected end of file')
841 unless defined $token;
843 error
("'$token' not allowed here")
844 if $token =~ /^[;{}]$/;
849 # return the value of a variable
850 sub variable_value
($) {
854 return $_->{vars
}{$name}
855 if exists $_->{vars
}{$name};
858 return $stack[0]{auto
}{$name}
859 if exists $stack[0]{auto
}{$name};
864 # determine the value of a variable, die if the value is an array
865 sub string_variable_value
($) {
867 my $value = variable_value
($name);
869 error
("variable '$name' must be a string, is an array")
875 # similar to the built-in "join" function, but also handle negated
876 # values in a special way
878 my ($expr, $value) = @_;
880 unless (ref $value) {
882 } elsif (ref $value eq 'ARRAY') {
883 return join($expr, @
$value);
884 } elsif (ref $value eq 'negated') {
885 # bless'negated' is a special marker for negated values
886 $value = join_value
($expr, $value->[0]);
887 return bless [ $value ], 'negated';
893 # returns the next parameter, which may either be a scalar or an array
895 my ($code, $param) = (shift, shift);
898 my $token = require_next_token
($code, $param);
901 # read an array until ")"
905 $token = getvalues
($code, $param,
906 parenthesis_allowed
=> 1,
909 unless (ref $token) {
910 last if $token eq ')';
913 error
('Comma is not allowed within arrays, please use only a space');
917 push @wordlist, $token;
918 } elsif (ref $token eq 'ARRAY') {
919 push @wordlist, @
$token;
921 error
('unknown toke type');
925 error
('empty array not allowed here')
926 unless @wordlist or not $options{non_empty
};
928 return @wordlist == 1
931 } elsif ($token =~ /^\`(.*)\`$/s) {
932 # execute a shell command, insert output
934 my $output = `$command`;
937 error
("failed to execute: $!");
938 } elsif ($?
& 0x7f) {
939 error
("child died with signal " . ($?
& 0x7f));
941 error
("child exited with status " . ($?
>> 8));
946 $output =~ s/#.*//mg;
949 my @tokens = grep { length } split /\s+/s, $output;
953 my $value = getvalues
(\
&next_array_token
, \
@tokens);
954 push @values, to_array
($value);
961 } elsif ($token =~ /^\'(.*)\'$/s) {
962 # single quotes: a string
964 } elsif ($token =~ /^\"(.*)\"$/s) {
965 # double quotes: a string with escapes
967 $token =~ s
,\
$(\w
+),string_variable_value
($1),eg
;
969 } elsif ($token eq '!') {
970 error
('negation is not allowed here')
971 unless $options{allow_negation
};
973 $token = getvalues
($code, $param);
975 error
('it is not possible to negate an array')
976 if ref $token and not $options{allow_array_negation
};
978 return bless [ $token ], 'negated';
979 } elsif ($token eq ',') {
981 if $options{comma_allowed
};
983 error
('comma is not allowed here');
984 } elsif ($token eq '=') {
985 error
('equals operator ("=") is not allowed here');
986 } elsif ($token eq '$') {
987 my $name = require_next_token
($code, $param);
988 error
('variable name expected - if you want to concatenate strings, try using double quotes')
989 unless $name =~ /^\w+$/;
991 my $value = variable_value
($name);
993 error
("no such variable: \$$name")
994 unless defined $value;
997 } elsif ($token eq '&') {
998 error
("function calls are not allowed as keyword parameter");
999 } elsif ($token eq ')' and not $options{parenthesis_allowed
}) {
1000 error
('Syntax error');
1001 } elsif ($token =~ /^@/) {
1002 if ($token eq '@resolve') {
1003 my @params = get_function_params
();
1004 error
('Usage: @resolve((hostname ...))')
1005 unless @params == 1;
1006 eval { require Net
::DNS
; };
1007 error
('For the @resolve() function, you need the Perl library Net::DNS')
1010 my $resolver = new Net
::DNS
::Resolver
;
1012 foreach my $hostname (to_array
($params[0])) {
1013 my $query = $resolver->search($hostname, $type);
1014 error
("DNS query for '$hostname' failed: " . $resolver->errorstring)
1016 foreach my $rr ($query->answer) {
1017 next unless $rr->type eq $type;
1018 push @result, $rr->address;
1023 error
("unknown ferm built-in function");
1030 # returns the next parameter, but only allow a scalar
1032 my $token = getvalues
(@_);
1034 error
('array not allowed here')
1035 if ref $token and ref $token eq 'ARRAY';
1040 sub get_function_params
(%) {
1041 my $token = next_token
();
1042 error
('function name must be followed by "()"')
1043 unless defined $token and $token eq '(';
1045 $token = peek_token
();
1046 if ($token eq ')') {
1055 $token = require_next_token
();
1059 error
('"," expected')
1060 unless $token eq ',';
1063 push @params, getvalues
(undef, undef, @_);
1069 # collect all tokens in a flat array reference until the end of the
1070 # command is reached
1071 sub collect_tokens
() {
1076 my $keyword = next_token
();
1077 error
('unexpected end of file within function/variable declaration')
1078 unless defined $keyword;
1080 if ($keyword =~ /^[\{\(]$/) {
1081 push @level, $keyword;
1082 } elsif ($keyword =~ /^[\}\)]$/) {
1083 my $expected = $keyword;
1084 $expected =~ tr/\}\)/\{\(/;
1085 my $opener = pop @level;
1086 error
("unmatched '$keyword'")
1087 unless defined $opener and $opener eq $expected;
1088 } elsif ($keyword eq ';' and @level == 0) {
1092 push @tokens, $keyword;
1095 if $keyword eq '}' and @level == 0;
1102 # returns the specified value as an array. dereference arrayrefs
1105 die unless wantarray;
1107 unless (ref $value) {
1109 } elsif (ref $value eq 'ARRAY') {
1116 # evaluate the specified value as bool
1121 unless (ref $value) {
1123 } elsif (ref $value eq 'ARRAY') {
1130 sub is_netfilter_core_target
($) {
1132 die unless defined $target and length $target;
1134 return $target =~ /^(?:ACCEPT|DROP|RETURN|QUEUE)$/;
1137 sub is_netfilter_module_target
($$) {
1138 my ($domain_family, $target) = @_;
1139 die unless defined $target and length $target;
1141 return defined $domain_family &&
1142 exists $target_defs{$domain_family} &&
1143 exists $target_defs{$domain_family}{$target};
1146 sub is_netfilter_builtin_chain
($$) {
1147 my ($table, $chain) = @_;
1149 return grep { $_ eq $chain }
1150 qw(PREROUTING INPUT FORWARD OUTPUT POSTROUTING);
1153 sub netfilter_canonical_protocol
($) {
1155 return unless defined $proto;
1157 if $proto eq 'ipv6-icmp';
1159 if $proto eq 'ipv6-mh';
1163 sub netfilter_protocol_module
($) {
1165 return unless defined $proto;
1167 if $proto eq 'icmpv6';
1171 # escape the string in a way safe for the shell
1172 sub shell_escape
($) {
1175 return $token if $token =~ /^[-_a-zA-Z0-9]+$/s;
1177 if ($option{fast
}) {
1178 # iptables-save/iptables-restore are quite buggy concerning
1179 # escaping and special characters... we're trying our best
1183 $token = '"' . $token . '"'
1184 if $token =~ /[\s\'\\;&]/s;
1187 if $token =~ /^\`.*\`$/;
1188 $token =~ s/'/\\'/g;
1189 $token = '\'' . $token . '\''
1190 if $token =~ /[\s\"\\;<>&|]/s;
1196 # append an option to the shell command line, using information from
1197 # the module definition (see %match_defs etc.)
1198 sub shell_append_option($$$$) {
1199 my ($ref, $def, $keyword, $value) = @_;
1202 if (ref $value and ref $value eq 'negated') {
1203 $value = $value->[0];
1205 if (exists $def->{pre_negation}) {
1212 unless (defined $value) {
1213 $$ref .= " --$keyword";
1214 } elsif (ref $value and ref $value eq 'params') {
1215 $$ref .= " --$keyword$negated ";
1216 $$ref .= join(' ', map { shell_escape($_) } @$value);
1217 } elsif (ref $value and ref $value eq 'multi') {
1219 $$ref .= " --$keyword " . shell_escape($_);
1222 $$ref .= " --$keyword$negated " . shell_escape($value);
1226 # dereference a bless'negated'
1227 sub extract_negation($) {
1229 ref && ref eq 'negated'
1234 # convert an internal rule structure into an iptables call
1238 my $domain = $rule->{domain};
1239 my $domain_info = $domains{$domain};
1240 $domain_info->{enabled} = 1;
1241 my $domain_family = $rule->{domain_family};
1243 my $table = $rule->{table};
1244 my $table_info = $domain_info->{tables}{$table} ||= {};
1246 my $chain = $rule->{chain};
1247 my $chain_info = $table_info->{chains}{$chain} ||= {};
1248 my $chain_rules = $chain_info->{rules} ||= [];
1250 return if $option{flush};
1252 my $action = $rule->{action};
1254 # mark this chain as "non
-empty
" because we will add stuff to
1255 # it now; this flag is later used to check if a custom chain
1256 # referenced by "jump
" was actually defined
1257 $chain_info->{non_empty} = 1;
1259 # check if the chain is already defined
1260 unless (exists $chain_info->{create} or
1261 is_netfilter_builtin_chain($table, $chain)) {
1262 $chain_info->{create} = 1;
1265 # check for unknown jump target
1266 if (defined $action and
1267 ($action->{type} eq 'jump' or
1268 $action->{type} eq 'goto') and
1269 not exists $table_info->{chains}{$action->{chain}}{create}) {
1270 my $chain = $action->{chain};
1271 $table_info->{chains}{$chain}{create} = 1;
1274 # target=policy is a special case
1275 if ($action->{type} eq 'policy') {
1276 $chain_info->{policy} = $action->{policy};
1280 # return if this is a declaration-only rule
1282 unless $rule->{has_rule};
1286 # general iptables options
1288 while (my ($keyword, $value) = each %{$rule->{builtin}}) {
1289 my $def = $match_defs{$domain_family}{''}{keywords}{$keyword};
1290 die unless defined $def;
1292 shell_append_option(\$rr, $def, $keyword, $value);
1296 # match module options
1301 if (defined $rule->{builtin}{protocol}) {
1302 my $proto = netfilter_canonical_protocol($rule->{builtin}{protocol});
1304 # special case: --dport and --sport for TCP/UDP
1305 if ($domain_family eq 'ip' and
1306 (exists $rule->{dport} or exists $rule->{sport}) and
1307 $proto =~ /^(?:tcp|udp|udplite|dccp|sctp)$/) {
1308 unless (exists $modules{$proto}) {
1309 $rr .= " -m
$proto";
1310 $modules{$proto} = 1;
1313 shell_append_option(\$rr, { params => 1,
1315 }, 'dport', $rule->{dport})
1316 if exists $rule->{dport};
1317 shell_append_option(\$rr, { params => 1,
1319 }, 'sport', $rule->{sport})
1320 if exists $rule->{sport};
1324 # modules stored in %match_defs
1326 foreach my $match (@{$rule->{match}}) {
1327 my $module_name = $match->{name};
1328 unless (exists $modules{$module_name}) {
1329 $rr .= " -m
$module_name";
1330 $modules{$module_name} = 1;
1333 my $defs = $match->{defs};
1335 while (my ($keyword, $value) = each %{$match->{options}}) {
1336 my $def = $defs->{keywords}{$keyword};
1337 die unless defined $def;
1339 shell_append_option(\$rr, $def, $keyword, $value);
1347 if ($action->{type} eq 'jump') {
1348 $rr .= " -j
" . shell_escape($action->{chain});
1349 } elsif ($action->{type} eq 'goto') {
1350 $rr .= " -g
" . shell_escape($action->{chain});
1351 } elsif ($action->{type} eq 'target') {
1352 $rr .= " -j
" . shell_escape($action->{target});
1354 # targets stored in %target_defs
1356 while (my ($keyword, $value) = each %{$rule->{target_options}}) {
1357 my $def = $target_defs{$domain_family}{$action->{target}}{keywords}{$keyword};
1358 die unless defined $def;
1360 shell_append_option(\$rr, $def, $keyword, $value);
1362 } elsif ($action->{type} ne 'nop') {
1367 push @$chain_rules, { rule => $rr,
1368 script => $rule->{script},
1372 sub transform_rule($) {
1375 $rule->{builtin}{protocol} = 'icmpv6'
1376 if $rule->{domain} eq 'ip6' and $rule->{builtin}{protocol} eq 'icmp';
1382 transform_rule($rule);
1384 # prints all rules in a hash
1389 sub check_unfold(\@$$) {
1390 my ($unfold, $parent, $key) = @_;
1392 return unless ref $parent->{$key} and
1393 ref $parent->{$key} eq 'ARRAY';
1395 push @$unfold, $parent, $key, $parent->{$key};
1398 # convert a bunch of internal rule structures in iptables calls,
1399 # unfold arrays during that
1401 # compile the list hashes into rules
1406 foreach my $key (qw(domain table chain)) {
1407 check_unfold
(@unfold, $fw, $key);
1410 foreach my $key (keys %{$fw->{builtin
}}) {
1411 check_unfold
(@unfold, $fw->{builtin
}, $key);
1414 foreach my $match (@
{$fw->{match
}}) {
1415 while (my ($key, $value) = each %{$match->{options
}}) {
1416 check_unfold
(@unfold, $match->{options
}, $key);
1420 check_unfold
(@unfold, $fw, 'sport');
1421 check_unfold
(@unfold, $fw, 'dport');
1430 my ($parent, $key, $values) = (shift, shift, shift);
1432 foreach my $value (@
$values) {
1433 $parent->{$key} = $value;
1446 sub filter_domains
($) {
1447 my $domains = shift;
1450 foreach my $domain (to_array
$domains) {
1451 next if exists $option{domain
}
1452 and $domain ne $option{domain
};
1455 initialize_domain
($domain);
1459 push @
$result, $domain;
1462 return @
$result == 1 ?
$result->[0] : $result;
1465 # parse tokens from builtin match modules
1466 sub parse_builtin_matches
($$$) {
1467 my ($current, $keyword, $negated_ref) = @_;
1469 my $domain_family = $current->{domain_family
};
1471 if (exists $match_defs{$domain_family}) {
1472 parse_option
($match_defs{$domain_family}, '',
1473 $current, $current->{builtin
},
1474 $keyword, $negated_ref)
1481 # parse a keyword from a module definition
1482 sub parse_keyword
($$$$) {
1483 my ($current, $def, $keyword, $negated_ref) = @_;
1485 my $params = $def->{params
};
1490 if ($$negated_ref && exists $def->{pre_negation
}) {
1492 undef $$negated_ref;
1495 unless (defined $params) {
1497 } elsif (ref $params && ref $params eq 'CODE') {
1498 $value = &$params($current);
1499 } elsif ($params eq 'm') {
1500 $value = bless [ to_array getvalues
() ], 'multi';
1501 } elsif ($params =~ /^[a-z]/) {
1502 if (exists $def->{negation
} and not $negated) {
1503 my $token = peek_token
();
1504 if ($token eq '!') {
1511 foreach my $p (split(//, $params)) {
1513 push @params, getvar
();
1514 } elsif ($p eq 'c') {
1515 my @v = to_array getvalues
(undef, undef,
1517 push @params, join(',', @v);
1523 $value = @params == 1
1525 : bless \
@params, 'params';
1526 } elsif ($params == 1) {
1527 if (exists $def->{negation
} and not $negated) {
1528 my $token = peek_token
();
1529 if ($token eq '!') {
1535 $value = getvalues
();
1537 warning
("log-prefix is too long; truncating to 29 characters: '$1'")
1538 if $keyword eq 'log-prefix' && $value =~ s
,^(.{29}).+$,$1,;
1540 if (exists $def->{negation
} and not $negated) {
1541 my $token = peek_token
();
1542 if ($token eq '!') {
1548 $value = bless [ map {
1550 } (1..$params) ], 'params';
1553 $value = bless [ $value ], 'negated'
1559 # parse options of a module
1560 sub parse_option
($$$$$$) {
1561 my ($defs, $name, $current, $store, $keyword, $negated_ref) = @_;
1563 my $def = $defs->{$name};
1564 return unless defined $def;
1566 my $k = $def->{keywords
}{$keyword};
1567 return unless defined $k;
1569 while (exists $k->{alias
}) {
1570 die if $k->{alias
} eq $keyword;
1571 $keyword = $k->{alias
};
1572 $k = $defs->{$name}{keywords
}{$keyword};
1573 die unless defined $k;
1577 = parse_keyword
($current, $k,
1578 $keyword, $negated_ref);
1579 $current->{has_rule
} = 1;
1583 # parse options for a protocol module definition
1584 sub parse_protocol_options
($$$$) {
1585 my ($current, $proto, $keyword, $negated_ref) = @_;
1587 my $domain_family = $current->{'domain_family'};
1588 my $proto_defs = $proto_defs{$domain_family};
1589 return unless defined $proto_defs;
1591 my $proto_def = $proto_defs->{$proto};
1592 return unless defined $proto_def;
1594 return unless exists $proto_def->{keywords
}{$keyword};
1596 my $module_name = $proto eq 'icmpv6' ?
'icmp6' : $proto;
1597 my @m = grep { $_->{name
} eq $proto } @
{$current->{match
}};
1600 $module = { name
=> $module_name,
1604 push @
{$current->{match
}}, $module;
1610 return parse_option
($proto_defs, $proto,
1611 $current, $module->{options
},
1612 $keyword, $negated_ref);
1615 # parse options of a match module
1616 sub parse_match_option
($$$$$$) {
1617 my ($match_defs, $name, $current, $store, $keyword, $negated_ref) = @_;
1619 return parse_option
($match_defs, $name,
1621 $keyword, $negated_ref);
1624 # parse options for a match module definition
1625 sub parse_module_options
($$$) {
1626 my ($current, $keyword, $negated_ref) = @_;
1628 my $domain_family = $current->{'domain_family'};
1629 my $match_defs = $match_defs{$domain_family};
1630 return unless defined $match_defs;
1632 # modules stored in %match_defs
1633 foreach my $module (@
{$current->{match
}}) {
1634 parse_match_option
($match_defs, $module->{name
},
1635 $current, $module->{options
},
1636 $keyword, $negated_ref)
1647 # parse options for a target module definition
1648 sub parse_target_options
($$$) {
1649 my ($current, $target, $keyword) = @_;
1651 my $domain_family = $current->{'domain_family'};
1652 my $target_defs = $target_defs{$domain_family};
1653 return unless defined $target_defs &&
1654 exists $target_defs->{$target}{keywords
}{$keyword};
1656 my $k = $target_defs->{$target}{keywords
}{$keyword};
1658 while (exists $k->{alias
}) {
1659 die if $k->{alias
} eq $keyword;
1660 $keyword = $k->{alias
};
1661 $k = $target_defs->{$target}{keywords
}{$keyword};
1662 die unless defined $k;
1666 $current->{target_options
}{$keyword}
1667 = parse_keyword
($current, $k,
1668 $keyword, \
$negated_dummy);
1673 sub clone_match
($) {
1675 return { name
=> $match->{name
},
1676 options
=> { %{$match->{options
}} },
1677 defs
=> $match->{defs
},
1681 sub new_level
(\
%$) {
1682 my ($current, $prev) = @_;
1685 if (defined $prev) {
1686 # copy data from previous level
1687 $current->{builtin
} = { %{$prev->{builtin
}} };
1688 $current->{match
} = [ map { clone_match
($_) } @
{$prev->{match
}} ];
1689 $current->{action
} = { %{$prev->{action
}} };
1690 foreach my $key (qw(domain domain_family table chain proto sport dport)) {
1691 $current->{$key} = $prev->{$key}
1692 if exists $prev->{$key};
1695 $current->{builtin
} = {};
1696 $current->{match
} = [];
1697 $current->{action
} = {};
1701 sub rule_defined
(\
%) {
1703 return defined($rule->{domain
}) or
1704 keys(%{$rule->{builtin
}}) > 0 or
1705 keys(%{$rule->{match
}}) > 0 or
1706 keys(%{$rule->{action
}}) > 0;
1709 # the main parser loop: read tokens, convert them into internal rule
1712 my $lev = shift; # current recursion depth
1713 my $prev = shift; # previous rule hash
1715 # enter is the core of the firewall setup, it is a
1716 # simple parser program that recognizes keywords and
1717 # retreives parameters to set up the kernel routing
1720 my $base_level = $script->{base_level
} || 0;
1721 die if $base_level > $lev;
1724 new_level
(%current, $prev);
1726 # read keywords 1 by 1 and dump into parser
1727 while (defined (my $keyword = next_token
())) {
1728 # check if the current rule should be negated
1729 my $negated = $keyword eq '!';
1731 # negation. get the next word which contains the 'real'
1733 $keyword = getvar
();
1735 error
('unexpected end of file after negation')
1736 unless defined $keyword;
1739 # the core: parse all data
1740 SWITCH
: for ($keyword)
1742 # deprecated keyword?
1743 if (exists $deprecated_keywords{$keyword}) {
1744 my $new_keyword = $deprecated_keywords{$keyword};
1745 warning
("'$keyword' is deprecated, please use '$new_keyword' instead");
1746 $keyword = $new_keyword;
1749 # effectuation operator
1750 if ($keyword eq ';') {
1751 if ($current{has_rule
} and not $current{action
}{type
}) {
1752 # something is wrong when a rule was specifiedd,
1754 error
('No action defined; did you mean "NOP"?');
1757 error
('No chain defined') unless defined $current{chain
};
1759 $current{script
} = { filename
=> $script->{filename
},
1760 line
=> $script->{line
},
1765 # and clean up variables set in this level
1766 new_level
(%current, $prev);
1771 # conditional expression
1772 if ($keyword eq '@if') {
1773 unless (eval_bool
(getvalues
)) {
1775 my $token = peek_token
();
1776 require_next_token
() if $token and $token eq '@else';
1782 if ($keyword eq '@else') {
1783 # hack: if this "else" has not been eaten by the "if"
1784 # handler above, we believe it came from an if clause
1785 # which evaluated "true" - remove the "else" part now.
1790 # hooks for custom shell commands
1791 if ($keyword eq 'hook') {
1792 error
('"hook" must be the first token in a command')
1793 if rule_defined
(%current);
1795 my $position = getvar
();
1797 if ($position eq 'pre') {
1798 $hooks = \
@pre_hooks;
1799 } elsif ($position eq 'post') {
1800 $hooks = \
@post_hooks;
1802 error
("Invalid hook position: '$position'");
1805 push @
$hooks, getvar
();
1807 $keyword = next_token
();
1808 error
('";" expected after hook declaration')
1809 unless defined $keyword and $keyword eq ';';
1814 # recursing operators
1815 if ($keyword eq '{') {
1817 my $old_stack_depth = @stack;
1819 unshift @stack, { auto
=> { %{$stack[0]{auto
} || {}} } };
1822 enter
($lev + 1, \
%current);
1826 die unless @stack == $old_stack_depth;
1828 # after a block, the command is finished, clear this
1830 new_level
(%current, $prev);
1835 if ($keyword eq '}') {
1836 error
('Unmatched "}"')
1837 if $lev <= $base_level;
1839 # consistency check: check if they havn't forgotten
1840 # the ';' before the last statement
1841 error
('Missing semicolon before "}"')
1842 if $current{has_rule
};
1848 # include another file
1849 if ($keyword eq '@include' or $keyword eq 'include') {
1850 my @files = collect_filenames to_array getvalues
;
1851 $keyword = next_token
;
1852 error
('Missing ";" - "include FILENAME" must be the last command in a rule')
1853 unless defined $keyword and $keyword eq ';';
1855 foreach my $filename (@files) {
1856 # save old script, open new script
1857 my $old_script = $script;
1858 open_script
($filename);
1859 $script->{base_level
} = $lev + 1;
1862 my $old_stack_depth = @stack;
1867 # include files may set variables for their parent
1868 $stack->{vars
} = ($stack[0]{vars
} ||= {});
1869 $stack->{functions
} = ($stack[0]{functions
} ||= {});
1870 $stack->{auto
} = { %{ $stack[0]{auto
} || {} } };
1873 unshift @stack, $stack;
1876 enter
($lev + 1, \
%current);
1880 die unless @stack == $old_stack_depth;
1882 # restore old script
1883 $script = $old_script;
1889 # definition of a variable or function
1890 if ($keyword eq '@def' or $keyword eq 'def') {
1891 error
('"def" must be the first token in a command')
1892 if $current{has_rule
};
1894 my $type = require_next_token
();
1896 my $name = require_next_token
();
1897 error
('invalid variable name')
1898 unless $name =~ /^\w+$/;
1900 $keyword = require_next_token
();
1901 error
('"=" expected after variable name')
1902 unless $keyword eq '=';
1904 my $value = getvalues
(undef, undef, allow_negation
=> 1);
1906 $keyword = next_token
();
1907 error
('";" expected after variable declaration')
1908 unless defined $keyword and $keyword eq ';';
1910 $stack[0]{vars
}{$name} = $value
1911 unless exists $stack[-1]{vars
}{$name};
1912 } elsif ($type eq '&') {
1913 my $name = require_next_token
();
1914 error
('invalid function name')
1915 unless $name =~ /^\w+$/;
1918 my $token = next_token
();
1919 error
('function parameter list or "()" expected')
1920 unless defined $token and $token eq '(';
1922 $token = require_next_token
();
1923 last if $token eq ')';
1926 error
('"," expected')
1927 unless $token eq ',';
1929 $token = require_next_token
();
1932 error
('"$" and parameter name expected')
1933 unless $token eq '$';
1935 $token = require_next_token
();
1936 error
('invalid function parameter name')
1937 unless $token =~ /^\w+$/;
1939 push @params, $token;
1944 $function{params
} = \
@params;
1946 $keyword = require_next_token
;
1947 error
('"=" expected')
1948 unless $keyword eq '=';
1950 my $tokens = collect_tokens
();
1951 $function{block
} = 1 if grep { $_ eq '{' } @
$tokens;
1952 $function{tokens
} = $tokens;
1954 $stack[0]{functions
}{$name} = \
%function
1955 unless exists $stack[-1]{functions
}{$name};
1957 error
('"$" (variable) or "&" (function) expected');
1964 if ($keyword eq '$') {
1965 error
('variable references are only allowed as keyword parameter');
1968 if ($keyword eq '&') {
1969 my $name = require_next_token
;
1970 error
('function name expected')
1971 unless $name =~ /^\w+$/;
1975 $function = $_->{functions
}{$name};
1976 last if defined $function;
1978 error
("no such function: \&$name")
1979 unless defined $function;
1981 my $paramdef = $function->{params
};
1982 die unless defined $paramdef;
1984 my @params = get_function_params
(allow_negation
=> 1);
1986 error
("Wrong number of parameters for function '\&$name': "
1987 . @
$paramdef . " expected, " . @params . " given")
1988 unless @params == @
$paramdef;
1991 for (my $i = 0; $i < @params; $i++) {
1992 $vars{$paramdef->[$i]} = $params[$i];
1995 if ($function->{block
}) {
1996 # block {} always ends the current rule, so if the
1997 # function contains a block, we have to require
1998 # the calling rule also ends here
1999 my $token = next_token
();
2000 error
("';' expected after block function call '\&$name'")
2001 unless defined $token and $token eq ';';
2004 my @tokens = @
{$function->{tokens
}};
2005 for (my $i = 0; $i < @tokens; $i++) {
2006 if ($tokens[$i] eq '$' and $i + 1 < @tokens and
2007 exists $vars{$tokens[$i + 1]}) {
2008 my @value = to_array
($vars{$tokens[$i + 1]});
2009 @value = ('(', @value, ')')
2010 unless @tokens == 1;
2011 splice(@tokens, $i, 2, @value);
2013 } elsif ($tokens[$i] =~ m
,^"(.*)"$,) {
2014 $tokens[$i] =~ s
,\
$(\w
+),exists $vars{$1} ?
$vars{$1} : "\$$1",eg
;
2018 unshift @
{$script->{tokens
}}, @tokens;
2023 # where to put the rule?
2024 if ($keyword eq 'domain') {
2025 error
('Domain is already specified')
2026 if exists $current{domain
};
2028 my $domain = getvalues
();
2029 my $filtered_domain = filter_domains
($domain);
2031 unless (ref $domain) {
2032 $domain_family = $domain eq 'ip6' ?
'ip' : $domain;
2033 } elsif (@
$domain == 0) {
2034 $domain_family = 'none';
2035 } elsif (grep { not /^ip6?$/s } @
$domain) {
2036 error
('Cannot combine non-IP domains');
2038 $domain_family = 'ip';
2040 $current{domain_family
} = $domain_family;
2042 $current{domain
} = $stack[0]{auto
}{DOMAIN
} = $filtered_domain;
2047 if ($keyword eq 'table') {
2048 error
('Table is already specified')
2049 if exists $current{table
};
2050 $current{table
} = $stack[0]{auto
}{TABLE
} = getvalues
();
2052 unless (exists $current{domain
}) {
2053 $current{domain
} = filter_domains
('ip');
2054 $current{domain_family
} = 'ip';
2060 if ($keyword eq 'chain') {
2061 error
('Chain is already specified')
2062 if exists $current{chain
};
2063 $current{chain
} = $stack[0]{auto
}{CHAIN
} = getvalues
();
2065 # ferm 1.1 allowed lower case built-in chain names
2066 foreach (ref $current{chain
} ? @
{$current{chain
}} : $current{chain
}) {
2067 error
('Please write built-in chain names in upper case')
2068 if /^(?:input|forward|output|prerouting|postrouting)$/;
2071 unless (exists $current{domain
}) {
2072 $current{domain
} = filter_domains
('ip');
2073 $current{domain_family
} = 'ip';
2076 $current{table
} = 'filter'
2077 unless exists $current{table
};
2082 error
('Chain must be specified')
2083 unless exists $current{chain
};
2085 # policy for built-in chain
2086 if ($keyword eq 'policy') {
2087 error
('Cannot specify matches for policy')
2088 if $current{has_rule
};
2090 my $policy = uc getvar
();
2091 error
("Invalid policy target: $policy")
2092 unless $policy =~ /^(?:ACCEPT|DROP)$/;
2094 $keyword = peek_token
();
2095 error
('";" expected after policy declaration')
2096 unless defined $keyword and $keyword eq ';';
2098 $current{action
} = { type
=> 'policy',
2105 if ($keyword eq '@subchain' or $keyword eq 'subchain') {
2106 error
('No rule specified before "@subchain"')
2107 unless $current{has_rule
};
2110 $keyword = next_token
();
2112 if ($keyword =~ /^(["'])(.*)\1$/s) {
2114 $keyword = next_token
();
2116 $subchain = 'ferm_auto_' . ++$auto_chain;
2119 error
('"{" or chain name expected after "sub"')
2120 unless $keyword eq '{';
2122 # create a deep copy of %current, only containing values
2123 # which must be in the subchain
2124 my %inner = ( builtin
=> {},
2127 $inner{domain
} = $current{domain
};
2128 $inner{domain_family
} = $current{domain_family
};
2129 $inner{table
} = $current{table
};
2130 $inner{chain
} = $inner{auto
}{CHAIN
} = $subchain;
2131 $inner{builtin
}{protocol
} = $current{builtin
}{protocol
}
2132 if exists $current{builtin
}{protocol
};
2137 # now handle the parent - it's a jump to the sub chain
2138 $current{action
} = { type
=> 'jump',
2142 $current{script
} = { filename
=> $script->{filename
},
2143 line
=> $script->{line
},
2148 # and clean up variables set in this level
2149 new_level
(%current, $prev);
2154 # everything else must be part of a "real" rule, not just
2156 $current{has_rule
}++;
2158 # extended parameters:
2159 if ($keyword =~ /^mod(?:ule)?$/) {
2160 foreach my $module (to_array getvalues
) {
2161 next if grep { $_->{name
} eq $module } @
{$current{match
}};
2163 my $domain_family = $current{domain_family
};
2164 my $defs = $match_defs{$domain_family}{$module};
2165 if (not defined $defs and exists $current{builtin
}{protocol
}) {
2166 my $proto = netfilter_canonical_protocol
($current{builtin
}{protocol
});
2167 $defs = $proto_defs{$domain_family}{$proto};
2170 push @
{$current{match
}}, { name
=> $module,
2179 parse_builtin_matches
(\
%current, $keyword, \
$negated)
2187 if ($keyword eq 'jump') {
2188 error
('There can only one action per rule')
2189 if defined $current{action
}{type
};
2190 my $chain = getvar
();
2191 if (is_netfilter_core_target
($chain) or
2192 is_netfilter_module_target
($current{domain_family
}, $chain)) {
2193 $current{action
} = { type
=> 'target',
2197 $current{action
} = { type
=> 'jump',
2205 if ($keyword eq 'realgoto') {
2206 error
('There can only one action per rule')
2207 if defined $current{action
}{type
};
2208 $current{action
} = { type
=> 'goto',
2215 if (is_netfilter_core_target
($keyword)) {
2216 error
('There can only one action per rule')
2217 if defined $current{action
}{type
};
2218 $current{action
} = { type
=> 'target',
2224 if ($keyword eq 'NOP') {
2225 error
('There can only one action per rule')
2226 if defined $current{action
}{type
};
2227 $current{action
} = { type
=> 'nop',
2232 if (is_netfilter_module_target
($current{domain_family
}, $keyword)) {
2233 error
('There can only one action per rule')
2234 if defined $current{action
}{type
};
2236 if ($keyword eq 'TCPMSS') {
2237 my $protos = $current{builtin
}{protocol
};
2238 error
('No protocol specified before TCPMSS')
2239 unless defined $protos;
2240 foreach my $proto (to_array
$protos) {
2241 error
('TCPMSS not available for protocol "$proto"')
2242 unless $proto eq 'tcp';
2246 $current{action
} = { type
=> 'target',
2252 my $proto = $current{builtin
}{protocol
};
2255 # module specific options
2258 parse_module_options
(\
%current, $keyword, \
$negated)
2262 # protocol specific options
2265 if (defined $proto and not ref $proto) {
2266 $proto = netfilter_canonical_protocol
($proto);
2268 if ($proto eq 'icmp') {
2269 my $domains = $current{domain
};
2270 $proto = 'icmpv6' if not ref $domains and $domains eq 'ip6';
2273 parse_protocol_options
(\
%current, $proto, $keyword, \
$negated)
2278 if ($keyword =~ /^[sd]port$/) {
2279 error
('To use sport or dport, you have to specify "proto tcp" or "proto udp" first')
2280 unless defined $proto and grep { /^(?:tcp|udp|udplite|dccp|sctp)$/ } to_array
$proto;
2282 $current{$keyword} = getvalues
(undef, undef,
2283 allow_negation
=> 1);
2288 # target specific options
2291 if (exists $current{action
}{type
} and
2292 $current{action
}{type
} eq 'target') {
2293 parse_target_options
(\
%current, $current{action
}{target
},
2299 error
("Unrecognized keyword: $keyword");
2302 # if the rule didn't reset the negated flag, it's not
2304 error
("Doesn't support negation: $keyword")
2308 error
('Missing "}" at end of file')
2309 if $lev > $base_level;
2311 # consistency check: check if they havn't forgotten
2312 # the ';' before the last statement
2313 error
("Missing semicolon before end of file")
2314 if $current{has_rule
}; # XXX
2318 while (my ($domain_name, $domain) = each %domains) {
2319 while (my ($table_name, $table_info) = each %{$domain->{tables
}}) {
2320 while (my ($chain_name, $chain) = each %{$table_info->{chains
}}) {
2321 warning
("chain $chain_name (domain $domain_name, table $table_name) was referenced, but not declared")
2322 if $chain->{was_created
} and not $chain->{non_empty
};
2328 sub execute_command
{
2329 my ($command, $script) = @_;
2331 print LINES
"$command\n"
2333 return if $option{noexec
};
2335 my $ret = system($_);
2336 unless ($ret == 0) {
2338 print STDERR
"failed to execute: $!\n";
2340 } elsif ($?
& 0x7f) {
2341 printf STDERR
"child died with signal %d\n", $?
& 0x7f;
2344 print STDERR
"(rule declared in $script->{filename}:$script->{line})\n"
2353 sub execute_slow
($$) {
2354 my ($domain, $domain_info) = @_;
2356 my $domain_cmd = $domain_info->{tools
}{tables
};
2358 while (my ($table, $table_info) = each %{$domain_info->{tables
}}) {
2359 my $table_cmd = "$domain_cmd -t $table";
2361 # reset chain policies
2362 while (my ($chain, $chain_info) = each %{$table_info->{chains
}}) {
2363 next unless $chain_info->{builtin
} or
2364 (not $table_info->{has_builtin
} and
2365 is_netfilter_builtin_chain
($table, $chain));
2366 $status ||= execute_command
("$table_cmd -P $chain ACCEPT");
2370 $status ||= execute_command
("$table_cmd -F");
2371 $status ||= execute_command
("$table_cmd -X");
2373 # create chains / set policy
2374 while (my ($chain, $chain_info) = each %{$table_info->{chains
}}) {
2375 if ($chain_info->{create
}) {
2376 $status ||= execute_command
("$table_cmd -N $chain");
2377 } elsif (exists $chain_info->{policy
}) {
2378 $status ||= execute_command
("$table_cmd -P $chain $chain_info->{policy}");
2383 while (my ($chain, $chain_info) = each %{$table_info->{chains
}}) {
2384 my $chain_cmd = "$table_cmd -A $chain";
2385 foreach my $rule (@
{$chain_info->{rules
}}) {
2386 $status ||= execute_command
($chain_cmd . $rule->{rule
});
2394 sub rules_to_save
($$) {
2395 my ($domain, $domain_info) = @_;
2397 # convert this into an iptables-save text
2398 my $result = "# Generated by ferm $VERSION on " . localtime() . "\n";
2400 while (my ($table, $table_info) = each %{$domain_info->{tables
}}) {
2402 $result .= '*' . $table . "\n";
2404 # create chains / set policy
2405 foreach my $chain (sort keys %{$table_info->{chains
}}) {
2406 my $chain_info = $table_info->{chains
}{$chain};
2407 my $policy = $chain_info->{create
}
2408 ?
'-' : ($chain_info->{policy
} || 'ACCEPT');
2409 $result .= ":$chain $policy\ [0:0]\n";
2413 foreach my $chain (sort keys %{$table_info->{chains
}}) {
2414 my $chain_info = $table_info->{chains
}{$chain};
2415 foreach my $rule (@
{$chain_info->{rules
}}) {
2416 $result .= "-A $chain$rule->{rule}\n";
2421 $result .= "COMMIT\n";
2427 sub restore_domain
($$) {
2428 my ($domain, $save) = @_;
2430 my $path = $domains{$domain}{tools
}{'tables-restore'};
2433 open RESTORE
, "|$path"
2434 or die "Failed to run $path: $!\n";
2436 print RESTORE
$save;
2439 or die "Failed to run $path\n";
2442 sub execute_fast
($$) {
2443 my ($domain, $domain_info) = @_;
2445 my $save = rules_to_save
($domain, $domain_info);
2447 if ($option{lines
}) {
2448 print LINES
"$domain_info->{tools}{'tables-restore'} <<EOT\n"
2455 return if $option{noexec};
2458 restore_domain($domain, $save);
2470 while (my ($domain, $domain_info) = each %domains) {
2471 next unless $domain_info->{enabled};
2472 unless (defined $domain_info->{tools}{'tables-restore'}) {
2473 print STDERR "Cannot rollback domain
'$domain' because there is
no ${domain
}tables
-restore
\n";
2478 while (my ($table, $table_info) = each %{$domain_info->{tables}}) {
2479 my $reset_chain = '';
2480 foreach my $chain (keys %{$table_info->{chains}{$table}}) {
2481 next unless is_netfilter_builtin_chain($table, $chain);
2482 $reset_chain .= ":${chain
} ACCEPT
[0:0]\n";
2484 $reset .= "*${table
}\n${reset_chain
}COMMIT
\n"
2485 if length $reset_chain;
2488 $reset .= $domain_info->{previous}
2489 if defined $domain_info->{previous};
2491 restore_domain($domain, $reset);
2494 print STDERR "\nFirewall rules rolled back
.\n" unless $error;
2499 # do nothing, just interrupt a system call
2502 sub confirm_rules() {
2503 $SIG{ALRM} = \&alrm_handler;
2508 . "ferm has applied the new firewall rules
.\n"
2509 . "Please type
'yes' to confirm
:\n";
2515 STDIN->sysread($line, 3);
2519 POSIX::tcflush(*STDIN, 2);
2521 print STDERR "$@
" if $@;
2523 $SIG{ALRM} = 'DEFAULT';
2525 return $line eq 'yes';
2534 ferm - a firewall rule parser for linux
2538 B<ferm> I<options> I<inputfiles>
2542 -n, --noexec Do not execute the rules, just simulate
2543 -F, --flush Flush all netfilter tables managed by ferm
2544 -l, --lines Show all rules that were created
2545 -i, --interactive Interactive mode: revert if user does not confirm
2546 --remote Remote mode; ignore host specific configuration.
2547 This implies --noexec and --lines.
2548 -V, --version Show current version number
2549 -h, --help Look at this text
2550 --fast Generate an iptables-save file, used by iptables-restore
2551 --shell Generate a shell script which calls iptables-restore
2552 --domain {ip|ip6} Handle only the specified domain
2553 --def '$name=v' Override a variable