Initial commit

Spawned from the proxyctl project.

8 files changed, 584 insertions, 0 deletions

diff --git a/lib/Config/HAProxy/Iterator.pm b/lib/Config/HAProxy/Iterator.pm
new file mode 100644
index 0000000..6b0208e
--- /dev/null
+++ b/lib/Config/HAProxy/Iterator.pm
@@ -0,0 +1,69 @@
+package Config::HAProxy::Iterator;
+use strict;
+use warnings;
+use Config::HAProxy::Node;
+use Carp;
+
+use constant {
+    NO_RECURSION => 0,
+    INORDER => 1,
+    POSTORDER => 2
+};
+
+sub new {
+    my $class = shift;
+    my $node = shift;
+    my $self = bless { }, $class;
+    if ($node->is_section) {
+	$self->{_list} = [ $node->tree() ];
+    } else {
+	$self->{_list} = [ $node ];
+    }
+    local %_ = @_;
+    if (defined($_{recursive})) {
+	$self->{_recursive} = $_{recursive};
+    } elsif ($_{inorder}) {
+	$self->{_recursive} = INORDER;
+    } elsif ($_{postorder}) {
+	$self->{_recursive} = POSTORDER;
+    } else {
+	$self->{_recursive} = NO_RECURSION;
+    }
+    return $self;
+}
+
+sub recursive  { shift->{_recursive} }
+sub inorder  { shift->{_recursive} == INORDER }
+sub postorder { shift->{_recursive} == POSTORDER } 
+
+sub next {
+    my $self = shift;
+
+    if ($self->{_itr}) {
+	if (defined(my $v = $self->{_itr}->next())) {
+	    return $v;
+	} else {
+	    delete $self->{_itr};
+	    return $self->{_cur} if $self->postorder;
+	}
+    }
+
+    if (defined($self->{_cur} = shift @{$self->{_list}})) {
+	if ($self->recursive && $self->{_cur}->is_section) {
+	    $self->{_itr} = $self->{_cur}->iterator(recursive => $self->recursive);
+	    if ($self->inorder) {
+		return $self->{_cur};
+	    } else {
+		return $self->next();
+	    }
+	}
+    }
+
+    return $self->{_cur};
+}
+
+1;
+
+	    
+
+	
diff --git a/lib/Config/HAProxy/Node.pm b/lib/Config/HAProxy/Node.pm
new file mode 100644
index 0000000..be09538
--- /dev/null
+++ b/lib/Config/HAProxy/Node.pm
@@ -0,0 +1,99 @@
+package Config::HAProxy::Node;
+use strict;
+use warnings;
+use Carp;
+use Config::HAProxy::Iterator;
+
+sub new {
+    my $class = shift;
+    local %_ = @_;
+    bless {
+	_kw => $_{kw},
+	_argv => $_{argv} // [],
+	_orig => $_{orig},
+	_locus => $_{locus},
+	_parent => $_{parent},
+	_index => -1
+    }, $class;
+}
+
+my @ATTRIBUTES = qw(kw orig locus parent index);
+
+{
+    no strict 'refs';
+    foreach my $attribute (@ATTRIBUTES) {
+	*{ __PACKAGE__ . '::' . $attribute } = sub {
+	    my $self = shift;
+	    if (defined(my $val = shift)) {
+		croak "too many arguments" if @_;
+		$self->{'_'.$attribute} = $val;
+	    }
+	    return $self->{'_'.$attribute};
+	}
+    }
+}
+
+sub argv {
+    my $self = shift;
+    if (my $val = shift) {
+	croak "too many arguments" if @_;
+	$self->{_argv} = $val;
+    }
+    return @{$self->{_argv}};
+}
+
+sub arg {
+    my $self = shift;
+    my $n = shift;
+    if (my $val = shift) {
+	croak "too many arguments" if @_;
+	$self->{_argv}[$n] = $val;
+    }
+    return $self->{_argv}[$n];
+}
+
+sub drop {
+    my $self = shift;
+    $self->parent->delete_node($self->index);
+}
+
+sub iterator {
+    return new Config::HAProxy::Iterator(@_);
+}
+
+sub depth {
+    my $self = shift;
+    my $n = 0;
+    while ($self = $self->parent) {
+	$n++;
+    }
+    return $n - 1;
+}
+
+sub root {
+    my $self = shift;
+    while ($self->parent()) {
+	$self = $self->parent();
+    }
+    return $self;
+}
+
+sub as_string {
+    my $self = shift;
+    if (defined(my $v = $self->orig)) {
+	return $v;
+    }
+    return '' unless $self->kw;
+    return $self->orig(join(' ', ($self->kw, $self->argv())));
+}
+
+# use overload
+#     '""' => sub { shift->as_string };
+
+sub is_root { 0 }
+sub is_section { 0 }
+sub is_statement { 0 }
+sub is_empty { 0 }
+sub is_comment { 0 }
+
+1;
diff --git a/lib/Config/HAProxy/Node/Comment.pm b/lib/Config/HAProxy/Node/Comment.pm
new file mode 100644
index 0000000..5d7ef88
--- /dev/null
+++ b/lib/Config/HAProxy/Node/Comment.pm
@@ -0,0 +1,6 @@
+package Config::HAProxy::Node::Comment;
+use parent 'Config::HAProxy::Node';
+
+sub is_comment { 1 }
+
+1;
diff --git a/lib/Config/HAProxy/Node/Empty.pm b/lib/Config/HAProxy/Node/Empty.pm
new file mode 100644
index 0000000..bee0f2e
--- /dev/null
+++ b/lib/Config/HAProxy/Node/Empty.pm
@@ -0,0 +1,6 @@
+package Config::HAProxy::Node::Empty;
+use parent 'Config::HAProxy::Node';
+
+sub is_empty { 1 }
+
+1;
diff --git a/lib/Config/HAProxy/Node/Root.pm b/lib/Config/HAProxy/Node/Root.pm
new file mode 100644
index 0000000..656bb9f
--- /dev/null
+++ b/lib/Config/HAProxy/Node/Root.pm
@@ -0,0 +1,31 @@
+package Config::HAProxy::Node::Root;
+use strict;
+use warnings;
+use parent 'Config::HAProxy::Node::Section';
+use Carp;
+
+sub new {
+    my $class = shift;
+    my $self = $class->SUPER::new(@_);
+    $self->{dirty} = 0;
+    return $self;
+}
+
+sub is_dirty {
+    my $self = shift;
+    return $self->{dirty}
+}
+
+sub mark_dirty {
+    my $self = shift;
+    $self->{dirty} = 1;
+}
+
+sub clear_dirty {
+    my $self = shift;
+    $self->{dirty} = 0;
+}
+    
+1;
+
+    
diff --git a/lib/Config/HAProxy/Node/Section.pm b/lib/Config/HAProxy/Node/Section.pm
new file mode 100644
index 0000000..c332155
--- /dev/null
+++ b/lib/Config/HAProxy/Node/Section.pm
@@ -0,0 +1,143 @@
+package Config::HAProxy::Node::Section;
+use strict;
+use warnings;
+use parent 'Config::HAProxy::Node';
+use Carp;
+
+sub new {
+    my $class = shift;
+    my $self = $class->SUPER::new(@_);
+    $self->{_tree} = [];
+    return $self;
+}
+
+sub is_section { 1 }
+
+sub append_node {
+    my $self = shift;
+    my $n = @{$self->{_tree}};
+    push @{$self->{_tree}},
+         map {
+	     $_->parent($self);
+	     $_->index($n++);
+	     $_
+	 }  @_;
+}
+
+sub append_node_nonempty {
+    my $self = shift;
+    my $n = $#{$self->{_tree}};
+    while ($n >= 0 && $self->{_tree}[$n]->is_empty) {
+	$n--;
+    }
+    $self->insert_node($n+1, @_);
+}
+    
+sub insert_node {
+    my $self = shift;
+    my $n = shift;
+    my $i = $n;
+    splice @{$self->{_tree}}, $n, 0,
+         map {
+	     $_->parent($self);
+	     $_->index($i++);
+	     $_
+	 }  @_;
+    for (; $i < @{$self->{_tree}}; $i++) {
+	$self->{_tree}[$i]->index($i);
+    }
+}
+
+sub delete_node {
+    my ($self, $n) = @_;
+    splice @{$self->{_tree}}, $n, 1;
+    for (; $n < @{$self->{_tree}}; $n++) {
+	$self->{_tree}[$n]->index($n);
+    }
+    $self->root->mark_dirty;
+}
+
+sub tree {
+    my ($self, $n) = @_;
+    if ($n) {
+	return undef if $n >= @{$self->{_tree}};
+	return $self->{_tree}[$n];
+    }
+    return @{shift->{_tree}}
+};
+
+sub ends_in_empty {
+    my $self = shift;
+    while ($self->is_section) {
+	$self = $self->tree(-1);
+    }
+    return $self->is_empty;
+}
+
+my %match = (
+    name => {
+	wantarg => 1,
+	matcher => sub {
+	    my ($node, $value) = @_;
+	    return $node->kw && $node->kw eq $value;
+	}
+    },
+    arg => {
+	wantarg => 1,
+	matcher => sub {
+	    my ($node, $value) = @_;
+	    my $arg = $node->arg($value->{n});
+	    return $arg && $arg eq $value->{v};
+	}
+    },
+    section => {
+	matcher => sub {
+	    my $node = shift;
+	    return $node->is_section;
+	}
+    },
+    statement => {
+	matcher => sub {
+	    my $node = shift;
+	    return $node->is_statement;
+	}
+    },
+    comment => {
+	matcher => sub {
+	    my $node = shift;
+	    return $node->is_comment;
+	}
+    }
+);
+		
+
+sub select {
+    my $self = shift;
+    my @prog;
+    while (my $p = shift) {
+	my $arg = shift or croak "missing argument";
+	my $m = $match{$p} or croak "unknown matcher: $p";
+	if ($m->{wantarg}) {
+	    push @prog, [ $m->{matcher}, $arg ];
+	} elsif ($arg) {
+	    push @prog, $m->{matcher};
+	}
+    }
+    grep { _test_node($_, @prog) } $self->tree;
+}
+
+sub _test_node {
+    my $node = shift;
+    foreach my $f (@_) {
+	if (ref($f) eq 'ARRAY') {
+	    return 0 unless &{$f->[0]}($node, $f->[1]);
+	} else {
+	    return 0 unless &{$f}($node);
+	}
+    }
+    return 1;
+}
+
+1;
+
+
diff --git a/lib/Config/HAProxy/Node/Statement.pm b/lib/Config/HAProxy/Node/Statement.pm
new file mode 100644
index 0000000..abf0e50
--- /dev/null
+++ b/lib/Config/HAProxy/Node/Statement.pm
@@ -0,0 +1,6 @@
+package Config::HAProxy::Node::Statement;
+use parent 'Config::HAProxy::Node';
+
+sub is_statement { 1 }
+
+1;
diff --git a/lib/Config/HAProxy/VirtualHost.pm b/lib/Config/HAProxy/VirtualHost.pm
new file mode 100644
index 0000000..3ad4168
--- /dev/null
+++ b/lib/Config/HAProxy/VirtualHost.pm
@@ -0,0 +1,224 @@
+package Config::HAProxy::VirtualHost;
+use strict;
+use warnings;
+use Carp;
+use File::Spec;
+use Config::HAProxy::Node::Empty;
+
+sub find_file {
+    my ($node, $hostdir) = @_;
+    my $rx = qr($hostdir);
+    my @argv = $node->argv;
+    while (my $arg = shift @argv) {
+	if ($arg eq '-f' && -f $argv[0]) {
+	    if ($argv[0] =~ s{^($rx/.+)$}{$1}) {
+		# Untaint the value
+		return $1;
+	    } else {
+		last;
+	    }
+	}
+    }
+}
+
+sub new {
+    my $class = shift;
+    my $self = bless {}, $class;
+    if (@_ == 2) {
+	my ($node, $hostdir) = @_;
+	$self->{node} = $node;
+	$self->{file} = find_file($node, $hostdir);
+	($self->{backend}) = $node->root->select(name => 'backend',
+						 arg => { n => 0,
+							  v => $node->arg(0) });
+    } elsif (@_ == 4) {
+	my ($cmd, $name, $port, $domains) = @_;
+
+	$self->{file} = File::Spec->catfile($cmd->hostdir, $name);
+	unlink $self->{file};
+	$self->add_domain(@$domains);
+	
+	my $node = new Config::HAProxy::Node::Statement(
+	    kw => 'use_backend',
+	    argv => [ $name, qw/if { hdr(host) -f/, $self->{file}, '}' ]);
+	$cmd->frontend->append_node_nonempty($node);
+	$self->{node} = $node;
+	
+	$node = new Config::HAProxy::Node::Section(
+	    kw => 'backend',
+	    argv => [ $name ]);
+	$node->append_node(new Config::HAProxy::Node::Statement(
+			       kw => 'server',
+			       argv => [
+				   'localhost',
+				   '127.0.0.1:'.$port
+			       ]));
+	$self->{backend} = $node;
+	unless ($cmd->config->tree->ends_in_empty) {
+	    $cmd->config->tree->append_node(new Config::HAProxy::Node::Empty);
+	}
+	$cmd->config->tree->append_node($node);
+	$cmd->config->tree->mark_dirty;
+	$self->mark_dirty;
+    } else {
+	croak "unrecognized arguments";
+    }
+    $self
+}
+
+sub valid {
+    my $self = shift;
+    return $self->file && $self->backend
+}
+
+sub file {
+    my $self = shift;
+    return $self->{file};
+}
+
+sub backend {
+    my $self = shift;
+    return $self->{backend};
+}
+
+sub node {
+    my $self = shift;
+    return $self->{node}
+}
+
+sub name {
+    my $self = shift;
+    return $self->node->arg(0);
+}
+
+sub _domainref {
+    my $self = shift;
+    unless ($self->{domains}) {
+	croak "can't use this method on invalid backend" unless $self->file;
+	if (-e $self->file) {
+	    open(my $fd, '<', $self->file)
+		or croak "can't open ".$self->file.": $!";
+	    chomp(my @domains = <$fd>);
+	    close $fd;
+	    $self->{domains} = \@domains;
+	} else {
+	    $self->{domains} = [];
+	}
+    }
+    return $self->{domains};
+}
+
+sub domains {
+    my $self = shift;
+    my $dom = $self->_domainref;
+    if (my $n = shift) {
+	return undef unless $n < @$dom;
+	return $dom->[$n]
+    }
+    return @$dom;
+}
+
+sub has_domain {
+    my ($self, $name) = @_;
+    $name = lc $name;
+    $name =~ s/\.$//;
+    foreach my $dom ($self->domains) {
+	return 1 if ($name eq $dom);
+    }
+    return 0
+}
+
+sub normalize_hostnames {
+    map { lc } @_
+}
+
+sub writable {
+    my $self = shift;
+    -w $self->file;
+}
+
+sub add_domain {
+    my $self = shift;
+    push @{$self->_domainref()}, normalize_hostnames(@_);
+    $self->mark_dirty;
+}
+    
+sub del_domain {
+    my $self = shift;
+    my @hosts = normalize_hostnames(@_);
+    my %dl;
+    @dl{@hosts} = (1) x @hosts;
+    $self->{domains} = [ 
+	grep { 
+	    if ($dl{$_}) {
+		$self->mark_dirty;
+		0;
+	    } else {
+		1
+	    }
+	} @{$self->_domainref()}
+    ];
+}
+    
+sub servers {
+    my $self = shift;
+    croak "can't use this method on invalid backend" unless $self->backend;
+    my @ret = map { $_->arg(1) } $self->backend->select(name => 'server');
+    if (@_) {
+	my $n = shift;
+	return undef unless $n < @ret;
+	return $ret[$n];
+    }
+    @ret;
+}
+
+sub is_dirty {
+    my $self = shift;
+    return $self->{dirty}
+}
+
+sub mark_dirty {
+    my $self = shift;
+    $self->{dirty} = 1;
+}
+
+sub clear_dirty {
+    my $self = shift;
+    $self->{dirty} = 0;
+}
+
+sub save {
+    my $self = shift;
+    if ($self->is_dirty) {
+	if ($self->domains == 0) {
+	    if (unlink $self->file) {
+		$self->clear_dirty;
+		return;
+	    }
+	}
+		    
+	open(my $fd, '>', $self->file)
+	    or croak "can't open ".$self->file." for writing: $!";
+	foreach my $dom ($self->domains) {
+	    print $fd $dom,"\n";
+	}
+	close $fd;
+
+	$self->clear_dirty
+    }
+}
+
+sub drop {
+    my $self = shift;
+    $self->node->drop;
+    $self->backend->drop;
+    $self->{domains} = [];
+    $self->mark_dirty;
+}
+
+sub DESTROY {
+    my $self = shift;
+    $self->save()
+}
+
+1;