export-netspoc

#!/usr/local/bin/perl

=head1 NAME

export-netspoc - Export data from Netspoc for use in Netspoc-Web

=head1 COPYRIGHT AND DISCLAIMER

(c) 2017 by Heinz Knutzen <heinz.knutzen@gmail.com>
(c) 2014 by Daniel Brunkhorst <daniel.brunkhorst@web.de>

https://github.com/hknutzen/Netspoc-Web

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.

=cut

use strict;
use warnings;
use Getopt::Long;
use File::Path 'make_path';
use JSON;
use Digest::SHA qw(sha1_base64);
use Netspoc::Compiler::GetArgs qw(read_config combine_config);
use Netspoc::Compiler::Common;
use Netspoc::Compiler::Pass1;
use open qw(:std :utf8);

sub usage {
    die "Usage: $0 [-q] netspoc-data out-directory\n";
}
my $quiet;
my $ipv6;

# Argument processing.
GetOptions ('quiet!' => \$quiet, 'ipv6' => \$ipv6 ) or usage();
my $netspoc_data = shift @ARGV or usage();
my $out_dir = shift @ARGV or usage();
@ARGV and usage();

# Remove trailing slash.
$out_dir =~ s,/$,,;

# Copy version information from this file and
# take modification date for all newly created files.
my $policy_file = "$netspoc_data/POLICY";

sub create_dirs {
    my ($path) = @_;
    $path = "$out_dir/$path";
    make_path($path, {error => \my $err} );
    # uncoverable branch true
    if (@$err) {
        for my $diag (@$err) {				# uncoverable statement
            my ($file, $msg) = %$diag;			# uncoverable statement
            # uncoverable branch true
            # uncoverable branch false
            if ($file eq '') {				# uncoverable statement
                die "General error: $msg\n";		# uncoverable statement
            }
            else {
                die "Problem creating $file: $msg\n";	# uncoverable statement
            }
        }
    }
    return;
}

sub export {
    my ($path, $data) = @_;
    $path = "$out_dir/$path";
    open (my $fh, '>', $path) or die "Can't open $path\n";
    print $fh to_json($data, {pretty => 1, canonical => 1});
    close $fh or die "Can't close $path\n";
    return;
}

sub by_name { return($a->{name} cmp $b->{name}) }

# Take higher bits from network NAT, lower bits from original IP.
# This works with and without NAT.
sub nat {
    my ($ip, $network) = @_;
    return($network->{ip} | $ip & ~ $network->{mask});
}

sub ip_nat_for_object {
    my ($obj) = @_;
    my $ip;
    my $nat;

# This code is a modified copy of sub address.
# - It needs to handle objects of type 'Host' instead of 'Subnet'.
# - Handles dynamic NAT for hosts.
# - It returns strings of textual ip/mask, not pairs of numbers.
    my $type = ref $obj;
    if ($type eq 'Network') {
        my $get_ip = sub {
            my ($obj) = @_;
            if ($obj->{hidden}) {
                'hidden';
            }

            # Don't print mask for loopback network. It needs to have
            # exactly the same address as the corresponding loopback interface.
            elsif ($obj->{loopback}) {
                print_ip($obj->{ip});
            }

            # Print no mask for aggregate with mask 0, for compatibility
            # with old version.
            elsif ($obj->{is_aggregate} && $obj->{mask} eq $zero_ip) {
                print_ip($obj->{ip});
            }
            else {
                join('/', print_ip($obj->{ip}), print_ip($obj->{mask}));
            }
        };
        $ip = $get_ip->($obj);
        if (my $hash = $obj->{nat}) {
            for my $tag (keys %$hash) {
                my $nat_obj = $hash->{$tag};
                $nat->{$tag} = $get_ip->($nat_obj);
            }
        }
    }
    elsif ($type eq 'Host') {
        my $get_ip = sub {
            my ($obj, $network) = @_;
            if ($network->{dynamic}) {
                my $nat_tag = $network->{nat_tag};
                if ($obj->{nat} and (my $ip = $obj->{nat}->{$nat_tag})) {

                    # Single static NAT IP for this host.
                    print_ip($ip);
                }
                elsif ($network->{hidden}) {
                    'hidden';
                }
                else {

                    # Dynamic NAT, take whole network.
                    join('/',
                         print_ip($network->{ip}), print_ip($network->{mask}));
                }
            }
            else {
                if ( my $range = $obj->{range} ) {
                    join('-', map { print_ip(nat($_, $network)) } @$range);
                }
                else {
                    print_ip(nat($obj->{ip}, $network));
                }
            }
        };
        my $network = $obj->{network};
        $ip = $get_ip->($obj, $network);
        if (my $hash = $network->{nat}) {
            for my $tag (keys %$hash) {
                my $nat_obj = $hash->{$tag};
                $nat->{$tag} = $get_ip->($obj, $nat_obj);
            }
        }
    }
    elsif ($type eq 'Interface') {
        my $get_ip = sub {
            my ($obj, $network) = @_;
            if ($network->{dynamic}) {
                my $nat_tag = $network->{nat_tag};
                if (my $ip = $obj->{nat}->{$nat_tag}) {

                    # Single static NAT IP for this interface.
                    print_ip($ip);
                }
                elsif ($network->{hidden}) {
                    'hidden';
                }
                else {

                    # Dynamic NAT, take whole network.
                    join('/',
                         print_ip($network->{ip}), print_ip($network->{mask}));
                }
            }
            elsif ($obj->{ip} =~ /unnumbered|short|bridged/) {
                $obj->{ip};
            }
            elsif ($obj->{ip} eq 'negotiated') {

                # Take whole network.
                join('/',
                     print_ip($network->{ip}), print_ip($network->{mask}));
            }
            else {
                print_ip(nat($obj->{ip}, $network));
            }
        };
        my $network = $obj->{network};
        $ip = $get_ip->($obj, $network);
        if (my $hash = $network->{nat}) {
            for my $tag (keys %$hash) {
                my $nat_obj = $hash->{$tag};
                $nat->{$tag} = $get_ip->($obj, $nat_obj);
            }
        }
    }
    return $nat ? ( ip => $ip, nat => $nat ) : ( ip => $ip );
}

