# Functions for finding and editing aliases and redirects for a website

# has_web_redirects(&domain)
# Returns 1 if redirect editing is supported for this domain's webserver
sub has_web_redirects
{
my ($d) = @_;
return 1 if ($d->{'web'});
my $p = &domain_has_website($d);
return 0 if (!$p);
return &plugin_defined($p, "feature_supports_web_redirects") &&
	&plugin_call($p, "feature_supports_web_redirects", $d);
}

# has_web_host_redirects(&domain)
# Returns 1 if redirect editing by hostname is supported for this domain's
# webserver
sub has_web_host_redirects
{
my ($d) = @_;
return 1 if ($d->{'web'});
my $p = &domain_has_website($d);
return 0 if (!$p);
return &plugin_defined($p, "feature_supports_web_host_redirects") &&
	&plugin_call($p, "feature_supports_web_host_redirects", $d);
}

# has_web_redirect_part_options(&domain)
# Returns 1 if redirect editing can remove filenames or query strings
sub has_web_redirect_part_options
{
my ($d) = @_;
return 1 if ($d->{'web'});
my $p = &domain_has_website($d);
return 0 if (!$p);
return &plugin_defined($p, "feature_supports_web_redirect_part_options") &&
	&plugin_call($p, "feature_supports_web_redirect_part_options", $d);
}

