API REST pour le conteneur DNS

dns/Dockerfile

@@ -11,10 +11,60 @@ RUN apk add \
     s6-overlay \
     vim
 
+# Dependencies for REST API
+RUN apk add \
+    gcc \
+    libc-dev \
+    make \
+    perl-app-cpanminus \
+    perl-clone \
+    perl-config-any \
+    perl-data-optlist \
+    perl-dev \
+    perl-exporter-tiny \
+    perl-extutils-config \
+    perl-extutils-helpers \
+    perl-extutils-installpaths \
+    perl-file-sharedir \
+    perl-file-sharedir-install \
+    perl-file-slurp \
+    perl-file-which \
+    perl-hash-merge-simple \
+    perl-hash-multivalue \
+    perl-http-date \
+    perl-http-headers-fast \
+    perl-import-into \
+    perl-json-maybexs \
+    perl-module-build \
+    perl-module-build-tiny \
+    perl-module-implementation \
+    perl-module-runtime \
+    perl-moo \
+    perl-params-util \
+    perl-params-validate \
+    perl-path-tiny \
+    perl-plack \
+    perl-readonly \
+    perl-ref-util \
+    perl-role-tiny \
+    perl-safe-isa \
+    perl-sub-exporter \
+    perl-sub-install \
+    perl-sub-quote \
+    perl-template-toolkit \
+    perl-type-tiny \
+    perl-yaml
+
+RUN cpanm -n -v \
+    Dancer2 \
+    Module::Pluggable::Object
+
 RUN install -o named -g root -m 0755 -d /var/db/bind
 COPY --chown=named:root etc/bind/named.conf /etc/bind/named.conf
 COPY --chown=named:root zones /etc/bind/zones
 
+COPY web-api /src/api
+
 COPY etc/s6-overlay /etc/s6-overlay
 
 ENTRYPOINT ["/init"]

dns/etc/s6-overlay/s6-rc.d/api/run

@@ -0,0 +1,2 @@
+#!/bin/execlineb -P
+/usr/bin/env perl /src/api/bin/app.psgi

dns/etc/s6-overlay/s6-rc.d/api/type

@@ -0,0 +1 @@
+longrun

dns/web-api/MANIFEST

@@ -0,0 +1,24 @@
+MANIFEST
+MANIFEST.SKIP
+.dancer
+Makefile.PL
+config.yml
+cpanfile
+views/index.tt
+views/layouts/main.tt
+lib/Email/SpoofingDemo/API/DNS.pm
+t/002_index_route.t
+t/001_base.t
+environments/production.yml
+environments/development.yml
+bin/app.psgi
+public/500.html
+public/dispatch.cgi
+public/dispatch.fcgi
+public/favicon.ico
+public/404.html
+public/javascripts/jquery.js
+public/css/error.css
+public/css/style.css
+public/images/perldancer-bg.jpg
+public/images/perldancer.jpg

dns/web-api/MANIFEST.SKIP

@@ -0,0 +1,17 @@
+^\.git\/
+maint
+^tags$
+.last_cover_stats
+Makefile$
+^blib
+^pm_to_blib
+^.*.bak
+^.*.old
+^t.*sessions
+^cover_db
+^.*\.log
+^.*\.swp$
+MYMETA.*
+^.gitignore
+^.svn\/
+^Email-SpoofingDemo-API-DNS-

dns/web-api/Makefile.PL

@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+# Normalize version strings like 6.30_02 to 6.3002,
+# so that we can do numerical comparisons on it.
+my $eumm_version = $ExtUtils::MakeMaker::VERSION;
+$eumm_version =~ s/_//;
+
+WriteMakefile(
+    NAME                => 'Email::SpoofingDemo::API::DNS',
+    AUTHOR              => q{Marc van der Wal <marc.vanderwal@afnic.fr>},
+    VERSION_FROM        => 'lib/Email/SpoofingDemo/API/DNS.pm',
+    ABSTRACT            => 'Email spoofing demo: REST API for DNS',
+    ($eumm_version >= 6.3001
+      ? ('LICENSE'=> 'all-rights-reserved')
+      : ()),
+    PL_FILES            => {},
+    PREREQ_PM => {
+        'Test::More' => 0,
+        'YAML'       => 0,
+        'Dancer2'     => 0.300000,
+    },
+    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+    clean               => { FILES => 'Email-SpoofingDemo-API-DNS-*' },
+);

