regress/cmdline/http-server

   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 STDOUT->autoflush(1);
 157 printf "$$: ready\n";
 158
 159 while (1) {
 160         my $client = $server->accept();
 161
 162         while (my $req = $client->get_request) {
 163                 if ($req->method eq "GET") {
 164                         handle_get($req, $client);
 165                 } elsif ($req->method eq "POST") {
 166                         handle_post($req, $client);
 167                 } else {
 168                         warn "unknown method ". $req->method . "\n";
 169                         my $res = HTTP::Response->new(405,
 170                             "Method not Allowed");
 171                         $client->send_response($res);
 172                         last;
 173                 }
 174         }
 175
 176         $client->close();
 177 }