src/import-ferm

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