Time to edit zone files

bin/build_zone

@@ -0,0 +1,142 @@
+#!/usr/bin/env perl
+
+=head1 build_zone
+
+Build the basic zone for a tCMS site and import it into powerdns.
+Otherwise, make it a post so you can edit it in the config backend.
+
+In general this should not be called outside of Installer.mk.
+
+=head2 OPTIONS
+
+=head3 subdomain
+
+Specify a subdomain, such as 'foo' to add to the domain.
+
+May be passed multiple times.
+
+=head3 gsv
+
+Google site verification string goes into TXT record
+
+=head3 cname
+
+Specify a cname, such as 'bar' to add to the domain.
+
+By default, the cnames 'www', 'mail' and 'chat' are set up, as these are essential tCMS services setup by the makefile before this.
+
+May be passed multiple times.
+
+=cut
+
+use strict;
+use warnings;
+
+no warnings qw{experimental};
+use feature qw{signatures state};
+
+use FindBin::libs;
+use Trog::Config();
+use Trog::Zone();
+
+use DNS::Unbound;
+use Net::DNS::Packet;
+
+use Text::Xslate;
+use Net::IP;
+
+use Getopt::Long qw{GetOptionsFromArray};
+
+exit main(@ARGV) unless caller;
+
+sub main(@args) {
+
+    my %options;
+    GetOptionsFromArray(\@args,
+        'subdomain=s@' => \$options{subdomains},
+        'gsv=s'        => \$options{gsv},
+        'cname=s@'     => \$options{cnames},
+    );
+
+    # Paranoia, some versions of getopt don't do this
+    $options{cnames}     //= [];
+    $options{subdomains} //=[];
+
+    my $domain = Trog::Config->get()->param('general.hostname');
+    die "Hostname not set in tCMS configuration.  Please set this first." unless $domain;
+
+    # Get a flesh start
+    Trog::Zone::delzone($domain);
+
+    my ($ip)  = domain2ips($domain, 'A');
+    my ($ip6) = domain2ips($domain, 'AAAA');
+
+    my $data = {
+        ip  => $ip,
+        ip6 => $ip6,
+        ip_reversed  => Net::IP->new($ip)->reverse_ip(),
+        ip6_reversed => Net::IP->new($ip6)->reverse_ip(),
+        title => $domain,
+        nameservers => ["ns1.$domain"],
+        subdomains  => [map { { name => $_, ip => domain2ips("$_.$domain", "A"), "ip6" => domain2ips("$_.$domain", "AAAA"), nameservers => ["ns1.$_.$domain"] } } @{$options{subdomains}}],
+        cnames      => [(qw{www mail chat},@{$options{cnames}})],
+        gsv_string  => $options{gsv},
+        version    => 0,
+        dkim_pkey => extract_pkey($domain),
+        acme_challenge => get_dns_dcv_string( $domain ),
+    };
+
+    my $zone = Trog::Zone::addzone($data);
+
+    my $processor = Text::Xslate->new( path => 'www/templates/text' );
+    print $processor->render('zone.tx', $zone);
+
+    return 0;
+}
+
+sub extract_pkey ( $domain ) {
+    open(my $fh, '<', "/etc/opendkim/keys/$domain/mail.public");
+    my @lines = map { chomp $_; $_ } readline $fh;
+    close $fh;
+    shift @lines;
+    pop @lines;
+    return join('', @lines);
+}
+
+sub get_dns_dcv_string( $domain ) {
+    return "TODO";
+}
+
+sub domain2ips( $domain, $type ) {
+    # XXX would be great to use state here, but felipe
+    my $resolver = DNS::Unbound->new();
+
+    my $p = $resolver->resolve( $domain, $type )->answer_packet();
+    my @rrs = Net::DNS::Packet->new( \$p )->answer;
+
+    my @addr = map { $_->address } @rrs;
+    @addr=(get_local_ip($type)) unless @addr;
+    return @addr;
+}
+
+my $addrout='';
+sub get_local_ip( $type ) {
+    $addrout //=qx{ip addr};
+    return $type eq 'A' ? _ipv4() : _ipv6();
+}
+
+sub _ipv4 {
+    state $ip;
+    return $ip if $ip;
+    ($ip) = $addrout =~ m{inet\s+([\d|\.|/]+)\s+scope\s+global}gmx;
+    return $ip;
+}
+
+sub _ipv6 {
+    state $ip6;
+    return $ip6 if $ip6;
+    ($ip6) = $addrout =~ m{inet6\s+([a-f|\d|:|/]+)\s+scope\s+global\s+dynamic\s+mngtmpaddr}gmx;
+    # We have to strip the CIDR off of it, or it breaks Net::IP's brain.
+    $ip6 =~ s|/\d+$||;
+    return $ip6;
+}