# list_redirects(&domain)
# Returns a list of URL paths and destinations for redirects and aliases. Each
# is a hash ref with keys :
#   path - A URL path like /foo
#   dest - Either a URL or a directory
#   alias - Set to 1 for an alias, 0 for a redirect
#   regexp - If set to 1, any sub-path is redirected to the same destination
#   stripfile - If set to 1, remove the last file-like part of kept sub-paths
#   stripquery - If set to 1, remove the original query string
#   host - Only match requests to this hostname
#   http - Set in the non-SSL virtual host
#   https - Set in the SSL virtual host
sub list_redirects
{
my ($d) = @_;
my $p = &domain_has_website($d);
if ($p && $p ne 'web') {
        my @rv = &plugin_call($p, "feature_list_web_redirects", $d);
	foreach my $r (@rv) {
		if (!$r->{'http'} && !$r->{'https'}) {
			# Deal with plugin that doesn't support protocols
			$r->{'http'} = $r->{'https'} = 1;
			}
		}
	return @rv;
        }
&require_apache();
my @ports = ( $d->{'web_port'},
	      $d->{'ssl'} ? ( $d->{'web_sslport'} ) : ( ) );
my @rv;
foreach my $p (@ports) {
	my ($virt, $vconf) = &get_apache_virtual($d->{'dom'}, $p);
	next if (!$virt);
	my $proto = $p == $d->{'web_port'} ? 'http' : 'https';
	foreach my $al (&apache::find_directive_struct("Alias", $vconf),
			&apache::find_directive_struct("AliasMatch", $vconf),
			&apache::find_directive_struct("Redirect", $vconf),
			&apache::find_directive_struct("RedirectMatch", $vconf),
		       ) {
		my $rd = { 'alias' => $al->{'name'} =~ /^Alias/i ? 1 : 0,
			   'dirs' => [ $al ],
			   $proto => 1 };
		my @w = @{$al->{'words'}};
		if (@w == 3) {
			# Has a code
			$rd->{'code'} = shift(@w);
			}
		$rd->{'dest'} = $w[1];
		if ($al->{'name'} eq 'Alias' || $al->{'name'} eq 'Redirect') {
			# Like Redirect /foo /bar
			# or   Alias /foo /home/smeg/public_html/bar
			# or   Redirect /foo http://bar.com/smeg
			$rd->{'path'} = $w[0];
			}
		elsif (($al->{'name'} eq 'AliasMatch' ||
			$al->{'name'} eq 'RedirectMatch') &&
		       ($w[0] =~ /^(.*)\.\*\$$/ ||
			$w[0] =~ /^(.*)\(\.\*\)\$$/)) {
			# Like RedirectMatch /foo(.*)$ /bar
			# or   AliasMatch /foo(.*)$ /home/smeg/public_html/bar
			$rd->{'path'} = $1;
			$rd->{'regexp'} = 1;
			}
		elsif (($al->{'name'} eq 'AliasMatch' ||
			$al->{'name'} eq 'RedirectMatch') &&
		       ($w[0] =~ /^\^(.*)\$$/ ||
			$w[0] =~ /^\^(.*)\$$/)) {
			# Like RedirectMatch ^/foo$ /bar
			# or   Alias ^/foo$ /home/smeg/public_html/bar
			# or   RedirectMatch ^/foo$ http://bar.com/smeg
			$rd->{'path'} = $1;
			$rd->{'exact'} = 1;
			}
		else {
			next;
			}
		$rd->{'id'} = $al->{'name'}."_".$rd->{'path'};

		my ($already) = grep { $_->{'path'} eq $rd->{'path'} } @rv;
		if ($already) {
			$already->{$proto} = 1;
			push(@{$already->{'dirs'}}, @{$rd->{'dirs'}});
			}
		else {
			push(@rv, $rd);
			}
		}

	# Find rewrite rules with or without conditions used for redirects
	# that preserve the hostname
	# We expect that the config be formatted like :
	# RewriteCond ...
	# RewriteCond ...
	# RewriteRule ...
	my @rws = (&apache::find_directive_struct("RewriteCond", $vconf),
		   &apache::find_directive_struct("RewriteRule", $vconf));
	@rws = sort { $a->{'line'} <=> $b->{'line'} } @rws;
	for(my $i=0; $i<@rws; $i++) {
		# Handle a standalone RewriteRule with no preceding RewriteCond
		if ($rws[$i]->{'name'} eq 'RewriteRule') {
			next if ($i > 0 &&
				 $rws[$i-1]->{'name'} eq 'RewriteCond');
			my $rwr = $rws[$i];
			next if ($rwr->{'words'}->[2] !~ /^\[.*R(=\d+)?.*\]$/);
			my @dirs = ( $rwr );
			my $rd = { 'alias' => 0, 'dirs' => \@dirs };
			$rd->{$proto} = 1;
			$rd->{'path'} = $rwr->{'words'}->[0];
			$rd->{'dest'} = $rwr->{'words'}->[1];
			&parse_rewritecond_flags($rwr->{'words'}->[2], $rd);
			&parse_rewriterule_redirect($rd);
			$rd->{'id'} = $rwr->{'name'}.'_'.$rd->{'path'};
			my ($already) = 
				grep { $_->{'path'} eq $rd->{'path'} &&
				       $_->{'host'} eq $rd->{'host'} } @rv;
			if ($already) {
				$already->{$proto} = 1;
				push(@{$already->{'dirs'}}, @{$rd->{'dirs'}});
				}
			else {
				push(@rv, $rd);
				}
			next;
			}
		# Handle RewriteCond + RewriteRule
		next if ($rws[$i]->{'name'} ne 'RewriteCond');
		my $j = $i;
		my $rwr;
		my ($rwc, $rwh);
		while($j < @rws) {
			if ($rws[$j]->{'name'} eq 'RewriteRule') {
				# Found final rule
				$rwr = $rws[$j];
				last;
				}
			if ($rws[$j]->{'words'}->[0] eq '%{HTTPS}') {
				# Found protocol selector condition
				$rwc = $rws[$j];
				}
			if ($rws[$j]->{'words'}->[0] eq '%{HTTP_HOST}') {
				# Found host selector condition
				$rwh = $rws[$j];
				}
			$j++;
			}
		next if (!$rwr || !$rwc && !$rwh);
		next if ($rwr->{'words'}->[2] !~ /^\[.*R(=\d+)?.*\]$/);
		my @dirs = ( $rwr );
		push(@dirs, $rwc) if ($rwc);
		push(@dirs, $rwh) if ($rwh);
		my $rd = { 'alias' => 0,
			   'dirs' => \@dirs,
			 };
		if ($rwc) {
			# Has HTTP / HTTPS condition
			if (lc($rwc->{'words'}->[1]) eq 'on') {
				$rd->{'https'} = 1;
				}
			elsif (lc($rwc->{'words'}->[1]) eq 'off') {
				$rd->{'http'} = 1;
				}
			else {
				next;
				}
			}
		else {
			# Protocol comes from port
			$rd->{$proto} = 1;
			}
		if ($rwh) {
			# Has hostname condition
			if ($rwh->{'words'}->[1] =~ /^=(.*)$/) {
				$rd->{'host'} = $1;
				$rd->{'hostregexp'} = 0;
				}
			elsif ($rwh->{'words'}->[1] =~ /\S/) {
				$rd->{'host'} = $rwh->{'words'}->[1];
				$rd->{'hostregexp'} = 1;
				}
			else {
				next;
				}
		}
		$rd->{'path'} = $rwr->{'words'}->[0];
		$rd->{'dest'} = $rwr->{'words'}->[1];
		&parse_rewritecond_flags($rwr->{'words'}->[2], $rd);
		&parse_rewriterule_redirect($rd);
		$rd->{'id'} = $rwr->{'name'}.'_'.$rd->{'path'};
		$rd->{'id'} .= '_'.$rd->{'host'} if ($rd->{'host'});
		my ($already) = grep { $_->{'path'} eq $rd->{'path'} &&
				       $_->{'host'} eq $rd->{'host'} } @rv;
		if ($already) {
			$already->{$proto} = 1;
			push(@{$already->{'dirs'}}, @{$rd->{'dirs'}});
			}
		else {
			push(@rv, $rd);
			}
		}
	}
return @rv;
}

