src/import-ferm

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