#!/usr/bin/perl
package IkiWiki::Hosting;

use warnings;
use strict;
use Getopt::Long;
use IkiWiki;
	
$config{ikisite_conffile}="/etc/ikiwiki-hosting/ikiwiki-hosting.conf";

sub assert_user {
	my $username=shift;

	my $uid=getpwnam($username);
	if (! defined $uid || $uid != $>) {
		error "this must be ran as user $username";
	}
}

sub assert_root {
	assert_user("root");
}

sub runas {
	my $username=shift;
	my $sub=shift;
	
	my ($uid, $gid, $homedir) = (getpwnam($username))[2, 3, 7];
	if (! defined $uid || ! defined $gid) {
		error "cannot determine uid/gid for $username";
	}

	if ($uid == $>) {
		return $sub->();
	}
	
	eval q{use YAML::Syck};
	die $@ if $@;
	$YAML::Syck::ImplicitUnicode=1;
	
	my $pid = open(RUNAS_CHILD, "-|");
	if (! defined $pid) {
		error "Can't fork: $!";
	}
	if (! $pid) {
		$)="$gid $gid";
		$(=$gid;
		$<=$uid;
		$>=$uid;
		if ($< != $uid || $> != $uid || $) ne "$gid $gid" || $( != $gid) {
			error "failed to drop permissions to $username";
		}
		$ENV{HOME}=$homedir;
		$ENV{USER}=$username;
	
		eval q{use POSIX 'setsid'};
		die $@ if $@;
		if (setsid() == -1) {
			die "setsid: $!";
		}

		print Dump($sub->());
		exit 0;
	}
	else {
		local $/=undef;
		my $child_yaml=<RUNAS_CHILD>;
		if (! close(RUNAS_CHILD)) {
			if ($? >> 8 != 0) {
				exit $? >> 8;
			}
			else {
				exit 127;
			}
		}
		return Load($child_yaml);	
	}
}

sub ikisite_template {
	my $templatefile=shift;
	
	readconfig();

	require HTML::Template;
	my $template=HTML::Template->new(
		loop_context_vars => 1,
		die_on_bad_params => 0,
		filename => $config{ikisite_templatedir}."/".$templatefile,
	);
	$template->param(%config, @_);
	return $template;
}

sub outtemplate {
	my $outfile=shift;
	my $templatefile=shift;

	debug("expand $templatefile -> $outfile");
	my $template=ikisite_template($templatefile, @_);
	writefile($outfile, "", $template->output);
}

sub site_addresses {
	# Looks up the site's main addresses; those that have a default
	# route.
	if ($config{hardcode_ipv4} && $config{hardcode_ipv6}) {
		return ($config{hardcode_ipv4}, $config{hardcode_ipv6});
	}
	my ($defiface) = `ip route` =~ m/^default via .* dev ([a-zA-Z0-9]+)/m;
	if (! $defiface) {
		# Maybe ipv6 only.
		($defiface) = `ip -6 route` =~ m/^default via .* dev ([a-zA-Z0-9]+)/m;
		if (! $defiface) {
			error("cannot see default route, so failed to determine host IP address");
		}
	}
	my $show=`ip addr show $defiface`;
	my ($ipv4) = $show =~ m/inet (\d+\.\d+\.\d+\.\d+).*scope global/m;
	my ($ipv6) = $show =~ m/inet6 ([a-zA-Z0-9:]+).*scope global/m;
	if ($config{hardcode_ipv4}) {
		$ipv4 = $config{hardcode_ipv4};
	}
	if ($config{hardcode_ipv6}) {
		$ipv6 = $config{hardcode_ipv6};
	}
	return ($ipv4, $ipv6);
}

sub host_address_or_cname {
	# Looks up a host in the DNS, and returns the (first) IP address,
	# or a desired CNAME, or undef if neither is found.
	my $host=shift;
	my $wanted_cname=lc(shift);

	# dig +trace is used to examine the DNS in order to avoid
	# cached NXDOMAIN from earlier tests. We want to see the current
	# state of the DNS.
	# dig has to be run a second time to check for ipv6 AAAA addresses.
	foreach my $atype (qw{A AAAA}) {
		open(DIG, "-|", "dig", "-t$atype", "+nofail", "+trace", "$host.") || error "dig: $!";
		while (<DIG>) {
			next if /^;/;
			chomp;
			if (defined $wanted_cname && 
			    /\s+\d+\s+IN\s+CNAME\s+(.*)\.$/ &&
			    lc($1) eq $wanted_cname) {
				close DIG;
				return $wanted_cname;
			}
			elsif (/\s+\d+\s+IN\s+(?:A|AAAA)\s+(.*)$/) {
				close DIG;
				return $1;
			}
		}
		close DIG;
	}
	return undef;
}

