#!/usr/bin/env perl
use feature 'say';
use Data::Dumper;
use Net::DNS;
use Net::LDAP;
use List::MoreUtils qw(uniq);
use LWP::UserAgent;

my $res = Net::DNS::Resolver->new;
my $ua = LWP::UserAgent->new;
my $ans;

my %do;
$do{kerberos} = 1;
$do{mail} = 1;
$do{verbose} = 1;
$do{ldap} = 1;
$do{xmpp} = 1;
$do{sip} = 1;

sub status {
	print STDERR "\r\033[K", shift; $|++;
}

sub done {
	print STDERR "\r\033[K"; $|++;
}

sub find_dom {
	my ($lhs, $rhs, $type) = @_;
	my @rhs = split(/\./, $rhs);
	while (@rhs) {
		my $dom = join(".", @rhs);
		my $qry = join(".", grep {defined} ($lhs, @rhs));
		my $ans = $res->query($qry, $type);
		return ($ans, $dom) if $ans;
		shift @rhs;
	}
}

$res->dnssec(1);

sub grep_txt {
	my ($ans) = @_;
	return	map {$_->txtdata}
		grep {$_->type eq "TXT"}
		$ans->answer;
}

sub get_spf {
	my ($dom) = @_;
	my ($ans, @spf);
	$ans = $res->query($dom, "SPF");
	if ($ans) {
		push @spf,
			grep {s/^v=spf1\s//}
			map {$_->txtdata}
			grep {$_->type eq "SPF"}
			$ans->answer;
	}
	$ans = $res->query($dom, "TXT");
	if ($ans) {
		push @spf,
			grep {s/^v=spf1\s//}
			map {$_->txtdata}
			grep {$_->type eq "TXT"}
			$ans->answer;
	}
	return uniq @spf;
}

sub sort_mx {
	sort {$a->preference <=> $b->preference}
	sort {$a->exchange cmp $b->exchange}
	@_;
}

sub sort_srv {
	sort {$a->priority <=> $b->priority}
	sort {$a->weight <=> $b->weight}
	sort {$a->target cmp $b->target}
	@_;
}

sub format_mx {
	uniq
	map {"[".$_->preference."] ".$_->exchange}
	sort_mx(grep {$_->type eq "MX"} @_);
}

sub format_srv {
	uniq
	map {"[".$_->priority."] ".$_->target.":".$_->port}
	sort_srv(grep {$_->type eq "SRV"} @_);
}

sub format_uri {
	uniq
	map {"[".$_->priority."] ".$_->target}
	sort_srv(grep {$_->type eq "URI"} @_);
}

for my $host (@ARGV) {
	my $domain;
	my @dom;
	my @ns;
	my $secure = 0;

	status "Looking up SOA...";
	$ans = $res->send($host, "SOA");
	for my $rr ($ans->answer, $ans->authority) {
		if ($rr->type eq "SOA") {
			$domain = $rr->name;
			push @dom, $domain . ($ans->header->ad
						? " (\e[38;5;10msecure\e[m)"
						: " (\e[38;5;3minsecure\e[m)");
		}
	}

	status "Looking up nameservers...";
	$ans = $res->query($domain, "NS");
	$secure = $ans->header->ad;
	for my $rr ($ans->answer, $ans->authority) {
		if ($rr->type eq "NS") {
			push @ns, $rr->nsdname;
		}
	}

	status "Looking up Active Directory...";
	($ans, $domain) = find_dom("_ldap._tcp._msdcs", $host, "SRV");
	push @dom, "$domain (Active Directory)" if $ans;
	done;

	if (@dom) {
		say "Domain:";
		say "\tdomain: $_" for @dom;
		say "\tnameserver: $_" for @ns;
	}

	if ($do{mail}) {
		status "Looking up mail servers...";
		my $mx_ans = $res->query($host, "MX");
		done;
		if ($mx_ans) {
			say "Mail:";
			say "\tdomain: $host";
			say "\tmailserver: $_" for format_mx($mx_ans->answer);
		}

		status "Looking up mail server configuration...";
		my @spf = get_spf($host);
		my $dmarc_ans = $res->query("_dmarc.$host", "TXT");
		my $tls_rpt_ans = $res->query("_smtp._tls.$host", "TXT");
		my $mta_sts_ans = $res->query("_mta-sts.$host", "TXT");
		done;
		say "\tSPF: $_" for @spf;
		if ($dmarc_ans) {
			my ($policy) = grep_txt($dmarc_ans);
			my %policy = map {split /=/, $_, 2} split(/;\s*/, $policy);
			say "\tDMARC: $policy";

			my (@mode, $key, $keydesc, $val, $valdesc);
			do {
				$key = "p";
				$keydesc = "failure action";
				$val = $policy{"p"};
				if ($val eq "none") {
					$valdesc = "none (accept, but generate reports to my postmaster)";
				} elsif ($val eq "quarantine") {
					$valdesc = "quarantine (accept, but mark as spam)";
				} elsif ($val eq "reject") {
					$valdesc = "reject (refuse during SMTP delivery)";
				}
				push @mode, [$key, $keydesc, $val, $valdesc];
			};
			if ($policy{"rua"}) {
				$key = "rua";
				$keydesc = "send aggregate reports to";
				$val = $policy{"rua"};
				$valdesc = "";
			}
			do {
				$key = "adkim";
				$keydesc = "DKIM alignment";
				$val = $policy{$key} // "r";
				if ($val eq "r") {
					$valdesc = "relaxed (RFC822-From domain must match or be a subdomain of DKIM-Signature domain)";
				} elsif ($val eq "s") {
					$valdesc = "strict (RFC822-From domain must exactly match DKIM-Signature domain)";
				}
				push @mode, [$key, $keydesc, $val, $valdesc];
			};
			do {
				$key = "aspf";
				$keydesc = "SPF alignment";
				$val = $policy{$key} // "r";
				if ($val eq "r") {
					$valdesc = "relaxed (RFC822-From domain must match or be a subdomain of Envelope-From domain)";
				} elsif ($val eq "s") {
					$valdesc = "strict (RFC822-From domain must exactly match Envelope-From domain)";
				}
				push @mode, [$key, $keydesc, $val, $valdesc];
			};

			for (@mode) {
				($key, $keydesc, $val, $valdesc) = @$_;
				my $def = (defined $policy{$key}) ? "*" : "-";
				say "\t\t$def $keydesc: $valdesc";
			}

		}
		if ($tls_rpt_ans) {
			# https://tools.ietf.org/html/rfc8460
			my ($policy) = grep_txt($tls_rpt_ans);
			if ($policy) {
				say "\tTLS Reporting: $policy";
			}
		}
		if ($mta_sts_ans) {
			# https://tools.ietf.org/html/rfc8461
			my ($flag) = grep_txt($mta_sts_ans);
			if ($flag) {
				say "\tMTA-STS: $flag";
				my $url = "https://mta-sts.$host/.well-known/mta-sts.txt";
				status("Retrieving MTA-STS policy...");
				my $resp = $ua->get($url);
				if ($resp->is_success) {
					$resp = $resp->decoded_content;
				} else {
					$resp = $resp->status_line;
				}
				done();
				say "\t\t$_" for split(/\n+/, $resp);
			}
		}
	}

	if ($do{kerberos}) {
		my ($txt_ans, $udp_ans, $uri_ans);
		status "Looking up Kerberos realm...";
		$txt_ans = $res->query("_kerberos.$host", "TXT");
		if ($txt_ans) {
			($realm) =
				grep {!/v=/}
				map {$_->txtdata}
				grep {$_->type eq "TXT"}
				$txt_ans->answer;
		} else {
			$realm = uc($host);
		}
		status "Looking up Kerberos servers in $realm...";
		$udp_ans = $res->query("_kerberos._udp.$realm", "SRV");
		$uri_ans = $res->query("_kerberos.$realm", "URI");
		done;
		if ($udp_ans || $txt_ans || $uri_ans) {
			say "Kerberos:";
			say "\trealm: $realm";
			if ($uri_ans) {
				say "\tkdc: (URI) $_" for format_uri($uri_ans->answer);
			}
			if ($udp_ans) {
				say "\tkdc: (SRV) $_" for format_srv($udp_ans->answer);
			}
		}
	}

	if ($do{ldap}) {
		status "Looking up LDAP servers...";
		$tcp_ans = $res->query("_ldap._tcp.$host", "SRV");
		$tls_ans = $res->query("_ldaps._tcp.$host", "SRV");
		done;
		if ($tcp_ans || $tls_ans) {
			my (@servers, @bases);
			say "LDAP:";
			if ($tcp_ans) {
				say "\tserver: $_ (TCP)" for format_srv($tcp_ans->answer);
				push @servers, sort_srv(grep {$_->type eq "SRV"} $tcp_ans->answer);
			}
			if ($tls_ans) {
				say "\tserver: $_ (TLS)" for format_srv($tls_ans->answer);
				push @servers, sort_srv(grep {$_->type eq "SRV"} $tls_ans->answer);
			}
			for my $item (@servers) {
				my $uri = $item->target;
				status "Looking up LDAP contexts on $uri...";
				my $ldap = Net::LDAP->new($uri);
				if ($ldap) {
					$ldap->bind;
					my $res = $ldap->search(
						base => "",
						scope => "base",
						filter => q(objectClass=*),
						attrs => ["+"],
					);
					$ldap->unbind;
					push @bases,
						grep {$_ ne ""}
						map {$_->get_value("namingContexts")}
						$res->entries;
					last;
				}
			}
			done;
			say "\tbase: $_" for @bases;
		}
	}

	if ($do{xmpp}) {
		status "Looking up XMPP servers...";
		$client_ans = $res->query("_xmpp-client._tcp.$host", "SRV");
		$server_ans = $res->query("_xmpp-server._tcp.$host", "SRV");
		done;
		if ($client_ans) {
			say "XMPP:";
			say "\tserver: $_" for format_srv($client_ans->answer);
			say "\t(not federated)" if !$server_ans;
		}
	}

	if ($do{sip}) {
		status "Looking up SIP servers...";
		# TODO: NAPTR
		$udp_ans = $res->query("_sip._udp.$host", "SRV");
		$tcp_ans = $res->query("_sip._tcp.$host", "SRV");
		$tls_ans = $res->query("_sips._tcp.$host", "SRV");
		done;
		if ($udp_ans || $tcp_ans || $tls_ans) {
			say "SIP:";
			if ($udp_ans) {
				say "\tproxy: $_ (UDP)" for format_srv($udp_ans->answer);
			}
			if ($tcp_ans) {
				say "\tproxy: $_ (TCP)" for format_srv($tcp_ans->answer);
			}
			if ($tls_ans) {
				say "\tproxy: $_ (TLS)" for format_srv($tls_ans->answer);
			}
		}
	}

	say "";
}
