#!/usr/bin/perl
# myapacheconf v2.0.6  (c) 31.8.2011 by Andreas Ley  (u) 25.2.2026
# Install user specific apache configuration

# Old: https://metacpan.org/release/NWIGER/Apache-ConfigFile-1.23
# Use: https://packages.debian.org/search?keywords=libapache-admin-config-perl&arch=amd64

use Getopt::Std;
use File::Spec::Functions;
use File::Temp 'tempfile';

$ENV{'PATH'} = '/usr/local/bin:/usr/bin:/bin';

#$contact = 'webmaster@kit.edu';
$contact = 'apache@scc.kit.edu';

$root = '/var/www';
$templates = '/etc/apache2/templates';
$httpd_conf = 'httpd.conf';
$vhost_conf = 'vhost.conf';
$dest = 'user.conf';
$prefix = 'test-';
$modules = '/etc/apache2/myapacheconf.modules';
$phpini_directives = '/etc/apache2/myapacheconf.phpini.directives';
#$php_fpm_pools = '/etc/php/7.3/fpm/pool.d';
my $php_version = readlink('/etc/alternatives/php') =~ s/^\/usr\/bin\/php//r;
$php_fpm_pools = "/etc/php/${php_version}/fpm/pool.d";
$sendmail = '/usr/lib/sendmail';
$nodes = '/etc/cluster/nodes';
$dist = '/usr/bin/dist';
$clcmd = '/usr/bin/clcmd';
#@reload = ('/bin/systemctl','reload');
@reload = ('/bin/systemctl','reload-or-restart');

@apache2cfg = ('/usr/sbin/owner',$root,'--','/usr/sbin/apache2cfg');

# http://httpd.apache.org/docs/2.2/mod/directives.html
%valid = (
	'acceptpathinfo' => \&all,
#	'action' => \&all,
	'addcharset' => \&all,
	'adddefaultcharset' => \&string,
	'addhandler' => \&all,
	'adddescription' => \&all,
	'addencoding' => \&all,
	'addicon' => \&all,
	'addiconbyencoding' => \&all,
	'addiconbytype' => \&all,
	'addinputfilter' => \&all,
	'addoutputfilter' => \&all,
	'addoutputfilterbytype' => \&all,
	'addtype' => \&all,
	'addoutputfilter' => \&all,
	'alias' => \&userfile2,
	'aliasmatch' => \&userfile2,
	'allowoverride' => \&all,
	'authbasicprovider' => \&all,
	'authformauthoritative' => \&on,
	'authformfakebasicauth' => \&on,
	'authformloginrequiredlocation' => \&string,
	'authformloginsuccesslocation' => \&string,
	'authformlogoutlocation' => \&string,
	'authformprovider' => \&all,
	'authgroupfile' => \&userfile,
	'authmerging' => \&andor,
	'authname' => \&string,
	'<authnprovideralias' => \&all,
	'</authnprovideralias>' => \&none,
	'authtype' => \&all,
	'authuserfile' => \&userfile,
	'browsermatch' => \&all,
	'browsermatchnocase' => \&all,
	'checkcaseonly' => \&on,
	'checkspelling' => \&on,
	'defaulticon' => \&all,
	'defaulttype' => \&all,
	'define' => \&all,
	'<directory' => \&all,
	'</directory>' => \&none,
	'directoryindex' => \&all,
	'<directorymatch' => \&all,
	'</directorymatch>' => \&none,
	'<else>' => \&none,
	'</else>' => \&none,
	'<elseif' => \&all,
	'</elseif>' => \&none,
	'errordocument' => \&string2,
	'expiresactive' => \&on,
	'expiresbytype' => \&all,
	'expiresdefault' => \&all,
	'fileetag' => \&all,
	'<files' => \&all,
	'</files>' => \&none,
	'<filesmatch' => \&all,
	'</filesmatch>' => \&none,
	'filterchain' => \&all,
	'filterdeclare' => \&all,
	'filterprotocol' => \&all,
	'filterprovider' => \&all,
	'forcetype' => \&all,
	'header' => \&all,
	'headername' => \&all,
	'<if' => \&all,
	'</if>' => \&none,
	'<ifdefine' => \&all,
	'</ifdefine>' => \&none,
	'<ifmodule' => \&all,
	'</ifmodule>' => \&none,
	'include' => \&includefile,
	'indexignore' => \&all,
	'indexoptions' => \&all,
	'indexorderdefault' => \&string2,
	'krb5keytab' => \&userfile,
	'<limit' => \&all,
	'</limit>' => \&none,
	'<limitexcept' => \&all,
	'</limitexcept>' => \&none,
	'<location' => \&all,
	'</location>' => \&none,
	'<locationmatch' => \&all,
	'</locationmatch>' => \&none,
	'loglevel' => \&loglevel,
	'options' => \&all,
	'oidcclientid' => \&string,
	'oidcclientsecret' => \&string,			# check for exec
	'oidccryptopassphrase' => \&string,		# check for exec
	'oidcprovidermetadataurl' => \&string,
	'oidcredirecturi' => \&string,
	'php_flag' => \&phpini,
	'php_value' => \&phpini,
	'proxyerroroverride' => \&on,
	'proxyfcgisetenvif' => \&all,
	'proxypass' => \&proxypass,
	'proxypassreverse' => \&proxypass,
	'proxypreservehost' => \&on,
	'readmename' => \&all,
	'redirect' => \&all,
	'redirectmatch' => \&all,
	'redirectpermanent' => \&all,
	'redirecttemp' => \&all,
	'removehandler' => \&all,
	'removeinputfilter' => \&all,
	'removelanguage' => \&all,
	'removeoutputfilter' => \&all,
	'removetype' => \&all,
	'require' => \&all,
	'<requireall' => \&none,
	'</requireall>' => \&none,
	'<requireany' => \&none,
	'</requireany>' => \&none,
	# People are notoriously using RewriteBase although, up to know, they always set it to the default, and always used it in situations that didn't require it
	'rewritebase' => \&string,
	'rewritecond' => \&all,
	'rewriteengine' => \&on,
	# Will be read/run as root, can't allow filenames under user control
	'rewritemap' => \&adminfile2colon,
	'rewriteoptions' => \&all,
	'rewriterule' => \&all,
	'scriptalias' => \&userfile2,
	'session' => \&on,
	'sessioncookiename' => \&all,
	'sessionenv' => \&on,
	'sessionheader' => \&all,
	'setenv' => \&all,
	'setenvif' => \&all,
	'setenvifexpr' => \&all,
	'setenvifnocase' => \&all,
	'sethandler' => \&all,
	'setinputfilter' => \&all,
	'setoutputfilter' => \&all,
	'shibrequestsetting' => \&all,
	'sslproxyengine' => \&on,
	'sslrequiressl' => \&none,
	'wsgiapplicationgroup' => \&all,
	'wsgidaemonprocess' => \&wsgidaemonprocess,
	'wsgiprocessgroup' => \&all,
	'wsgipythonhome' => \&all,
	'wsgiscriptalias' => \&userfile2,
	'wsgiscriptaliasmatch' => \&userfile2,
	);
