| 1 | ###################################################################### |
|---|
| 2 | # Management connection from a client |
|---|
| 3 | ###################################################################### |
|---|
| 4 | |
|---|
| 5 | package Perlbal::ClientManage; |
|---|
| 6 | use strict; |
|---|
| 7 | use warnings; |
|---|
| 8 | no warnings qw(deprecated); |
|---|
| 9 | |
|---|
| 10 | use base "Perlbal::Socket"; |
|---|
| 11 | use fields ('service', |
|---|
| 12 | 'buf', |
|---|
| 13 | 'is_http', # bool: is an HTTP request? |
|---|
| 14 | 'ctx', # command context |
|---|
| 15 | ); |
|---|
| 16 | |
|---|
| 17 | # ClientManage |
|---|
| 18 | sub new { |
|---|
| 19 | my Perlbal::ClientManage $self = shift; |
|---|
| 20 | my ($service, $sock) = @_; |
|---|
| 21 | $self = fields::new($self) unless ref $self; |
|---|
| 22 | $self->SUPER::new($sock); |
|---|
| 23 | $self->{service} = $service; |
|---|
| 24 | $self->{buf} = ""; # what we've read so far, not forming a complete line |
|---|
| 25 | |
|---|
| 26 | $self->{ctx} = Perlbal::CommandContext->new; |
|---|
| 27 | $self->{ctx}->verbose(1); |
|---|
| 28 | |
|---|
| 29 | $self->watch_read(1); |
|---|
| 30 | return $self; |
|---|
| 31 | } |
|---|
| 32 | |
|---|
| 33 | # ClientManage |
|---|
| 34 | sub event_read { |
|---|
| 35 | my Perlbal::ClientManage $self = shift; |
|---|
| 36 | |
|---|
| 37 | my $bref; |
|---|
| 38 | unless ($self->{is_http}) { |
|---|
| 39 | $bref = $self->read(1024); |
|---|
| 40 | return $self->close() unless defined $bref; |
|---|
| 41 | $self->{buf} .= $$bref; |
|---|
| 42 | |
|---|
| 43 | if ($self->{buf} =~ /^(?:HEAD|GET|POST) /) { |
|---|
| 44 | $self->{is_http} = 1; |
|---|
| 45 | $self->{headers_string} .= $$bref; |
|---|
| 46 | } |
|---|
| 47 | } |
|---|
| 48 | |
|---|
| 49 | if ($self->{is_http}) { |
|---|
| 50 | my $hd = $self->read_request_headers; |
|---|
| 51 | return unless $hd; |
|---|
| 52 | $self->handle_http(); |
|---|
| 53 | return; |
|---|
| 54 | } |
|---|
| 55 | |
|---|
| 56 | while ($self->{buf} =~ s/^(.+?)\r?\n//) { |
|---|
| 57 | my $line = $1; |
|---|
| 58 | |
|---|
| 59 | if ($line =~ /^quit|exit$/) { |
|---|
| 60 | $self->close('user_requested_quit'); |
|---|
| 61 | return; |
|---|
| 62 | } |
|---|
| 63 | |
|---|
| 64 | my $out = sub { |
|---|
| 65 | $self->write("$_[0]\r\n"); |
|---|
| 66 | }; |
|---|
| 67 | |
|---|
| 68 | Perlbal::run_manage_command($line, $out, $self->{ctx}); |
|---|
| 69 | } |
|---|
| 70 | } |
|---|
| 71 | |
|---|
| 72 | sub event_write { |
|---|
| 73 | my $self = shift; |
|---|
| 74 | $self->watch_write(0) if $self->write(undef); |
|---|
| 75 | } |
|---|
| 76 | |
|---|
| 77 | # ClientManage |
|---|
| 78 | sub event_err { my $self = shift; $self->close; } |
|---|
| 79 | sub event_hup { my $self = shift; $self->close; } |
|---|
| 80 | |
|---|
| 81 | # HTTP management support |
|---|
| 82 | sub handle_http { |
|---|
| 83 | my Perlbal::ClientManage $self = shift; |
|---|
| 84 | |
|---|
| 85 | my $uri = $self->{req_headers}->request_uri; |
|---|
| 86 | |
|---|
| 87 | my $body; |
|---|
| 88 | my $code = "200 OK"; |
|---|
| 89 | |
|---|
| 90 | my $prebox = sub { |
|---|
| 91 | my $cmd = shift; |
|---|
| 92 | my $alt = shift; |
|---|
| 93 | $body .= "<pre><div style='margin-bottom: 5px; background: #ddd'><b>$cmd</b></div>"; |
|---|
| 94 | Perlbal::run_manage_command($cmd, sub { |
|---|
| 95 | my $line = $_[0] || ""; |
|---|
| 96 | $alt->(\$line) if $alt; |
|---|
| 97 | $body .= "$line\n"; |
|---|
| 98 | }); |
|---|
| 99 | $body .= "</pre>\n"; |
|---|
| 100 | |
|---|
| 101 | }; |
|---|
| 102 | |
|---|
| 103 | $body .= "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"; |
|---|
| 104 | $body .= "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en-ZA\">\n"; |
|---|
| 105 | $body .= "<head><title>perlbal management interface</title><meta name=\"generator\" content=\"perlbal\" /></head><body>"; |
|---|
| 106 | |
|---|
| 107 | if ($uri eq "/") { |
|---|
| 108 | $body .= "<h1>perlbal management interface</h1><ul>"; |
|---|
| 109 | $body .= "<li><a href='/socks'>Sockets</a></li>"; |
|---|
| 110 | $body .= "<li><a href='/obj'>Perl Objects in use</a></li>"; |
|---|
| 111 | $body .= "<li>Service Details<ul>"; |
|---|
| 112 | foreach my $sname (Perlbal->service_names) { |
|---|
| 113 | my Perlbal::Service $svc = Perlbal->service($sname); |
|---|
| 114 | next unless $svc; |
|---|
| 115 | my $listen = $svc->{listen} ? " ($svc->{listen})" : ""; |
|---|
| 116 | $body .= "<li><a href='/service?$sname'>$sname</a> - $svc->{role}$listen</li>\n"; |
|---|
| 117 | } |
|---|
| 118 | $body .= "</ul></li>"; |
|---|
| 119 | $body .= "</ul>"; |
|---|
| 120 | } elsif ($uri eq "/socks") { |
|---|
| 121 | $prebox->('socks summary'); |
|---|
| 122 | |
|---|
| 123 | $prebox->('socks', sub { |
|---|
| 124 | ${$_[0]} =~ s!service \'(\w+)\'!<a href=\"/service?$1\">$1</a>!; |
|---|
| 125 | }); |
|---|
| 126 | } elsif ($uri eq "/obj") { |
|---|
| 127 | $prebox->('obj'); |
|---|
| 128 | } elsif ($uri =~ m!^/service\?(\w+)$!) { |
|---|
| 129 | my $service = $1; |
|---|
| 130 | $prebox->("show service $service"); |
|---|
| 131 | } else { |
|---|
| 132 | $code = "404 Not found"; |
|---|
| 133 | $body .= "<h1>$code</h1>"; |
|---|
| 134 | } |
|---|
| 135 | |
|---|
| 136 | $body .= "<hr style='margin-top: 10px' /><p><a href='/'>Perlbal management</a>.</p></body></html>\n"; |
|---|
| 137 | $self->write("HTTP/1.0 $code\r\nContent-type: text/html\r\nContent-Length: " . length($body) . |
|---|
| 138 | "\r\n\r\n$body"); |
|---|
| 139 | $self->write(sub { $self->close; }); |
|---|
| 140 | return; |
|---|
| 141 | } |
|---|
| 142 | |
|---|
| 143 | 1; |
|---|
| 144 | |
|---|
| 145 | |
|---|
| 146 | # Local Variables: |
|---|
| 147 | # mode: perl |
|---|
| 148 | # c-basic-indent: 4 |
|---|
| 149 | # indent-tabs-mode: nil |
|---|
| 150 | # End: |
|---|