######################################################################
# Setup zones
######################################################################

# We can't use %aggregates from Netspoc.pm because it only holds named
# aggregates. But we need unnamed aggregates like any:[network:XX]
# as well.
my @all_zones;

sub setup_zones {
    progress('Setup zones');
    my %seen;
    for my $network (values %networks) {
        $network->{disabled} and next;
        my $zone = $network->{zone};
        next if $seen{$zone}++;
#        debug "$network->{name} in $zone->{name}";
        push @all_zones, $zone;
    }
    return;
}

######################################################################
# Setup services
######################################################################

# Globally change name of owners from "owner:name" to "name".
sub adapt_owner_names {
    for my $owner (values %owners) {
        $owner->{name} =~ s/^owner://;
    }
}

sub owner_for_object {
    my ($object) = @_;
    if (my $owner_obj = $object->{owner}) {
        return $owner_obj->{name};
    }
    return ();
}

sub part_owners_for_object {
    my ($object) = @_;
    if (my $aref = $object->{part_owners}) {
        return map { $_->{name} } @$aref;
    }
    return ();
}

sub outer_owners_for_object {
    my ($object) = @_;
    if (my $list = $object->{outer_owners}) {
        return map { $_->{name} } @$list;
    }
    return ();
}

sub owners_for_objects {
    my ($objects) = @_;
    my %owners;
    for my $object (@$objects) {
        if (my $name = owner_for_object($object)) {
            $owners{$name} = $name;
        }
    }
    return [ sort values %owners ];
}

sub part_owners_for_objects {
    my ($objects) = @_;
    my %owners;
    for my $object (@$objects) {
        for my $name (part_owners_for_object($object)) {
            $owners{$name} = $name;
        }
    }
    return [ sort values %owners ];
}

sub outer_owners_for_objects {
    my ($objects) = @_;
    my %owners;
    for my $object (@$objects) {
        for my $name (outer_owners_for_object($object)) {
            $owners{$name} = $name;
        }
    }
    return [ sort values %owners ];
}

sub proto_descr {
    my ($protocols) = @_;
    my @result;
    for my $proto0 (@$protocols) {
        my $protocol = $proto0;
        my $desc = my $ptype = $protocol->{proto};
        my $num;
        if ($ptype eq 'tcp' or $ptype eq 'udp') {
            my $port_code = sub {
                my ($range_obj) = @_;
                my ($v1, $v2) = @{ $range_obj->{range} };
                if ($v1 == $v2) {
                    return $v1;
                }
                elsif ($v1 == 1 and $v2 == 65535) {
                    return (undef);
                }
                else {
                    return "$v1-$v2";
                }
            };
            my $src_range = $protocol->{src_range};
            my $sport = $src_range && $port_code->($src_range);
            my $dport = $port_code->($protocol->{dst_range});
            if ($sport) {
                $desc .= " $sport:$dport";
            }
            elsif ($dport) {
                $desc .= " $dport";
                ($num) = split('-', $dport)
            }
        }
        elsif ($ptype eq 'icmp') {
            if (defined(my $type = $protocol->{type})) {
                if (defined(my $code = $protocol->{code})) {
                    $desc .= " $type/$code";
                }
                else {
                    $desc .= " $type";
                }
                $num = $type;
            }
        }
        if (my $modifiers = $protocol->{modifiers}) {
            for my $key (sort keys %$modifiers) {
                next if $key eq 'stateless_icmp';
                next if $key eq 'overlaps';
                next if $key eq 'no_check_supernet_rules';
                $desc .= ", $key";
            }
        }
        $num ||= 0;
        push @result, [ $desc, $ptype, $num ];
    }
    @result =
        map { $_->[0] }

        # Sort by protocol, port/type, all (if proto and num are equal)
        sort { $a->[1] cmp $b->[1] ||
               $a->[2] <=> $b->[2] ||
               $a->[0] cmp $b->[0] }
        @result;
    return \@result;
}