# parse_rewritecond_flags(flags, &redirect)
# Turn a flag string like [R=302,L] into settings in a redirect
sub parse_rewritecond_flags
{
my ($flags, $rd) = @_;
if ($flags =~ /^\[(.*)\]$/) {
	my @flags = split(/,/, $1);
	foreach my $f (@flags) {
		if ($f =~ /^R=(\d+)$/) {
			$rd->{'code'} = $1;
			}
		elsif ($f eq "L") {
			$rd->{'last'} = 1;
			}
		elsif ($f eq "QSD") {
			$rd->{'stripquery'} = 1;
			}
		}
	}
}

# parse_rewriterule_redirect(&redirect)
# Parses a RewriteRule path and destination into redirect path-handling flags
sub parse_rewriterule_redirect
{
my ($rd) = @_;
my $uses_subpath = $rd->{'dest'} =~ /\$1(?:[?#].*)?$/;
if ($uses_subpath &&
    $rd->{'path'} =~ /^(.*)\(\.\*\?\)\(\?:\[\^\/\]\*\\\.\[\^\/\]\*\)\?\$$/) {
	# Path strips a trailing file-like segment from the kept sub-path
	$rd->{'path'} = $1;
	$rd->{'dest'} = &remove_redirect_destination_path($rd->{'dest'});
	$rd->{'stripfile'} = 1;
	}
elsif (!$uses_subpath &&
       ($rd->{'path'} =~ /^(.*)\.\*\$$/ ||
	$rd->{'path'} =~ /^(.*)\(\.\*\)\$$/)) {
	# Path is like /something(.*) but the destination does not
	# include $1, meaning that sub-paths are matched but are not used
	$rd->{'path'} = $1;
	$rd->{'regexp'} = 1;
	}
elsif ($rd->{'path'} =~ /^\^(.*)\$$/) {
	# Path is like ^/something$, meaning that sub-paths are not matched
	$rd->{'path'} = $1;
	$rd->{'exact'} = 1;
	}
elsif ($rd->{'path'} =~ /^(.*)\(\.\*\)\$$/) {
	# Path is like /something(.*) and the destination includes $1,
	# meaning that sub-paths are matched and included in the redirect
	$rd->{'path'} = $1;
	$rd->{'dest'} = &remove_redirect_destination_path($rd->{'dest'});
	}
}

# normalize_redirect_destination_slash(&redirect)
# For redirects that keep sub-paths, mirror the source path trailing slash on
# the destination so Apache does not join with a missing or duplicate slash.
sub normalize_redirect_destination_slash
{
my ($redirect) = @_;
return if ($redirect->{'alias'} || $redirect->{'regexp'} ||
	   $redirect->{'exact'});
return if (!defined($redirect->{'path'}) || !defined($redirect->{'dest'}));
return if ($redirect->{'dest'} !~ /^(https?:\/\/|\/)/);

my $dest = $redirect->{'dest'};
my $suffix = "";
if ($dest =~ s/([?#].*)$//) {
	$suffix = $1;
	}

if ($redirect->{'path'} =~ /\/$/) {
	$dest .= "/" if ($dest !~ /\/$/);
	}
else {
	$dest =~ s/\/$// if ($dest =~ /^(https?:\/\/.+\/|\/.+\/)$/);
	}
$redirect->{'dest'} = $dest.$suffix;
}

# append_redirect_destination_path(destination, path-part)
# Inserts a generated sub-path before any destination query string or fragment
sub append_redirect_destination_path
{
my ($dest, $part) = @_;
my $suffix = "";
if ($dest =~ s/([?#].*)$//) {
	$suffix = $1;
	}
return $dest.$part.$suffix;
}

# remove_redirect_destination_path(destination)
# Removes a generated sub-path before any destination query string or fragment
sub remove_redirect_destination_path
{
my ($dest) = @_;
$dest =~ s/\$1([?#].*)?$/$1 || ""/e;
return $dest;
}

# create_redirect(&domain, &redirect)
# Creates a new alias or redirect in some domain
sub create_redirect
{
my ($d, $redirect) = @_;
if ($redirect->{'alias'} &&
    ($redirect->{'stripfile'} || $redirect->{'stripquery'})) {
	return "Filename and query string options cannot be used with ".
	       "directory aliases";
	}
if (($redirect->{'stripfile'} || $redirect->{'stripquery'}) &&
    !&has_web_redirect_part_options($d)) {
	return "Filename and query string redirect options are not supported ".
	       "for this website type";
	}
&normalize_redirect_destination_slash($redirect);
my $p = &domain_has_website($d);
if ($p && $p ne 'web') {
        return &plugin_call($p, "feature_create_web_redirect", $d, $redirect);
        }
&require_apache();
my @ports = ( $d->{'web_port'},
	      $d->{'ssl'} ? ( $d->{'web_sslport'} ) : ( ) );
my $count = 0;
if ($redirect->{'dest'} =~ /%\{HTTP_/ &&
    $redirect->{'http'} && $redirect->{'https'}) {
	return "Redirects using HTTP_ variables cannot be applied to both ".
	       "HTTP and HTTPS modes";
	}
if ($redirect->{'host'} && $redirect->{'alias'}) {
	return "Redirects to a directory cannot be limited to a ".
	       "specific hostname";
	}
foreach my $p (@ports) {
	my ($virt, $vconf, $conf) = &get_apache_virtual($d->{'dom'}, $p);
	my $proto = $p == $d->{'web_port'} ? 'http' : 'https';
	next if (!$redirect->{$proto});
	next if (!$virt);
	if ($redirect->{'dest'} =~ /%\{HTTP_/ || $redirect->{'host'} ||
	    $redirect->{'stripfile'} || $redirect->{'stripquery'}) {
		# Advanced matching needs RewriteRule instead of Redirect
		my @rwes = &apache::find_directive("RewriteEngine", $vconf);
		my @rwcs = &apache::find_directive("RewriteCond", $vconf);
		my @rwrs = &apache::find_directive("RewriteRule", $vconf);
		my @flags;
		push(@flags, $redirect->{'code'} ? "R=".$redirect->{'code'}
						 : "R");
		push(@flags, "L") if ($redirect->{'last'});
		push(@flags, "QSD") if ($redirect->{'stripquery'});
		if ($redirect->{'host'}) {
			push(@rwcs, "%{HTTP_HOST} ".
			     ($redirect->{'hostregexp'} ? "" : "=").
			     $redirect->{'host'});
			}
		my $path;
		my $dest = $redirect->{'dest'};
		if ($redirect->{'exact'}) {
			# Only match the exact path, not any sub-paths
			$path = "^".$redirect->{'path'}."\$";
			}
		elsif ($redirect->{'stripfile'}) {
			# Match all sub-paths, strip a trailing file-like
			# component, and include the rest in the redirect
			$path = $redirect->{'path'}.
				"(.*?)(?:[^/]*\\.[^/]*)?\$";
			$dest = &append_redirect_destination_path($dest, "\$1");
			}
		elsif ($redirect->{'regexp'}) {
			# Match all sub-paths, but do not include them
			# in the redirect
			$path = $redirect->{'path'}."(\.\*)\$";
			}
		else {
			# Match all sub-paths, and include them in the
			# redirect
			$path = $redirect->{'path'}."(\.\*)\$";
			$dest = &append_redirect_destination_path($dest, "\$1");
			}
		push(@rwrs, $path." ".$dest." [".join(",", @flags)."]");
		if (!@rwes) {
			&apache::save_directive(
				"RewriteEngine", ["on"], $vconf, $conf);
			}
		&apache::save_directive("RewriteCond", \@rwcs, $vconf, $conf,1);
		&apache::save_directive("RewriteRule", \@rwrs, $vconf, $conf,1);
		}
	else {
		# Can just use Alias or Redirect
		my $dir = $redirect->{'alias'} ? "Alias" : "Redirect";
		my $path;
		if ($redirect->{'exact'}) {
			# Only match the exact path, not any sub-paths
			$path = "^".$redirect->{'path'}."\$";
			$dir .= "Match";
			}
		elsif ($redirect->{'regexp'}) {
			# Match all sub-paths, but do not include them
			# in the redirect
			$path = $redirect->{'path'}."(\.\*)\$";
			$dir .= "Match";
			}
		else {
			# Just use a bare redirect which automatically matches
			# sub-paths and includes them in the redirect
			$path = $redirect->{'path'};
			}
		my @aliases = &apache::find_directive($dir, $vconf);
		push(@aliases,
			($redirect->{'code'} && !$redirect->{'alias'} ?
				$redirect->{'code'}." " : "").
			$path." ".$redirect->{'dest'});
		&apache::save_directive($dir, \@aliases, $vconf, $conf);
		}
	&flush_file_lines($virt->{'file'});
	$count++;
	}
if ($count) {
	&register_post_action(\&restart_apache);
	return undef;
	}
return "No Apache virtualhost found";
}

# delete_redirect(&domain, &redirect)
# Remove some redirect from a domain
sub delete_redirect
{
my ($d, $redirect) = @_;
my $p = &domain_has_website($d);
if ($p && $p ne 'web') {
        return &plugin_call($p, "feature_delete_web_redirect", $d, $redirect);
        }
&require_apache();
my @ports = ( $d->{'web_port'},
              $d->{'ssl'} ? ( $d->{'web_sslport'} ) : ( ) );
my $count = 0;
foreach my $port (@ports) {
	my ($virt, $vconf, $conf) = &get_apache_virtual($d->{'dom'}, $port);
	next if (!$virt);
	my $changed = 0;
	if ($redirect->{'dirs'}->[0]->{'name'} eq 'RewriteRule' && 
	    @{$redirect->{'dirs'}} == 1) {
		# Standalone RewriteRule without preceding RewriteCond
		my $target = $redirect->{'dirs'}->[0];
		my @rwr = &apache::find_directive_struct("RewriteRule", $vconf);
		my ($found) = grep { $_->{'line'} == $target->{'line'} } @rwr;
		if ($found) {
			&apache::save_directive_struct($found, undef,
						       $vconf, $conf);
			$changed++;
			}
		}
	elsif ($redirect->{'dirs'}->[0]->{'name'} =~ /^Rewrite/i) {
		# Remove RewriteCond and RewriteRule
		my @rwcs = &apache::find_directive_struct("RewriteCond",$vconf);
		my @rwrs = &apache::find_directive_struct("RewriteRule",$vconf);
		my @dirlines = map { $_->{'line'} } @{$redirect->{'dirs'}};
		my @newrwcs = map { join(" ", @{$_->{'words'}}) }
		  grep { &indexof($_->{'line'}, @dirlines) < 0 } @rwcs;
		my @newrwrs = map { join(" ", @{$_->{'words'}}) }
		  grep { &indexof($_->{'line'}, @dirlines) < 0 } @rwrs;
		if (@rwcs != @newrwcs || @rwrs != @newrwrs) {
			&apache::save_directive(
				"RewriteCond", \@newrwcs, $vconf, $conf);
			&apache::save_directive(
				"RewriteRule", \@newrwrs, $vconf, $conf);
			$changed++;
			}
		}
	else {
		# Remove a single Alias or Redirect line
		my $dir = $redirect->{'alias'} ? "Alias" : "Redirect";
		$dir .= "Match" if ($redirect->{'regexp'} ||
				    $redirect->{'exact'});
		my @aliases = &apache::find_directive($dir, $vconf);
		my $re = $redirect->{'path'};
		my @newaliases;
		if ($redirect->{'regexp'}) {
			# Handle .*$ or (.*)$ at the end
			@newaliases = grep { !/^(\d+\s+)?\Q$re\E(\.\*|\(\.\*\))\$\s/ } @aliases;
			}
		elsif ($redirect->{'exact'}) {
			# Handle ^ at start and $ at end
			@newaliases = grep { !/^(\d+\s+)?\^\Q$re\E\$\s/ } @aliases;
			}
		else {
			# Match on path only
			@newaliases = grep { !/^(\d+\s+)?\Q$re\E\s/ } @aliases;
			}
		if (scalar(@aliases) != scalar(@newaliases)) {
			&apache::save_directive($dir, \@newaliases, $vconf, $conf);
			$changed++;
			}
		}
	if ($changed) {
		&flush_file_lines($virt->{'file'});
		$count++;
		}
	}
if ($count) {
	&register_post_action(\&restart_apache);
	return undef;
	}
return "No matching Alias or Redirect found";
}

# modify_redirect(&domain, &redirect, &old-redirect)
# Update some existing website redirect
sub modify_redirect
{
my ($d, $redirect, $oldredirect) = @_;
# Replace in a safe order, so if creating the new redirect fails, restore old
# one so edits are non-destructive
my $err = &delete_redirect($d, $oldredirect);
return $err if ($err);
$err = &create_redirect($d, $redirect);
if ($err) {
	my $rerr = &create_redirect($d, $oldredirect);
	if ($rerr) {
		$err .= " (failed to restore previous redirect: $rerr)";
		}
	}
return $err;
}

# get_redirect_root(&domain)
# Returns the allowed base directory for aliases for the current user
sub get_redirect_root
{
my ($d) = @_;
if (&master_admin()) {
	return "/";
	}
elsif ($d->{'parent'}) {
	my $pd = &get_domain($d->{'parent'});
	return &get_redirect_root($pd);
	}
else {
	return $d->{'home'};
	}
}

# add_wellknown_redirect(&redir)
# If a redirect is for everything, modify it to be for a regexp that skips
# .well-known
sub add_wellknown_redirect
{
my ($redir) = @_;
if ($redir->{'path'} eq '/' && !$redir->{'alias'} &&
    !$redir->{'regexp'} && !$redir->{'exact'}) {
	$redir->{'path'} = '^/(?!\.well-known)';
	$redir->{'regexp'} = 1;
	}
return $redir;
}

# remove_wellknown_redirect(&redir)
# If a redirect is for everything except .well-known, modify it to be for just /
sub remove_wellknown_redirect
{
my ($redir) = @_;
if (($redir->{'path'} eq '^/(?!.well-known)' ||
     $redir->{'path'} eq '^(?!/.well-known)' ||
     $redir->{'path'} eq '^/(?!\.well-known)') &&
    !$redir->{'alias'} && $redir->{'regexp'}) {
	$redir->{'path'} = '/';
	$redir->{'regexp'} = 0;
	}
return $redir;
}

# is_redirect_to_ssl(&domain, &redirect)
# Returns 1 if a redirect rule to SSL exists
sub is_redirect_to_ssl
{
my ($d, $r) = @_;
return 0 if (!$r || $r->{'alias'});
return 0 if (!$r->{'http'} || $r->{'https'});
my $exp = &get_redirect_to_ssl($d);
return $r->{'dest'} eq $exp->{'dest'} ? 1 : 0;
}

# get_redirect_to_ssl(&domain)
# Returns a default non-SSL to SSL redirect
sub get_redirect_to_ssl
{
my ($d) = @_;
return { 'path' => '^/(?!.well-known)',
	 'dest' => 'https://%{HTTP_HOST}/$1',
	 'alias' => 0,
	 'regexp' => 1,
	 'http' => 1,
	 'https' => 0 };
}

# is_webmail_redirect(&domain, &redirect)
# Returns 1 if a redirect is for use by admin sub-domain, 2 if for the webmail
# sub-domain, or 0 otherwise.
sub is_webmail_redirect
{
my ($d, $r) = @_;
return 0 if (!$r->{'host'});
return 0 if ($r->{'path'} ne '/');
my ($dhost, $dport) =
	&parse_http_url($r->{'dest'} || '', undef, undef, undef, undef, undef,
			undef, 1);
return 0 if (!$dhost || !$dport);
$dhost = lc($dhost);
my $basedom = lc($d->{'dom'});
return 0 if ($dhost ne $basedom && $dhost !~ /\.\Q$basedom\E$/);
my $rhost = lc($r->{'host'});
return 1 if ($rhost eq "admin.".$basedom);
return 2 if ($rhost eq "webmail.".$basedom);
return 0;
}

# is_www_redirect(&domain, &redirect)
# Returns 1 if a redirect is from www.domain to domain, 2 if from domain to
# www.domain, 3 if from any sub-domain to domain. and 0 otherwise
sub is_www_redirect
{
my ($d, $r) = @_;
return 0 if (!$r);
return 0 if (!$r->{'host'});
return 0 if ($r->{'path'} ne '/');
foreach my $ad ($d, &get_domain_by("alias", $d->{'id'})) {
	if ($r->{'host'} eq 'www.'.$ad->{'dom'} &&
	    $r->{'dest'} =~ /^(http|https):\/\/\Q$ad->{'dom'}\E\//) {
		return 1;
		}
	if ($r->{'host'} eq $ad->{'dom'} &&
	    $r->{'dest'} =~ /^(http|https):\/\/www\.\Q$ad->{'dom'}\E\//) {
		return 2;
		}
	if ($r->{'host'} eq '[a-z0-9_\-]+.'.$ad->{'dom'} &&
	    $r->{'dest'} =~ /^(http|https):\/\/\Q$ad->{'dom'}\E\//) {
		return 3;
		}
	}
return 0;
}

# get_www_redirect(&domain)
# Returns the objects for a redirect from domain to www.domain, for passing to
# create_redirect
sub get_www_redirect
{
my ($d) = @_;
my @rv;
foreach my $ad ($d, &get_domain_by("alias", $d->{'id'})) {
	push(@rv, { 'path' => '/',
		    'host' => $d->{'dom'},
		    'code' => 301,
		    'http' => 1,
		    'https' => 1,
		    'regexp' => 1,
		    'dest' => (&domain_has_ssl($d) ? 'https://' : 'http://').
		   	      'www.'.$d->{'dom'}.'/$1',
	          });
	}
return @rv;
}

# get_non_www_redirect(&domain)
# Returns the objects for a redirect from www.domain to domain, for passing to
# create_redirect
sub get_non_www_redirect
{
my ($d) = @_;
my @rv;
foreach my $ad ($d, &get_domain_by("alias", $d->{'id'})) {
	push(@rv, { 'path' => '/',
		    'host' => 'www.'.$ad->{'dom'},
		    'code' => 301,
		    'http' => 1,
		    'https' => 1,
		    'regexp' => 1,
		    'dest' => (&domain_has_ssl($ad) ? 'https://' : 'http://').
			      $ad->{'dom'}.'/$1',
		  });
	}
return @rv;
}

# get_non_canonical_redirect(&domain)
# Returns the objects for a redirect from any sub-domain to domain, for passing
# to create_redirect
sub get_non_canonical_redirect
{
my ($d) = @_;
my @rv;
foreach my $ad ($d, &get_domain_by("alias", $d->{'id'})) {
	push(@rv, { 'path' => '/',
		    'host' => '[a-z0-9_\-]+.'.$ad->{'dom'},
		    'code' => 301,
		    'hostregexp' => 1,
		    'http' => 1,
		    'https' => 1,
		    'regexp' => 1,
		    'dest' => (&domain_has_ssl($ad) ? 'https://' : 'http://').
			      $ad->{'dom'}.'/$1',
		  });
	}
return @rv;
}

# get_redirect_by_mode(&domain, mode)
# Returns the redirect objects based on the same mode number returned by
# is_www_redirect
sub get_redirect_by_mode
{
my ($d, $mode) = @_;
return $mode == 1 ? &get_non_www_redirect($d) :
       $mode == 2 ? &get_www_redirect($d) :
       $mode == 3 ? &get_non_canonical_redirect($d) : ( );
}

1;
