apache2-frontend/proxy_impl.pm

package proxy_impl;

use overload;

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

# regex syntax
# .   literal dot         (like "\." in normaql 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;

      $_
   };
}

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::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::RquestRec
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);
#   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) = @_;

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