sub find_visibility {
    my ($owners, $uowners) = @_;
    my $visibility;
    my %hash = map { $_ => 1} @$owners;
    my @extra_uowners = grep { not $hash{$_} } @$uowners;
    my @DA_extra = grep({ $_ =~ /^DA_/ } @extra_uowners);
    my @other_extra = grep({ $_ !~ /^DA_/ } @extra_uowners);

    # No known owner or owner of users.
    if (not @$owners and not @$uowners) {
        # Default: private
    }
    # Set of uowners is subset of owners.
    elsif (not @extra_uowners) {
        # Default: private
    }
    # Restricted visibility
    elsif (@other_extra <= 2) {
        if (@DA_extra >= 3) {
            $visibility = qr/^DA_/;
        }
    }
    else {
        $visibility = qr/^.*/;
    }
    return $visibility;
}

# All objects referenced in rules and in networks and hosts of owners.
my %all_objects;

# Split service, if 'user' has different values in normalized rules.
sub normalize_services_for_export {
    progress("Normalize services for export");
    my @result;
    for my $service (sort by_name values %services) {
        next if $service->{disabled};
        my $sname   = $service->{name};
        my $context = $sname;
        my $user    = expand_group($service->{user}, "user of $context");
        my $rules   = $service->{rules};
        my $foreach = $service->{foreach};

        my %key2rules;
        my %key2user;

        my $seen_as_user = sub {
            my ($list) = @_;
            my $list_key = join(',', map { $_->{name} } @$list);
            return $key2user{$list_key};
        };

        for my $unexpanded (@$rules) {
            my $action   = $unexpanded->{action};
            my $prt_list = proto_descr(expand_protocols($unexpanded->{prt},
                                                        "rule in $context"));
            my $has_user = $unexpanded->{has_user};

            for my $element ($foreach ? @$user : ($user)) {
                my $src_dst_list_pairs =
                    normalize_src_dst_list($unexpanded, $element, $context);
                for my $src_dst_list (@$src_dst_list_pairs) {
                    my ($src_list, $dst_list) = @$src_dst_list;

                    # Artificially take one of 'src' and 'dst' as user
                    # for case like
                    # src = user; dst = any:[user];
                    if ($has_user eq 'both' and
                        not aref_eq($src_list, $dst_list))
                    {
                        if ($seen_as_user->($src_list)) {
                            $has_user = 'src';
                        }
                        elsif($seen_as_user->($dst_list)) {
                            $has_user = 'dst';
                        }
                        elsif(@$src_list >= @$dst_list) {
                            $has_user = 'src';
                        }
                        else {
                            $has_user = 'dst';
                        }
                    }
                    my $rule = {
                        action   => $action,
                        prt      => $prt_list,
                        has_user => $has_user,
                    };
                    if ($has_user eq 'src') {
                        $rule->{dst} = $dst_list;
                    }
                    elsif ($has_user eq 'dst') {
                        $rule->{src} = $src_list;
                    }

                    my $user_list = $has_user eq 'dst' ? $dst_list : $src_list;
                    my $user_key = join(',', map { $_->{name} } @$user_list);
                    push @{ $key2rules{$user_key} }, $rule;
                    $key2user{$user_key} = $user_list;
                }
            }
        }

        # 'user' has different value for some rules
        # and we get multiple services with identical name.
        my $is_split = (1 < keys %key2rules);

        for my $user_key (keys %key2rules) {
            my $user_list = $key2user{$user_key};
            my $rules     = $key2rules{$user_key};
            my $new_service = { %$service,
                                user  => $user_list,
                                rules => $rules,
            };
            $new_service->{is_split} = 1 if $is_split;
            push @result, $new_service;
        }
    }
    return \@result;
}

