"Fossies" - the Fresh Open Source Software Archive

Member "ferm-2.6/src/import-ferm" (30 Jan 2021, 17758 Bytes) of package /linux/privat/ferm-2.6.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "import-ferm": 2.5.1_vs_2.6.

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