#!/usr/bin/perl -s

# This descends from huepl and TTYtter, and is therefore under the Floodgap
# Free Software License. It is not required to build or run Firefox or
# TenFourFox.

BEGIN {
	$VERSION = "v0.5";
        if ($] >= 5.014000 && $ENV{'PERL_SIGNALS'} ne 'unsafe') {
                $signals_use_posix = 1;
        } else {
                $ENV{'PERL_SIGNALS'} = 'unsafe';
        }
}

$lastexception = 0;
@wend = ('-L', '-s', '-m', '20', '-A', '', '-H', 'Expect:');
eval "use POSIX;";
$URL = "https://raw.githubusercontent.com/mozilla-services/shavar-prod-lists/master/disconnect-blacklist.json";

$exit_mode = 0;
$stringify_args = sub {
	my $basecom = shift;
	my $resource = shift;
	my $data = shift;
	my $p;
	my $l = '';

	foreach $p (@_) {
		if ($p =~ /^-/) {
			$l .= "\n" if (length($l));
			$l .= "$p ";
			next;
		}
		$l .= $p;
	}
	$l .= "\n";

	# if resource is an arrayref, then it's a GET with URL
	# and args
	$resource = join('?', @{ $resource })
		if (ref($resource) eq 'ARRAY');
	$l .= "url = \"$resource\"\n";
	$data =~ s/"/\\"/g;
	$l .= "data = \"$data\"\n" if length($data);
	return ("$basecom -K -", $l, undef);
};

sub sigify {
        # this routine abstracts setting signals to a subroutine reference.
        # check and see if we have to use POSIX.pm (Perl 5.14+) or we can
        # still use $SIG for proper signalling. We prefer the latter, but
        # must support the former.
        my $subref = shift;
        my $k;

        if ($signals_use_posix) {
                my @w;
                my $sigaction = POSIX::SigAction->new($subref);
                while ($k = shift) {
                        my $e = &posix_signal_of($k);
                        # some signals may not exist on all systems.
                        next if (!(0+$e));
                        POSIX::sigaction($e, $sigaction)
                                || die("sigaction failure: $! $@\n");
                }
        } else {
                while ($k = shift) { $SIG{$k} = $subref; }
        }
}
sub posix_signal_of {
        die("never call posix_signal_of if signals_use_posix is false\n")
                if (!$signals_use_posix);

        # this assumes that POSIX::SIG* returns a scalar int value.
        # not all signals exist on all systems. this ensures zeroes are
        # returned for locally bogus ones.
        return 0+(eval("return POSIX::SIG".shift));
}