sub setup_service_info {
    my ($normalized_services) = @_;
    progress("Setup service info");

    for my $service (@$normalized_services) {
        my $users = $service->{user};

        # Non 'user' objects.
        my @objects;

        # Check, if service contains a coupling rule with only "user" elements.
        my $is_coupling = 0;

        for my $rule (@{ $service->{rules} }) {
            my $has_user = $rule->{has_user};
            if ($has_user eq 'both') {
                $is_coupling = 1;
                next;
            }
            for my $what (qw(src dst)) {

                next if $what eq $has_user;
                my $all = $rule->{$what};
                push(@objects, @$all);
            }
        }

        @objects = unique(@objects);

        if ($is_coupling) {
            @objects = unique(@objects, @$users);
            $users = [];
        }

        # Store referenced objects for later use during export.
        @all_objects{@objects, @$users} = (@objects, @$users);

        # Input: owner objects, output: owner names
        my $owners = owners_for_objects(\@objects);
        if ($service->{sub_owner}) {
            $service->{sub_owner} = $service->{sub_owner}->{name};
        }
        $service->{owners} = $owners;
        $service->{part_owners} = part_owners_for_objects(\@objects);
        $service->{outer_owners} = outer_owners_for_objects(\@objects);

        my $uowners = owners_for_objects($users);
        $service->{uowners} = $uowners;
        $service->{part_uowners} = part_owners_for_objects($users);
        $service->{outer_uowners} = outer_owners_for_objects($users);

        $service->{visible} = find_visibility($owners, $uowners);
    }
}

######################################################################
# Fill attribute part_owners at objects which contain objects
# belonging to other owners.
######################################################################

sub setup_part_owners {
    progress("Setup part owners");

    # Handle hosts of network.
    # Don't handle interfaces here, because
    # - unmanaged interface doesn't have owner and
    # - managed interface isn't part of network.
    for my $network (values %networks) {
        $network->{disabled} and next;
        my $net_owner = $network->{owner} || '';
        for my $host (@{ $network->{hosts} }) {
            my $owner = $host->{owner} or next;
            if ($owner ne $net_owner) {
                $network->{part_owners}->{$owner} = $owner;
#               debug "$network->{name} : $owner->{name}";
            }
        }
    }

    # Add owner and part_owner of network to enclosing aggregates,
    # networks and zone.
    for my $network (values %networks) {
        $network->{disabled} and next;
        my @owners;
        if (my $hash = $network->{part_owners}) {
            @owners = values %$hash;
        }
        if (my $net_owner = $network->{owner}) {
            push @owners, $net_owner;
        }
        my $add_part_owner = sub {
            my($obj) = @_;
            my $obj_owner = $obj->{owner} || '';
            for my $owner (@owners) {
                if ($owner ne $obj_owner) {
                    $obj->{part_owners}->{$owner} = $owner;
#                   debug "$obj->{name} : $owner->{name}";
                }
            }
        };
        my $up = $network->{up};
        while($up) {
            $add_part_owner->($up);
            $up = $up->{up};
        }
        $add_part_owner->($network->{zone});
    }

    # Substitute hash by array in attribute {part_owners}.
    for my $network (values %networks) {
        $network->{disabled} and next;
        if (my $hash = $network->{part_owners}) {
            $network->{part_owners} = [ values %$hash ];
        }
    }
    for my $zone (@all_zones) {
        if (my $hash = $zone->{part_owners}) {
            $zone->{part_owners} = [ values %$hash ];
        }
        for my $obj (values %{ $zone->{ipmask2aggregate} }) {
            if (my $hash = $obj->{part_owners}) {

                # Ignore supernet which is both, network and member of
                # ipmask2aggregate.
                next if !$obj->{is_aggregate};
                $obj->{part_owners} = [ values %$hash ];
            }
        }
    }
    return;
}