%invalid = (
	'accessfilename' => 'performance',
	'allow' => undef,
# Required for htaccess2myapacheconf when it finds .allowoverride
#	'allowoverride' => 'performance',
	'deny' => undef,
	'documentroot' => 'policy',
	'errorlog' => 'policy',
	'listen' => 'security',
	'order' => undef,
	'satisfy' => undef,
	'sslengine' => 'configuration',
	'ssloptions' => 'configuration',
	);

if (-d $php_fpm_pools) {
	for my $key (keys %valid) {
		if ($key =~ /^php_/) {
			delete $valid{$key};
			$invalid{$key} = undef;
		}
	}
}

sub usage
{
	my $image = $0;
	$image =~ s!.*/!!;
	print STDERR "Usage: $image [-v] -V vhost [filename]\n";
	print STDERR "-v  verbose mode\n";
	print STDERR "-V  Create configuration for the given VHost\n";
	exit(1);
}

getopts('TDL:hxvV:') or &usage;

# Compile check
exit(0) if (defined($opt_T));

&usage if (defined($opt_h) || !defined($opt_V) || $#ARGV > 0);

$opt_D = $opt_L if (defined($opt_L));
if (defined($opt_v) || defined($opt_D)) {
	$|=1;
	select((select(STDERR),$|=1)[0]);
}

@D = ('-D') if ($opt_D);
@x = ('-x') if ($opt_x);
@v = ('-v') if ($opt_v);
@q = ('-q') unless ($opt_v);

warn "original -> $ENV{'ORIGINAL_UID'}/$ENV{'ORIGINAL_GID'}" if ($opt_D);
warn "real -> $</$(" if ($opt_D);
warn "effective -> $>/$)" if ($opt_D);

open(MODULES,$modules) or die "Can't read $modules: $!\n";
while (<MODULES>) {
	chomp;
	my ($directive,$module_identifier,$source_file) = split;
	$module_identifier{lc($directive)} = $module_identifier;
	$source_file{lc($directive)} = $source_file;
	$source_to_identifier{$source_file} = $module_identifier;
}
close(MODULES);

unless (-d $php_fpm_pools) {
	open(PHPINI_DIRECTIVES,$phpini_directives) or die "Can't read $phpini_directives: $!\n";
	while (<PHPINI_DIRECTIVES>) {
		chomp;
		$phpini_valid{lc($_)} = '';
	}
	close(PHPINI_DIRECTIVES);
}
	
if (open(DOMAIN,'/etc/DOMAIN')) {
	$domain = <DOMAIN>;
	chomp $domain;
	close(DOMAIN);
}

# Well, yes, we should check opt_V (there may be .. in it)
$server_conf = catdir($root,$opt_V,'conf');
warn "server_conf = $server_conf" if ($opt_D);

################################################################################
#
# Parse httpd.conf for Defines
#

$httpd = catfile($server_conf,$httpd_conf);
open(HTTPD,$httpd) or die "Can't open $httpd: $!\n";
while (<HTTPD>) {
	if (/^\s*Define\s+(\S+)\s+"*(\S*?[^"])"*\s*$/i) {
		my $var = $1;
		$define{$var} = $2;
		warn "define{$var} = $define{$var}" if ($opt_D);
		while ($define{$var} =~ /\$\{([^}]+)\}/) {
			my $replace = $1;
			$define{$var} =~ s/\$\{$replace\}/$define{$replace}/g;
			warn "define{$var} = $define{$var}" if ($opt_D);
		}
	}
}
close(HTTPD);

