summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--HTTP/Server/Brick.pm722
-rw-r--r--INF.pm4
-rw-r--r--INF/ILO.pm401
-rw-r--r--Makefile11
-rwxr-xr-xilo/certs38
-rw-r--r--ilo/intgapp_221.jarbin0 -> 374079 bytes
-rw-r--r--ilo/mypolicy7
-rw-r--r--ilo/server.cnf19
-rw-r--r--ilo/server.crt14
-rw-r--r--ilo/server.jksbin0 -> 600 bytes
-rw-r--r--ilo/server.key16
-rwxr-xr-xinf.pl2
12 files changed, 1233 insertions, 1 deletions
diff --git a/HTTP/Server/Brick.pm b/HTTP/Server/Brick.pm
new file mode 100644
index 0000000..b54a48a
--- /dev/null
+++ b/HTTP/Server/Brick.pm
@@ -0,0 +1,722 @@
+package HTTP::Server::Brick;
+
+use version;
+our $VERSION = qv('0.1.0');
+
+# $Id: Brick.pm,v 1.23 2007/07/24 09:54:46 aufflick Exp $
+
+=head1 NAME
+
+HTTP::Server::Brick - Simple pure perl http server for prototyping "in the style of" Ruby's WEBrick
+
+
+=head1 VERSION
+
+This document describes HTTP::Server::Brick version 0.1.0
+
+
+=head1 SYNOPSIS
+
+ use HTTP::Server::Brick;
+ use HTTP::Status;
+
+ my $server = HTTP::Server::Brick->new( port => 8888 );
+
+ $server->mount( '/foo/bar' => {
+ path => '/some/directory/htdocs',
+ });
+
+ $server->mount( '/test/proc' => {
+ handler => sub {
+ my ($req, $res) = @_;
+ $res->add_content("<html><body>
+ <p>Path info: $req->{path_info}</p>
+ </body></html>");
+ 1;
+ },
+ wildcard => 1,
+ });
+
+ $server->mount( '/test/proc/texty' => {
+ handler => sub {
+ my ($req, $res) = @_;
+ $res->add_content("flubber");
+ $res->header('Content-type', 'text/plain');
+ 1;
+ },
+ wildcard => 1,
+ });
+
+ # these next two are equivalent
+ $server->mount( '/favicon.ico' => {
+ handler => sub { RC_NOT_FOUND },
+ });
+ $server->mount( '/favicon.ico' => {
+ handler => sub {
+ my ($req, $res) = @_;
+ $res->code(RC_NOT_FOUND);
+ 1;
+ },
+ });
+
+ # start accepting requests (won't return unless/until process
+ # receives a HUP signal)
+ $server->start;
+
+For an SSL (https) server, replace the C<new()> line above with:
+
+ use HTTP::Daemon::SSL;
+
+ my $server = HTTP::Server::Brick->new(
+ port => 8889,
+ daemon_class => 'HTTP::Daemon::SSL',
+ daemon_args => [
+ SSL_key_file => 'my_ssl_key.pem',
+ SSL_cert_file => 'my_ssl_cert.pem',
+ ],
+ );
+
+See the docs of L<HTTP::Daemon::SSL> for other options.
+
+=head1 DESCRIPTION
+
+HTTP::Server::Brick allows you to quickly wrap a prototype web server around some
+Perl code. The underlying server daemon is HTTP::Daemon and the performance should
+be fine for demo's, light internal systems, etc.
+
+=head1 METHODS
+
+=cut
+
+use warnings;
+use strict;
+
+use HTTP::Daemon;
+use HTTP::Status;
+use LWP::MediaTypes;
+
+use constant DEBUG => $ENV{DEBUG} || 0;
+
+
+my $__singleton;
+my $__server_should_run = 0;
+
+$SIG{__WARN__} = sub { $__singleton ? $__singleton->_log( error => '[warn] ' . shift ) : CORE::warn(@_) };
+$SIG{__DIE__} = sub {
+ CORE::die (@_) if $^S; # don't interfere with eval
+ $__singleton->_log( error => '[die] ' . $_[0] ) if $__singleton;
+ CORE::die (@_)
+};
+$SIG{HUP} = sub { $__server_should_run = 0; };
+
+
+=head2 new
+
+C<new> takes nine named arguments (all of which are optional):
+
+=over
+
+=item error_log, access_log
+
+Should be self-explanatory - can be anything that responds to C<print> eg.
+file handle, IO::Handle, etc. Default to stderr and stdout respectively.
+
+=item port
+
+The port to listen on. Defaults to a random high port (you'll see it in the error log).
+
+=item host
+
+The server hostname. Defaults to something sensible.
+
+=item timeout
+
+Used for various timout values - see L<HTTP::Daemon> for more information.
+
+=item directory_index_file
+
+The filename for directory indexing. Note that this only applies to static path mounts.
+Defaults to C<index.html>.
+
+=item directory_indexing
+
+If no index file is available (for a static path mount), do you want a clickable list
+of files in the directory be rendered? Defaults to true.
+
+=item leave_sig_pipe_handler_alone
+
+HTTP::Daemon, the http server module this package is built on, chokes in certain multiple-request
+situations unless you ignore PIPE signals. By default PIPE signals are ignored as soon as you start
+the server (and restored if the server exits via HUP). If you want to handle PIPE signals your own
+way, pass in a true value for this.
+
+If this makes no sense to you, just ignore it - the "right thing" will happen by default.
+
+=item daemon_class
+
+The class which actually handles webserving. The default is C<HTTP::Daemon>.
+If you want SSL, use C<HTTP::Daemon::SSL>. Whatever class you use must inherit
+from HTTP::Daemon.
+
+=item daemon_args
+
+Sometimes you need to pass extra arguments to your C<daemon_class>, e.g. SSL
+configuration. This arrayref will be dereferenced and passed to C<new>.
+
+=back
+
+=cut
+
+sub new {
+ my ($this, %args) = @_;
+ my $class = ref($this) || $this;
+
+ if ($args{daemon_class} and not
+ eval { $args{daemon_class}->isa('HTTP::Daemon') }) {
+ die "daemon_class argument '$args{daemon_class}'" .
+ " must inherit from HTTP::Daemon";
+ }
+
+ my $self = bless {
+ _site_map => [],
+ error_log => \*STDERR,
+ access_log => \*STDOUT,
+ directory_index_file => 'index.html',
+ directory_indexing => 1,
+ daemon_class => 'HTTP::Daemon',
+ daemon_args => [],
+ %args,
+ }, $class;
+
+ $__singleton = $self;
+
+ return $self;
+}
+
+=head2 mount
+
+C<mount> takes two positional arguments. The first a full uri (as
+a string beginning with '/' - any trailing '/' will be stripped). The
+second is a hashref which serves as a spec for the mount. The allowable
+hash keys in this spec are:
+
+=over
+
+=item path
+
+A full path to a local filesystem directory or file for static serving.
+Mutually exclusive with C<handler>.
+
+=item handler
+
+A coderef. See L</Handlers> below. Mutually exclusive with C<path>.
+
+=item wildcard
+
+If false, only exact matches will be served. If true, any requests based
+on the uri will be served. eg. if C<wildcard> is false, C<'/foo/bar'> will
+only match C<http://mysite.com/foo/bar> and not, say, C<http://mysite.com/foo/bar/sheep>.
+If C<wildcard> is true, on the other hand, it will match. A handler can
+access the path extension as described below in L</Handlers>.
+
+Static handlers that are directories default to wildcard true.
+
+=back
+
+The site map is always searched depth-first, in other words a more specific
+uri will trump a less-specific one.
+
+=cut
+
+sub mount {
+ my ($self, $uri, $args) = @_;
+
+ ref($args) eq 'HASH' or die 'third arg to mount must be a hashref';
+
+ my $depth;
+ if ($uri eq '/') {
+ $depth = 0;
+ } else {
+ $uri =~ s!/$!!;
+ my @parts = split( m!/!, $uri );
+ $depth = scalar(@parts) - 1; # leading / adds one
+ }
+
+ $self->{_site_map}[$depth] ||= {};
+ $self->{_site_map}[$depth]{$uri} = $args;
+
+ # we should default a static path to a wildcard mount if it's a directory
+ if (!exists $args->{wildcard} && exists $args->{path} && -d $args->{path}) {
+ $args->{wildcard} = 1;
+ }
+
+ my $mount_type = exists $args->{handler} ? 'handler' :
+ exists $args->{path} ? 'directory' : '(unknown)';
+ $self->_log( error => 'Mounted' . ($args->{wildcard} ? ' wildcard' : '') . " $mount_type at $uri" );
+
+ 1;
+}
+
+=head2 start
+
+Actually starts the server - this will loop indefinately, or until
+the process recieves a C<HUP> signal in which case it will return after servicing
+any current request, or waiting for the next timeout (which defaults to 5s - see L</new>).
+
+=cut
+
+sub start {
+ my $self = shift;
+
+ $__server_should_run = 1;
+
+ # HTTP::Daemon chokes on multiple simultaneous requests
+ unless ($self->{leave_sig_pipe_handler_alone}) {
+ $self->{_old_sig_pipe_handler} = $SIG{'PIPE'};
+ $SIG{'PIPE'} = 'IGNORE';
+ }
+
+ $SIG{CHLD} = 'IGNORE' if $self->{fork};
+
+ $self->{daemon} = $self->{daemon_class}->new(
+ ReuseAddr => 1,
+ LocalPort => $self->{port},
+ LocalHost => $self->{host},
+ Timeout => 5,
+ @{ $self->{daemon_args} },
+ ) or die "Can't start daemon: $!";
+
+ $self->_log(error => "Server started on " . $self->{daemon}->url);
+
+ while ($__server_should_run) {
+ my $conn = $self->{daemon}->accept or next;
+
+ # if we're a forking server, fork. The parent will wait for the next request.
+ # TODO: limit number of children
+ next if $self->{fork} and fork;
+ while (my $req = $conn->get_request) {
+
+ my ($submap, $match) = $self->_map_request($req);
+
+ if ($submap) {
+ if (exists $submap->{path}) {
+ $self->_handle_static_request( $conn, $req, $submap, $match);
+
+ } elsif (exists $submap->{handler}) {
+ $self->_handle_dynamic_request( $conn, $req, $submap, $match);
+
+ } else {
+ $self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR, 'Corrupt Site Map');
+ }
+
+ } else {
+ $self->_send_error($conn, $req, RC_NOT_FOUND, ' Not Found in Site Map');
+ }
+ }
+ # should use a guard object here to protect against early exit leaving zombies
+ exit if $self->{fork};
+ }
+
+
+ unless ($self->{leave_sig_pipe_handler_alone}) {
+ $SIG{'PIPE'} = $self->{_old_sig_pipe_handler};
+ }
+
+ 1;
+}
+
+sub _handle_static_request {
+ my ($self, $conn, $req, $submap, $match) = @_;
+
+ my $path = $submap->{path} . '/' . $match->{path_info};
+
+ if (-d $path && $match->{full_path} !~ m!/$! ) {
+ $conn->send_redirect( $match->{full_path} . '/', RC_SEE_OTHER );
+ DEBUG && $self->_log(error => 'redirecting to path with / appended: ' . $match->{full_path});
+ return;
+ }
+
+ my $serve_path = -d $path ? "$path/$self->{directory_index_file}" : $path;
+
+ if (-r $serve_path) {
+ my $code = $conn->send_file_response($serve_path);
+ $self->_log_status($req, $code);
+
+ } elsif (-d $path && $self->{directory_indexing}) {
+
+ my $res = $self->_render_directory($path, $match->{full_path});
+ $conn->send_response( $res );
+ $self->_log( access => '[' . RC_OK . "] $match->{full_path}" );
+
+
+ } elsif (-d $path) {
+ $self->_send_error($conn, $req, RC_FORBIDDEN, 'Directory Indexing Not Allowed' );
+
+ } else {
+ $self->_send_error($conn, $req, RC_NOT_FOUND, 'File Not Found' );
+ }
+}
+
+sub _handle_dynamic_request {
+ my ($self, $conn, $req, $submap, $match) = @_;
+
+ my $res = HTTP::Response->new;
+ $res->base($match->{full_path});
+
+ # stuff the match info into the request
+ $req->{mount_path} = $match->{mount_path};
+ $req->{path_info} = $match->{path_info} ? '/' . $match->{path_info} : undef;
+
+ # and some other useful bits TODO: document (and, actually, subclass HTTP::Request...)
+ if ($req->header('Host') =~ /^(.*):(.*)$/) {
+ $req->{hostname} = $1;
+ $req->{port} = $2;
+ } elsif ($req->header('Host')) {
+ $req->{hostname} = $req->header('Host');
+ $req->{port} = $self->{daemon}->url->port;
+ } else {
+ $req->{hostname} = $self->{daemon}->url->host;
+ $req->{port} = $self->{daemon}->url->port;
+ }
+
+ # actually call the handler
+ if ( my $return_code = eval { $submap->{handler}->($req, $res) } ) {
+
+ # choose the status in this order:
+ # 1. if the handler died or returned false => RC_INTERNAL_SERVER_ERROR
+ # 2. if the handler set a code on the response object, use that
+ # 3. if the handler returned something that looks like a return code
+ # 4. RC_OK
+
+ my $code = !$return_code ? RC_INTERNAL_SERVER_ERROR :
+ $res->code ? $res->code :
+ $return_code >= 100 ? $return_code : RC_OK;
+
+ $res->code($code);
+
+ # default mime type to text/html
+ $res->header( 'Content-Type' ) || $res->header( 'Content-Type', 'text/html' );
+
+ if ($res->is_success) {
+ $conn->send_response( $res );
+ $self->_log( access => "[$code] $match->{full_path}" );
+
+ } elsif ($res->is_error) {
+ # should send user content and use $@ if provided
+ $self->_send_error( $conn, $req, $res->code, $res->message );
+
+ } elsif ($res->is_redirect) {
+ if (UNIVERSAL::can($res->{target_uri}, 'path')) {
+ my $target = $res->{target_uri}->path;
+
+ if ($target !~ m!^/!) {
+ # prepend dirname of original request
+ $match->{full_path} =~ m!^(.*/)! and
+ $target = $1 . $target;
+ }
+ $conn->send_redirect($target, $code);
+ $self->_log( access => "[$code] Redirecting to " . $target );
+ } else {
+ $self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR,
+ 'Handler Tried to Redirect Without Setting Target URI');
+ }
+
+ } else {
+ $self->_send_error($conn, $req,
+ RC_NOT_IMPLEMENTED,
+ 'Handler Returned an Unimplemented Response Code: ' . $code);
+ }
+ } else {
+ $self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR, 'Handler Failed');
+ }
+
+ 1;
+}
+
+sub _render_directory {
+ my ($self, $path, $uri ) = @_;
+
+ my $res = HTTP::Response->new( RC_OK );
+ $res->header( 'Content-type', 'text/html' );
+
+ $res->add_content(<<END_HEADER);
+<html>
+<head>
+<title>Directory for $uri</title>
+</head>
+<body>
+<h1>Directory for $uri</h1>
+<blockquote><pre>
+<a href="..">.. (Parent directory)</a>
+END_HEADER
+
+ $res->add_content("<a href=\"$_\">$_</a>\n") for map {s!.*/!!; $_} sort glob "$path/*";
+
+ $res->add_content(<<END_FOOTER);
+</pre></blockquote>
+</body>
+</html>
+END_FOOTER
+
+ return $res;
+}
+
+sub _send_error {
+ my ($self, $conn, $req, $code, $text) = @_;
+
+ $conn->send_error($code, $text);
+
+ $self->_log_status($req, $code, $text);
+}
+
+sub _log_status {
+ my ($self, $req, $code, $text) = @_;
+
+ if ($code == RC_OK || $code == RC_UNAUTHORIZED || $code == RC_NOT_FOUND) {
+ $self->_log( access => "[$code] " . $req->uri->path );
+ }
+
+ $self->_log( error => "[$code] [" . $req->uri->path . '] ' . ($text || status_message($code)) )
+ unless $code == RC_OK;
+}
+
+# this is not the best data structure for a complex site map, but it's
+# easy to insert and query (although very hard to move things around).
+# basically for every path depth (ie. number of /) there is a hash of
+# full paths and their associated handler and meta-data.
+
+# this would be an obvious performance point if you wanted to use this
+# for actual serving.
+
+sub _map_request {
+ my ($self, $request) = @_;
+
+ my $map = $self->{_site_map};
+
+ my $uri = $request->uri->path;
+
+ my @parts = split( m!/!, $uri );
+
+ my $depth = scalar(@parts) - 1;
+ # the test is reall for $uri eq '/', but an integer comparison is faster
+ $depth = 0 if $depth == -1;
+ my $match_depth = $depth;
+
+ while ($match_depth >= 0) {
+
+ my $mount_path = '/' . join('/', @parts[1..$match_depth]);
+
+ if ($map->[$match_depth] && exists $map->[$match_depth]{$mount_path}) {
+
+ # if we find a depth-first match, but it's not flagged as a wildcard
+ # mount, then don't match
+ if ($match_depth != $depth && !$map->[$match_depth]{$mount_path}{wildcard}) {
+ return;
+ }
+
+ return(
+ $map->[$match_depth]{$mount_path},
+ {
+ full_path => $uri,
+ mount_path => $mount_path,
+ path_info => join('/', @parts[$match_depth+1..$depth]),
+ },
+ );
+ }
+
+ $match_depth--;
+ }
+}
+
+=head2 add_type
+
+The mime-type of static files is automatically determined by L<LWP::MediaTypes>. You
+can add any types it doesn't know about via this method.
+
+The first argument is the mime type, all subsequent arguments form a list of
+possible file extensions for that mime type. See L<LWP::MediaTypes> for more info.
+
+=cut
+
+# Improve LWP::MediaTypes' mime-type knowledge.
+LWP::MediaTypes::add_type('image/png' => qw(png));
+LWP::MediaTypes::add_type('text/css' => qw(css));
+LWP::MediaTypes::add_type('text/javascript' => qw(js));
+
+sub add_type {
+ my ($self, @args) = @_;
+
+ LWP::MediaTypes::add_type(@args);
+}
+
+sub _log {
+ my ($self, $log_key, $text) = @_;
+
+ $self->{"${log_key}_log"}->print( '[' . localtime() . "] [$$] ", $text, "\n" );
+}
+
+
+1; # Magic true value required at end of module
+__END__
+
+=head1 Handlers
+
+When a mounted handler codred matches a requested url, the sub is called with two
+arguments in C<@_>, first a request object then a response object.
+
+=head2 Request
+
+The request object is an instance of L<HTTP::Request> with two extra properties:
+
+=over
+
+=item C<$req-E<gt>{mount_path}>
+
+The mounted path that was matched. This will always be identical to C<$req->uri->path>
+for non-wildcard mounts.
+
+=item C<$req-E<gt>{path_info}>
+
+Using nomenclature from L<CGI.pm>, any extra path (or rather, uri) info after the matched C<mount_path>.
+This will always be empty for non-wildcard mounts.
+
+=back
+
+The documentation for L<HTTP::Request> will be of use for extracting all the other
+useful information.
+
+=head2 Response
+
+The response object is an instance of L<HTTP::Response>. The useful operations (which
+you can learn how to do from the L<HTTP::Response> docs) are setting headers,
+adding content and setting the http status code.
+
+=head2 Response Headers
+
+The C<Content-type> header defaults to C<text/html> unless your handler sets it to
+something else. The C<Content-length> header is set for you.
+
+=head2 Redirection
+
+If you set the response code to a redirect code, you need to set a C<{target_uri}> property on the
+request object to an instance of a C<URI::http> object reflecting the uri you want to redirect to
+(either fully qualified or relative to the directory of the requested url). There are examples
+in the test file C<t/serving.t> in this module's distribution.
+
+This is weak because we're breaking encapsulation by assuming it's ok to stuff an extra variable
+into the response object (just as we are to propogate the C<path_info> property). It does in fact
+work fine and is unlikely to ever break, but a future version (prior to 1.0.0) of this module will
+replace this behavior with a subclassed L<HTTP::Response> and appropriate setter/getter methods.
+
+=head2 Handler Return
+
+The handler sub must return true for a normal response. The actual http response
+is determined as follows:
+
+ 1. if the handler died or returned false => RC_INTERNAL_SERVER_ERROR (ie. 500)
+ 2. if the handler set a code on the response object, use that
+ 3. if the handler returned something that looks like a return code
+ 4. RC_OK (ie. 200)
+
+=head1 DEBUGGING
+
+If an envronment variable DEBUG is set (to something Perl considers true) there will
+be extra logging to C<error_log>.
+
+=head1 DEPENDENCIES
+
+L<LWP>
+L<Test::More>
+L<version>
+
+=head1 HISTORY
+
+Over the past few years I've spent quite a bit of time noodling about with Ruby
+based web code - whether Rails or super cool continuation stuff - and it's always
+easy to get a prototype up and serving thanks to WEBrick (the pure-Ruby server
+that's part of the standard Ruby distribution). I've never found it quite as easy
+to throw together such a prototype in Perl, hence YASHDM (yet another simple http
+daemon module).
+
+HTTP::Server::Brick is not a clone of WEBrick - it's "in the style of" WEBrick like
+those movies in the discount VHS bin are "in the style of Lassie": The good guys
+get saved, the bad guys get rounded up, but the dog's never quite as well trained...
+
+To be more fair, I have just taken the ideas I have used (and liked) when building
+prototypes with WEBrick and implemented them in (what I hope is) a Perlish way.
+
+
+=head1 BUGS AND LIMITATIONS
+
+=over
+
+=item It's version 0.1.0 - there's bound to be some bugs!
+
+=item The tests fail on windows due to forking limitations. I don't see any reason why the server itself won't work but I haven't tried it personally, and I have to figure out a way to test it from a test script that will work on Windows.
+
+=item In forking mode there is no attempt to limit the number of forked children - beware of forking yourself ;)
+
+=item No attention has been given to propagating any exception text into the http error (although the exception/die message will appear in the error_log).
+
+=item Versions 1.02 and earlier of HTTP::Daemon::SSL has a feature/documentation conflict where it will never timeout. This means your server won't respond to a HUP signal until the next request is served. Version 1.03_01 (developer release) and later do not have this issue.
+
+=back
+
+If you want to check out the latest development version of HTTP::Server::Brick
+you can do so from my L<CVS Server|http://cvs.pumptheory.com/viewcvs/viewcvs.cgi/perl/HTTP-Server-Brick/>.
+
+Please report any bugs or feature requests to
+C<bug-http-server-brick@rt.cpan.org>, through the web interface at
+L<http://rt.cpan.org> or via email to the author.
+
+=head1 SEE ALSO
+
+CPAN has various other modules that may suit you better. Search for HTTP::Server or HTTP::Daemon.
+L<HTTP::Daemon>, L<HTTP::Daemon::App> and L<HTTP::Server::Simple> spring to mind.
+
+
+=head1 AUTHOR
+
+=over
+
+=item Original version by: Mark Aufflick C<< <mark@aufflick.com> >> L<http://mark.aufflick.com/>
+
+=item SSL and original forking support by: Mark Aufflick C<< <mark@aufflick.com> >>.
+
+=item Maintained by: Mark Aufflick
+
+=back
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Mark Aufflick C<< <mark@aufflick.com> >>.
+Portions Copyright (c) 2007, Hans Dieter Pearcey C<< <hdp@pobox.com> >>
+
+All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
diff --git a/INF.pm b/INF.pm
index d3301f6..46500e4 100644
--- a/INF.pm
+++ b/INF.pm
@@ -1,6 +1,7 @@
package INF;
use INF::APC;
use INF::DSRx020;
+use INF::ILO;
#$infs = [
@@ -30,6 +31,9 @@ sub new ($;$) {
elsif ( $inf->{inf_type} eq 'apc' ) {
return INF::APC->new($inf);
}
+ elsif ( $inf->{inf_type} eq 'ilo' ) {
+ return INF::ILO->new($inf);
+ }
else {
return undef;
}
diff --git a/INF/ILO.pm b/INF/ILO.pm
new file mode 100644
index 0000000..9af27c4
--- /dev/null
+++ b/INF/ILO.pm
@@ -0,0 +1,401 @@
+#!/usr/bin/env perl
+
+IO::Socket::SSL::set_ctx_defaults( SSL_verify_mode => SSL_VERIFY_NONE );
+
+package INF::ILO;
+
+use HTTP::Daemon::SSL;
+use HTTP::Server::Brick;
+use HTTP::Status;
+
+use IO::Socket::SSL qw();
+use HTML::TreeBuilder;
+use HTTP::Request::Common;
+use LWP::UserAgent;
+use URI::Escape;
+use File::Temp qw/ tempfile tempdir /;
+use XML::Simple;
+use Data::Dumper;
+use JSON::PP;
+
+sub read_file($) {
+ my ($name) = @_;
+
+ my $fh = new IO::File "<" . $name;
+ local $/;
+ my $guts = $fh->getline;
+ $fh->close;
+ undef $fh;
+
+ return $guts;
+}
+
+sub setup_port_proxy($$$) {
+ my ( $local_port, $remote_host, $remote_port ) = @_;
+
+ my $child = fork();
+
+ print STDERR "balance ",
+ join(
+ ' ',
+ (
+ "balance", "-d", "-f", "127.0.0.1", $local_port,
+ $remote_host . ":" . $remote_port
+ )
+ ),
+ "\n";
+
+ if ( $child == 0 ) {
+
+ exec( "balance", "-d", "-f", "-b", "127.0.0.1", $local_port,
+ $remote_host . ":" . $remote_port );
+ print STDERR "failed to start port proxy";
+ sleep(10000);
+ }
+
+ print "Setup proxy $local_port -> $remote_host:$remote_port\n";
+
+ return $child;
+}
+
+sub proxy($$$) {
+ my ( $self, $req, $res ) = @_;
+
+ if ( $req->uri->as_string =~ /^\/html\/java_irc.html/ ) {
+
+ $res->header( 'Content-type' => 'text/html' );
+ $res->add_content( $self->{java_html} );
+ $res->code(200);
+
+ return;
+
+ }
+
+ if ( $req->uri->as_string =~ /^\/html\/intgapp_.*\.jar/ ) {
+
+ $res->header( 'Content-type' => 'application/x-ms-application' );
+ $res->add_content(
+ read_file('/usr/local/share/inf/ilo/intgapp_221.jar') );
+ $res->code(200);
+
+ return;
+ }
+
+ my $proxy_req =
+ HTTP::Request->new( $req->method, $self->{ilo_url} . $req->uri->as_string,
+ [], $req->content );
+
+ $proxy_req->header( 'cookie' => 'sessionKey=' . $self->{skey} );
+
+ my $proxy_res = $self->{ua}->request($proxy_req);
+
+ unless ( $proxy_res->is_success ) {
+ print STDERR "request failed - did not get 200\n";
+ }
+
+ print "URI:", $req->uri->as_string, " code ", $proxy_res->code, " type ",
+ $proxy_res->header('Content-type'), "\n";
+
+ $res->code( $proxy_res->code );
+ $res->header( 'Content-type' => $proxy_res->header('Content-type') );
+
+ my $content = $proxy_res->content;
+
+ if ( $req->uri->as_string =~ /^\/json\/rc_info/ ) {
+
+ my $local_port = int( rand(30000) ) + 30000;
+
+ $content =~ s/"rc_port":(\d+),/"rc_port":$local_port,/;
+ push @{ $self->{to_kill} },
+ setup_port_proxy( $local_port, $self->{host}, $1 );
+
+ $local_port = int( rand(30000) ) + 30000;
+
+ $content =~ s/"vm_port":(\d+),/"vm_port":$local_port,/;
+ push @{ $self->{to_kill} },
+ setup_port_proxy( $local_port, $self->{host}, $1 );
+
+ }
+
+ $res->add_content($content);
+
+}
+
+sub login($) {
+ my $self = shift;
+
+ my $post = POST( $self->{ilo_url} . '/json/login_session' );
+ my $json =
+ '{"method":"login","user_login":"'
+ . $self->{user}
+ . '","password":"'
+ . $self->{password} . '"}';
+
+ $post->header( 'Content-Type' => 'application/json' );
+ $post->header( 'Content-Length' => length($json) );
+ $post->content($json);
+
+ #my $get = GET( $self->{ilo_url}."/html/login.html" );
+
+ my $res = $self->{ua}->request($post);
+
+ unless ( $res->is_success ) {
+ print STDERR "Login failed - did not get 200\n";
+
+ print Dumper($res);
+
+ $self->{skey} = undef;
+ return -1;
+ }
+
+ my $json = decode_json( $res->content );
+
+ $self->{skey} = $json->{session_key};
+
+ # print "Session key ".$self->{skey}."\n";
+
+ return 0;
+}
+
+sub view($) {
+ my $self = shift;
+
+ $self->login() unless defined $self->{skey};
+
+ my $get = GET( $self->{ilo_url} . '/html/java_irc.html?lang=en' );
+
+ my $res = $self->{ua}->request($get);
+
+ unless ( $res->is_success ) {
+ print STDERR "IRC frequest failed - did not get 200\n";
+ return -1;
+ }
+ my $content = $res->content;
+
+ unless ( $content =~ /Netscape'\) {(.*)}[\s\n]*else if/s ) {
+ print STDERR "returned html doesn't look right\n";
+ return -1;
+ }
+
+ $content = $1;
+
+ #$content=~ s/document.writeln\("(.*)"\);$/\1/m;
+ $content =~ s/^\s*document.writeln\("(.*)"\);\s*$/\1/mg;
+ $content =~ s/\\//g;
+
+ $content =~ s/RCINFO1=.*$/RCINFO1="$self->{skey}"/m;
+ $content =~ s/RCINFO6=.*$/RCINFO6="17990"/m;
+ $content =~ s/RCINFOLANG=.*$/RCINFOLANG="en"/m;
+ $content =~ s%(archive=)(/.*)$%\1$self->{proxy_url}\2%m;
+
+ $content = "<html><head></head><body>" . $content . "</body></html>";
+
+ $self->{java_html} = $content;
+
+ my $webserver_pid = fork();
+
+ if ( $webserver_pid == 0 ) {
+ $SIG{INT} = sub { kill 'KILL', ( @{ $self->{to_kill} } ); die; };
+ $SIG{TERM} = sub { kill 'KILL', ( @{ $self->{to_kill} } ); die; };
+
+ $self->{server}->start;
+ print STDERR "failed to web server";
+ sleep(100000);
+ }
+
+ push @{ $self->{to_kill} }, $webserver_pid;
+
+ $SIG{INT} = sub { kill 'INT', ( @{ $self->{to_kill} } ); die; };
+ $SIG{TERM} = sub { kill 'TERM', ( @{ $self->{to_kill} } ); die; };
+
+ system(
+ "appletviewer",
+ "-J-Djava.security.manager",
+ "-J-Djava.security.policy=/usr/local/share/inf/ilo/mypolicy",
+ "-J-Djavax.net.ssl.trustStore=/usr/local/share/inf/ilo/server.jks",
+ $self->{proxy_url} . "/html/java_irc.html"
+ );
+
+ kill 'TERM', ( @{ $self->{to_kill} } );
+}
+
+sub get_host_power($) {
+ my ($self) = @_;
+
+ $self->login() unless defined $self->{skey};
+
+ my $get = GET( $self->{ilo_url} . '/json/host_power' );
+
+ $get->header( 'cookie' => 'sessionKey=' . $self->{skey} );
+
+ my $res = $self->{ua}->request($get);
+
+ unless ( $res->is_success ) {
+ print STDERR " get host power - did not get 200\n";
+ return undef;
+ }
+
+ my $state = decode_json $res->content;
+
+ return $state->{'hostpwr_state'};
+
+}
+
+sub set_host_power($$) {
+ my ( $self, $what ) = @_;
+
+ $self->login() unless defined $self->{skey};
+
+ my $post = POST( $self->{ilo_url} . '/json/host_power' );
+ my $json =
+ '{"method":"' . $what . '","session_key":"' . $self->{skey} . '"}';
+ $post->header( 'Content-Type' => 'application/json' );
+ $post->header( 'Content-Length' => length($json) );
+ $post->content($json);
+ $post->header( 'cookie' => 'sessionKey=' . $self->{skey} );
+
+ my $res = $self->{ua}->request($post);
+
+ unless ( $res->is_success ) {
+ print STDERR " $what - did not get 200\n";
+ return 0;
+ }
+
+ return 1;
+}
+
+sub cold_boot($) {
+ my $self = shift;
+ return $self->set_host_power('system_coldboot');
+}
+
+sub reset($) {
+ my $self = shift;
+ return $self->set_host_power('system_reset');
+}
+
+sub off($) {
+ my $self = shift;
+ if ( $self->get_host_power =~ /ON/i ) {
+ return $self->set_host_power('hold_power_button');
+ }
+ return 1;
+}
+
+sub on($) {
+ my $self = shift;
+ if ( $self->get_host_power =~ /OFF/i ) {
+ return $self->set_host_power('press_power_button');
+ }
+ return 1;
+}
+
+sub port_on($$) {
+ my $self = shift;
+ return $self->on();
+}
+
+sub port_off($$) {
+ my $self = shift;
+ return $self->off();
+}
+
+sub port_cycle($$) {
+ my $self = shift;
+ return $self->cold_boot();
+}
+
+sub port_state_get_no_cache($$) {
+ my $self = shift;
+ return $self->get_host_power();
+}
+
+sub port_state_get($$) {
+ my $self = shift;
+ return $self->get_host_power();
+}
+
+sub port_name_get($$) {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub name_get($) {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub pdu_load_get($) {
+ return "N/A";
+}
+
+sub psu_status($) {
+ return "N/A";
+}
+
+sub port_count($) {
+ return 1;
+}
+
+sub port_id_get_by_number($$) {
+ return "K0";
+}
+
+sub new ($;$) {
+ my ( $class, $parm ) = @_;
+ my $self;
+
+ $self->{ua} = my $ua = LWP::UserAgent->new;
+
+ $self->{host} = $parm->{host} || "127.0.0.1";
+
+ $self->{user} = $parm->{user} || "Administrator";
+ $self->{password} = $parm->{password} || "";
+
+ $self->{name} = $parm->{name} || $self->{host};
+
+ $self->{ilo_url} = $parm->{ilo_url}
+ || 'https://' . $self->{host};
+ $self->{userid} = undef;
+
+ $self->{ua}->ssl_opts(
+ SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
+ verify_hostname => 0,
+ );
+
+ my
+
+ $local_port = int( rand(30000) ) + 30000;
+
+ $self->{proxy_url} = 'https://127.0.0.1:' . $local_port;
+
+ $self->{server} = HTTP::Server::Brick->new(
+ port => $local_port,
+ daemon_class => 'HTTP::Daemon::SSL',
+ daemon_args => [
+ LocalAddr => '127.0.0.1',
+ SSL_key_file => '/usr/local/share/inf/ilo/server.key',
+ SSL_cert_file => '/usr/local/share/inf/ilo/server.crt',
+ ],
+ );
+ $self->{server}->mount(
+ '/' => {
+ handler => sub {
+ my ( $req, $res ) = @_;
+
+ $self->proxy( $req, $res );
+ 1;
+ },
+ wildcard => 1,
+ }
+ );
+
+ $self->{skey} = undef;
+ $self->{to_kill} = [];
+
+ return bless $self, $class;
+
+}
+
+1;
+
diff --git a/Makefile b/Makefile
index d5d6618..d9d401e 100644
--- a/Makefile
+++ b/Makefile
@@ -1,12 +1,16 @@
install:
mkdir -p /usr/local/share/inf/mibs/compiled
mkdir -p /usr/local/share/inf/INF
+ mkdir -p /usr/local/share/inf/HTTP/Server
mkdir -p /usr/local/share/inf/avocent
+ mkdir -p /usr/local/share/inf/ilo
install -m 755 inf.pl /usr/local/bin/inf
+ install -m 644 HTTP/Server/Brick.pm /usr/local/share/inf/HTTP/Server/
install -m 644 INF.pm /usr/local/share/inf/
install -m 644 INF/INF.pm /usr/local/share/inf/INF
install -m 644 INF/APC.pm /usr/local/share/inf/INF
install -m 644 INF/DSRx020.pm /usr/local/share/inf/INF
+ install -m 644 INF/ILO.pm /usr/local/share/inf/INF
install -m 644 mibs/PowerNet-MIB.mib /usr/local/share/inf/mibs/
install -m 644 mibs/RFC1155-SMI.mib /usr/local/share/inf/mibs/
install -m 644 mibs/RFC-1212.mib /usr/local/share/inf/mibs/
@@ -24,3 +28,10 @@ install:
install -m 644 avocent/avmWin32Lib.jar /usr/local/share/inf/avocent/
install -m 644 avocent/jpcscdll.jar /usr/local/share/inf/avocent/
install -m 644 avocent/jpcscso.jar /usr/local/share/inf/avocent/
+ install -m 644 ilo/certs /usr/local/share/inf/ilo/
+ install -m 644 ilo/intgapp_221.jar /usr/local/share/inf/ilo/
+ install -m 644 ilo/mypolicy /usr/local/share/inf/ilo/
+ install -m 644 ilo/server.cnf /usr/local/share/inf/ilo/
+ install -m 644 ilo/server.crt /usr/local/share/inf/ilo/
+ install -m 644 ilo/server.jks /usr/local/share/inf/ilo/
+ install -m 644 ilo/server.key /usr/local/share/inf/ilo/
diff --git a/ilo/certs b/ilo/certs
new file mode 100755
index 0000000..4b4e262
--- /dev/null
+++ b/ilo/certs
@@ -0,0 +1,38 @@
+#!/bin/bash
+
+rm -f server.jks server.key server.csr server.crt server.cnf
+
+cat << EOF > server.cnf
+
+[req]
+distinguished_name = req_distinguished_name
+x509_extensions = v3_req
+prompt = no
+
+[ req_distinguished_name ]
+commonName = localhost
+
+[v3_req]
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+basicConstraints = CA:TRUE
+subjectAltName = @alt_names
+
+[alt_names]
+DNS.1 = localhost
+IP.1 = 127.0.0.1
+
+EOF
+
+
+
+#openssl genrsa -out server.key 1024
+#openssl req -config server.cnf -new -key server.key -out server.csr
+#openssl x509 -req -days 3650 -in server.csr -signkey server.key -out server.crt
+
+openssl req -x509 -nodes -days 3650 -newkey rsa:1024 -keyout server.key -out server.crt -config server.cnf
+
+yes | keytool -import -v -trustcacerts -alias 127.0.0.1 -file server.crt -keystore server.jks -keypass changeit -storepass changeit
+
+
+
diff --git a/ilo/intgapp_221.jar b/ilo/intgapp_221.jar
new file mode 100644
index 0000000..c18f4ab
--- /dev/null
+++ b/ilo/intgapp_221.jar
Binary files differ
diff --git a/ilo/mypolicy b/ilo/mypolicy
new file mode 100644
index 0000000..e945c25
--- /dev/null
+++ b/ilo/mypolicy
@@ -0,0 +1,7 @@
+grant {
+ permission java.net.SocketPermission "localhost", "connect, accept ,resolve, listen";
+ permission java.util.PropertyPermission "java.io.tmpdir","read";
+ permission java.io.FilePermission "/tmp/-", "read, write";
+ permission java.io.FilePermission "/tmp", "read, write";
+ permission java.lang.RuntimePermission "loadLibrary.*";
+};
diff --git a/ilo/server.cnf b/ilo/server.cnf
new file mode 100644
index 0000000..fd38814
--- /dev/null
+++ b/ilo/server.cnf
@@ -0,0 +1,19 @@
+
+[req]
+distinguished_name = req_distinguished_name
+x509_extensions = v3_req
+prompt = no
+
+[ req_distinguished_name ]
+commonName = localhost
+
+[v3_req]
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+basicConstraints = CA:TRUE
+subjectAltName = @alt_names
+
+[alt_names]
+DNS.1 = localhost
+IP.1 = 127.0.0.1
+
diff --git a/ilo/server.crt b/ilo/server.crt
new file mode 100644
index 0000000..998ba96
--- /dev/null
+++ b/ilo/server.crt
@@ -0,0 +1,14 @@
+-----BEGIN CERTIFICATE-----
+MIICEjCCAXugAwIBAgIJALIh/DebfUKPMA0GCSqGSIb3DQEBBQUAMBQxEjAQBgNV
+BAMTCWxvY2FsaG9zdDAeFw0xNTA2MDUxMDI3NDFaFw0yNTA2MDIxMDI3NDFaMBQx
+EjAQBgNVBAMTCWxvY2FsaG9zdDCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA
+qovkL5zBHilo+a9dHIWfTYE2IQzFluyKv7sTHO3E0g91gbIpKkqdtHZ0TjZMU+Gr
+/2q5bWmXRYJUAHNezzKLHDFTWjMJ8fQkjg9+82gMYMiecPrbDtaZSWH8ZQf0RWjN
+XD5oV/JOl5DEsaI48xiiIuofdr1SwUvVlyfE1AhqoRECAwEAAaNsMGowHQYDVR0O
+BBYEFPBsC/4d9RfwGvMo4peoXHvlBMp6MB8GA1UdIwQYMBaAFPBsC/4d9RfwGvMo
+4peoXHvlBMp6MAwGA1UdEwQFMAMBAf8wGgYDVR0RBBMwEYIJbG9jYWxob3N0hwR/
+AAABMA0GCSqGSIb3DQEBBQUAA4GBAGS0FTrKSY7QtrLAufONRsqWkY3plSf/Cf0O
+6MQbcQIFcu9clsj1yOcdrMJe/xd1Jhyfu1KAOIIVbif/hPP/oxn8aiT6ibCKCTTq
+TInk38NwGtnZ7SQDBNL8JMCpTChDSgkdggU3PeIQip93MR0Yfhv7lePdqAD0Jdig
+wFBte97D
+-----END CERTIFICATE-----
diff --git a/ilo/server.jks b/ilo/server.jks
new file mode 100644
index 0000000..5460fa4
--- /dev/null
+++ b/ilo/server.jks
Binary files differ
diff --git a/ilo/server.key b/ilo/server.key
new file mode 100644
index 0000000..1938bed
--- /dev/null
+++ b/ilo/server.key
@@ -0,0 +1,16 @@
+-----BEGIN PRIVATE KEY-----
+MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBAKqL5C+cwR4paPmv
+XRyFn02BNiEMxZbsir+7ExztxNIPdYGyKSpKnbR2dE42TFPhq/9quW1pl0WCVABz
+Xs8yixwxU1ozCfH0JI4PfvNoDGDInnD62w7WmUlh/GUH9EVozVw+aFfyTpeQxLGi
+OPMYoiLqH3a9UsFL1ZcnxNQIaqERAgMBAAECgYAzTTVs5RhqfEZppUi7Ba7v34hq
+1K6zQaBTIHEVaKimD6RnSTJ82EksOd2ukULQkLfucyooMXUhoZynLg09ApU5fh92
+CXFa4R9JjHlIyqw1nJb9L2F6q+WYMiycCLIHBhlVjjsIb/ZyJWOc8x6Ad1CPKlZx
+i5tilaj5YYoEgoi24QJBANEnbnZE94NVN4Rck6TuECtNNDdQsx3K2GMHYxlQk+dm
+Yr/yMH1Tn56OEHR+m6xhVDLiV5Ov9x7x64mLI9E1JD0CQQDQvsLSGZAbiy4v4s4+
+uq9ZB98Aly/+gpqNm4Hm+iE7liSjW/de+JqOH27I3LUACwO2NHmK3FcBL2pYZWXG
+RPllAkAfjnN8JKuzhQf7UHx2RfTqk5ttPR/JPvGm/1ZUW3P1Vd1QWJo4ToWmxoh1
+CyUxvP2XL89G2SXP5XBEMFoXFo2BAkB/twb5hrxdrcT/dVPcm1mnLiKpeNbbb8rh
+svBCgm0MyOr3q8/ook/lfqPIbwiq0xJdSzPF2tO8nOcC2F7xdMflAkEAxTqQimce
+wkc4DAzKTuwq7vtogTakOglVZxNdYq0wQ9fPCjhpaMOIEHGCnu3Ii8ay1CnPHYpD
+8+W8jck6EITNCA==
+-----END PRIVATE KEY-----
diff --git a/inf.pl b/inf.pl
index 5bf289b..4861240 100755
--- a/inf.pl
+++ b/inf.pl
@@ -85,7 +85,7 @@ sub thing($$$$) {
$i = $wait
if ( ( defined $looks )
and ( not( $s =~ /Pending/ ) )
- and ( $s =~ /$looks/ ) );
+ and ( $s =~ /$looks/i ) );
print "Outlet is $s\n";
$i++;
} until ( ( $i > $wait )
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 20:32:31 +0000