# 1. Fill attribute {outer_owners} at hosts, interfaces and networks.
#    For network, collect owners from enclosing networks and zone,
#    that are different from networks owner.
#    For host, collect owners of enclosing networks and zone,
#    that are different from hosts owner.
# 2. Fill attribute {extended_by} for owners, with list of other owners
#    of enclosing objects, that are allowed to watch that owner.
#    An outer owner is allowed to select the role of an inner owner,
#    if all assets of the inner owner are located inside of assets
#    that are owned by the outer owner.
# Attribute {hide_from_outer_owners} is given at inner owner and hides
# from outer owners.
# Attribute {show_hidden_owners} at outer owner cancels effect of
# {hide_from_outer_owners}
sub setup_outer_owners {
    progress("Setup outer owners");

    # Find master owner.
    my $master_owner;
    if (($master_owner) = grep { $_->{show_all} } values %owners) {
        progress("Found master owner: $master_owner->{name}");
    }

    # For each owner, collect intersection of all outer owners.
    my %owner2outer_owners;
    my $intersect_outer_owners = sub {
        my ($owner, $outer_owners) = @_;
        if (my $owner_hash = $owner2outer_owners{$owner}) {
            $outer_owners = [ grep { $owner_hash->{$_} } @$outer_owners ];
        }
        my %new_hash;
        @new_hash{@$outer_owners} = @$outer_owners;
        $owner2outer_owners{$owner} = \%new_hash;
    };

    # Collect outer owners for each zone and all objects inside zone.
    for my $zone (@all_zones) {
        my @zone_owners;
        my $zone_owner = $zone->{owner};
        if ($zone_owner) {
            push @zone_owners, $zone_owner;
        }

        # {watching_owners} holds list of owners, that have been
        # inherited from areas.
        if (my $watching = $zone->{watching_owners}) {
            my @outer_owners = @$watching;
            if ($zone_owner and $zone_owner->{hide_from_outer_owners}) {
                @outer_owners = grep { $_->{show_hidden_owners} } @outer_owners;
            }
            if ($zone_owner) {
                $intersect_outer_owners->($zone_owner, \@outer_owners);
            }
            push @zone_owners, @outer_owners;
            $zone->{outer_owners} = \@outer_owners;
        }

        for my $network (@{ add_subnetworks($zone->{networks}) },
                         values %{ $zone->{ipmask2aggregate} })
        {
            my %outer_owners;
            my $net_owner = $network->{owner} || '';
            my $up = $network;
            while ($up = $up->{up}) {
                my $outer_owner = $up->{owner} or next;
                next if $outer_owner eq $net_owner;
                $outer_owners{$outer_owner} = $outer_owner;
            }
            @outer_owners{@zone_owners} = @zone_owners;
            delete $outer_owners{$net_owner};
            my @net_outer_owners = sort by_name values %outer_owners;
            if ($net_owner and $net_owner->{hide_from_outer_owners}) {
                @net_outer_owners =
                    grep { $_->{show_hidden_owners} } @net_outer_owners;
            }
            if (@net_outer_owners) {
                $network->{outer_owners} = \@net_outer_owners;
            }
            if ($net_owner) {
                $intersect_outer_owners->($net_owner, \@net_outer_owners);
                $outer_owners{$net_owner} = $net_owner;
            }
            for my $obj (@{ $network->{interfaces} }, @{ $network->{hosts} }) {
                my $owner = $obj->{owner} || '';
                my %outer_for_obj;
                my $router = $obj->{router};
                if ($router and ($router->{managed} or $router->{routing_only}))
                {
                    if ($master_owner) {
                        %outer_for_obj = ($master_owner => $master_owner);
                    }
                }
                else {
                    %outer_for_obj = %outer_owners;
                }
                delete $outer_for_obj{$owner};
                my @obj_outer_owners = sort by_name values %outer_for_obj;
                if ($owner and $owner->{hide_from_outer_owners}) {
                    @obj_outer_owners =
                        grep { $_->{show_hidden_owners} } @obj_outer_owners;
                }
                @obj_outer_owners or next;
                $obj->{outer_owners} = \@obj_outer_owners;
                if ($owner) {
                    $intersect_outer_owners->($owner, \@obj_outer_owners);
                }
            }
        }
    }

    # Intersection of all outer owners of one owner is allowed to take
    # role of corresponding inner owner.
    for my $owner (values %owners) {
        my $outer_owners = $owner2outer_owners{$owner} or next;
        keys %$outer_owners or next;
        $owner->{extended_by} = [ sort by_name values %$outer_owners ];
    }
}

######################################################################
# Export no-NAT-set
# - relate each network to its owner and part_owners
# - build a no_nat_set for each owner, where own networks aren't translated
######################################################################

