1 #!/usr/bin/env perl
2 #
3 # Copyright (c) 2024 Omar Polo <op@openbsd.org>
4 # Copyright (c) 2024 Stefan Sperling <stsp@openbsd.org>
5 #
6 # Permission to use, copy, modify, and distribute this software for any
7 # purpose with or without fee is hereby granted, provided that the above
8 # copyright notice and this permission notice appear in all copies.
9 #
10 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17 
18 use v5.36;
19 use IPC::Open2;
20 use Getopt::Long qw(:config bundling);
21 use HTTP::Daemon;
22 use HTTP::Status;
23 use HTTP::Request;
24 
25 my $port = 8000;
26 
27 my $usage = "usage: $0 [-p port] repo_root_path\n";
28 GetOptions("p:i" => \$port) or die($usage);
29 
30 # $HTTP::Daemon::DEBUG = 1;
31 
32 my $server = HTTP::Daemon->new(
33 	Domain => AF_INET,
34 	Type => SOCK_STREAM,
35 	Proto => 'tcp',
36 	LocalHost => '127.0.0.1',
37 	LocalPort => $port,
38 	ReusePort => 1,
39 	Listen => 1,
40 ) || die "Could not open socket 127.0.0.1:$port: $IO::Socket::errstr";
41 
42 $ENV{GIT_HTTP_EXPORT_ALL} = '';
43 
44 $SIG{'PIPE'} = 'IGNORE';
45 
46 my $repo_root = $ARGV[0];
47 
48 sub handle_get {
49 	my ($req, $client) = @_;
50 	my $done = 0;
51 
52 	my $path = $req->uri->path;
53 	$ENV{PATH_TRANSLATED} = "/$repo_root/$path";
54 	$ENV{REQUEST_METHOD} = 'GET';
55 	$ENV{QUERY_STRING} = $req->uri->query;
56 
57 	my $gitpid = open2(my $gitout, my $gitin, 'git', 'http-backend');
58 
59 	close($gitin);
60 
61 	my $headers = HTTP::Headers->new;
62 	my ($status_code, $status) = (200, "OK");
63 	while (<$gitout>) {
64 		local $/ = "\r\n";
65 		chomp;
66 		last if m/^$/;
67 
68 		if (m/^Status: ([0-9]+)(.*)$/) {
69 			($status_code, $status) = ($1, $2);
70 			chomp $status;
71 			next;
72 		}
73 
74 		# XXX we don't support 'folded' headers
75 		my ($name, $value) = split(':', $_);
76 		$headers->header($name => $value);
77 	}
78 
79 	my $resp = HTTP::Response->new($status_code, $status, $headers,
80 	    sub {
81 		    my $r = read($gitout, my $buf, 1024);
82 		    warn "error reading git output: $!" unless defined $r;
83 		    return undef if not defined($r) or $r == 0;
84 		    return $buf;
85 	    });
86 
87 	$client->send_response($resp);
88 
89 	close($gitout);
90 	waitpid($gitpid, 0);
91 
92 	printf "GET %s: 200 OK\n", $req->uri->path;
93 }
94 
95 sub handle_post {
96 	my ($req, $client) = @_;
97 	my $done = 0;
98 
99 	my $path = $req->uri->path;
100 	$ENV{PATH_TRANSLATED} = "/$repo_root/$path";
101 	$ENV{REQUEST_METHOD} = 'POST';
102 	$ENV{QUERY_STRING} = "";
103 	$ENV{CONTENT_TYPE} = $req->header('Content-Type');
104 
105 	my $gitpid = open2(my $gitout, my $gitin, 'git', 'http-backend');
106 
107 	my $content = $req->content();
108 	my $len = length($content);
109 	while ($len > 0) {
110 		my $w = syswrite($gitin, $content, $len);
111 		last if $w <= 0;
112 		$len -= $w;
113 		$content = substr($content, $w);
114 	}
115 
116 	die "failed to upload payload" if ($len != 0);
117 
118 	close($gitin);
119 
120 	my $headers = HTTP::Headers->new;
121 	my ($status_code, $status) = (200, "OK");
122 	while (<$gitout>) {
123 		local $/ = "\r\n";
124 		chomp;
125 		last if m/^$/;
126 
127 		if (m/^Status: ([0-9]+)(.*)$/) {
128 			($status_code, $status) = ($1, $2);
129 			chomp $status;
130 			next;
131 		}
132 
133 		# XXX we don't support 'folded' headers
134 		my ($name, $value) = split(':', $_);
135 		$headers->header($name => $value);
136 	}
137 
138 	my $resp = HTTP::Response->new($status_code, $status, $headers,
139 		sub {
140 			my $r = read($gitout, my $buf, 1024);
141 			if (not defined($r) or $r == 0) {
142 				warn "read error: $!" unless defined $r;
143 				return undef;
144 			}
145 			return $buf;
146 		});
147 
148 	$client->send_response($resp);
149 
150 	close($gitout);
151 	waitpid($gitpid, 0);
152 
153 	printf "POST %s: 200 OK\n", $req->uri->path;
154 }
155 
156 while (1) {
157 	my $client = $server->accept();
158 
159 	while (my $req = $client->get_request) {
160 		if ($req->method eq "GET") {
161 			handle_get($req, $client);
162 		} elsif ($req->method eq "POST") {
163 			handle_post($req, $client);
164 		} else {
165 			warn "unknown method ". $req->method . "\n";
166 			my $res = HTTP::Response->new(405,
167 			    "Method not Allowed");
168 			$client->send_response($res);
169 			last;
170 		}
171 	}
172 
173 	$client->close();
174 }