###########################################################################
# plugin to do selecting based on URL
###########################################################################

package Perlbal::Plugin::Urlmatch;

use strict;
use warnings;
no  warnings qw(deprecated);

our %Services;  # service_name => $svc

# From glob_to_regex out of Text::Glob, but allowing ** to match slashes too
sub urlmatch_to_regex {
    my $glob = shift;
    my ($regex, $in_wildcard, $escaping);
    local $_;
    for ($glob =~ m/(.)/gs) {
        if ($_ ne '*' || $escaping) {
	    $in_wildcard = 0;
	}
        if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' ||
            $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) {
            $regex .= "\\$_";
        }
        elsif ($_ eq '*') {
	    if ($escaping) {
	        $regex .= "\\*";
	    }
	    else {
	      $regex .= $in_wildcard ? ".*" : "[^/]*";
	      $in_wildcard = 1;
	    }
        }
        elsif ($_ eq '?') {
            $regex .= $escaping ? "\\?" : "[^/]";
        }
        elsif ($_ eq "\\") {
            if ($escaping) {
                $regex .= "\\\\";
                $escaping = 0;
            }
            else {
                $escaping = 1;
            }
            next;
        }
        else {
            $regex .= $_;
        }
        $escaping = 0;
    }
    qr/^$regex$/;
}

# when "LOAD" directive loads us up
sub load {
    my $class = shift;

    Perlbal::register_global_hook('manage_command.url', sub {
        my $mc = shift->parse(qr/^url\s+(?:(\w+)\s+)?(\S+)\s*=\s*(\w+)$/,
                              "usage: URL [<service>] <url_pattern> = <dest_service>");
        my ($selname, $url, $target) = $mc->args;
        unless ($selname ||= $mc->{ctx}{last_created}) {
            return $mc->err("omitted service name not implied from context");
        }

        my $ss = Perlbal->service($selname);
        return $mc->err("Service '$selname' is not a selector service")
            unless $ss && $ss->{role} eq "selector";

        $url = lc $url;
        return $mc->err("invalid url pattern: '$url'")
            unless $url =~ /^[\w\-\_\.\*\;\:\/]+$/;

	# Turn $url into a regexp
	my $re = urlmatch_to_regex($url);

	$ss->{extra_config}->{_urls} ||= ();
	push(@{$ss->{extra_config}->{_urls}},$url);

        $ss->{extra_config}->{_urltargets} ||= {};
        $ss->{extra_config}->{_urltargets}{$url} = $target;

	$ss->{extra_config}->{_urlmatches} ||= {};
	$ss->{extra_config}->{_urlmatches}{$url} = $re;

        return $mc->ok;
    });
    return 1;
}

# unload our global commands, clear our service object
sub unload {
    my $class = shift;

    Perlbal::unregister_global_hook('manage_command.urls');
    unregister($class, $_) foreach (values %Services);
    return 1;
}

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;
    unless ($svc && $svc->{role} eq "selector") {
        die "You can't load the urlmatch plugin on a service not of role selector.\n";
    }

    $svc->selector(\&url_selector);
    $svc->{extra_config}->{_urls} = ();
    $svc->{extra_config}->{_urltargets} = {};
    $svc->{extra_config}->{_urlmatches} = {};

    $Services{"$svc"} = $svc;
    return 1;
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;
    $svc->selector(undef);
    delete $Services{"$svc"};
    return 1;
}

# call back from Service via ClientHTTPBase's event_read calling service->select_new_service(Perlbal::ClientHTTPBase)
sub url_selector {
    my Perlbal::ClientHTTPBase $cb = shift;

    my $req = $cb->{req_headers};
    return $cb->_simple_response(404, "Not Found (no reqheaders)") unless $req;

    my $vhost = $req->header("Host");
    my $uri = $req->request_uri;
    my $urls = $cb->{service}{extra_config}{_urls} ||= ();
    my $targets = $cb->{service}{extra_config}{_urltargets} ||= {};
    my $matches = $cb->{service}{extra_config}{_urlmatches} ||= {};

    # returns 1 if done with client, 0 if no action taken
    my $map_using = sub {
        my ($match_on) = @_;

	foreach my $url (@$urls) {
	  if ($match_on =~ /$matches->{$url}/) {
	    my $svc_name = $targets->{$url};
	    my $svc = $svc_name ? Perlbal->service($svc_name) : undef;

	    unless ($svc) {
	      $cb->_simple_response(404, "Not Found (no configured URL)");
	      return 1;
	    }

	    $svc->adopt_base_client($cb);
	    return 1;
	  }
	}
	
	return 0;
    };

    # Strip off any querystring
    $uri =~ s/\?.*//;

    return if $map_using->($uri);

    $cb->_simple_response(404, "Not Found (no matching URL)");
    return 1;
}

1;