1 5565365c 2024-03-27 op #!/usr/bin/env perl
 2 5565365c 2024-03-27 op #
 3 5565365c 2024-03-27 op # Copyright (c) 2024 Omar Polo <op@openbsd.org>
 4 5565365c 2024-03-27 op #
 5 5565365c 2024-03-27 op # Permission to use, copy, modify, and distribute this software for any
 6 5565365c 2024-03-27 op # purpose with or without fee is hereby granted, provided that the above
 7 5565365c 2024-03-27 op # copyright notice and this permission notice appear in all copies.
 8 5565365c 2024-03-27 op #
 9 5565365c 2024-03-27 op # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10 5565365c 2024-03-27 op # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 5565365c 2024-03-27 op # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12 5565365c 2024-03-27 op # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13 5565365c 2024-03-27 op # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14 5565365c 2024-03-27 op # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15 5565365c 2024-03-27 op # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16 5565365c 2024-03-27 op 
17 5565365c 2024-03-27 op use v5.36;
18 5565365c 2024-03-27 op use IPC::Open2;
19 5565365c 2024-03-27 op use Getopt::Long qw(:config bundling);
20 5565365c 2024-03-27 op 
21 050c0b8c 2024-04-16 op my $auth;
22 5565365c 2024-03-27 op my $port = 8000;
23 5565365c 2024-03-27 op 
24 050c0b8c 2024-04-16 op GetOptions("a:s" => \$auth, "p:i" => \$port)
25 050c0b8c 2024-04-16 op     or die("usage: $0 [-a auth] [-p port]\n");
26 5565365c 2024-03-27 op 
27 5565365c 2024-03-27 op my $pid = open2(my $out, my $in, 'nc', '-l', 'localhost', $port);
28 5565365c 2024-03-27 op 
29 5565365c 2024-03-27 op my $clen;
30 5565365c 2024-03-27 op while (<$out>) {
31 5565365c 2024-03-27 op 	local $/ = "\r\n";
32 5565365c 2024-03-27 op 	chomp;
33 5565365c 2024-03-27 op 
34 5565365c 2024-03-27 op 	last if /^$/;
35 5565365c 2024-03-27 op 
36 5565365c 2024-03-27 op 	if (m/^POST/) {
37 5565365c 2024-03-27 op 		die "bad http request" unless m,^POST / HTTP/1.1$,;
38 5565365c 2024-03-27 op 		next;
39 5565365c 2024-03-27 op 	}
40 5565365c 2024-03-27 op 
41 5565365c 2024-03-27 op 	if (m/^Host:/) {
42 5565365c 2024-03-27 op 		die "bad Host header" unless /^Host: localhost:$port$/;
43 5565365c 2024-03-27 op 		next;
44 5565365c 2024-03-27 op 	}
45 5565365c 2024-03-27 op 
46 5565365c 2024-03-27 op 	if (m/^Content-Type/) {
47 5565365c 2024-03-27 op 		die "bad content-type header"
48 5565365c 2024-03-27 op 		    unless m,Content-Type: application/json$,;
49 5565365c 2024-03-27 op 		next;
50 5565365c 2024-03-27 op 	}
51 5565365c 2024-03-27 op 
52 5565365c 2024-03-27 op 	if (m/^Content-Length/) {
53 5565365c 2024-03-27 op 		die "double content-length" if defined $clen;
54 5565365c 2024-03-27 op 		die "bad content-length header"
55 5565365c 2024-03-27 op 		    unless m/Content-Length: (\d+)$/;
56 5565365c 2024-03-27 op 		$clen = $1;
57 5565365c 2024-03-27 op 		next;
58 5565365c 2024-03-27 op 	}
59 5565365c 2024-03-27 op 
60 5565365c 2024-03-27 op 	if (m/Connection/) {
61 5565365c 2024-03-27 op 		die "bad connection header"
62 5565365c 2024-03-27 op 		    unless m/Connection: close$/;
63 5565365c 2024-03-27 op 		next;
64 5565365c 2024-03-27 op 	}
65 050c0b8c 2024-04-16 op 
66 050c0b8c 2024-04-16 op 	if (m/Authorization/) {
67 050c0b8c 2024-04-16 op 		die "bad authorization header"
68 050c0b8c 2024-04-16 op 		    unless m/Authorization: basic (.*)$/;
69 050c0b8c 2024-04-16 op 		my $t = $1;
70 050c0b8c 2024-04-16 op 		die "wrong authorization; got $t want $auth"
71 050c0b8c 2024-04-16 op 		    if not defined($auth) or $auth ne $t;
72 050c0b8c 2024-04-16 op 		next;
73 050c0b8c 2024-04-16 op 	}
74 5565365c 2024-03-27 op }
75 5565365c 2024-03-27 op 
76 5565365c 2024-03-27 op die "no Content-Length header" unless defined $clen;
77 5565365c 2024-03-27 op 
78 5565365c 2024-03-27 op while ($clen != 0) {
79 5565365c 2024-03-27 op 	my $len = $clen;
80 5565365c 2024-03-27 op 	$len = 512 if $clen > 512;
81 5565365c 2024-03-27 op 
82 5565365c 2024-03-27 op 	my $r = read($out, my $buf, $len);
83 5565365c 2024-03-27 op 	$clen -= $r;
84 5565365c 2024-03-27 op 
85 5565365c 2024-03-27 op 	print $buf;
86 5565365c 2024-03-27 op }
87 5565365c 2024-03-27 op say "";
88 5565365c 2024-03-27 op 
89 5565365c 2024-03-27 op print $in "HTTP/1.1 200 OK\r\n";
90 5565365c 2024-03-27 op print $in "Content-Length: 0\r\n";
91 5565365c 2024-03-27 op print $in "Connection: close\r\n";
92 5565365c 2024-03-27 op print $in "\r\n";
93 5565365c 2024-03-27 op 
94 5565365c 2024-03-27 op close $in;
95 5565365c 2024-03-27 op close $out;
96 5565365c 2024-03-27 op 
97 5565365c 2024-03-27 op waitpid($pid, 0);
98 5565365c 2024-03-27 op exit $? >> 8;