sub export_no_nat_set {
    progress("Export no-NAT-sets");
    my %owner2net;
    for my $network (values %networks) {
        $network->{disabled} and next;
        for my $owner_name
            (owner_for_object($network),
             part_owners_for_object($network),
             outer_owners_for_object($network),
            )
        {
            $owner2net{$owner_name}->{$network} = $network;
        }
    }
    my %owner2no_nat_set;
    my %all_nat_tags;
    $owner2net{$_} ||= {} for keys %owners;
    for my $owner_name (sort keys %owner2net) {
        my %nat_domains;
        for my $network (values %{ $owner2net{$owner_name} }) {
            my $nat_domain = $network->{nat_domain};
            $nat_domains{$nat_domain} = $nat_domain;
        }
        my @nat_domains = values %nat_domains;
        if (not @nat_domains) {

            # Special value 'undef' marks owner without any networks.
            # This will be changed to all_nat_tags below.
            $owner2no_nat_set{$owner_name} = undef;
            next;
        }
#       if ((my $count = @nat_domains) > 1) {
#           print "$owner_name has $count nat_domains\n";
#           for my $network (values %{ $owner2net{$owner_name} }) {
#               my $d = $network->{nat_domain};
#               print " - $d->{name}: $network->{name}\n";
#           }
#       }

        # Build union of no_nat_sets
        my $no_nat_set = [ sort(unique(map { keys(%{ $_->{no_nat_set} }) }
                                           @nat_domains)) ];
#       debug "$owner_name: ", join(',', sort @$no_nat_set);
        $owner2no_nat_set{$owner_name} = $no_nat_set;
        @all_nat_tags{@$no_nat_set} = @$no_nat_set;
    }
    my @all_nat_tags = sort values %all_nat_tags;
    for my $owner_name (keys %owner2no_nat_set) {
        my $no_nat_set = $owner2no_nat_set{$owner_name} || \@all_nat_tags;
        create_dirs("owner/$owner_name");
        export("owner/$owner_name/no_nat_set", $no_nat_set);
    }
    return;
}

####################################################################
# Export hosts, networks and zones (represented by aggregate 0/0) for
# each owner and sub_owner.
####################################################################

# {networks} only contains toplevel networks.
# Add subnets recursively.
sub add_subnetworks {
    my ($networks) = @_;
    my $result;
    for my $network (@$networks) {
        if (my $subnetworks = $network->{networks}) {
            push @$result, @{ add_subnetworks($subnetworks) };
        }
    }
    if ($result) {
        push @$result, @$networks;
        return $result;
    }
    else {
        return $networks;
    }
}

sub export_assets {
    progress("Export assets");
    my %result;

    my $export_networks = sub {
        my ($networks, $owner, $own_zone) = @_;
        my %sub_result;
        for my $net (@$networks) {
            next if $net->{ip} eq 'tunnel';
            if ($net->{loopback}) {

                # Show loopback interface as network in assets.
                for my $interface (@{ $net->{interfaces} }) {
                    $all_objects{$interface} = $interface;
                    my $intf_name = $interface->{name};
                    $sub_result{$intf_name} = [];
                }
                next;
            }
            $all_objects{$net} = $net;
            my $net_name = $net->{name};

            # Export hosts and interfaces.
            my @childs = (@{ $net->{hosts} }, @{ $net->{interfaces} });

            # Show only own childs in foreign network.
            if (!$own_zone) {
                my $net_owner = owner_for_object($net) || '';
                if ($net_owner ne $owner) {
                    @childs =
                        grep({ my $o = owner_for_object($_); $o and $o eq $owner }
                             @childs);
                }
            }

            @all_objects{@childs} = @childs;
            @childs = sort map { $_->{name} } @childs;
            $sub_result{$net_name} = \@childs;
        }
        return \%sub_result;
    };

    # Different zones can use the same name from ipmask2aggregate
    # '0/0' if they belong to the same zone_cluster.
    # Hence augment existing hash.
    my $add_networks_hash = sub {
        my ($owner, $name, $hash) = @_;
        @{ $result{$owner}->{anys}->{$name}->{networks} }{ keys %$hash } =
            values %$hash;
    };

    for my $zone (@all_zones) {

        # All aggregates can be used in rules.
        for my $aggregate (values %{ $zone->{ipmask2aggregate} }) {
            $all_objects{$aggregate} = $aggregate;
        }

        # Ignore empty zone with only tunnel or unnumbered networks.
        next if not @{ $zone->{networks} };

        # Zone with network 0/0 doesn't have an aggregate 0/0.
        my $any = $zone->{ipmask2aggregate}->{"$zero_ip$zero_ip"};
        my $zone_name = $any ? $any->{name} : $zone->{name};
#        debug "$zone_name";
        my $networks = add_subnetworks($zone->{networks});
        for my $owner (owner_for_object($zone),
                       outer_owners_for_object($zone))
        {
#            debug "- $owner";
            $add_networks_hash->(
                $owner,
                $zone_name,
                $export_networks->($networks, $owner, 1));
        }
        for my $owner (part_owners_for_object($zone)) {

            # Show only own or part_owned networks in foreign zone.
            my $own_networks =
                [ grep
                  { grep({ $owner eq $_ }
                         owner_for_object($_), part_owners_for_object($_)) }
                  @$networks ];
#            debug "- $_->{name}" for @$own_networks;
            $add_networks_hash->(
                $owner,
                $zone_name,
                $export_networks->($own_networks, $owner, 0));
        }
    }

    $result{$_} ||= {} for keys %owners;
    for my $owner (keys %result) {
        my $hash = $result{$owner};
        create_dirs("owner/$owner");
        export("owner/$owner/assets", $hash);
    }
    return;
}

