apache2-frontend/proxy_impl.pm

package proxy_impl;

use overload;

#use 5.020; # recommended for $& without performance penalty

# regex syntax
# .   literal dot         (like "\." in normal regexes)
# ·   match one character (like "." in normal regexes)
# **  match anything      (like ".*" in normal regexes)
sub uriregex {
   overload::constant qr => sub {
      local $_ = shift;

      s/\./\\./g;
      s/·/./g;
      s/\*\*/.*/g;
      s/(?<!\\)\$\z/\\z/;

      $_
   };
}

BEGIN { uriregex }

use Apache2::Const -compile => qw(
   OK DECLINED DONE NOT_FOUND SERVER_ERROR AUTH_REQUIRED FORBIDDEN
   PROXYREQ_REVERSE
);
use Apache2::RequestUtil ();
use Apache2::RequestRec ();
#use Apache2::RequestIO ();
use Apache2::Connection ();
use Apache2::Util ();
use Apache2::URI ();

use APR::Const -compile => qw(
   FILETYPE_DIR FINFO_NORM
);
use APR::Error ();
use APR::Finfo ();

use common::sense;

# per-request values, cached here for performance, use them
our $req;  # Apache2::RequestRec
our $host; # $req->hostname
our $uri;  # $req->uri, already resolved .. and protects against %xx, hopefully
our $ip;   # $req->connection->client_ip, alternative ->useragent_ip

# finish immediately with given status
sub status($) {
   die \(my $status = shift);
}

#sub escape_path($) {
#   Apache2::Util::escape_path shift, $req->pool
#}

