###########################################################################
# basic Perlbal statistics gatherer
###########################################################################

package Perlbal::Plugin::Jslab;

use strict;
use warnings;

use GD;
use MIME::Base64;

our $im = new GD::Image(250,250);
our $white = $im->colorAllocate(255,255,255);
#$im->transparent($white);
our $black = $im->colorAllocate(0,0,0);

our @subs;  # subscribers

sub send_event {
    my $js = shift;
    my $need_clean = 0;
    my $now = time();
    foreach my $s (@subs) {
	if ($s->{closed}) {
	    $need_clean = 1;
	    next;
	}
	$s->{alive_time} = $now;
	$s->write(sprintf("%8d$js", length($js)));
    }
    if ($need_clean) {
	@subs = grep { ! $_->{closed} } @subs;
	send_event("setCount(" . scalar @subs . ");");
    }
}

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;

    Perlbal::Socket::register_callback(1, sub {
	my $ct = @subs;
	@subs = grep { ! $_->{closed} } @subs;
	my $ct2 = @subs;
	if ($ct != $ct2) {
	    send_event("setCount($ct2);");
	}
	return 1;
    });
    Perlbal::Socket::register_callback(5, sub {
	send_event("1;");
	return 5;
    });

    $svc->register_hook('Jslab', 'start_proxy_request', sub {
	my Perlbal::ClientProxy $self = shift;
	my Perlbal::HTTPHeaders $hds = $self->{req_headers};
	return 0 unless $hds;
	my $uri = $hds->request_uri;
	return 0 unless $uri =~ m!^/jslab,(\w+)(?:\?(.*))?!;
	my ($mode, $qs) = ($1, $2);
	#print "MODE: $mode, QS: $qs\n";

	my $send = sub {
	    my ($ctype, $bodyref) = @_;
	    my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
	    $res->header("Content-Type", "text/plain");
	    $res->header('Content-Length', length($$bodyref));
	    $self->setup_keepalive($res);

	    $self->state('xfer_resp');
	    $self->tcp_cork(1);  # cork writes to self
	    $self->write($res->to_string_ref);
	    unless ($self->{req_headers} && $self->{req_headers}->request_method eq 'HEAD') {
		# don't write body for head requests
		$self->write($bodyref);
	    }
	    $self->write(sub { $self->http_response_sent; });
	    
	};

	if ($mode eq "sub") {
	    my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
            $res->header("Content-Type", "text/plain");
	    $res->header('Connection', 'close');
	    push @subs, $self;
	    
            $self->write($res->to_string_ref);
	    send_event("setCount(" . scalar @subs . ");");
	    return 1;
	}

	if ($mode eq "image") {
	    my $png = $im->png;
	    $send->("image/png", \$png);
	    return 1;
	}

	if ($mode eq "sendcmd") {
	    #print "sendcmd: $qs\n";
	    my $dirty_image = 0;
	    my $brush = 1;

	    my $js = "";  # response
	    my @pairs = split(/,/, $qs);
	    while (my $cmd = shift @pairs) {
		if ($cmd eq "lb") {
		    $dirty_image = 1;
		    $brush = int shift @pairs;
		    my ($x1, $y1, $x2, $y2) = map { int($_) } splice(@pairs, 0, 4);

		    my $width = $brush - 1;
		    $width = 0 if $width < 0;
		    $width = 3 if $width > 3;

		    for (my $dx = -$width; $dx <= $width; $dx ++) {
                        for (my $dy = -$width; $dy <= $width; $dy ++) {
                            $im->line($x1+$dx, $y1+$dy, $x2+$dx, $y2+$dy, $black);
                        }
                    }
		}

		my $snapfile = time() . ".png";
		my $snap = sub {
		    return 0 unless
			open (S, ">/var/www/danga.com/htdocs/misc/jsdraw/archive/$snapfile");
		    print S $im->png;
		    close S;
		};

		if ($cmd eq "wipe") {
		    $dirty_image = 1;
		    $snap->();
		    $im->filledRectangle(0,0,250,250, $white);
		    $js .= "insChat(\"" . ejs("<i>[SCREEN WIPE from " . $self->peer_ip_string . "]</i>") . "\");\n";
		}
		
		if ($cmd eq "chat") {
		    my $chat = durl(splice(@pairs, 0, 1));
		    if ($chat ne "") {
			$js .= "insChat(\"<b>" . ejs($self->peer_ip_string . ":</b> $chat") . "\");\n";
		    }
		    if ($chat eq "snap") {
			$snap->();
		    }
		}
	    }

	    if ($dirty_image) {
		my $enc = encode_base64($im->png);
		$enc =~ s/[\n\r]//g;
		$js .= "document.getElementById('foo').src = \"data:image/png;base64,$enc\";\n";
	    }

	    send_event($js);

	    #$send->("text/plain", \$body);

	    $send->("text/plain", \ "OK");
	    return 1;
	}

	return 0;
    });

    return 1;
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;

    return 1;
}

# called when we are loaded
sub load {
    return 1;
}

# called for a global unload
sub unload {
    return 1;
}

sub durl
{
    my ($a) = @_;
    $a =~ tr/+/ /;
    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    return $a;
}

sub ejs
{
    my $a = $_[0];
    $a =~ s/[\"\'\\]/\\$&/g;
    $a =~ s/\r?\n/\\n/gs;
    $a =~ s/\r//;
    return $a;
}


1;