lib/Trog/Data.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 no warnings 'experimental';
-use feature qw{signatures};
+use feature qw{signatures state};
 
 #It's just a factory
 
@@ -19,11 +19,15 @@ Returns a new Trog::Data::* class appropriate to what is configured in the Trog:
 =cut
 
 sub new ( $class, $config ) {
+    state $datamodule;
+    return $datamodule if $datamodule;
+
     my $module = "Trog::Data::" . $config->param('general.data_model');
     my $req    = $module;
     $req =~ s/::/\//g;
     require "$req.pm";
-    return $module->new($config);
+    $datamodule = $module->new($config);
+    return $datamodule;
 }
 
 1;

lib/Trog/DataModule.pm

@@ -140,23 +140,21 @@ sub _fixup ( $self, @filtered ) {
     return @filtered;
 }
 
+sub _filter_param ( $query, $param, @filtered ) {
+    @filtered = grep { ( $_->{$param} || '') eq $query->{$param} } @filtered;
+    @filtered = _dedup_versions( $query->{version}, @filtered );
+    return @filtered;
+}
+
 sub filter ( $self, $query, @filtered ) {
     $query->{acls}         //= [];
     $query->{tags}         //= [];
     $query->{exclude_tags} //= [];
 
-    # If an ID is passed, just get that (and all it's prior versions)
-    if ( $query->{id} ) {
-        @filtered = grep { $_->{id} eq $query->{id} } @filtered;
-        @filtered = _dedup_versions( $query->{version}, @filtered );
-        return @filtered;
-    }
-
-    # XXX aclname and id are essentially serving the same purpose, should unify
-    if ( $query->{aclname} ) {
-        @filtered = grep { ( $_->{aclname} || '' ) eq $query->{aclname} } @filtered;
-        @filtered = _dedup_versions( $query->{version}, @filtered );
-        return @filtered;
+    # If an ID or title or acl is passed, just get that (and all it's prior versions)
+    foreach my $key (qw{id title aclname}) {
+        next unless exists $query->{$key};
+        return _filter_param( $query, $key, @filtered);
     }
 
     @filtered = _dedup_versions( undef, @filtered );
@@ -319,6 +317,9 @@ our %schema = (
     # Author of the post
     'user'    => $not_ref,
     'created' => $not_ref,
+
+    # Specific to various posts below.
+
     ## Series specific parameters
     'child_form' => $not_ref,
     'aclname'    => $not_ref,
@@ -333,6 +334,7 @@ our %schema = (
     # user avatar, but does double duty in content posts as preview images on videos, etc
     'preview_file' => $hashref_or_string,
     'preview'      => $not_ref,
+
     ## Content specific parameters
     'audio_href' => $not_ref,
     'video_href' => $not_ref,

lib/Trog/Routes/TXT.pm

@@ -0,0 +1,50 @@
+package Trog::Routes::JSON;
+
+use strict;
+use warnings;
+
+no warnings 'experimental';
+use feature qw{signatures state};
+
+use Clone qw{clone};
+use JSON::MaybeXS();
+
+use Scalar::Util();
+
+use Trog::Utils();
+use Trog::Config();
+use Trog::Auth();
+use Trog::Routes::HTML();
+
+use Trog::Log::Metrics();
+
+my $conf = Trog::Config::get();
+
+# TODO de-duplicate this, it's shared in html
+my $theme_dir = '';
+$theme_dir = "themes/" . $conf->param('general.theme') if $conf->param('general.theme') && -d "www/themes/" . $conf->param('general.theme');
+
+our %routes = (
+    '/text/zone' => {
+        method     => 'GET',
+        callback   => \&zone,
+        parameters => {},
+        admin      => 1,
+    },
+);
+
+sub zone ($query) {
+    return _render( 200, {}, $query );
+}
+
+sub _render ( $code, $headers, %data ) {
+    return Trog::Renderer->render(
+        code        => 200,
+        data        => \%data,
+        template    => 'zone.tx',
+        contenttype => 'text/plain',
+        headers     => $headers,
+    );
+}
+
+1;

lib/Trog/Vars.pm

@@ -3,6 +3,12 @@ package Trog::Vars;
 use strict;
 use warnings;
 
+use feature qw{signatures};
+no warnings qw{experimental};
+
+use Ref::Util();
+use List::Util qw{any};
+
 #1MB chunks
 our $CHUNK_SEP  = 'tCMSep666YOLO42069';
 our $CHUNK_SIZE = 1024000;
@@ -27,4 +33,83 @@ our %cache_control = (
     static     => "public, max-age=604800, immutable",
 );
 
+our $not_ref = sub {
+    return !Ref::Util::is_ref(shift);
+};
+
+our $valid_cb = sub {
+    my $subname = shift;
+    my ($modname) = $subname =~ m/^([\w|:]+)::\w+$/;
+
+    # Modules always return 0 if they succeed!
+    eval { require $modname; } and do {
+        WARN("Post uses a callback whos module ($modname) cannot be found!");
+        return 0;
+    };
+
+    no strict 'refs';
+    my $ref = eval '\&' . $subname;
+    use strict;
+    return Ref::Util::is_coderef($ref);
+};
+
+our $hashref_or_string = sub {
+    my $subj = shift;
+    return Ref::Util::is_hashref($subj) || $not_ref->($subj);
+};
+
+# Shared Post schema
+our %schema = (
+    ## Parameters which must be in every single post
+    'title'      => $not_ref,
+    'callback'   => $valid_cb,
+    'tags'       => \&Ref::Util::is_arrayref,
+    'version'    => $not_ref,
+    'visibility' => $not_ref,
+    'aliases'    => \&Ref::Util::is_arrayref,
+    'tiled'      => $not_ref,
+
+    # title links here
+    'href' => $not_ref,
+
+    # Link to post locally
+    'local_href' => $not_ref,
+
+    # Post body
+    'data' => $not_ref,
+
+    # How do I edit this post?
+    'form' => $not_ref,
+
+    # Post is restricted to visibility to these ACLs if not public/unlisted
+    'acls' => \&Ref::Util::is_arrayref,
+    'id'   => $not_ref,
+
+    # Author of the post
+    'user'    => $not_ref,
+    'created' => $not_ref,
+);
+
+=head2 filter($data,[$schema]) = %$data_filtered
+
+Filter the provided data through the default schema, and optionally a user-provided schema.
+
+Remove unwanted params to keep data slim & secure.
+
+=cut
+
+sub filter ($data, $user_schema={}) {
+    %$user_schema = (
+        %schema,
+        %$user_schema,
+    );
+
+    # Filter all the irrelevant data
+    foreach my $key ( keys(%$data) ) {
+        # We need to have the key in the schema, and it validate.
+        delete $data->{$key} unless List::Util::any { ( $_ eq $key ) && ( $user_schema->{$key}->( $data->{$key} ) ) } keys(%$user_schema);
+    }
+    return %$data;
+}
+
 1;

lib/Trog/Zone.pm

@@ -0,0 +1,102 @@
+package Trog::Zone;
+
+=head1 Trog::Zone
+
+=head2 DESCRIPTION
+
+Zonefile CRUD
+
+=cut
+
+use strict;
+use warnings;
+
+use feature qw{signatures};
+no warnings qw{experimental};
+
+use Trog::Config;
+use Trog::Data;
+use Trog::Vars;
+
+use Net::IP;
+use Ref::Util;
+
+=head2 zone($domain) = @zonedata
+
+Returns the zone data for the requested zone.
+Like any other post in TCMS it's versioned.
+
+=cut
+
+sub zone($domain, $version=undef) {
+    my $conf = Trog::Config::get();
+    my $data = Trog::Data->new($conf);
+
+    my @zonedata = $data->get( tags => ['zone'], acls => [qw{admin}], title => $domain  );
+    @zonedata = grep { $_->{version} == $version } @zonedata if defined $version;
+    return @zonedata;
+}
+
+=head2 addzone($domain, %options)
+
+Add a post of 'zone' type.
+
+=cut
+
+my $valid_ip = sub {
+    return Net::IP->new(shift);
+};
+
+my $valid_rev_ip = sub {
+    return shift =~ m/\.in-addr\.arpa$/;
+};
+
+my $valid_rev_ip6 = sub {
+    return shift =~ m/\.ip6\.arpa$/;
+};
+
+my $spec = {
+    ip             => $valid_ip,
+    ip6            => $valid_ip,
+    ip_reversed    => $valid_rev_ip,
+    ip6_reversed   => $valid_rev_ip6,
+    domain         => $Trog::Vars::not_ref,
+    nameservers    => \&Ref::Util::is_arrayref,
+    subdomains     => \&Ref::Util::is_arrayref,
+    cnames         => \&Ref::Util::is_arrayref,
+    gsv_string     => $Trog::Vars::not_ref,
+    dkim_pkey      => $Trog::Vars::not_ref,
+    acme_challenge => $Trog::Vars::not_ref,
+};
+
+sub addzone($query) {
+    my $domain = $query->{title};
+    return unless $domain;
+    my ($latest) = zone($domain);
+    $latest //= {};
+
+    my $conf = Trog::Config::get();
+    my $data = Trog::Data->new($conf);
+
+    %$latest = (
+        %$latest,
+        Trog::Vars::filter($query, $spec),
+    );
+
+    $data->add($latest);
+
+    #TODO render and import into pdns
+
+    return $latest;
+}
+
+sub delzone($domain) {
+    my $conf = Trog::Config::get();
+    my $data = Trog::Data->new($conf);
+
+    my ($latest) = zone($domain);
+    return unless $latest;
+    return $data->delete($latest);    
+}
+
+1;

www/templates/text/zone.tx

@@ -1,7 +1,7 @@
 $TTL    300
 
-@       IN      SOA     <: $domain :>. soa.<: $domain :>. (
-                        <: $post.version :> ; Serial
+@       IN      SOA     <: $title :>. soa.<: $title :>. (
+                        <: $version :> ; Serial
                         10800   ; Refresh
                         3600    ; Retry
                         604800  ; Expire
@@ -10,46 +10,46 @@ $TTL    300
 ; NS Records.
 ; These are actually academic, as the registrar is where any of this matters.
 ; You'll have to also set up A / AAAA records with the IP of these NS subdos of yours.
-: for $post.nameservers -> $ns {
-<: $domain :>. IN NS <: $ns :>.
+: for $nameservers -> $ns {
+<: $title :>. IN NS <: $ns :>.
 : }
 
 ; A Records
-<: $domain :>. IN A <: $ip :>
-<: $domain :>. IN AAAA <: $ip6 :>
+<: $title :>. IN A <: $ip :>
+<: $title :>. IN AAAA <: $ip6 :>
 
 ; PTR - also academic.  Must be set not with your registrar, but your ISP/colo etc.
-<: $ip_reversed :> IN PTR <: $domain :>
-<: $ip6_reversed :>    IN PTR <: $domain :>
+<: $ip_reversed :> IN PTR <: $title :>
+<: $ip6_reversed :>    IN PTR <: $title :>
 
-; Subdomains. Look ma, it's a glue record!
-: for $post.subdomains -> $sub {
-<: $sub.name :>.<: $domain :>. IN A    <: $sub.ip :>
-<: $sub.name :>.<: $domain :>. IN AAAA <: $sub.ip6 :>
+; Subtitles. Look ma, it's a glue record!
+: for $subdomains -> $sub {
+<: $sub.name :>.<: $title :>. IN A    <: $sub.ip :>
+<: $sub.name :>.<: $title :>. IN AAAA <: $sub.ip6 :>
 :     for $sub.nameservers -> $ns {
-<: $sub.name :>.<: $domain :>. IN NS   <: $ns :>
+<: $sub.name :>.<: $title :>. IN NS   <: $ns :>
 :     }
 : }
 
 ; CNAME records
-: for $post.cnames -> $cname {
-<: $cname :>.<: $domain :>. IN CNAME <: $domain :>.
+: for $cnames -> $cname {
+<: $cname :>.<: $title :>. IN CNAME <: $title :>.
 : }
 
 ; MX & SRV records
-<: $domain :>.    IN MX  0 mail.<: $domain :>.
+<: $title :>.    IN MX  0 mail.<: $title :>.
 _smtps._tcp.mail. IN SRV 10 5 587 .
 _imaps._tcp.mail. IN SRV 10 5 993 .
 _pop3s._tcp.mail. IN SRV 10 5 995 .
 
 ; SPF, DKIM, DMARC
-_dmarc.<: $domain :>.          IN TXT "v=DMARC1; p=reject; rua=mailto:postmaster@<: $domain :>; ruf=mailto:postmaster@<: $domain :>"
-mail._domainkey.<: $domain :>. IN TXT "v=DKIM1; h=sha256; k=rsa; t=y; p=<: $dkim_pkey :>"
-<: $domain :>.                 IN TXT "v=spf1 +mx +a +ip4:<: $ip :> +ip6:<: $ip :> ~all"
+_dmarc.<: $title :>.          IN TXT "v=DMARC1; p=reject; rua=mailto:postmaster@<: $title :>; ruf=mailto:postmaster@<: $title :>"
+mail._domainkey.<: $title :>. IN TXT "v=DKIM1; h=sha256; k=rsa; t=y; p=<: $dkim_pkey :>"
+<: $title :>.                 IN TXT "v=spf1 +mx +a +ip4:<: $ip :> +ip6:<: $ip :> ~all"
 
 ; Indexer verification
-<: $domain :>.                 IN TXT "google-site-verification=<: $post.gsv_string :>"
+<: $title :>.                 IN TXT "google-site-verification=<: $gsv_string :>"
 
 ; LetsEncyst
-_acme-challenge.<: $domain :>. IN TXT  "<: $acme_challenge :>"
-<: $domain :>                  IN CAA 0 issue letsencrypt.org
+_acme-challenge.<: $title :>. IN TXT  "<: $acme_challenge :>"
+<: $title :>                  IN CAA 0 issue letsencrypt.org