git.rot13.org Git - pxelator/blob - lib/PXElator/httpd.pm

   1 package httpd;
   2
   3 use warnings;
   4 use strict;
   5 use autodie;
   6
   7 =head1 httpd
   8
   9 Start with:
  10
  11   perl -Ilib/PXElator -Mhttpd -e httpd::start
  12
  13 =cut
  14
  15 use Data::Dump qw/dump/;
  16 use Carp qw/confess/;
  17 use File::Slurp;
  18 #use JSON;
  19 use IO::Socket::INET;
  20 use Module::Refresh;
  21
  22 our $pids;
  23 $pids = { httpd => $$ } unless defined $pids; # keep pids on refresh
  24
  25 sub DESTROY {
  26         warn "pids ",dump( $pids );
  27         foreach ( values %$pids ) {
  28                 warn "kill $_";
  29                 kill 1,$_ || kill 9, $_;
  30         }
  31 }
  32
  33 our $port = 7777;
  34
  35 use server;
  36 our $debug = server::debug;
  37 our $url = "http://$server::ip:$port";
  38
  39 use html;
  40 our $static_pids;
  41
  42 sub static {
  43         my ($client,$path) = @_;
  44
  45         my $full = "$server::base_dir/tftp/$path";
  46
  47         return if ! -f $full;
  48
  49         if ( my $pid = fork ) {
  50                 # parent
  51                 close($client);
  52                 print "http static child $pid\n";
  53                 $static_pids->{$pid} = $path;
  54                 return 1;
  55         }
  56
  57         my $type = 'application/octet-stream';
  58         $type = 'text/html' if $path =~ m{\.htm};
  59         $type = 'application/javascript' if $path =~ m{\.js};
  60         $type = 'text/plain' if $path =~ m{\.txt};
  61
  62         my $size = -s $full || return;
  63
  64         print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\nContent-Length: $size\r\nConnection: close\r\n\r\n";
  65
  66         open(my $fh, $full);
  67         print "static $path $type $size\n";
  68
  69         my $block = 8192;
  70         my $buff;
  71         my $pos = 0;
  72
  73         while( my $len = read $fh, $buff, $block ) {
  74                 print $client $buff;
  75                 $pos += $len;
  76                 printf "%s %d/%d %.2f%%\r", $path, $pos, $size, $pos * 100 / $size;
  77         }
  78         close($fh);
  79         close($client);
  80
  81         print "$path $pos == $size OK\n";
  82
  83         exit;
  84 }
  85
  86 use boolean;
  87
  88 use screen;
  89 use kvm;
  90
  91 $SIG{CHLD} = 'IGNORE';
  92
  93 sub start_stop {
  94         my $daemon = shift;
  95         my $pid = $pids->{$daemon};
  96
  97         warn "start_stop $daemon $pid pids: ",dump( $pids );
  98
  99         if ( $pid =~ m{^\d+$} ) {
 100                 warn "kill 9 $pid";
 101                 kill 9, $pid;
 102                 $pids->{$daemon} = 'stopped';
 103                 return qq|$daemon pid $pid stopped|;
 104         } else {
 105                 if ( $pid = fork ) {
 106                         # parent
 107                         $pids->{$daemon} = $pid;
 108                         warn "forked $daemon $pid";
 109                         return qq|$daemon pid $pid started|;
 110                 } elsif ( defined $pid ) {
 111                         # child
 112                         my $eval = $daemon . '::start(' . ( @_ ? dump(@_) : '' ) . ')';
 113                         warn "eval $eval";
 114                         eval $eval;
 115                         warn "can't start $daemon: $@" if $@;
 116                         exit;
 117                 } else {
 118                         die "fork error $!";
 119                 }
 120         }
 121 }
 122
 123 my $ok =       qq|HTTP/1.0 200 OK\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n|;
 124 my $redirect = qq|HTTP/1.1 302 Found\r\nContent-type: text/html\r\nLocation: $url\r\n\r\n|;
 125
 126 sub get_request {
 127         my ( $client, $path, $param ) = @_;
 128
 129         warn "get_request $client $path ",dump( $param );
 130
 131         if ( my $found = static( $client,$path ) ) {
 132                 warn "static $found" if $debug;
 133         } elsif ( $path eq '/' ) {
 134
 135                 my $screen = $pids->{screen} ? qq|stop <tt>$pids->{screen}</tt>|        : 'start';
 136                 my $kvm    = $pids->{kvm}    ? qq|stop <tt>$pids->{kvm}</tt>|           :
 137                                          $pids->{screen} ? qq|start|                                                    : qq|start screen first|;
 138
 139                 my @rows = (
 140                         'ip',           html::tt( $server::ip ),
 141                         'netmask',      html::tt( $server::netmask ),
 142
 143                         'debug',        qq|<a href=/our/debug/| . boolean::toggle($debug) . qq|>$debug</a>|,
 144                 );
 145
 146                 warn 'pids: ', dump( $pids );
 147                 foreach my $name ( keys %$pids ) {
 148                         my $pid = $pids->{$name} || next;
 149                         my $proc = "/proc/$pid/status";
 150
 151                         my $html = qq|<a href=/$name>$pid</a>|;
 152                         $html   .= qq|<pre style="font-size: 10%">|
 153                                         .  ( $debug && -e $proc ? read_file($proc) : '' )
 154                                         .  qq|</pre>| if $debug;
 155
 156                         push @rows, ( $name => $html );
 157                 }
 158
 159                 warn 'static_pids: ', dump( $static_pids );
 160                 foreach my $pid ( keys %$static_pids ) {
 161                         my $path = $static_pids->{$pid};
 162                         if ( -d "/proc/$pid" ) {
 163                                 push @rows, ( $path => qq|<a href=/kill/static/$pid>$pid</a>| );
 164                         } else {
 165                                 push @rows, ( $path => "$pid competed" );
 166                         }
 167                 }
 168
 169                 print $client $ok, html::table( 2, @rows );
 170
 171         } elsif ( $path =~ m{^/our/(\w+)/(\S+)} ) {
 172                 eval 'our $' . $1 . ' = ' . $2;
 173                 warn $@ if $@;
 174                 print $client $redirect, qq|<big>$1 = $2</big><br>Location: <a href="$url">$url</a>|;
 175                 server::debug( $debug ) if $1 eq 'debug';
 176         } elsif ( $path =~ m{^/(screen|kvm)} ) {
 177                 print $client $redirect, start_stop($1);
 178         } elsif ( $path =~ m{^/kill/static/(\d+)} ) {
 179                 print $client $redirect;
 180                 kill 9, $1 && warn "killed $1";
 181         } elsif ( $path eq '/exit' ) {
 182 #               DESTROY;
 183                 exit 0;
 184         } elsif ( $path =~ m{/boot} ) {
 185                 print $client qq{$ok
 186 #!gpxe
 187 imgfree
 188 login
 189 chain http://$server::ip:$httpd::port/
 190
 191                         };
 192         } else {
 193                 print $client "HTTP/1.0 404 $path\r\nConnection: close\r\nContent-type: text/html\r\n\r\n<big>404 $path</big>";
 194                 warn "404 $path";
 195         }
 196
 197 }
 198
 199 use browser;
 200
 201 sub start {
 202
 203         my $server = IO::Socket::INET->new(
 204                         Proto     => 'tcp',
 205                         LocalPort => $httpd::port,
 206                         Listen    => SOMAXCONN,
 207                         Reuse     => 1
 208         ) || die "can't start server on $url: $!";
 209
 210         print "url $url\n";
 211
 212         start_stop 'browser', $url;
 213         start_stop 'screen';
 214         start_stop 'kvm';
 215
 216         while (my $client = $server->accept()) {
 217                 $client->autoflush(1);
 218                 my $request = <$client>;
 219
 220                 warn "request $request\n" if $debug;
 221
 222                 Module::Refresh->refresh;
 223
 224                 if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
 225                         my $path = $1;
 226                         my $param;
 227                         if ( $path =~ s{\?(.+)}{} ) {
 228                                 foreach my $p ( split(/[&;]/, $1) ) {
 229                                         my ($n,$v) = split(/=/, $p, 2);
 230                                         $param->{$n} = $v;
 231                                 }
 232                                 warn "param: ",dump( $param ) if $debug;
 233                         }
 234                         warn "path $path param: ",dump( $param );
 235                         get_request $client, $path, $param;
 236                 } else {
 237                         print $client "HTTP/1.0 500 No method\r\nConnection: close\r\nContent-type: text/plain\r\n\r\n500 $request";
 238                         warn "500 $request";
 239                 }
 240
 241                 print $client qq{
 242                 <div style="font-size: 80%; color: #888">
 243                 <a href="">reload</a>
 244                 <a href=/>index</a>
 245                 <a href=/exit>exit</a>
 246                 </div>
 247                 } if $client->connected;
 248
 249         }
 250
 251         die "server died";
 252 }
 253
 254 warn "loaded";
 255
 256 1;