####################################################################
# Services, rules, users
####################################################################

# Set attribute {visible_owner_hash} once for all objects.
# When creating user and service lists for each owner,
# we need to lookup, if an object should be visible by this owner.
sub set_visible_owner_hash {
    for my $object (values %all_objects) {
        my @owner_list = (
            owner_for_object($object),
            part_owners_for_object($object),
            outer_owners_for_object($object)
        );
        @{$object->{visible_owner_hash}}{@owner_list} = @owner_list;
    }
}

# Calculate unique id for set of rules.
# Take first 8 characters of base64 encoded SHA1 hash.
# This gives 8x6=48 bits.
# Collisions would occur with probability of 0.5 for 2^24 different ids.
# We should be extremely safe for up to 2^14 different ids.
sub calc_rules_key {
    my ($rules) = @_;
    my $text = to_json($rules, {canonical => 1});
    my $digest = sha1_base64($text);
    my $result = substr($digest, 0, 8);
    $result =~ tr/+\//-_/;
    return $result;
}

sub export_services {
    my ($normalized_services) = @_;
    progress("Export services");
    my %shash;
    my %owner2type2shash;
    for my $service (@$normalized_services) {
        my @rules = map {
            {
                action => $_->{action},
                has_user => $_->{has_user},
                src => [ sort map { $_->{name} } @{ $_->{src} } ],
                dst => [ sort map { $_->{name} } @{ $_->{dst} } ],
                prt => $_->{prt},
            }
        } @{ $service->{rules} };

        # Add extension to make name of split service unique.
        if ($service->{is_split}) {
            my $rules_key = calc_rules_key(\@rules);
            $service->{name} .= "($rules_key)";
        }

        for my $owner ($service->{sub_owner} || (),
                       @{ $service->{owners} },
                       @{ $service->{part_owners} },
                       @{ $service->{outer_owners} })
        {
            $owner2type2shash{$owner}->{owner}->{$service} = $service;
        }
        for my $owner (@{ $service->{uowners} },
                       @{ $service->{part_uowners} },
                       @{ $service->{outer_uowners} })
        {
            next if $owner2type2shash{$owner}->{owner}->{$service};
            $owner2type2shash{$owner}->{user}->{$service} = $service;
        }
        if (my $visible = $service->{visible}) {
            for my $owner (keys %owners) {
                my $hash = $owner2type2shash{$owner} ||= {};
                next if $hash->{owner}->{$service};
                next if $hash->{user}->{$service};
                if ($owner =~ $visible) {
                    $hash->{visible}->{$service} = $service;
                }
            }
        }

        # Show artificial owner :unknown if owner is unknown.
        my $exported_owners = $service->{owners};
        push @$exported_owners, ':unknown' if !@$exported_owners;
        my $details = {
            description => $service->{description},
            owner => $exported_owners,
        };
        if ($service->{sub_owner}) {
            $details->{sub_owner} = $service->{sub_owner};
        }

# Currently not used in backend.
#       if (@{ $service->{part_owners} }) {
#           $details->{part_owners} = $service->{part_owners};
#       }

        (my $sname = $service->{name}) =~ s/^\w+://;
        $shash{$sname} = { details => $details, rules => \@rules };
    }
    export("services", \%shash);
    return \%owner2type2shash;
}

sub export_users_and_service_lists {
    my ($owner2type2shash) = @_;

    progress("Export users and service_lists");
    set_visible_owner_hash();

    # Create file even for owner having no service at all.
    $owner2type2shash->{$_} ||= {} for keys %owners;
    for my $owner (sort keys %$owner2type2shash) {
        my $type2shash = $owner2type2shash->{$owner};
        my %type2snames;
        my %service2users;
        for my $type (qw(owner user visible)) {
            my @snames;
            for my $service (values %{ $type2shash->{$type} }) {
                (my $sname = $service->{name}) =~ s/^\w+://;
                push @snames, $sname;
                next if $type eq 'visible';
                my @users;
                if ($type eq 'owner') {
                    @users = @{ $service->{user} };
                }
                elsif ($type eq 'user') {
                    @users = grep({ $_->{visible_owner_hash}->{$owner} }
                                  @{ $service->{user} });
                }
                @users = sort map { $_->{name} } @users;
                $service2users{$sname} = \@users;
            }
            $type2snames{$type} = [ sort @snames ];
        }
        create_dirs("owner/$owner");
        export("owner/$owner/service_lists", \%type2snames);
        export("owner/$owner/users", \%service2users);
    }
    return;
}