dns/web-api/bin/app.psgi

@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Email::SpoofingDemo::API::DNS;
+Email::SpoofingDemo::API::DNS->to_app;

dns/web-api/config.yml

@@ -0,0 +1,13 @@
+
+appname: "Email::SpoofingDemo::API::DNS"
+charset: "UTF-8"
+serializer: JSON
+
+# App-specific configuration
+
+# Directory in where zone files reside
+zone_directory: "/etc/bind/zones"
+
+# List of dynamic zones, requiring special treatment
+dynamic_zones:
+  - "expediteur.example"

dns/web-api/cpanfile

@@ -0,0 +1,11 @@
+requires "Dancer2" => "0.300000";
+
+recommends "YAML"             => "0";
+recommends "URL::Encode::XS"  => "0";
+recommends "CGI::Deurl::XS"   => "0";
+recommends "HTTP::Parser::XS" => "0";
+
+on "test" => sub {
+    requires "Test::More"            => "0";
+    requires "HTTP::Request::Common" => "0";
+};

dns/web-api/environments/development.yml

@@ -0,0 +1,15 @@
+# configuration file for development environment
+
+logger: "console"
+log: "core"
+
+# should Dancer2 consider warnings as critical errors?
+warnings: 1
+
+# should Dancer2 show a stacktrace when an 5xx error is caught?
+# if set to yes, public/500.html will be ignored and either
+# views/500.tt, 'error_template' template, or a default error template will be used.
+show_errors: 1
+
+# print the banner
+startup_info: 1

dns/web-api/environments/production.yml

@@ -0,0 +1,16 @@
+# configuration file for production environment
+
+# only log warning and error messsages
+log: "warning"
+
+# log message to a file in logs/
+logger: "file"
+
+# don't consider warnings critical
+warnings: 0
+
+# hide errors
+show_errors: 0
+
+# disable server tokens in production environments
+no_server_tokens: 1

dns/web-api/lib/Email/SpoofingDemo/API/DNS.pm

@@ -0,0 +1,112 @@
+package Email::SpoofingDemo::API::DNS;
+use Dancer2;
+
+use Email::SpoofingDemo::DNS::ZoneFile
+    qw(get_txt get_zone_file import_zone_file remove_txt set_txt
+       zone_file_path);
+
+our $VERSION = '0.1';
+
+my $base_dir = config->{'zone_directory'};
+my $dynamic_zones = config->{'dynamic_zones'};
+
+get '/' => sub { return "Welcome"; };
+
+prefix '/zone/:zone' => sub {
+    get '/file' => sub {
+        my $zone = route_parameters->get('zone');
+
+        if (zone_file_path($zone, $base_dir)) {
+            my $contents = get_zone_file($zone, $base_dir, $dynamic_zones);
+            return { contents => $contents };
+        }
+        else {
+            status 'not_found';
+            return "$zone: not found";
+        }
+    };
+
+    put '/file' => sub {
+        my $zone = route_parameters->get('zone');
+        my $contents = body_parameters->get("contents");
+
+        if (not defined $contents) {
+            status 'bad_request';
+            return "missing zone file contents";
+        }
+
+        my $result = import_zone_file($zone, $base_dir, $contents, $dynamic_zones);
+        if ($result) {
+            return;
+        }
+        else {
+            status 'bad_request';
+            return "bad zone file";
+        }
+    };
+
+    get '/spf' => sub {
+        my $zone = route_parameters->get('zone');
+        my @spfs = get_txt($zone, "", qr/v=spf1(\s+|\Z)/i, 1);
+
+        my %result;
+
+        for my $rec (@spfs) {
+            $result{$rec->{owner}} = $rec->{txt};
+        }
+
+        return \%result;
+    };
+
+    put '/spf' => sub {
+        my $zone = route_parameters->get('zone');
+        my $spf = body_parameters->get('spf');
+
+        status (set_txt($zone, "", $spf) ? 'ok' : 'forbidden');
+    };
+
+    del '/spf' => sub {
+        my $zone = route_parameters->get('zone');
+
+        status (remove_txt($zone, "") ? 'ok' : 'not_found');
+    };
+
+    get '/domainkey' => sub {
+        my $zone = route_parameters->get('zone');
+        my @dkims = get_txt($zone, "", qr/^v=DKIM1/, 1);
+
+        my %domainkeys;
+
+        for my $rec (@dkims) {
+            if ($rec->{owner} =~ /^(.+)\._domainkey\.(.*)$/i) {
+                my $selector = $1;
+                my $subzone = $2;
+                $domainkeys{$subzone}{$selector} = $rec->{txt};
+            }
+        }
+
+        return \%domainkeys;
+    };
+
+    get '/dmarc' => sub {
+        my $zone = route_parameters->get('zone');
+        my @dmarcs = get_txt($zone, "", qr/^v=DMARC1/, 1);
+
+        my %result;
+
+        for my $rec (@dmarcs) {
+            if ($rec->{owner} =~ /^_dmarc\.(.*)$/) {
+                my $domain = $1;
+                $result{$domain} = $rec->{txt};
+            }
+        }
+
+        return \%result;
+    };
+};
+
+any qr{.*} => sub { status 'not_found'; return "Invalid route" };
+
+dance;
+
+true;