sub parsejson {
	my $data = shift;
	my $my_json_ref = undef; # durrr hat go on foot
	my $i;
	my $tdata;
	my $seed;
	my $bbqqmask;
	my $ddqqmask;
	my $ssqqmask;

	# test for single logicals
	return {
		'ok' => 1,
		'result' => (($1 eq 'true') ? 1 : 0),
		'literal' => $1,
			} if ($data =~ /^['"]?(true|false)['"]?$/);

	# first isolate escaped backslashes with a unique sequence.
	$bbqqmask = "BBQQ";
	$seed = 0;
	$seed++ while ($data =~ /$bbqqmask$seed/);
	$bbqqmask .= $seed;
	$data =~ s/\\\\/$bbqqmask/g;

	# next isolate escaped quotes with another unique sequence.
	$ddqqmask = "DDQQ";
	$seed = 0;
	$seed++ while ($data =~ /$ddqqmask$seed/);
	$ddqqmask .= $seed;
	$data =~ s/\\\"/$ddqqmask/g;

	# then turn literal ' into another unique sequence. you'll see
	# why momentarily.
	$ssqqmask = "SSQQ";
	$seed = 0;
	$seed++ while ($data =~ /$ssqqmask$seed/);
	$ssqqmask .= $seed;
	$data =~ s/\'/$ssqqmask/g;

	# here's why: we're going to turn doublequoted strings into single
	# quoted strings to avoid nastiness like variable interpolation.
	$data =~ s/\"/\'/g;

	# and then we're going to turn the inline ones all back except
	# ssqq, which we'll do last so that our syntax checker still works.
	$data =~ s/$bbqqmask/\\\\/g;
	$data =~ s/$ddqqmask/"/g;

	print STDOUT "$data\n" if ($superverbose);

	# first, generate a syntax tree.
	$tdata = $data;
	1 while $tdata =~ s/'[^']*'//; # empty strings are valid too ...
	$tdata =~ s/-?[0-9]+\.?[0-9]*([eE][+-][0-9]+)?//g;
		# have to handle floats *and* their exponents
	$tdata =~ s/(true|false|null)//g;
	$tdata =~ s/\s//g;

	print STDOUT "$tdata\n" if ($superverbose);

	# now verify the syntax tree.
	# the remaining stuff should just be enclosed in [ ], and only {}:,
	# for example, imagine if a bare semicolon were in this ...
	if ($tdata !~ s/^\[// || $tdata !~ s/\]$// || $tdata =~ /[^{}:,]/) {
		$tdata =~ s/'[^']*$//; # cut trailing strings
		if (($tdata =~ /^\[/ && $tdata !~ /\]$/)
				|| ($tdata =~ /^\{/ && $tdata !~ /\}$/)) {
			# incomplete transmission
			&exception(10, "*** JSON warning: connection cut\n");
			return undef;
		}
		if ($tdata =~ /(^|[^:])\[\]($|[^},])/) { # oddity
			&exception(11, "*** JSON warning: null list\n");
			return undef;
		}
		# at this point all we should have are structural elements.
		# if something other than JSON structure is visible, then
		# the syntax tree is mangled. don't try to run it, it
		# might be unsafe.
		if ($tdata =~ /[^\[\]\{\}:,]/) {
			&exception(99, "*** JSON syntax error\n");
			die(<<"EOF");
--- data received ---
$data
--- syntax tree ---
$tdata
--- JSON PARSING ABORTED DUE TO SYNTAX TREE FAILURE --
EOF
			exit;
			return undef;
		}
	}

	# syntax tree passed, so let's turn it into a Perl reference.
	# have to turn colons into ,s or Perl will gripe. but INTELLIGENTLY!
	1 while
	($data =~ s/([^'])'\s*:\s*(true|false|null|\'|\{|\[|-?[0-9])/\1\',\2/);

	# removing whitespace to improve interpretation speed actually made
	# it SLOWER.
	#($data =~ s/'\s*,\s*/',/sg);
	#($data =~ s/\n\s*//sg);

	# finally, single quotes, just before interpretation.
	$data =~ s/$ssqqmask/\\'/g;

	# now somewhat validated, so safe (?) to eval() into a Perl struct
	eval "\$my_json_ref = $data;";
	print STDOUT "$data => $my_json_ref $@\n"  if ($superverbose);

	# do a sanity check
	if (!defined($my_json_ref)) {
		&exception(99, "*** JSON syntax error\n");
		print STDOUT <<"EOF" if ($verbose);
--- data received ---
$data
--- syntax tree ---
$tdata
--- JSON PARSING FAILED --
$@
--- JSON PARSING FAILED --
EOF
	}

	return $my_json_ref;
}

sub backticks {
	# more efficient/flexible backticks system
	my $comm = shift;
	my $rerr = shift;
	my $rout = shift;
	my $resource = shift;
	my $data = shift;
	my $dont_do_auth = shift;
	my $buf = '';
	my $undersave = $_;
	my $pid;
	my $args;

	($comm, $args, $data) = &$stringify_args($comm, $resource,
		$data, $dont_do_auth, @_);
	print STDOUT "$comm\n$args\n$data\n" if ($superverbose);
	if(open(BACTIX, '-|')) {
		while(<BACTIX>) {
			$buf .= $_;
		} close(BACTIX);
		$_ = $undersave;
		return $buf; # and $? is still in $?
	} else {
		$in_backticks = 1;
		&sigify(sub {
			die(
		"** user agent not honouring timeout (caught by sigalarm)\n");
		}, qw(ALRM));
		alarm 120; # this should be sufficient
		if (length($rerr)) {
			close(STDERR); 
			open(STDERR, ">$rerr");
		}
		if (length($rout)) {
			close(STDOUT);
			open(STDOUT, ">$rout");
		}
		if(open(FRONTIX, "|$comm")) {
			print FRONTIX "$args\n";
			print FRONTIX "$data" if (length($data));
			close(FRONTIX);
		} else {
			die(
			"backticks() failure for $comm $rerr $rout @_: $!\n");
		}
		$rv = $? >> 8;
		exit $rv;
	}
}

sub wherecheck {
	my ($prompt, $filename, $fatal) = (@_);
	my (@paths) = split(/\:/, $ENV{'PATH'});
	my $setv = '';

	push(@paths, '/usr/bin'); # the usual place
	@paths = ('') if ($filename =~ m#^/#); # for absolute paths

	foreach(@paths) {
		if (-r "$_/$filename") {
			$setv = "$_/$filename";
			1 while $setv =~ s#//#/#;
			last;
		}
	}
	if (!length($setv)) {
		die ($fatal) if ($fatal);
		exit(1);
	}
	return $setv;
}

sub url_oauth_sub {
        my $x = shift;
        $x =~ s/([^-0-9a-zA-Z._~])/"%".uc(unpack("H*",$1))/eg; return $x;
}

# this is a sucky nonce generator. I was looking for an awesome nonce
# generator, and then I realized it would only be used once, so who cares?
# *rimshot*
sub generate_nonce { unpack("H32", pack("u", rand($$).$$.time())); }

sub exception {
	my ($num, $tex) = (@_);
	$lastexception = $num;
	print STDOUT "$tex" if ($verbose);
}

sub grabjson {
	my $url = shift;
	my $no_auth = shift;
	my $data;
	chomp($data = &backticks($curl,
			'/dev/null', undef, $url, undef,
			$no_auth, @wind));
	return &genericnetworkjson($data, $url, $no_auth);
}
sub postjson {
	my $url = shift;
	my $postdata = shift;
	my $no_auth = shift;
	my $data;
	chomp($data = &backticks($curl,
			'/dev/null', undef, $url, $postdata,
			$no_auth, @wend));
	return &genericnetworkjson($data, $url, $no_auth);
}
sub putjson {
	my $url = shift;
	my $postdata = shift;
	my $no_auth = shift;
	my $data;
	chomp($data = &backticks($curl,
			'/dev/null', undef, $url, $postdata,
			$no_auth, @wund));
	return &genericnetworkjson($data, $url, $no_auth);
}

sub genericnetworkjson {
	my $data = shift;
	my $url = shift;
	my $no_auth = shift;
	my $my_json_ref = undef; # durrr hat go on foot
	my $i;
	my $tdata;
	my $seed;

	my $k = $? >> 8;
	$data =~ s/[\r\l\n\s]*$//s;
	$data =~ s/^[\r\l\n\s]*//s;

	if (!length($data) || $k == 28 || $k == 7 || $k == 35) {
		&exception(1, "*** warning: timeout or no data\n");
		return undef;
	}

	if ($k > 0) {
		&exception(4,
"*** warning: unexpected error code ($k) from user agent\n");
		return undef;
	}

	# handle things like 304, or other things that look like HTTP
	# error codes
	if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) {
		$code = 0+$1;
		print $stdout $data if ($superverbose);

		# 304 is actually a cop-out code and is not usually
		# returned, so we should consider it a non-fatal error
		if ($code == 304 || $code == 200 || $code == 204) {
			&exception(1, "*** warning: timeout or no data\n");
			return undef;
		}
		&exception(4,
"*** warning: unexpected HTTP return code $code from server\n");
		return undef;
	}

	$my_json_ref = &parsejson($data);
	$laststatus = 0;
	return $my_json_ref;
}

$curl ||= &wherecheck("checking for cURL", "curl", <<"EOF");

cURL is required. if cURL is not usually in your path, you can
hardcode it with -curl=/path/to/curl

EOF

$vv = `$curl --version`;
($vv =~ /^curl (\d+)\.(\d+)/) && ($major = $1, $minor = $2);
die("at least cURL 7.58 required, you have ${major}.${minor}.\n\n$vv\n")
	if ($major < 7 || ($major == 7 && $minor < 58));

$json_ref = &grabjson("https://raw.githubusercontent.com/mozilla-services/shavar-prod-lists/master/disconnect-blacklist.json");

die("this doesn't look like the right format\n\ncheck URL\n$url\n")
if (!defined($json_ref->{'license'}) ||
    !defined($json_ref->{'categories'}) ||
    !defined($json_ref->{'categories'}->{'Cryptomining'}));

select(STDOUT); $|++;
%dupedupe = ();
&emit('Cryptomining');
&emit('FingerprintingInvasive');
# considering
#&emit('Analytics');

sub emit {
my $cat = shift(@_);
foreach $a (@{ $json_ref->{'categories'}->{$cat} }) {
	foreach $b (keys(%{ $a })) {
		die("illegal newline: $b\n") if ($b =~ /[\r\n]/s);
		print "// $b\n";

		foreach $c (keys(%{ $a->{$b} })) {
			next if ($c eq 'performance');
			die("illegal newline: $c\n") if ($c =~ /[\r\n]/s);

			print "//    $c\n";
			foreach $d (@{ $a->{$b}->{$c} }) {
				die("illegal quote: $d\n") if ($d =~ /"/);
				next if ($dupedupe{$d}++);

				# whitelist (with regrets)
				next if (0 ||
					$d eq 'ibm.com' ||
					$d eq 'godaddy.com' ||
				0);
				print "        BLOK(\"$d\") ||\n";
				print "        BLOKD(\".$d\") ||\n";
			}
		}
	}
}
}