src/import-ferm

   1 #!/usr/bin/perl
   2
   3 #
   4 # ferm, a firewall setup program that makes firewall rules easy!
   5 #
   6 # Copyright (C) 2001-2006 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 # This tool allows you to import an existing firewall configuration
  13 # into ferm.
  14
  15 #
  16 # This program is free software; you can redistribute it and/or modify
  17 # it under the terms of the GNU General Public License as published by
  18 # the Free Software Foundation; either version 2 of the License, or
  19 # (at your option) any later version.
  20 #
  21 # This program is distributed in the hope that it will be useful,
  22 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 # GNU General Public License for more details.
  25 #
  26 # You should have received a copy of the GNU General Public License
  27 # along with this program; if not, write to the Free Software
  28 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  29 #
  30
  31 # $Id$
  32
  33 use strict;
  34
  35 use Data::Dumper;
  36
  37 use vars qw($indent $table $chain @rules);
  38
  39 sub parse_table {
  40     map {
  41         /(.+)=(.+)/ ? ( $1 => $2 ) : ( $_ => $_ )
  42     } split(/\s+/s, shift);
  43 }
  44
  45 my %p0 = parse_table(<<EOT);
  46 f=fragment
  47 syn
  48 clamp-mss-to-pmtu
  49 ecn-tcp-cwr ecn-tcp-ece
  50 physdev-is-in physdev-is-out physdev-is-bridged
  51 set rcheck update remove rttl
  52 save-mark restore-mark
  53 log-tcp-sequence log-tcp-options log-ip-options log-uid
  54 continue tee
  55 strict next
  56 fragres fragfirst fragmore fraglast
  57 nodst
  58 ecn-tcp-remove
  59 EOT
  60
  61 my %p1 = parse_table(<<EOT);
  62 i=interface o=outerface
  63 s=saddr d=daddr
  64 dport sport
  65 reject-with icmp-type icmpv6-type
  66 to-destination to-ports to
  67 tos mark
  68 tcp-option mss set-mss
  69 ttl-set
  70 ulog-nlgroup ulog-prefix ulog-cprange ulog-qthreshold
  71 src-type dst-type
  72 ahspi
  73 ctstate ctproto ctorigsrc ctorigdst ctreplsrc ctrepldst ctstatus ctexpire
  74 dscp dscp-class
  75 dstlimit
  76 ecn-ip-ect
  77 espspi
  78 helper
  79 iplimit-above iplimit-mask
  80 src-range dst-range
  81 length
  82 limit limit-burst
  83 mac-source
  84 every counter start packet
  85 uid-owner gid-owner pid-owner sid-owner cmd-owner
  86 physdev-in physdev-out
  87 pkt-type
  88 psd-weight-threshold psd-delay-threshold
  89 psd-lo-ports-weight psd-hi-ports-weight
  90 average
  91 realm
  92 name seconds hitcount
  93 timestart timestop days datestart datestop
  94 tos
  95 ttl-eq ttl-gt ttl-lt
  96 set-class
  97 set-mark mask
  98 log-level log-prefix
  99 oif iif gw
 100 set-tos
 101 ttl-set ttl-dec ttl-inc
 102 comment
 103 dir pol reqid spi proto mode tunnel-src tunnel-dst
 104 dst-len
 105 fragid fraglen
 106 dccp-option
 107 queue-num
 108 set-dscp set-dscp-class
 109 EOT
 110
 111 my %p1c = parse_table(<<EOT);
 112 state
 113 source-ports destination-ports ports
 114 dst-opts
 115 dccp-types
 116 EOT
 117
 118 my %p1multi = parse_table(<<EOT);
 119 to-source
 120 EOT
 121
 122 my %p2c = parse_table(<<EOT);
 123 tcp-flags
 124 chunk-types
 125 EOT
 126
 127 my @pre_negated = qw(fragment connbytes connlimit-above
 128 rr ts ra any-opt
 129 set rcheck update remove seconds hitcount
 130 syn mss
 131 );
 132
 133 my @mix_negated = qw(
 134 iplimit-above
 135 src-range dst-range
 136 realm
 137 );
 138
 139 my @negated = qw(
 140 protocol saddr daddr interface outerface sport dport
 141 ahspi condition connrate
 142 ctorigsrc ctorigdst ctreplsrc ctrepldst
 143 espspi src-cc dst-cc
 144 icmp-type icmpv6-type
 145 mac-source source-ports destination-ports ports
 146 genre realm chunk-types
 147 tcp-flags tcp-option
 148 dst-len
 149 fragid fraglen
 150 dccp-types dccp-option
 151 );
 152
 153 sub is_netfilter_core_target {
 154     my $target = shift;
 155     die unless defined $target and length $target;
 156
 157     return $target =~ /(?:ACCEPT|DROP|RETURN|QUEUE|NOP)$/;
 158 }
 159
 160 sub is_netfilter_module_target {
 161     my $target = shift;
 162     die unless defined $target and length $target;
 163
 164     return $target =~ /(?:BALANCE|CLASSIFY|CLUSTERIP|CONNMARK
 165                          |DNAT|DSCP|ECN|LOG|MARK|MASQUERADE
 166                          |MIRROR|NETMAP|REDIRECT|REJECT|ROUTE
 167                          |SNAT|TCPMSS|TOS|TRACE|TTL|ULOG
 168                          |TARPIT
 169                        )/x;
 170 }
 171
 172 sub ferm_escape {
 173     local $_ = shift;
 174     return $_ unless /[^-\w.:]/s;
 175     return "\'$_\'";
 176 }
 177
 178 sub format_array {
 179     my $a = shift;
 180     return ferm_escape($a) unless ref $a;
 181     return ferm_escape($a->[0]) if @$a == 1;
 182     return '(' . join(' ', @$a) . ')';
 183 }
 184
 185 sub write_line {
 186     # write a line of tokens, with indent handling
 187
 188     # don't add space before semicolon
 189     my $comma = $_[-1] eq ';' ? pop : '';
 190     # begins with closing curly braces -> decrease indent
 191     $indent -= 4 if $_[0] =~ /^}/;
 192     # do print line
 193     print ' ' x $indent;
 194     print join(' ', @_);
 195     print "$comma\n";
 196     # ends with opening curly braces -> increase indent
 197     $indent += 4 if $_[-1] =~ /{$/;
 198 }
 199
 200 sub module_match_count {
 201     my ($module, $rules) = @_;
 202     my $count = 0;
 203     foreach (@$rules) {
 204         last unless $_->{mod}{$module};
 205         $count++;
 206     }
 207     return $count;
 208 }
 209
 210 sub prefix_matches {
 211     my ($prefix, $rule) = @_;
 212     return unless exists $rule->{match};
 213     while (my ($key, $value) = each %$prefix) {
 214         return unless exists $rule->{match}{$key}
 215           and Dumper($rule->{match}{$key}) eq Dumper($value);
 216     }
 217     return 1;
 218 }
 219
 220 sub prefix_match_count {
 221     my ($prefix, $rules) = @_;
 222     my $count = 0;
 223     foreach (@$rules) {
 224         last unless prefix_matches($prefix, $_);
 225         $count++;
 226     }
 227     return $count;
 228 }
 229
 230 sub is_merging_array_member {
 231     my $value = shift;
 232     return defined $value &&
 233       ((!ref($value)) or
 234        ref $value eq 'ARRAY');
 235 }
 236
 237 sub array_matches {
 238     my ($key, $rule1, $rule2) = @_;
 239     return unless is_merging_array_member($rule1->{match}{$key});
 240     return unless is_merging_array_member($rule2->{match}{$key});
 241     my %r1 = %$rule1;
 242     my %r2 = %$rule2;
 243     $r1{match} = {%{$r1{match}}};
 244     $r2{match} = {%{$r2{match}}};
 245     delete $r1{match}{$key};
 246     delete $r2{match}{$key};
 247     return Dumper(\%r1) eq Dumper(\%r2);
 248 }
 249
 250 sub array_match_count {
 251     my ($key, $first, $rules) = @_;
 252     my $count = 0;
 253     foreach (@$rules) {
 254         last unless array_matches($key, $first, $_);
 255         $count++;
 256     }
 257     return $count;
 258 }
 259
 260 sub optimize {
 261     my @result;
 262
 263     # try to combine rules with arrays:
 264     # saddr 1.2.3.4 proto tcp ACCEPT;
 265     # saddr 5.6.7.8 proto tcp ACCEPT;
 266     # ->
 267     # saddr (1.2.3.4 5.6.7.8) proto tcp ACCEPT;
 268     while (@_ > 0) {
 269         my $rule = shift;
 270         if (exists $rule->{match}) {
 271             my $match_key;
 272             my $match_count = 0;
 273             my %match_copy = %{$rule->{match}};
 274             while (my ($key, $value) = each %match_copy) {
 275                 next unless defined $value;
 276                 next if ref $value and ref $value eq 'HASH';
 277                 my $match_count2 = array_match_count($key, $rule, \@_);
 278                 if ($match_count2 > $match_count) {
 279                     $match_key = $key;
 280                     $match_count = $match_count2;
 281                 }
 282             }
 283
 284             if ($match_count > 0) {
 285                 my @values = map {
 286                     my $value = $_->{match}{$match_key};
 287                     ref $value ? @$value : $value;
 288                 } ($rule, splice(@_, 0, $match_count));
 289                 $rule->{match}{$match_key} = \@values;
 290                 unshift @_, $rule;
 291             } else {
 292                 push @result, $rule;
 293             }
 294         } else {
 295             push @result, $rule;
 296         }
 297     }
 298
 299     @_ = @result;
 300     undef @result;
 301
 302     # try to find a common prefix for modules
 303     # mod state state INVALID DROP;
 304     # mod state state (ESTABLISHED RELATED) ACCEPT;
 305     # ->
 306     # mod state {
 307     #     state INVALID DROP;
 308     #     state (ESTABLISHED RELATED) ACCEPT;
 309     # }
 310     while (@_ > 0) {
 311         my $rule = shift;
 312         if (exists $rule->{mod}) {
 313             my $match_module;
 314             my $match_count = 0;
 315             foreach my $module (keys %{$rule->{mod}}) {
 316                 my $match_count2 = module_match_count($module, \@_);
 317                 if ($match_count2 > $match_count) {
 318                     $match_module = $module;
 319                     $match_count = $match_count2;
 320                 }
 321             }
 322             if ($match_count > 0) {
 323                 my @block = map {
 324                     delete $_->{mod}{$match_module};
 325                     $_;
 326                 } ($rule, splice(@_, 0, $match_count));
 327                 push @result, { mod => { $match_module => 1 },
 328                                 block => [ optimize(@block) ],
 329                               };
 330             } else {
 331                 push @result, $rule;
 332             }
 333         } else {
 334             push @result, $rule;
 335         }
 336     }
 337
 338     @_ = @result;
 339     undef @result;
 340
 341     # try to find a common prefix and put rules in a block:
 342     # saddr 1.2.3.4 proto tcp dport ssh ACCEPT;
 343     # saddr 5.6.7.8 proto tcp dport ssh DROP;
 344     # ->
 345     # proto tcp dport ssh {
 346     #     saddr 1.2.3.4 ACCEPT;
 347     #     saddr 5.6.7.8 DROP;
 348     # }
 349     while (@_ > 0) {
 350         my $rule = shift;
 351         if (exists $rule->{match}) {
 352             my %prefix;
 353             my $match_count = 0;
 354             while (my ($key, $value) = each %{$rule->{match}}) {
 355                 my $prefix2 = { $key => $value };
 356                 my $match_count2 = prefix_match_count($prefix2, \@_);
 357                 if ($match_count2 > $match_count) {
 358                     %prefix = %$prefix2;
 359                     $match_count = $match_count2;
 360                 }
 361             }
 362             if ($match_count > 0) {
 363                 my @block = map {
 364                     foreach my $key (keys %prefix) {
 365                         delete $_->{match}{$key};
 366                     }
 367                     #delete @_->{match}{keys %prefix};
 368                     $_;
 369                 } ($rule, splice(@_, 0, $match_count));
 370                 push @result, { match => \%prefix,
 371                                 block => [ optimize(@block) ]
 372                               };
 373             } else {
 374                 push @result, $rule;
 375             }
 376         } else {
 377             push @result, $rule;
 378         }
 379     }
 380
 381     # combine simple closures:
 382     # proto tcp { dport http { LOG; ACCEPT; } }
 383     # ->
 384     # proto tcp dport http { LOG; ACCEPT; }
 385     foreach my $rule (@result) {
 386         next unless exists $rule->{block} && @{$rule->{block}} == 1;
 387
 388         # a block with only one item can be merged
 389         my $inner = $rule->{block}[0];
 390         delete $rule->{block};
 391
 392         # merge modules
 393
 394         # merge rule
 395         foreach (qw(match jump target)) {
 396             next unless exists $inner->{$_};
 397             while (my ($key, $value) = each %{$inner->{$_}}) {
 398                 $rule->{$_}{$key} = $value;
 399             }
 400             delete $inner->{$_};
 401         }
 402
 403         # inherit everything else
 404         while (my ($key, $value) = each %$inner) {
 405             $rule->{$key} = $value;
 406         }
 407     }
 408
 409     return @result;
 410 }
 411
 412 sub flush_option {
 413     my ($line, $key, $value) = @_;
 414
 415     if (ref($value) and ref($value) eq 'HASH' and
 416         $value->{wrap} eq 'pre-negation') {
 417         push @$line, '!';
 418         $value = $value->{value};
 419     }
 420
 421     push @$line, $key;
 422
 423     if (ref($value) and ref($value) eq 'HASH' and
 424         $value->{wrap} eq 'negation') {
 425         push @$line, '!';
 426         $value = $value->{value};
 427     }
 428
 429     if (ref($value) and ref($value) eq 'HASH' and
 430         $value->{wrap} eq 'multi') {
 431         foreach (@{$value->{values}}) {
 432             push @$line, format_array($_);
 433         }
 434     } elsif (defined $value) {
 435         push @$line, format_array($value);
 436     }
 437 }
 438
 439 sub flush {
 440     # optimize and write a list of rules
 441
 442     my @r = @_ ? @_ : @rules;
 443     @r = optimize(@r);
 444     foreach my $rule (@r) {
 445         my @line;
 446         # assemble the line, match stuff first, then target parameters
 447         foreach my $mod (keys %{$rule->{mod} || {}}) {
 448             push @line, 'mod', $mod;
 449         }
 450
 451         if ($rule->{match}{proto}) {
 452             flush_option(\@line, 'proto', $rule->{match}{proto});
 453             delete $rule->{match}{proto};
 454         }
 455
 456         foreach (qw(match jump target)) {
 457             unless (exists $rule->{$_}) {
 458                 push @line, 'NOP' if $_ eq 'jump';
 459                 next;
 460             }
 461
 462             while (my ($key, $value) = each %{$rule->{$_}}) {
 463                 flush_option(\@line, $key, $value);
 464             }
 465         }
 466
 467         if (exists $rule->{block}) {
 468             # this rule begins a block created in &optimize
 469             write_line(@line, '{');
 470             flush(@{$rule->{block}});
 471             write_line('}');
 472         } else {
 473             # just a simple rule
 474             write_line(@line, ';');
 475         }
 476     }
 477     undef @rules;
 478 }
 479
 480 sub tokenize {
 481     local $_ = shift;
 482     my @result;
 483     while (s/^\s*"([^"]+)"//s || s/^\s*(!)// || s/^\s*(\S+)//s) {
 484         push @result, $1;
 485     }
 486     return @result;
 487 }
 488
 489 sub wrap_pre_negated {
 490     my ($option, $negated_ref, $value) = @_;
 491     return $value unless $negated_ref && $$negated_ref;
 492
 493     my $wrap;
 494     if (grep { $_ eq $option } @pre_negated) {
 495         $wrap = 'pre-negation';
 496     } elsif (grep { $_ eq $option } @mix_negated) {
 497         $wrap = 'negation';
 498     }
 499
 500     die "option '$option' in line $. cannot be pre-negated\n"
 501       unless defined $wrap;
 502
 503     undef $$negated_ref;
 504
 505     return { wrap => $wrap,
 506              value => $value,
 507            };
 508 }
 509
 510 sub fetch_token {
 511     my ($option, $tokens) = @_;
 512     die "not enough arguments for option '$option' in line $."
 513       unless @$tokens > 0;
 514     shift @$tokens;
 515 }
 516
 517 sub fetch_token_comma {
 518     [ split(',', fetch_token(@_)) ]
 519 }
 520
 521 sub fetch_two_tokens_comma {
 522     return { wrap => 'multi',
 523              values => [ fetch_token_comma(@_),
 524                          fetch_token_comma(@_) ],
 525            };
 526 }
 527
 528 sub wrap_negated {
 529     my ($option, $tokens, $fetch) = (shift, shift, shift);
 530
 531     my $negated = @$tokens > 0 && $tokens->[0] eq '!' && shift @$tokens;
 532
 533     die "option '$option' in line $. cannot be negated\n"
 534       if $negated and not grep { $_ eq $option } @negated;
 535
 536     my $value = &$fetch($option, $tokens, @_);
 537
 538     $value = { wrap => 'negation',
 539                value => $value,
 540              }
 541       if $negated;
 542
 543     return $value;
 544 }
 545
 546 sub parse_option {
 547     my ($line, $option, $pre_negated, $tokens) = @_;
 548
 549     my $cur = $line->{cur};
 550     die unless defined $cur;
 551
 552     if ($option eq 'p') {
 553         my $keyword = 'protocol';
 554         my $param = wrap_negated($keyword, $tokens, \&fetch_token);
 555         # protocol implicitly loads the module
 556         unless (ref $param) {
 557             my $mod = $param eq 'ipv6-icmp' ? 'icmpv6' : $param;
 558             delete $line->{mod}{$mod};
 559         }
 560         $cur->{proto} = $param;
 561     } elsif ($option eq 'm') {
 562         die unless @$tokens;
 563         my $param = shift @$tokens;
 564         # we don't need this module if the protocol with the
 565         # same name is already specified
 566         $line->{mod}{$param} = 1
 567           unless exists $cur->{proto} and
 568             ($cur->{proto} eq $param or
 569              $cur->{proto} eq 'ipv6-icmp' and $param eq 'icmpv6');
 570     } elsif (exists $p0{$option}) {
 571         my $keyword = $p0{$option};
 572         $cur->{$keyword} = wrap_pre_negated($keyword, \$pre_negated, undef);
 573     } elsif (exists $p1{$option}) {
 574         my $keyword = $p1{$option};
 575         my $param = wrap_negated($keyword, $tokens, \&fetch_token);
 576         $cur->{$keyword} = wrap_pre_negated($keyword, \$pre_negated, $param);
 577     } elsif (exists $p1c{$option}) {
 578         my $keyword = $p1c{$option};
 579         my $param = wrap_negated($keyword, $tokens, \&fetch_token_comma);
 580         $cur->{$keyword} = wrap_pre_negated($keyword, \$pre_negated, $param);
 581     } elsif (exists $p1multi{$option}) {
 582         my $keyword = $p1multi{$option};
 583         my $param = wrap_negated($keyword, $tokens, \&fetch_token);
 584         $cur->{$keyword} ||= [];
 585         push @{$cur->{$keyword}},
 586           wrap_pre_negated($option, \$pre_negated, $param);
 587     } elsif (exists $p2c{$option}) {
 588         my $keyword = $p2c{$option};
 589         my $param = wrap_negated($keyword, $tokens, \&fetch_two_tokens_comma);
 590         $cur->{$keyword} = wrap_pre_negated($keyword, \$pre_negated, $param);
 591     } elsif ($option eq 'j') {
 592         die unless @$tokens;
 593         my $target = shift @$tokens;
 594         # store the target in $line->{jump}
 595         $cur = $line->{jump} = {};
 596         unless (is_netfilter_core_target($target) ||
 597                 is_netfilter_module_target($target)) {
 598             $cur->{goto} = $target;
 599         } else {
 600             $cur->{$target} = undef;
 601         }
 602         # what now follows is target parameters; set $cur
 603         # correctly
 604         $line->{cur} = $line->{target} = {};
 605     } else {
 606         die "option '$option' in line $. not understood\n";
 607     }
 608
 609     die "option '$option' in line $. cannot be negated\n"
 610       if $pre_negated;
 611 }
 612
 613 if (grep { $_ eq '-h' || $_ eq '--help' } @ARGV) {
 614     require Pod::Usage;
 615     Pod::Usage::pod2usage(-exitstatus => 0,
 616                           -verbose => 99);
 617 }
 618
 619 if (@ARGV == 0 && -t STDIN) {
 620     open STDIN, "/sbin/iptables-save|"
 621       or die "Failed run to /sbin/iptables-save: $!";
 622 } elsif (grep { /^-./ } @ARGV) {
 623     require Pod::Usage;
 624     Pod::Usage::pod2usage(-exitstatus => 1,
 625                           -verbose => 99);
 626 }
 627
 628 print "# ferm rules generated by import-ferm\n";
 629 print "# http://ferm.foo-projects.org/\n";
 630 write_line qw(domain ip {);
 631
 632 while (<>) {
 633     if (/^(?:#.*)?$/) {
 634         # empty or comment
 635     } elsif (/^\*(\w+)$/) {
 636         # table
 637         write_line('}') if defined $table;
 638         $table = $1;
 639         write_line('table', $table, '{');
 640     } elsif (/^:(\S+)\s+-\s+/) {
 641         # custom chain
 642         die unless defined $table;
 643         write_line("chain $1;");
 644     } elsif (/^:(\S+)\s+(\w+)\s+/) {
 645         # built-in chain
 646         die unless defined $table;
 647         write_line('chain', $1, 'policy', $2, ';');
 648     } elsif (s/^-A (\S+)\s+//) {
 649         # a rule
 650         unless (defined $chain) {
 651             flush;
 652             $chain = $1;
 653             write_line('chain', $chain, '{');
 654         } elsif ($1 ne $chain) {
 655             flush;
 656             write_line('}');
 657             $chain = $1;
 658             write_line('chain', $chain, '{');
 659         }
 660
 661         my @tokens = tokenize($_);
 662
 663         my %line;
 664         # separate 'match' parameters from 'targe't parameters; $cur
 665         # points to the current position
 666         $line{cur} = $line{match} = {};
 667         while (@tokens) {
 668             local $_ = shift @tokens;
 669             if (/^-(\w)$/ || /^--(\S+)$/) {
 670                 parse_option(\%line, $1, undef, \@tokens);
 671             } elsif ($_ eq '!') {
 672                 die unless @tokens;
 673                 $_ = shift @tokens;
 674                 /^-(\w)$/ || /^--(\S+)$/
 675                   or die "option expected in line $.\n";
 676                 parse_option(\%line, $1, 1, \@tokens);
 677             } else {
 678                 print STDERR "warning: unknown token '$_' in line $.\n";
 679             }
 680         }
 681         delete $line{cur};
 682         push @rules, \%line;
 683     } elsif ($_ =~ /^COMMIT/) {
 684         flush;
 685
 686         if (defined $chain) {
 687             write_line('}');
 688             undef $chain;
 689         }
 690     } else {
 691         print STDERR "line $. was not understood, ignoring it\n";
 692     }
 693 }
 694
 695 flush;
 696 write_line '}' if defined $chain;
 697 write_line '}' if defined $table;
 698
 699 write_line qw(});
 700
 701 die unless $indent == 0;
 702
 703 __END__
 704
 705 =head1 NAME
 706
 707 import-ferm - import existing firewall rules into ferm
 708
 709 =head1 SYNOPSIS
 710
 711 B<import-ferm> > ferm.conf
 712
 713 iptables-save | B<import-ferm> > ferm.conf
 714
 715 B<import-ferm> I<inputfile> > ferm.conf
 716
 717 =head1 DESCRIPTION
 718
 719 This script helps you with porting an existing IPv4 firewall
 720 configuration to ferm.  It reads a file generated with
 721 B<iptables-save>, and tries to suggest a ferm configuration file.
 722
 723 If no input file was specified on the command line, B<import-ferm>
 724 runs F<iptables-save>.
 725
 726 =cut