dns/web-api/lib/Email/SpoofingDemo/DNS/ZoneFile.pm

@@ -0,0 +1,239 @@
+
+package Email::SpoofingDemo::DNS::ZoneFile;
+
+use strict;
+use warnings;
+use utf8;
+use v5.10;
+
+use Exporter qw(import);
+
+use File::Slurp;
+use Try::Tiny;
+
+our @EXPORT_OK = qw(get_txt get_zone_file import_zone_file remove_txt set_txt
+                    zone_file_path);
+
+sub safe_system {
+    my @argv = @_;
+    my $retval = system @argv;
+    die $! if ($retval == -1);
+    if ($retval != 0) {
+        my $status = $retval >> 8;
+        die join(" ", @argv) . " exited with status $status\n";
+    };
+    return 1;
+}
+
+sub is_dynamic_zone {
+    my ($zone, $dynamic_zones) = @_;
+
+    return grep { $_ eq $zone } @$dynamic_zones;
+}
+
+sub rndc_freeze {
+    my ($zone) = @_;
+
+    safe_system('rndc', 'freeze', $zone);
+}
+
+sub rndc_thaw {
+    my ($zone) = @_;
+
+    safe_system('rndc', 'thaw', $zone);
+}
+
+sub rndc_reload {
+    my ($zone) = @_;
+
+    safe_system('rndc', 'reload', $zone);
+}
+
+sub encode_txt {
+    my ($text) = @_;
+
+    my $chunk_length = 255;
+    my $text_bytes = $text;
+    utf8::encode($text_bytes);
+
+    my @parts;
+    for (my $i = 0; $i < length($text_bytes); $i += $chunk_length) {
+        my $part = substr($text_bytes, $i, 255);
+        $part =~ s/[\x00-\x1f"\x7f-\xff]/sprintf('\\%03d', ord($0))/eg;
+        push @parts, qq{"$part"};
+    }
+
+    return join(" ", @parts);
+}
+
+sub relative_to_absolute {
+    my ($zone, $relative_owner) = @_;
+
+    if ($relative_owner eq '') {
+        return $zone;
+    }
+    else {
+        return "$relative_owner.$zone";
+    }
+}
+
+sub nsupdate {
+    my ($zone, @instructions) = @_;
+
+    open(my $pipe, '|-', 'nsupdate') or die "Can’t fork: $!";
+    say $pipe qq{zone $zone};
+    say $pipe $_ foreach (@instructions);
+    close($pipe);
+
+    return (($? >> 8) == 0);
+}
+
+sub get_txt {
+    my ($zone, $relative_owner, $filter, $sublabels_ok) = @_;
+
+    $filter //= qr{.*};
+    $sublabels_ok //= 0;
+
+    my @dig_opts = qw(+nottlid +noclass +norecurse +noall +answer @127.0.0.1);
+
+    my $owner_suffix = relative_to_absolute($zone, $relative_owner);
+    my $qname = ($sublabels_ok ? $zone : $owner_suffix);
+    my $qtype = ($sublabels_ok ? 'AXFR' : 'TXT');
+    my $owner_match_re = ($sublabels_ok ? qr/^([^.]+\.)*$owner_suffix\.$/i : qr/^$qname\.$/i);
+
+    my @result;
+
+    open(my $pipe, '-|', 'dig', @dig_opts, $qtype, $qname) or die "Can’t fork: $!";
+
+    while (<$pipe>) {
+        chomp;
+
+        next if /^;/;
+        next if /^\s*$/;
+
+        my ($owner, $type, $data) = split(" ", $_, 3);
+
+        unless ($type eq 'TXT') {
+            next;
+        }
+        unless ($owner =~ $owner_match_re) {
+            next;
+        }
+
+        my $concat_data = ($data =~ s/"((?:[^\\"]|\\"|\\\d{3})*)"\s*/$1/gr);
+        unless ($concat_data =~ $filter) {
+            next;
+        }
+
+        push @result, { owner => ($owner =~ s/\.$//r), txt => $concat_data };
+    }
+
+    close($pipe);
+
+    if (wantarray) {
+        return @result;
+    }
+    else {
+        return $result[0];
+    }
+}
+
+sub set_txt {
+    my ($zone, $relative_owner, $txt) = @_;
+    my $owner = relative_to_absolute($zone, $relative_owner);
+    my $txt_encoded = encode_txt($txt);
+
+    nsupdate(
+        $zone,
+        "update delete $owner 0 IN TXT",
+        "update add $owner IN TXT $txt_encoded",
+        "send");
+}
+
+sub remove_txt {
+    my ($zone, $relative_owner) = @_;
+    my $owner = relative_to_absolute($zone, $relative_owner);
+
+    nsupdate(
+        $zone,
+        "update delete $owner 0 IN TXT",
+        "send");
+}
+
+sub check_zone {
+    my ($zone_contents, $origin) = @_;
+
+    open(my $pipe, '|-', 'named-checkzone', $origin, '-') or die "Can’t fork: $!";
+    print $pipe $zone_contents;
+    close($pipe);
+
+    return (($? >> 8) == 0);
+}
+
+sub zone_file_path {
+    my ($zone, $base_dir, $force) = @_;
+
+    my @components = reverse(split(/\./, $zone));
+    my $path = $base_dir . '/' . (join('/', @components)) . ".zone";
+
+    if (not -f $path and not $force) {
+        return undef;
+    }
+    return $path;
+}
+
+sub get_zone_file {
+    my ($zone, $base_dir, $dynamic_zones) = @_;
+
+    my $path = zone_file_path($zone, $base_dir);
+    return undef if not defined $path;
+
+    rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);
+
+    my $contents;
+    try {
+        $contents = read_file($path);
+    }
+    finally {
+        rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
+    };
+
+    return $contents;
+}
+
+sub import_zone_file {
+    my ($zone, $base_dir, $contents, $dynamic_zones) = @_;
+
+    if ($contents =~ /^\s*$/) {
+        warn "Zone to import is empty";
+        return undef;
+    }
+
+    my $path = zone_file_path($zone, $base_dir);
+    if (not defined $path) {
+        warn "No zone file for $zone in $base_dir";
+        return undef;
+    }
+
+    if (not check_zone($contents, $zone)) {
+        warn "Zone file contents do not pass syntax check";
+        return undef;
+    }
+
+    rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);
+
+    try {
+        write_file($path, $contents);
+        rndc_reload($zone) unless is_dynamic_zone($zone, $dynamic_zones);
+    }
+    catch {
+        die $_;
+    }
+    finally {
+        rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
+    };
+
+    return 1;
+}
+
+1;

dns/web-api/public/dispatch.cgi

@@ -0,0 +1,16 @@
+#!/usr/bin/env perl
+BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
+use Dancer2;
+use FindBin '$RealBin';
+use Plack::Runner;
+
+# For some reason Apache SetEnv directives don't propagate
+# correctly to the dispatchers, so forcing PSGI and env here
+# is safer.
+set apphandler => 'PSGI';
+set environment => 'production';
+
+my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
+die "Unable to read startup script: $psgi" unless -r $psgi;
+
+Plack::Runner->run($psgi);

dns/web-api/public/dispatch.fcgi

@@ -0,0 +1,18 @@
+#!/usr/bin/env perl
+BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
+use Dancer2;
+use FindBin '$RealBin';
+use Plack::Handler::FCGI;
+
+# For some reason Apache SetEnv directives don't propagate
+# correctly to the dispatchers, so forcing PSGI and env here
+# is safer.
+set apphandler => 'PSGI';
+set environment => 'production';
+
+my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
+my $app = do($psgi);
+die "Unable to read startup script: $@" if $@;
+my $server = Plack::Handler::FCGI->new(nproc => 5, detach => 1);
+
+$server->run($app);