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-2008 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(%proto_defs %match_defs %target_defs);
  38
  39 BEGIN {
  40     my $ferm;
  41     if ($0 =~ /^(.*)\//) {
  42         $ferm = "$1/ferm";
  43     } else {
  44         $ferm = 'ferm';
  45     }
  46
  47     open(FERM, "<$ferm")
  48       or die "Failed to open $ferm\n";
  49     my $ferm_code = do { local $/; <FERM>; };
  50     close FERM;
  51
  52     $ferm_code =~ /%target_defs\);
  53                    \s*(.+?)\s*
  54                    add_match_def_x\ /sx
  55                      or die "Failed to parse $ferm\n";
  56     undef $ferm_code;
  57     eval $1;
  58 }
  59
  60 use vars qw(%aliases);
  61 %aliases = (
  62     i => 'interface',
  63     o => 'outerface',
  64     p => 'proto',
  65     d => 'daddr',
  66     s => 'saddr',
  67 );
  68
  69 use vars qw($indent $table $chain @rules $domain $next_domain);
  70
  71 sub is_netfilter_core_target {
  72     my $target = shift;
  73     die unless defined $target and length $target;
  74
  75     return $target =~ /(?:ACCEPT|DROP|RETURN|QUEUE|NOP)$/;
  76 }
  77
  78 sub is_netfilter_module_target($) {
  79     my $target = shift;
  80     return exists $target_defs{'ip'}{$target};
  81 }
  82
  83 sub ferm_escape {
  84     local $_ = shift;
  85     return $_ unless /[^-\w.:]/s;
  86     return "\'$_\'";
  87 }
  88
  89 sub format_array {
  90     my $a = shift;
  91     return ferm_escape($a) unless ref $a;
  92     return ferm_escape($a->[0]) if @$a == 1;
  93     return '(' . join(' ', map { ferm_escape($_) } @$a) . ')';
  94 }
  95
  96 sub write_line {
  97     # write a line of tokens, with indent handling
  98
  99     # don't add space before semicolon
 100     my $comma = $_[-1] eq ';' ? pop : '';
 101     # begins with closing curly braces -> decrease indent
 102     $indent -= 4 if $_[0] =~ /^}/;
 103     # do print line
 104     print ' ' x $indent;
 105     print join(' ', @_);
 106     print "$comma\n";
 107     # ends with opening curly braces -> increase indent
 108     $indent += 4 if $_[-1] =~ /{$/;
 109 }
 110
 111 sub module_match_count {
 112     my ($module, $rules) = @_;
 113     my $count = 0;
 114     foreach (@$rules) {
 115         last unless $_->{mod}{$module};
 116         $count++;
 117     }
 118     return $count;
 119 }
 120
 121 sub prefix_matches {
 122     my ($a, $b) = @_;
 123     return @{$b->{match}} > 0 &&
 124       (Dumper($a->{match}[0]) eq Dumper($b->{match}[0]));
 125 }
 126
 127 sub prefix_match_count {
 128     my ($prefix, $rules) = @_;
 129     my $count = 0;
 130     foreach (@$rules) {
 131         last unless prefix_matches($prefix, $_);
 132         $count++;
 133     }
 134     return $count;
 135 }
 136
 137 sub is_merging_array_member {
 138     my $value = shift;
 139     return defined $value &&
 140       ((!ref($value)) or
 141        ref $value eq 'ARRAY');
 142 }
 143
 144 sub array_matches($$) {
 145     my ($rule1, $rule2) = @_;
 146     return unless is_merging_array_member($rule1->{match}[0][1]);
 147     return unless is_merging_array_member($rule2->{match}[0][1]);
 148     return unless @{$rule2->{match}} > 0;
 149     return unless $rule1->{match}[0][0] eq $rule2->{match}[0][0];
 150     my %r1 = %$rule1;
 151     my %r2 = %$rule2;
 152     $r1{match} = [ @{$r1{match}} ];
 153     $r2{match} = [ @{$r2{match}} ];
 154     shift @{$r1{match}};
 155     shift @{$r2{match}};
 156     return Dumper(\%r1) eq Dumper(\%r2);
 157 }
 158
 159 sub array_match_count($\@) {
 160     my ($first, $rules) = @_;
 161     return 0 unless @{$first->{match}} > 0;
 162     my $count = 0;
 163     foreach (@$rules) {
 164         last unless array_matches($first, $_);
 165         $count++;
 166     }
 167     return $count;
 168 }
 169
 170 sub optimize {
 171     my @result;
 172
 173     # try to combine rules with arrays:
 174     # saddr 1.2.3.4 proto tcp ACCEPT;
 175     # saddr 5.6.7.8 proto tcp ACCEPT;
 176     # ->
 177     # saddr (1.2.3.4 5.6.7.8) proto tcp ACCEPT;
 178     while (@_ > 0) {
 179         my $rule = shift;
 180         my $match_count = array_match_count($rule, @_);
 181
 182         if ($match_count > 0) {
 183             my $option = $rule->{match}[0][0];
 184             my @matching = ( $rule, splice(@_, 0, $match_count) );
 185             my @params = map {
 186                 (ref $_ and ref $_ eq 'ARRAY') ? @$_ : $_
 187             } map {
 188                 $_->{match}[0][1]
 189             } @matching;
 190
 191             $rule->{match}[0][1] = \@params;
 192         }
 193
 194         push @result, $rule;
 195     }
 196
 197     @_ = @result;
 198     undef @result;
 199
 200     # try to find a common prefix and put rules in a block:
 201     # saddr 1.2.3.4 proto tcp dport ssh ACCEPT;
 202     # saddr 5.6.7.8 proto tcp dport ssh DROP;
 203     # ->
 204     # proto tcp dport ssh {
 205     #     saddr 1.2.3.4 ACCEPT;
 206     #     saddr 5.6.7.8 DROP;
 207     # }
 208     while (@_ > 0) {
 209         my $rule = shift;
 210         if (@{$rule->{match}} > 0) {
 211             my $match_count = prefix_match_count($rule, \@_);
 212
 213             if ($match_count > 0) {
 214                 my $match = $rule->{match}[0];
 215                 my @matching = ( $rule, splice(@_, 0, $match_count) );
 216                 map { shift @{$_->{match}} } @matching;
 217
 218                 push @result, { match => [ $match ],
 219                                 block => [ optimize(@matching) ],
 220                               };
 221             } else {
 222                 push @result, $rule;
 223             }
 224         } else {
 225             push @result, $rule;
 226         }
 227     }
 228
 229     # combine simple closures:
 230     # proto tcp { dport http { LOG; ACCEPT; } }
 231     # ->
 232     # proto tcp dport http { LOG; ACCEPT; }
 233     foreach my $rule (@result) {
 234         next unless exists $rule->{block} && @{$rule->{block}} == 1;
 235
 236         # a block with only one item can be merged
 237         my $inner = $rule->{block}[0];
 238         delete $rule->{block};
 239
 240         # merge rule
 241         push @{$rule->{match}}, @{$inner->{match}};
 242         $rule->{jump} = $inner->{jump}
 243           if exists $inner->{jump};
 244         $rule->{goto} = $inner->{goto}
 245           if exists $inner->{goto};
 246         $rule->{block} = $inner->{block}
 247           if exists $inner->{block};
 248         push @{$rule->{target} ||= []}, @{$inner->{target}}
 249           if exists $inner->{target};
 250     }
 251
 252     return @result;
 253 }
 254
 255 sub flush_option {
 256     my ($line, $key, $value) = @_;
 257
 258     if (ref($value) and ref($value) eq 'pre_negated') {
 259         push @$line, '!';
 260         $value = $value->[0];
 261     }
 262
 263     push @$line, $key;
 264
 265     if (ref($value) and ref($value) eq 'negated') {
 266         push @$line, '!';
 267         $value = $value->[0];
 268     }
 269
 270     if (ref($value) and ref($value) eq 'params') {
 271         foreach (@$value) {
 272             push @$line, format_array($_);
 273         }
 274     } elsif (defined $value) {
 275         push @$line, format_array($value);
 276     }
 277 }
 278
 279 sub flush {
 280     # optimize and write a list of rules
 281
 282     my @r = @_ ? @_ : @rules;
 283     @r = optimize(@r);
 284
 285     foreach my $rule (@r) {
 286         my @line;
 287         # assemble the line, match stuff first, then target parameters
 288         if (exists $rule->{match}) {
 289             foreach (@{$rule->{match}}) {
 290                 flush_option(\@line, @$_);
 291             }
 292         }
 293
 294         if (exists $rule->{jump}) {
 295             if (is_netfilter_core_target($rule->{jump}) ||
 296                 is_netfilter_module_target($rule->{jump})) {
 297                 push @line, $rule->{jump};
 298             } else {
 299                 flush_option(\@line, 'jump', $rule->{jump});
 300             }
 301         } elsif (exists $rule->{goto}) {
 302             flush_option(\@line, 'realgoto', $rule->{goto});
 303         } elsif (not exists $rule->{block}) {
 304             push @line, 'NOP';
 305         }
 306
 307         if (exists $rule->{target}) {
 308             foreach (@{$rule->{target}}) {
 309                 flush_option(\@line, @$_);
 310             }
 311         }
 312
 313         if (exists $rule->{block}) {
 314             # this rule begins a block created in &optimize
 315             write_line(@line, '{');
 316             flush(@{$rule->{block}});
 317             write_line('}');
 318         } else {
 319             # just a simple rule
 320             write_line(@line, ';');
 321         }
 322     }
 323     undef @rules;
 324 }
 325
 326 sub flush_domain {
 327     flush;
 328     write_line '}' if defined $chain;
 329     write_line '}' if defined $table;
 330     write_line '}' if defined $domain;
 331
 332     undef $chain;
 333     undef $table;
 334     undef $domain;
 335 }
 336
 337 sub tokenize {
 338     local $_ = shift;
 339     my @result;
 340     while (s/^\s*"([^"]+)"//s || s/^\s*(!)// || s/^\s*(\S+)//s) {
 341         push @result, $1;
 342     }
 343     return @result;
 344 }
 345
 346 sub fetch_token {
 347     my ($option, $tokens) = @_;
 348     die "not enough arguments for option '$option' in line $."
 349       unless @$tokens > 0;
 350     shift @$tokens;
 351 }
 352
 353 sub fetch_negated(\@) {
 354     my $tokens = shift;
 355     @$tokens > 0 && $tokens->[0] eq '!' && shift @$tokens;
 356 }
 357
 358 sub wrap_negated {
 359     my ($option, $tokens, $fetch) = (shift, shift, shift);
 360
 361     my $negated = @$tokens > 0 && $tokens->[0] eq '!' && shift @$tokens;
 362
 363     # XXX
 364     #die "option '$option' in line $. cannot be negated\n"
 365     #  if $negated and not grep { $_ eq $option } @negated
 366
 367     my $value = &$fetch($option, $tokens, @_);
 368
 369     return bless [$value], 'negated'
 370       if $negated;
 371     return $value;
 372 }
 373
 374 sub merge_keywords(\%$$) {
 375     my ($rule, $module, $keywords) = @_;
 376     while (my ($name, $def) = each %$keywords) {
 377         $rule->{keywords}{$name} = $def;
 378     }
 379 }
 380
 381 sub parse_def_option($\%$\@) {
 382     my ($option, $def, $negated, $tokens) = @_;
 383
 384     while (exists $def->{alias}) {
 385         ($option, $def) = @{$def->{alias}};
 386         die unless defined $def;
 387     }
 388
 389     my $params = $def->{params};
 390     my $value;
 391
 392     $negated = 1 if fetch_negated(@$tokens);
 393
 394     unless (defined $params) {
 395         undef $value;
 396     } elsif (ref $params && ref $params eq 'CODE') {
 397         # XXX we assume this is ipt_multiport
 398         $value = [ split /,/, fetch_token($option, $tokens) ];
 399     } elsif ($params eq 'm') {
 400         $value = bless [ fetch_token($option, $tokens) ], 'multi';
 401     } elsif ($params =~ /^[a-z]/) {
 402         die if @$tokens < length($params);
 403
 404         my @params;
 405         foreach my $p (split(//, $params)) {
 406             if ($p eq 's') {
 407                 push @params, shift @$tokens;
 408             } elsif ($p eq 'c') {
 409                 push @params, [ split /,/, shift @$tokens ];
 410             } else {
 411                 die;
 412             }
 413         }
 414
 415         $value = @params == 1
 416           ? $params[0]
 417             : bless \@params, 'params';
 418     } elsif ($params == 1) {
 419         $value = fetch_token($option, $tokens);
 420     } else {
 421         $value = bless [ map {
 422             fetch_token($option, $tokens)
 423         } (1..$params) ], 'multi';
 424     }
 425
 426     $value = bless [ $value ], exists $def->{pre_negation} ? 'pre_negated' : 'negated'
 427       if $negated;
 428
 429     return $value;
 430 }
 431
 432 sub parse_option {
 433     my ($line, $option, $pre_negated, $tokens) = @_;
 434
 435     my $cur = $line->{cur};
 436     die unless defined $cur;
 437
 438     $option = $aliases{$option} if exists $aliases{$option};
 439     $option = 'destination-ports' if $option eq 'dports';
 440     $option = 'source-ports' if $option eq 'sports';
 441
 442     if ($option eq 'protocol') {
 443         my %def = ( params => 1 );
 444         my $value = parse_def_option($option, %def, $pre_negated, @$tokens);
 445         $line->{proto} = $value;
 446         push @$cur, [ 'proto', $value ];
 447     } elsif ($option eq 'm') {
 448         die unless @$tokens;
 449         my $param = shift @$tokens;
 450         $line->{mod}{$param} = 1;
 451         # we don't need this module if the protocol with the
 452         # same name is already specified
 453         push @$cur, [ 'mod', $param ]
 454           unless exists $line->{proto} and
 455             ($line->{proto} eq $param or
 456              $line->{proto} =~ /^(ipv6-icmp|icmpv6)$/s and $param eq 'icmp6');
 457
 458         my $module = $param eq 'icmp6' ? 'icmpv6' : $param;
 459         if (exists $match_defs{ip}{$module}) {
 460             merge_keywords(%$line, $module, $match_defs{ip}{$module}{keywords});
 461         } elsif (exists $proto_defs{ip}{$module}) {
 462             merge_keywords(%$line, $module, $proto_defs{ip}{$module}{keywords});
 463         }
 464
 465         if ($param =~ /^(?:tcp|udp|udplite|dccp|sctp)$/) {
 466             my %def = (
 467                 params => 1,
 468                 negation => 1,
 469                );
 470             $line->{keywords}{sport} = \%def;
 471             $line->{keywords}{dport} = \%def;
 472         }
 473     } elsif (exists $line->{keywords}{$option}) {
 474         my $def = $line->{keywords}{$option};
 475         my $value = parse_def_option($option, %$def, $pre_negated, @$tokens);
 476
 477         if (ref $value and ref $value eq 'multi' and
 478               @{$line->{cur}} > 0 and $line->{cur}[-1][0] eq $option and
 479                 ref $line->{cur}[-1][1] eq 'multi') {
 480             # merge multiple "--u32" into a ferm array
 481             push @{$line->{cur}[-1][1]}, @$value;
 482             return;
 483         }
 484
 485         undef $pre_negated;
 486         push @{$line->{cur}}, [ $option, $value ];
 487     } elsif ($option eq 'j') {
 488         die unless @$tokens;
 489         my $target = shift @$tokens;
 490         # store the target in $line->{jump}
 491         $line->{jump} = $target;
 492         # what now follows is target parameters; set $cur
 493         # correctly
 494         $line->{cur} = $line->{target} = [];
 495
 496         $line->{keywords} = {};
 497         merge_keywords(%$line, $target, $target_defs{ip}{$target}{keywords})
 498           if exists $target_defs{ip}{$target};
 499     } elsif ($option eq 'g') {
 500         die unless @$tokens;
 501         my $target = shift @$tokens;
 502         # store the target in $line->{jump}
 503         $line->{goto} = $target;
 504     } else {
 505         die "option '$option' in line $. not understood\n";
 506     }
 507
 508     die "option '$option' in line $. cannot be negated\n"
 509       if $pre_negated;
 510 }
 511
 512 if (grep { $_ eq '-h' || $_ eq '--help' } @ARGV) {
 513     require Pod::Usage;
 514     Pod::Usage::pod2usage(-exitstatus => 0,
 515                           -verbose => 99);
 516 }
 517
 518 if (@ARGV == 0 && -t STDIN) {
 519     open STDIN, "/sbin/iptables-save|"
 520       or die "Failed run to /sbin/iptables-save: $!";
 521 } elsif (grep { /^-./ } @ARGV) {
 522     require Pod::Usage;
 523     Pod::Usage::pod2usage(-exitstatus => 1,
 524                           -verbose => 99);
 525 }
 526
 527 print "# ferm rules generated by import-ferm\n";
 528 print "# http://ferm.foo-projects.org/\n";
 529
 530 $next_domain = $ENV{FERM_DOMAIN} || 'ip';
 531
 532 my %policies;
 533
 534 while (<>) {
 535     if (/^(?:#.*)?$/) {
 536         # empty or comment
 537
 538         $next_domain = $1 if /^#.*\b(ip|ip6)tables(?:-save)\b/;
 539     } elsif (/^\*(\w+)$/) {
 540         # table
 541
 542         if (keys %policies > 0) {
 543             while (my ($chain, $policy) = each %policies) {
 544                 write_line('chain', $chain, 'policy', $policy, ';');
 545             }
 546             undef %policies;
 547         }
 548
 549         unless (defined $domain and $domain eq $next_domain) {
 550             flush_domain;
 551             $domain = $next_domain;
 552             write_line 'domain', $domain, '{';
 553         }
 554
 555         write_line('}') if defined $table;
 556         $table = $1;
 557         write_line('table', $table, '{');
 558     } elsif (/^:(\S+)\s+-\s+/) {
 559         # custom chain
 560         die unless defined $table;
 561         write_line("chain $1;");
 562     } elsif (/^:(\S+)\s+(\w+)\s+/) {
 563         # built-in chain
 564         die unless defined $table;
 565         $policies{$1} = $2;
 566     } elsif (s/^-A (\S+)\s+//) {
 567         # a rule
 568         unless (defined $chain) {
 569             flush;
 570             $chain = $1;
 571             write_line('chain', $chain, '{');
 572         } elsif ($1 ne $chain) {
 573             flush;
 574             write_line('}');
 575             $chain = $1;
 576             write_line('chain', $chain, '{');
 577         }
 578
 579         if (exists $policies{$chain}) {
 580             write_line('policy', $policies{$chain}, ';');
 581             delete $policies{$chain};
 582         }
 583
 584         my @tokens = tokenize($_);
 585
 586         my %line;
 587         $line{keywords} = {};
 588         merge_keywords(%line, '', $match_defs{ip}{''}{keywords});
 589
 590         # separate 'match' parameters from 'target' parameters; $cur
 591         # points to the current position
 592         $line{cur} = $line{match} = [];
 593         while (@tokens) {
 594             local $_ = shift @tokens;
 595             if (/^-(\w)$/ || /^--(\S+)$/) {
 596                 parse_option(\%line, $1, undef, \@tokens);
 597             } elsif ($_ eq '!') {
 598                 die unless @tokens;
 599                 $_ = shift @tokens;
 600                 /^-(\w)$/ || /^--(\S+)$/
 601                   or die "option expected in line $.\n";
 602                 parse_option(\%line, $1, 1, \@tokens);
 603             } else {
 604                 print STDERR "warning: unknown token '$_' in line $.\n";
 605             }
 606         }
 607         delete $line{cur};
 608         push @rules, \%line;
 609     } elsif ($_ =~ /^COMMIT/) {
 610         flush;
 611
 612         if (defined $chain) {
 613             write_line('}');
 614             undef $chain;
 615         }
 616     } else {
 617         print STDERR "line $. was not understood, ignoring it\n";
 618     }
 619 }
 620
 621 if (keys %policies > 0) {
 622     while (my ($chain, $policy) = each %policies) {
 623         write_line('chain', $chain, 'policy', $policy, ';');
 624     }
 625 }
 626
 627 flush_domain if defined $domain;
 628
 629 die unless $indent == 0;
 630
 631 __END__
 632
 633 =head1 NAME
 634
 635 import-ferm - import existing firewall rules into ferm
 636
 637 =head1 SYNOPSIS
 638
 639 B<import-ferm> > ferm.conf
 640
 641 iptables-save | B<import-ferm> > ferm.conf
 642
 643 B<import-ferm> I<inputfile> > ferm.conf
 644
 645 =head1 DESCRIPTION
 646
 647 This script helps you with porting an existing IPv4 firewall
 648 configuration to ferm.  It reads a file generated with
 649 B<iptables-save>, and tries to suggest a ferm configuration file.
 650
 651 If no input file was specified on the command line, B<import-ferm>
 652 runs F<iptables-save>.
 653
 654 =head1 BUGS
 655
 656 iptables-save older than 1.3 is unable to write valid saves - this is
 657 not a bug in B<import-ferm>.
 658
 659 =cut