####################################################################
# Export all objects referenced by rules, users and assets.
####################################################################

sub zone_and_subnet {
    my ($obj) = @_;

    # Change loopback interface to equivalent loopback network.
    # Network gets zone attribute added, which is needed in IP search
    # of NetspocWeb.
    if (is_interface($obj) && $obj->{loopback}) {
        $obj = $obj->{network};
    }
    is_network $obj or return ();
    my $zone = $obj->{zone};
    if ($obj->{is_aggregate}) {
        if (my $cluster = $zone->{zone_cluster}) {

            # Get deterministic zone for multiple aggregates with
            # identical name from zone cluster.
            ($zone) = @$cluster;
        }
    }
    my $any = $zone->{ipmask2aggregate}->{"$zero_ip$zero_ip"};
    my $zone_name = $any ? $any->{name} : $zone->{name};

    # Netspoc-Web only needs info about subnets in other zone.
    # Attribute name is different for historic reasons.
    my $is_supernet = $obj->{has_other_subnet};
#    debug "$obj->{name} $zone_name";
    return (zone => $zone_name, $is_supernet ? (is_supernet => 1) : () );
}

sub export_objects {
    progress("Export objects");
    my %objects = map {
        $_->{name} => {


            # Add key 'ip' and optionally key 'nat'.
            ip_nat_for_object($_),

            # Change loopback interface to loopback netwok, but leave name unchanged.
            # Add key 'zone' for network and aggregate.
            # Optionally add key 'is_supernet' for network and aggregate.
            zone_and_subnet($_),

            owner => scalar owner_for_object($_),
        }
    } values %all_objects;
    export("objects", \%objects);
    return;
}

####################################################################
# find Email -> Owner
####################################################################

sub export_owners {
    progress("Export owners");
    my %email2owners;
    for my $name ( keys %owners ) {
        my $owner = $owners{$name};
        my (@emails, @watchers, @e_owners);
        create_dirs("owner/$name");
        for my $email ( @{ $owner->{admins} } ) {
            $email2owners{$email}->{$name} = $name;
            push @emails, $email;
        }
        for my $email ( @{ $owner->{watchers} } ) {
            $email2owners{$email}->{$name} = $name;
            push @watchers, $email;
        }

        # Handle extending owners.
        my $outer_owners = $owner->{extended_by} || [];
        for my $e_owner (@$outer_owners) {

            # Allow both, admins and watchers to look at owner.
            for my $email (@{ $e_owner->{admins} }, @{ $e_owner->{watchers} }) {
                $email2owners{$email}->{$name} = $name;
            }
            push @e_owners, $e_owner->{name};
        }

        export("owner/$name/emails",
               [ map { { email => $_ } } sort @emails ]);
        export("owner/$name/watchers",
               [ map { { email => $_ } } sort @watchers ]);
        export("owner/$name/extended_by",
               [ map { { name => $_ } } sort @e_owners ]);
    }

    # Substitute hash by array.
    $_ = [ sort values(%$_) ] for values %email2owners;

    export("email", \%email2owners);

    # Is no longer used and is always empty.
    # Only exported for compatibility with older version of Netspoc-Web.
    my %owner2alias;
    export('owner2alias', \%owner2alias);
    return;
}

sub copy_policy_file {
    if ( -f $policy_file) {
        system("find $out_dir -type f -exec touch -r $policy_file {} \\;");
        system("cp -pf $policy_file $out_dir") == 0 or
            die "Can't copy $policy_file\n";
    }
    return;
}

####################################################################
# Initialize Netspoc data
####################################################################
$config =
    combine_config({time_stamps => 1, max_errors => 9999,
                    verbose => !$quiet, ipv6 => $ipv6? 1 : 0 });
init_global_vars();
read_file_or_dir($netspoc_data);
order_protocols();
link_topology();
mark_disabled();
set_zone();
setpath();
distribute_nat_info();
find_subnets_in_zone();

# Copy of %services with those services split, that have different 'user'.
my $normalized_services = normalize_services_for_export();
propagate_owners();
find_subnets_in_nat_domain();
adapt_owner_names();
setup_zones();
setup_part_owners();
setup_outer_owners();
setup_service_info($normalized_services);

####################################################################
# Export data
####################################################################
create_dirs('');
export_owners();
export_assets();
my $owner2type2shash = export_services($normalized_services);
export_users_and_service_lists($owner2type2shash);
export_objects();
export_no_nat_set();
copy_policy_file();
progress("Ready");