# escapes everything not allowed in a url hpath
sub pesc($) {
   local $_ = shift;

   s/([^a-zA-z0-9\$\-_.+!*'(),;?&=\/])/sprintf "%%%02x", ord $1/ge;

   $_
}

sub err($) {
   warn "$_[0]";
   status 500;
}

# external redirect with status code
sub redirect($$) {
   my ($status, $location) = @_;

#   $location =~ s,^(http://[^/:]+)/,$1:34567/,;#d#

   $req->headers_out->set (Location => $location);
   status $status;
}

# permanent external redirect
sub rperm($) {
   redirect 301, shift
}

# temporary redirect, could be internal, but never is
sub rtemp($) {
   redirect 302, shift
}

# internal redirect, TODO
sub rint($) {
   &rtemp
}

# serve some path, do not call directly
sub _rpathname($) {
   my $path = shift;

   my $finfo = eval { APR::Finfo::stat $path, APR::Const::FINFO_NORM, $req->pool }
      or status Apache2::Const::NOT_FOUND;

   # let mod_dir, mod_autoindex and the default-handler handle this
   $req->filename ($path);
   $req->finfo ($finfo);

   if ($path =~ m%/.well-known/openid-configuration$%) {
      $req->headers_out->set ("content-type" => "application/json");
      $req->headers_out->set ("access-control-allow-origin" => "*");
   }

#   warn "serve <$path,",$req->handler,">\n";#d#
   status Apache2::Const::OK;
}

# serve a regular file from disk
sub rfile($) {
   $req->handler ("default-handler");
   &_rpathname
}

# serve a directory from disk
sub rdir($) {
   my $path = shift;

   if ($req->uri !~ m,/$,) {
      # redirect dir to dir/
      rperm $req->construct_url (pesc $req->uri . "/");

   } elsif (-e "$path/index.html") {
      # mod_dir emulation, display index.html if any
      $req->content_type ("text/html");
      rfile "$path/index.html";
   } elsif (-e "$path/index.xhtml") {
      $req->content_type ("text/html"); # we assume to follow the compatibility guidelines
      rfile "$path/index.xhtml";

   } else {
      # let mod_autoindex handle it later
      $req->handler ("httpd/unix-directory");
      _rpathname $path;
   }
}

# like rpath, but assumes caller already stat'ed
sub rpath_nostat($) {
   -d _ ? &rdir : &rfile
}

# serve a generic path, can be dir or file
sub rpath($) {
   stat $_[0];
   &rpath_nostat
}

# sets SCRIPT_NAME and PATH_INFO from previous regex match
# pathinfo must be specified via a regex match
# either
# - $1 has matched SCRIPT_NAME
# - OR $1 as above, and $2 matches PATH_INFO (for extra checking)
# - OR (?<name>...) and (?<path>...) exist and match SCRIPT_NAME and PATH_INFO.
sub _get_pathinfo() {
   my ($name, $path);

   if (exists $+{name} && exists $+{path}) {
      $name = $+{name};
      $path = $+{path};
   } elsif (defined $1) {
      $name = $1;
      $path = defined $2 ? $2 : substr "$`$&$'", $+[1];
   } else {
      err "$uri: cannot set pathinfo";
   }

   if ($uri ne "$name$path") {
      err "$uri: imperfect split into <$name> and <$path>";
   }

   ($name, $path)
}

sub _set_pathinfo() {
   my ($name, $path) = _get_pathinfo;

   $req->uri ("$name$path");
   $req->path_info ($path);
}

# run a cgi script, first argument is script,
# also sets pathinfo, see _get_pathinfo
sub rcgi($) {
   my ($path) = @_;

   _set_pathinfo;

   $req->handler ("cgi-script");
   $req->notes->set ("alias-forced-type" => "cgi-script"); # leave a note for mod_cgi, so it ignores missing ExecCGI
   _rpathname $path;
}

# simplest reverse proxy, target is target url for this request
sub rproxy($;$) {
   my ($target, $preservehost) = @_;

   $req->proxyreq (Apache2::Const::PROXYREQ_REVERSE);
   $req->filename ("proxy:$target");
   $req->handler ("proxy-server");
   $req->subprocess_env->set ("proxy-sendchunked", 1);
   #$notes->set ("proxy-nocanon", 1);
   #$env->set ("proxy-initial-not-pooled", 1);

   # disable compression, see http://www.apachetutor.org/admin/reverseproxies
   # $req->headers_in->unset ("accept-encoding");
   # alternatively recompress, SetOutputFilter INFLATE;DEFLATE

   $req->add_config (["ProxyPreserveHost on"], ~0)
      if $preservehost;

   $req->headers_out->set ("x-forwarded-for", $req->connection->client_ip);
   $req->headers_out->set ("x-forwarded-proto", "https"); # unable to find a way to access ap_http_scheme

   status Apache2::Const::OK;
}

# host, port
# also sets pathinfo, see _get_pathinfo
sub rscgi($;$) {
   my ($target) = @_;

   _set_pathinfo;
   rproxy $target;

   # notes: uds_path
}

# reverse proxy
# path is local root uri
# target is target root url
# suffix is appended to target url
# @lines is extra config lines
sub rproxy_html($$$@) {
   my ($path, $target, $suffix, @lines) = @_;

   (my $cpath = $path) =~ s/([^A-Za-z0-9\/.\-_])/sprintf "\\x%02x", ord $1/ge;

   push @lines, (
      "ProxyPassReverse /",
      "ProxyHTMLEnable on",
#      "ProxyHTMLURLMap $target $cpath",
#      "ProxyHTMLURLMap / $cpath/",
   );

#   warn "PROXY<$path,$target,$suffix>\n";#d#
#   warn map "$_\n",@lines;

   $req->add_config (\@lines, ~0, $path);
  
   rproxy "$target$suffix";
}

my $rules;

sub load_rules {
   open my $fh, "<:raw", Apache2::ServerUtil::server_root . "/rules"
      or die Apache2::ServerUtil::server_root . "/rules: $!";
   local $/;

   $rules = <$fh>;

   $rules = eval "use common::sense; BEGIN { uriregex }\nsub {\n#line 0 'rules'\n$rules\n}"
      or die $@;

   warn "proxy rules successfully loaded.\n";

   Apache2::Const::OK
}

sub map_to_storage {
   local $req = shift;
   local ($host, $uri, $ip) = ($req->hostname, $req->uri, $req->connection->client_ip);

   eval {
      # the uri is pre-parsed and "protected" by apache
      # the hostname is lowercased but otherwise completely unchecked,
      # so better be safe than sorry
      $host =~ /^[A-Za-z0-9\-.]+$/
         or status 404;

      # must have at least one dot
      $host =~ /./
         or status 404;

      local $_ = "$host$uri";
      $rules->($req);
   };

   if ($@) {
      if (SCALAR:: eq ref $@) {
         return ${$@};
      } else {
         die;
      }
   }

   Apache2::Const::NOT_FOUND
}

load_rules;

warn "proxy loaded and iniitalised.\n";

1

Revision:	1.13
Committed:	Wed Apr 16 00:02:05 2025 UTC (17 months, 2 weeks ago) by root
Branch:	MAIN
Changes since 1.12:	+1 -1 lines
Log Message:	* empty log message *
#	Content
1	package proxy_impl;
2
3	use overload;
4
5	#use 5.020; # recommended for $& without performance penalty
6
7	# regex syntax
8	# . literal dot (like "\." in normal regexes)
9	# · match one character (like "." in normal regexes)
10	# ** match anything (like ".*" in normal regexes)
11	sub uriregex {
12	overload::constant qr => sub {
13	local $_ = shift;
14
15	s/\./\\./g;
16	s/·/./g;
17	s/\\/.*/g;
18	s/(?<!\\)\$\z/\\z/;
19
20	$_
21	};
22	}
23
24	BEGIN { uriregex }
25
26	use Apache2::Const -compile => qw(
27	OK DECLINED DONE NOT_FOUND SERVER_ERROR AUTH_REQUIRED FORBIDDEN
28	PROXYREQ_REVERSE
29	);
30	use Apache2::RequestUtil ();
31	use Apache2::RequestRec ();
32	#use Apache2::RequestIO ();
33	use Apache2::Connection ();
34	use Apache2::Util ();
35	use Apache2::URI ();
36
37	use APR::Const -compile => qw(
38	FILETYPE_DIR FINFO_NORM
39	);
40	use APR::Error ();
41	use APR::Finfo ();
42
43	use common::sense;
44
45	# per-request values, cached here for performance, use them
46	our $req; # Apache2::RequestRec
47	our $host; # $req->hostname
48	our $uri; # $req->uri, already resolved .. and protects against %xx, hopefully
49	our $ip; # $req->connection->client_ip, alternative ->useragent_ip
50
51	# finish immediately with given status
52	sub status($) {
53	die \(my $status = shift);
54	}
55
56	#sub escape_path($) {
57	# Apache2::Util::escape_path shift, $req->pool
58	#}
59
60	# escapes everything not allowed in a url hpath
61	sub pesc($) {
62	local $_ = shift;
63
64	s/([^a-zA-z0-9\$\-_.+!*'(),;?&=\/])/sprintf "%%%02x", ord $1/ge;
65
66	$_
67	}
68
69	sub err($) {
70	warn "$_[0]";
71	status 500;
72	}
73
74	# external redirect with status code
75	sub redirect($$) {
76	my ($status, $location) = @_;
77
78	# $location =~ s,^(http://[^/:]+)/,$1:34567/,;#d#
79
80	$req->headers_out->set (Location => $location);
81	status $status;
82	}
83
84	# permanent external redirect
85	sub rperm($) {
86	redirect 301, shift
87	}
88
89	# temporary redirect, could be internal, but never is
90	sub rtemp($) {
91	redirect 302, shift
92	}
93
94	# internal redirect, TODO
95	sub rint($) {
96	&rtemp
97	}
98
99	# serve some path, do not call directly
100	sub _rpathname($) {
101	my $path = shift;
102
103	my $finfo = eval { APR::Finfo::stat $path, APR::Const::FINFO_NORM, $req->pool }
104	or status Apache2::Const::NOT_FOUND;
105
106	# let mod_dir, mod_autoindex and the default-handler handle this
107	$req->filename ($path);
108	$req->finfo ($finfo);
109
110	if ($path =~ m%/.well-known/openid-configuration$%) {
111	$req->headers_out->set ("content-type" => "application/json");
112	$req->headers_out->set ("access-control-allow-origin" => "*");
113	}
114
115	# warn "serve <$path,",$req->handler,">\n";#d#
116	status Apache2::Const::OK;
117	}
118
119	# serve a regular file from disk
120	sub rfile($) {
121	$req->handler ("default-handler");
122	&_rpathname
123	}
124
125	# serve a directory from disk
126	sub rdir($) {
127	my $path = shift;
128
129	if ($req->uri !~ m,/$,) {
130	# redirect dir to dir/
131	rperm $req->construct_url (pesc $req->uri . "/");
132
133	} elsif (-e "$path/index.html") {
134	# mod_dir emulation, display index.html if any
135	$req->content_type ("text/html");
136	rfile "$path/index.html";
137	} elsif (-e "$path/index.xhtml") {
138	$req->content_type ("text/html"); # we assume to follow the compatibility guidelines
139	rfile "$path/index.xhtml";
140
141	} else {
142	# let mod_autoindex handle it later
143	$req->handler ("httpd/unix-directory");
144	_rpathname $path;
145	}
146	}
147
148	# like rpath, but assumes caller already stat'ed
149	sub rpath_nostat($) {
150	-d _ ? &rdir : &rfile
151	}
152
153	# serve a generic path, can be dir or file
154	sub rpath($) {
155	stat $_[0];
156	&rpath_nostat
157	}
158
159	# sets SCRIPT_NAME and PATH_INFO from previous regex match
160	# pathinfo must be specified via a regex match
161	# either
162	# - $1 has matched SCRIPT_NAME
163	# - OR $1 as above, and $2 matches PATH_INFO (for extra checking)
164	# - OR (?<name>...) and (?<path>...) exist and match SCRIPT_NAME and PATH_INFO.
165	sub _get_pathinfo() {
166	my ($name, $path);
167
168	if (exists $+{name} && exists $+{path}) {
169	$name = $+{name};
170	$path = $+{path};
171	} elsif (defined $1) {
172	$name = $1;
173	$path = defined $2 ? $2 : substr "$`$&$'", $+[1];
174	} else {
175	err "$uri: cannot set pathinfo";
176	}
177
178	if ($uri ne "$name$path") {
179	err "$uri: imperfect split into <$name> and <$path>";
180	}
181
182	($name, $path)
183	}
184
185	sub _set_pathinfo() {
186	my ($name, $path) = _get_pathinfo;
187
188	$req->uri ("$name$path");
189	$req->path_info ($path);
190	}
191
192	# run a cgi script, first argument is script,
193	# also sets pathinfo, see _get_pathinfo
194	sub rcgi($) {
195	my ($path) = @_;
196
197	_set_pathinfo;
198
199	$req->handler ("cgi-script");
200	$req->notes->set ("alias-forced-type" => "cgi-script"); # leave a note for mod_cgi, so it ignores missing ExecCGI
201	_rpathname $path;
202	}
203
204	# simplest reverse proxy, target is target url for this request
205	sub rproxy($;$) {
206	my ($target, $preservehost) = @_;
207
208	$req->proxyreq (Apache2::Const::PROXYREQ_REVERSE);
209	$req->filename ("proxy:$target");
210	$req->handler ("proxy-server");
211	$req->subprocess_env->set ("proxy-sendchunked", 1);
212	#$notes->set ("proxy-nocanon", 1);
213	#$env->set ("proxy-initial-not-pooled", 1);
214
215	# disable compression, see http://www.apachetutor.org/admin/reverseproxies
216	# $req->headers_in->unset ("accept-encoding");
217	# alternatively recompress, SetOutputFilter INFLATE;DEFLATE
218
219	$req->add_config (["ProxyPreserveHost on"], ~0)
220	if $preservehost;
221
222	$req->headers_out->set ("x-forwarded-for", $req->connection->client_ip);
223	$req->headers_out->set ("x-forwarded-proto", "https"); # unable to find a way to access ap_http_scheme
224
225	status Apache2::Const::OK;
226	}
227
228	# host, port
229	# also sets pathinfo, see _get_pathinfo
230	sub rscgi($;$) {
231	my ($target) = @_;
232
233	_set_pathinfo;
234	rproxy $target;
235
236	# notes: uds_path
237	}
238
239	# reverse proxy
240	# path is local root uri
241	# target is target root url
242	# suffix is appended to target url
243	# @lines is extra config lines
244	sub rproxy_html($$$@) {
245	my ($path, $target, $suffix, @lines) = @_;
246
247	(my $cpath = $path) =~ s/([^A-Za-z0-9\/.\-_])/sprintf "\\x%02x", ord $1/ge;
248
249	push @lines, (
250	"ProxyPassReverse /",
251	"ProxyHTMLEnable on",
252	# "ProxyHTMLURLMap $target $cpath",
253	# "ProxyHTMLURLMap / $cpath/",
254	);
255
256	# warn "PROXY<$path,$target,$suffix>\n";#d#
257	# warn map "$_\n",@lines;
258
259	$req->add_config (\@lines, ~0, $path);
260
261	rproxy "$target$suffix";
262	}
263
264	my $rules;
265
266	sub load_rules {
267	open my $fh, "<:raw", Apache2::ServerUtil::server_root . "/rules"
268	or die Apache2::ServerUtil::server_root . "/rules: $!";
269	local $/;
270
271	$rules = <$fh>;
272
273	$rules = eval "use common::sense; BEGIN { uriregex }\nsub {\n#line 0 'rules'\n$rules\n}"
274	or die $@;
275
276	warn "proxy rules successfully loaded.\n";
277
278	Apache2::Const::OK
279	}
280
281	sub map_to_storage {
282	local $req = shift;
283	local ($host, $uri, $ip) = ($req->hostname, $req->uri, $req->connection->client_ip);
284
285	eval {
286	# the uri is pre-parsed and "protected" by apache
287	# the hostname is lowercased but otherwise completely unchecked,
288	# so better be safe than sorry
289	$host =~ /^[A-Za-z0-9\-.]+$/
290	or status 404;
291
292	# must have at least one dot
293	$host =~ /./
294	or status 404;
295
296	local $_ = "$host$uri";
297	$rules->($req);
298	};
299
300	if ($@) {
301	if (SCALAR:: eq ref $@) {
302	return ${$@};
303	} else {
304	die;
305	}
306	}
307
308	Apache2::Const::NOT_FOUND
309	}
310
311	load_rules;
312
313	warn "proxy loaded and iniitalised.\n";
314
315	1
316