sub shell_exitcode {
	my $command=shift;

	# redirect all shell output to stderr to avoid polluting
	# the command's own output
	open(SAVEDOUT, ">&STDOUT");
	open(STDOUT, ">&STDERR");
	debug(join(" ", $command, @_));
	my $ret=system($command, @_);
	open(STDOUT, ">&SAVEDOUT");
	close(SAVEDOUT);

	return $ret
}

sub shell {
	my $command=shift;
	my $ret=shell_exitcode($command, @_);
	if ($ret ne 0) {
		error "$command failed";
	}
	return 1;
}

sub getshell {
	my $command=shift;
	
	if (! open (DOSHELL, "-|", $command, @_)) {
		$?=1;
		return;
	}
	my $out;
	{
		local $/=undef;
		$out=<DOSHELL>;
	}
	if (close DOSHELL) {
		$?=0;
	}
	else {
		$?=1;
	}
	chomp $out;
	return $out;
}

sub yamlgetshell {
	my $yaml=getshell(@_)."\n";
	my $status=$?;
	
	eval q{use YAML::Syck};
	die $@ if $@;
	$YAML::Syck::ImplicitUnicode=1;
	my $parsed=Load($yaml);

	$?=$status;
	return $parsed;
}

my $config_read;
sub readconfig {
	return if $config_read;
	$config_read=1;
	open(IN, "<", $config{ikisite_conffile}) || error "$config{ikisite_conffile}: $!";
	while (<IN>) {
		chomp;
		s/^\s*//;
		s/^#.*//;
		next unless length;

		my ($key, $value)=split("=", $_, 2);
		if (! defined $key || ! length $key || ! defined $value) {
			error "parse error in $config{ikisite_conffile}: $_";
		}

		if ($value=~/^"(.*)"/) {
			$value=$1;
		}
		elsif ($value=~/^'(.*)'/) {
			$value=$1;
		}

		$config{$key}=$value;
	}
	close IN;
}

sub get_subcommand_meta {
	my $subcommand=shift;

	my $symbol="meta_$subcommand";
	return undef unless exists $IkiWiki::Hosting::{$symbol};

	no strict 'refs';
	return {
		$symbol->(),
		subcommand => $subcommand,
	}
}

sub get_subcommands_meta {
	my @ret;
	foreach my $symbol (sort keys %IkiWiki::Hosting::) {
		my ($subcommand)=$symbol=~/^meta_(.*)/;
		next unless defined $subcommand;

		push @ret, get_subcommand_meta($subcommand);
	}

	return @ret;
}

sub sorted_subcommands_meta {
	sort {
		   $a->{section} cmp $b->{section}
		                 ||
		$a->{subcommand} cmp $b->{subcommand}
       	} get_subcommands_meta()
}

sub usage_subcommand {
	my $subcommand=shift;
	my $message=shift;
	my $standalone=!shift;
	print STDERR "$message\n\n" if $message;

	my $meta=get_subcommand_meta($subcommand);
	if ($standalone) {
		print STDERR "usage: $0 $meta->{subcommand} ";
	}
	else {
		print STDERR "\t$meta->{subcommand} ";
	}
	foreach my $required (@{$meta->{required}}) {
		print STDERR "$required ";
	}
	foreach my $option (@{$meta->{options}}) {
		if ($option eq '...') {
			print STDERR "$option ";
			next;
		}

		# convert Getopt::Long to human readable option
		unless ($option=~s/=\w$/=value/) {
			$option=~s/=/ /;
		}
		$option=~s/!$//;

		print STDERR "[--$option] ";
	}
	print STDERR "\n\t\t$meta->{description}\n";
	exit 1 if $standalone;
}

sub usage {
	print STDERR "@_\n\n" if @_;
	print STDERR "usage: $0 [--config=file] [--verbose] subcommand [options]\n";

	my $section="";
	foreach my $meta (sorted_subcommands_meta()) {
		if ($section ne $meta->{section}) {
			$section=$meta->{section};
			print STDERR "\n$section subcommands:\n";
		}
		usage_subcommand($meta->{subcommand}, "", 1);
	}

	exit 1;
}