################################################################################
#
# Parse vhost.conf for DocumentRoot
#

$vhost = catfile($server_conf,$vhost_conf);
open(VHOST,$vhost) or die "Can't open $vhost: $!\n";
while (<VHOST>) {
	if (/^\s*DocumentRoot\s+"*(\S*?[^"])"*\s*$/i) {
		$docroot = $1;
		warn "docroot = $docroot" if ($opt_D);
		while ($docroot =~ /\$\{([^}]+)\}/) {
			my $replace = $1;
			$docroot =~ s/\$\{$replace\}/$define{$replace}/g;
			warn "docroot = $docroot" if ($opt_D);
		}
		last;
	}
}
close(VHOST);
die "No DocumentRoot in $vhost\n" if (!defined($docroot));

################################################################################
#
# Check DocumentRoot for correct ownership
#

$base = ($docroot =~ m!^(/home/ws/(?:[^/]+))/!) ? $1 : $docroot;
warn "base = $base" if ($opt_D);
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($base) or die "Can't stat $base: $!\n";
warn "stat($base) -> $uid/$gid" if ($opt_D);
die "Can't create apache configuration: you're not owner of $base\n" if ($uid != $ENV{'ORIGINAL_UID'});

################################################################################
#
# Parse input configuration
#

my $at = " $ARGV[0]" unless ($#ARGV <0);
my ($config,$module,@modules);
while (<>) {
	# FIXME: Handle continuation lines
	chomp;
	warn "\"$_\"" if ($opt_D>2);
	s/\s+$//;
	# Does this look like a directive?
	# Comments can't be placed on the same line as directives, so no need to trim them first
	# http://httpd.apache.org/docs/2.2/configuring.html#syntax
	if (/^\s*([^#\s]\S*)\s*/) {
		my $directive = $1;
		$directive = $1 if ($directive =~ /^(<[^\/]\S*)>$/);
		my $lc_directive = lc($directive);
		warn "[$.] \"$lc_directive\" ",defined($invalid{$lc_directive})," ",defined($valid{$lc_directive})," ",$valid{$lc_directive}," \"$'\"" if ($opt_D>1);
		if (/^(\s*<IfModule\s+)(\S+)(>)$/i) {
			warn "$2: \"$_\"" if ($opt_D);
			push(@modules,defined($source_to_identifier{$2})?$source_to_identifier{$2}:$2);
			$_ = $1.$source_to_identifier{$2}.$3 if (defined($opt_m) && defined($source_to_identifier{$2}));
		}
		elsif ($lc_directive eq '</ifmodule>') {
			pop(@modules);
		}
		elsif (defined($invalid{$lc_directive})) {
			die "Directive '$directive' prohibited at$at line $..\nThis directive has ".$invalid{$lc_directive}." implications and cannot be used within a user specific configuration. If you need to use this directive, contact $contact.\n";
		}
		elsif (exists($invalid{$lc_directive})) {
			die "Directive '$directive' prohibited at$at line $..\nThis directive is obsolete and can no longer be used within a user specific configuration.\n";
		}
		elsif (defined($valid{$lc_directive})) {
			# FIXME: Allow for a reason to be returned
			&{$valid{$lc_directive}}($') or die "Invalid argument(s) '$'' to directive '$directive' at$at line $..\n";
		}
		elsif (!$opt_f && !exists($module_identifier{$lc_directive})) {
			die "Invalid directive '$directive' at$at line $..\nSee $url.\n";
		}
		else {
			push (@unhandled,$directive);
			warn "Unknown directive '$directive' at$at line $..\nThe security implications of this directive haven't been analyzed yet. A request for inclusion in a user specific configuration will be sent automatically - please try again tomorrow.\n";
		}
		# Directive has passed all tests
		warn $module_identifier{$lc_directive},": ",join(',',@modules),"" if ($opt_D);
		unless (grep($_ eq $module_identifier{$lc_directive},@modules,$module)) {
			$config .= "</IfModule>\n" if (defined($module));
			$module = $module_identifier{$lc_directive};
			$config .= "<IfModule $module>\n" if (defined($module));
		}
	}
	$config .= $_."\n";
}
$config .= "</IfModule>\n" if (defined($module));

if (@unhandled) {
	my $image = $0;
	$image =~ s!.*/!!;
	my $boundary = "you're_geek_when_you're_reading_boundaries";
	my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell,$expire) = getpwuid($ENV{'ORIGINAL_UID'});
	$gcos =~ s!,.*!!;
	open(MAIL,"|$sendmail -i -t") or die "Can't run $sendmail: $!\n";
	print MAIL "From: $gcos <$name@$domain>\n";
	print MAIL "To: $contact\n";
	print MAIL "Subject: $image: Unhandled directive(s): ",join(', ',sort(uniq(@unhandled))),"\n";
	print MAIL "MIME-Version: 1.0\n";
	print MAIL "Content-Type: multipart/mixed; boundary=${boundary}\n";
	print MAIL "\n";
	print MAIL "Unhandled directive(s): ",join(', ',sort(uniq(@unhandled))),"\n";
	print MAIL "\n";
	print MAIL "--${boundary}\n";
	print MAIL "Content-Type: text/plain\n";
	print MAIL "Content-Disposition: inline\n";
	print MAIL "\n";
	print MAIL $config;
	print MAIL "\n";
	print MAIL "--${boundary}--\n";
	close(MAIL);
	exit(2);
}

sub uniq
{
	my (%uniq);

	map($uniq{$_}=undef,@_);
	return(keys %uniq);
}

################################################################################
#
# Write validated configuration to apache config file
#

sub write_config
{
	my ($dest) = @_;

	my $user = catfile($server_conf,$dest);
	my ($tmp,$tmpname) = tempfile($dest.'.XXXXXX', 'DIR' => $server_conf);
	print $tmp $template,$config or die "Can't write to $tmpname: $!\n";
	close($tmp) or die "Can't close $tmpname: $!\n";
	chmod(0444,$tmpname) or die "Can't chmod 0444 $tmpname: $!\n";
	warn "+ mv $tmpname $user\n" if ($opt_D);
	rename($tmpname,$user) or die "Can't rename $tmpname to $user: $!\n";
}

# Read user specific configuration template
open(TEMPLATE,catfile($templates,$dest)) or die "Can't open ".catfile($templates,$dest).": $!\n";
$template = join('',<TEMPLATE>);
close(TEMPLATE);

# Write test configuration, run apache check
&write_config($prefix.$dest);
my @cmd = (@apache2cfg,@D,'-C','-T',$opt_V);
warn '+ ',join(' ',@cmd),"\n" if ($opt_D);
system(@cmd) and die "Generated apache test config failed syntax check!\n";

# Write configuration
&write_config($dest);
my @cmd = (@apache2cfg,@D,'-c',$opt_V);
warn '+ ',join(' ',@cmd),"\n" if ($opt_D);
system(@cmd) and die "Generated apache config failed syntax check! System corrupted! PANIC!\n";

# Distribute user specific configuration
if (-s $nodes) {
	my @cmd = ($dist,@x,@q,catfile($server_conf,$dest));
	warn '+ ',join(' ',@cmd),"\n" if ($opt_D);
	system(@cmd) and die "Failed to distribute ".catfile($server_conf,$dest)."\n";
}

# Reload apache serving configured VHost
#my @cmd = (@reload,'httpd@'.$opt_V);
my @cmd = (@reload,'httpd@'.$uid.':'.$gid);
unshift(@cmd,$clcmd,@x,@v) if (-s $nodes);
warn '+ ',join(' ',@cmd),"\n" if ($opt_D);
system(@cmd) and die "Failed to reload apache httpd\n";

################################################################################
#
# Validating subroutines
#

sub all
{
	warn "&all(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);

	return (1);
}

sub none
{
	warn "&none(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return ($argument =~ /^$/);
}

sub includefile
{
	warn "&includefile(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (0) if ($argument =~ m!/\.\.?/!);
	# FIXME: validate include files content?
	return (1) if ($argument =~ m!^/etc/apache2/include/!);
	return (0);
}

sub proxypass
{
	warn "&proxypass(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	# This currently only handles server context
	if ($argument =~ /\s+/) {
		my $path = $`;
		$path =~ s/^"(.*)"$/$1/;
		$path =~ s/\/{2,}/\//;
		# Do not proxy a whole site; use CNAME instead
		# This probably also would hinder service paths like /server-status or /.well-known/
		return (1) if ($path ne '/');
	}

	return (0);
}

sub on
{
	warn "&on(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (1) if ($argument =~ /^(?:on|"on"|off|"off")$/i);
	return (0);
}

sub andor
{
	warn "&on(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (1) if ($argument =~ /^(?:and|"and"|or|"or"|off|"off")$/i);
	return (0);
}

sub optional
{
	warn "&optional(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (1) if ($argument =~ /^(?:on|"on"|off|"off"|optional|"optional")$/i);
	return (0);
}

sub any
{
	warn "&any(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (1) if ($argument =~ /^(?:any|"any"|all|"all")$/i);
	return (0);
}

sub string
{
	warn "&string(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	return (0) if ($argument =~ /^[^"]+\s|\s[^"]+$/);
	return (1);
}

sub string2
{
	warn "&string2(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument =~ s/^\S+\s+//;
	return (&string($argument));
}

sub adminfile
{
	warn "&adminfile(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	# FIXME: Check realpath($argument) vs. realpath($docroot)
	return (0) if ($argument =~ m!/\.\.?/!);
	return (1) if ($argument =~ m!^$server_conf/!);
	return (0);
}

sub adminfile2colon
{
	warn "&adminfile2colon(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument =~ s/^\S+\s+//;
	$argument =~ s/^'(.*)'$/$1/;
	$argument =~ s/^"(.*)"$/$1/;
	$argument =~ s/^[^:]+://;
	return (&adminfile($argument));
}

sub userfile
{
	warn "&userfile(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument = $1 if (argument =~ /^"(.+)"$/);

	# FIXME: Omit explicit warning if file lies within DocumentRoot
	# FIXME: Also check cgi-bin
	# FIXME: Check realpath($argument) vs. realpath($docroot)
	return (0) if ($argument =~ m!/\.\.?/!);
	return (0) if ($argument =~ m!^$docroot/!);
	return (1) if ($argument =~ m!^$base/!);
	return (1) if ($argument =~ m!^$server_conf/!);
	return (0);
}

sub userfile2
{
	warn "&userfile2(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument =~ s/^\S+\s+//;
	return (&userfile($argument));
}

sub userfile2colon
{
	warn "&userfile2colon(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument =~ s/^\S+\s+//;
	$argument =~ s/^'(.*)'$/$1/;
	$argument =~ s/^"(.*)"$/$1/;
	$argument =~ s/^[^:]+://;
	return (&userfile($argument));
}

sub loglevel
{
	warn "&loglevel(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	# Allow LogLevel of at least error (default is warn)
	# emerg, alert and crit miss too much information
	return (1) if ($argument =~ /^(?:error|"error"|warn|"warn"|notice|"notice"|info|"info"|debug|"debug")$/i);
	return (0);
}

sub phpini
{
	warn "&phpini(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($argument) = @_;

	$argument =~ s/\s.*//;
	warn "&phpini: check \$phpini_valid{lc($argument)}\n" if ($opt_D);
	return (1) if (defined($phpini_valid{lc($argument)}));
	return (0);
}

sub wsgidaemonprocess
{
	warn "&wsgidaemonprocess(",join(',',map("\"$_\"",@_)),")\n" if ($opt_D);
	my ($name,@options) = @_;

	for my $option (@options) {
		return (0) if ($option =~ /^(user|group)=/i);
	}
	return (1);
}
