lib/PXElator/httpd.pm

package httpd;

use warnings;
use strict;
use autodie;

=head1 httpd

Start with:

  perl -Ilib/PXElator -Mhttpd -e httpd::start

=cut

use Data::Dump qw/dump/;
use Carp qw/confess/;
use File::Slurp;
#use JSON;
use IO::Socket::INET;
use Module::Refresh;

our $pids = { httpd => $$ };

sub DESTROY {
        warn "pids ",dump( $pids );
        foreach ( values %$pids ) {
                warn "kill $_";
                kill 1,$_ || kill 9, $_;
        }
}

our $port = 7777;
our $debug = 0;

use server;
our $url = "http://$server::ip:$port";

use html;

sub static {
        my ($client,$path) = @_;

        my $full = "$server::base_dir/tftp/$path";

        return if ! -f $full;

        my $type = 'application/octet-stream';
        $type = 'text/html' if $path =~ m{\.htm};
        $type = 'application/javascript' if $path =~ m{\.js};
        $type = 'text/plain' if $path =~ m{\.txt};

        my $size = -s $full || return;

        print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\nContent-Length: $size\r\nConnection: close\r\n\r\n";

        open(my $fh, $full);
        print "static $path $type $size\n";

        my $block = 8192;
        my $buff;
        my $pos = 0;

        while( my $len = read $fh, $buff, $block ) {
                print $client $buff;
                $pos += $len;
                printf "%s %d/%d %.2f%%\r", $path, $pos, $size, $pos * 100 / $size;
        }
        close($fh);
        close($client);

        print "$path $pos == $size OK\n";

        return $path;
}

my $ok = "HTTP/1.0 200 OK\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n";

use boolean;

use screen;
use kvm;

$SIG{CHLD} = 'IGNORE';

sub start_stop {
        my $daemon = shift;
        my $pid = $pids->{$daemon};

        warn "start_stop $daemon pids: ",dump( $pids );

        if ( $pid ) {
                warn "kill 9 $pid";
                kill 9, $pid;
                $pids->{$daemon} = 'stopped';
                return qq|$daemon pid $pid stopped|;
        } else {
                if ( $pid = fork ) {
                        # parent
                        $pids->{$daemon} = $pid;
                        warn "forked $daemon $pid";
                        return qq|$daemon pid $pid started|;
                } elsif ( defined $pid ) {
                        # child
                        my $eval = $daemon . '::start(' . dump(@_) . ')';
                        warn "eval $eval";
                        eval $eval;
                        warn "can't start $daemon: $@" if $@;
                        exit;
                } else {
                        die "fork error $!";
                }
        }
}

sub get_request {
        my ( $client, $path, $param ) = @_;

        warn "get_request $client $path ",dump( $param );

        if ( my $found = static( $client,$path ) ) {
                warn "static $found" if $debug;
        } elsif ( $path eq '/' ) {

                my $screen = $pids->{screen} ? qq|stop <tt>$pids->{screen}</tt>|        : 'start';
                my $kvm    = $pids->{kvm}    ? qq|stop <tt>$pids->{kvm}</tt>|           :
                                         $pids->{screen} ? qq|start|                                                    : qq|start screen first|;

                my @rows = (
                        'ip',           html::tt( $server::ip ),
                        'netmask',      html::tt( $server::netmask ),

                        'debug',        qq|<a href=/our/debug/| . boolean::toggle($debug) . qq|>$debug</a>|,
                );
                foreach my $name ( %$pids ) {
                        my $pid = $pids->{$name} || next;

                        my $html = qq|<a href=/$name>$pid</a>|;
                        $html   .= qq|<pre style="font-size: 10%">|
                                        .  ( $debug ? read_file("/proc/$pid/status") : '' )
                                        .  qq|</pre>| if $debug;

                        push @rows, ( $name => $html );
                }

                print $client $ok, html::table( 2, @rows );

        } elsif ( $path =~ m{^/our/(\w+)/(\S+)} ) {
                eval 'our $' . $1 . ' = ' . $2;
                warn $@ if $@;
                print $client qq|HTTP/1.1 302 Found\r\nLocation: $url\r\nContent-type: text/html\r\n\r\n<big>$1 = $2</big><br>Location: <a href="$url">$url</a>|;
        } elsif ( $path =~ m{^/(screen|kvm)} ) {
                print $client $ok, start_stop($1);
        } elsif ( $path eq '/exit' ) {
#               DESTROY;
                exit 0;
        } elsif ( $path =~ m{/boot} ) {
                print $client qq{$ok
#!gpxe
imgfree
login
chain http://$server::ip:$httpd::port/

                        };
        } else {
                print $client "HTTP/1.0 404 $path\r\nConnection: close\r\nContent-type: text/html\r\n\r\n<big>404 $path</big>";
                warn "404 $path";
        }

}

use browser;

sub start {

        my $server = IO::Socket::INET->new(
                        Proto     => 'tcp',
                        LocalPort => $httpd::port,
                        Listen    => SOMAXCONN,
                        Reuse     => 1
        ) || die "can't start server on $url: $!";

        print "url $url\n";

        start_stop 'browser', $url;
        start_stop 'screen';
        start_stop 'kvm';

        while (my $client = $server->accept()) {
                $client->autoflush(1);
                my $request = <$client>;

                warn "request $request\n" if $debug;

                Module::Refresh->refresh;

                if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
                        my $path = $1;
                        my $param;
                        if ( $path =~ s{\?(.+)}{} ) {
                                foreach my $p ( split(/[&;]/, $1) ) {
                                        my ($n,$v) = split(/=/, $p, 2);
                                        $param->{$n} = $v;
                                }
                                warn "param: ",dump( $param ) if $debug;
                        }
                        warn "path $path param: ",dump( $param );
                        get_request $client, $path, $param;
                } else {
                        print $client "HTTP/1.0 500 No method\r\nConnection: close\r\nContent-type: text/plain\r\n\r\n500 $request";
                        warn "500 $request";
                }

                print $client qq{
                <div style="font-size: 80%; color: #888">
                <a href="">reload</a>
                <a href=/>index</a>
                <a href=/exit>exit</a>
                </div>
                } if $client->connected;

        }

        die "server died";
}

warn "loaded";

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