# used for free-form logging
my $syslog_open;
sub syslog {
	my $message=shift;
	my $subcommand=shift;

	eval q{use Sys::Syslog};
	error $@ if $@;
	unless ($syslog_open) {
		Sys::Syslog::setlogsock('unix');
		openlog($0, '', 'user');
		$syslog_open=1;
	}
	
	syslog('debug', "$subcommand: $message");
}

sub dispatch {
	my $logger=shift;
	my $subcommand=shift;
	my @options=@_;

	# run subcommand, handle result
	$logger->("started", $subcommand, @options);
	no strict "refs";
	my @result=eval {
		$subcommand->(@options);
	};
	if ($@) {
		my $err=$@;
		$logger->("error: $err", $subcommand, @options);
		error "error: $err";
	}
	elsif (ref($result[0]) eq 'IkiWiki::FailReason') {
		$logger->("failure: @result", $subcommand, @options);
		print "@result\n";
		exit 1;
	}
	elsif (ref($result[0]) eq 'IkiWiki::SuccessReason') {
		$logger->("success: @result", $subcommand, @options);
		print "@result\n";
		exit 0;
	}
	elsif (@result && defined $result[0]) {
		$logger->("success: @result", $subcommand, @options);
		if (! ref $result[0]) {
			print join("\n", @result)."\n";
		}
		else {
			eval q{use YAML::Syck};
			error $@ if $@;
			print Dump(@result);
		}
		exit 0;
	}
	else {
		$logger->("success", $subcommand, @options);
		exit 0;
	}
}

sub daemonize (;$) {
	my $nochdir=shift;

	eval q{use POSIX 'setsid'};
	die $@ if $@;

	defined(my $pid = fork) or die "fork: $!";
	return $pid if $pid;

	if (! $nochdir) {
		chdir '/' or die "chdir: $!";
	}
	open STDIN, '/dev/null' or die "/dev/null: $!";
	open STDOUT, '>/dev/null' or die "/dev/null: $!";
	open STDERR, '>/dev/null' or die "/dev/null: $!";

	if (setsid() == -1) {
		die "setsid: $!";
	}

	return 0;
}

sub main {
	my $logger=shift || \&syslog;

	# work out which argument is the subcommand
	my $subcommand;
	for (my $i=0; $i <= $#ARGV; $i++) {
		if ($ARGV[$i]=~/^\w+$/) {
			$subcommand=splice(@ARGV, $i, 1);
			last;
		}
	}
	usage() unless $subcommand;
	my $meta=get_subcommand_meta($subcommand);
	usage("unknown subcommand \"$subcommand\"") unless $meta;

	# option processing
	my %options;
	my @getopts;
	for (my $x=0; $x < @{$meta->{options}}; $x++) {
		my $option=$meta->{options}->[$x];
		if ($option=~/([^=]*)=(\w\w+)/) {
			$option="$1=s";
		}
		my $dest=$option;
		$dest=~s/=.*//;
		$dest=~s/!$//;
		if ($x+1 < @{$meta->{options}} &&
		    $meta->{options}->[$x+1] eq '...') {
			# option can be repeated
			push @getopts, ($option => sub { push @{$options{$dest}}, $_[1] });
			$x++;
		}
		else {
			push @getopts, ($option => \$options{$dest});
		}
	}
	my $ret=GetOptions(@getopts,
		"config=s" => \$config{ikisite_conffile},
		"v|verbose!" => \$config{verbose},
	);
	if (! $ret) {
		usage_subcommand($subcommand);
	}

	# getopt sets option keys to undef if the option is not specified;
	# remove instead
	foreach my $key (keys %options) {
		delete $options{$key} if ! defined $options{$key};
	}

	# remainder of @ARGV is required parameters
	my @required;
	foreach my $required (@{$meta->{required}}) {
		if ($required eq "...") {
			push @required, @ARGV;
			@ARGV=();
		}
		else {
			push @required, shift @ARGV
				|| usage_subcommand($subcommand, "missing $required");
		}
	}
	if (@ARGV) {
		usage_subcommand($subcommand, "unknown parameter(s): @ARGV");
	}

	readconfig();
	dispatch($logger, $subcommand, @required, %options);
}

1
