Implement the dbrw module.

* Makefile.PL: Update.
* lib/MakeRedirect/Output/dbrw.pm: New module.
* lib/MakeRedirect/Output/rewrite.pm: Minor change in the description.
* lib/MakeRedirect/URI.pm (local): New method.
(canonical): Use local.

4 files changed, 645 insertions, 10 deletions

diff --git a/Makefile.PL b/Makefile.PL
index e3f563b..7d3e6a3 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -25,11 +25,25 @@ WriteMakefile(
     	'Text::Locus' => '1.03',
 	'URI::Encode' => '1.1.1',
         'String::Escape' => '2010.002',
-	'Clone' => 0    
+	'Clone' => 0,
+	'Inline::Files' => 0,
+	'Safe' => 0,
+	'DBI' => 0,
+	'DBD::mysql' => 0    
+    },
+    BUILD_REQUIRES => {
+	'Test::More' => '0.88',
+        'File::Temp' => 0
     },
-    BUILD_REQUIRES => {'Test::More' => '0.88'},
     META_MERGE        => {
     	'meta-spec' => { version => 2 },
+        prereqs => {
+            runtime => {
+                recommends => {
+                    'Text::CSV_XS' => 0,
+                },
+            },
+        },
     	resources => {
     	    repository => {
     		type => 'git',
diff --git a/lib/MakeRedirect/Output/dbrw.pm b/lib/MakeRedirect/Output/dbrw.pm
new file mode 100644
index 0000000..4b41519
--- /dev/null
+++ b/lib/MakeRedirect/Output/dbrw.pm
@@ -0,0 +1,617 @@
+package MakeRedirect::Output::dbrw;
+use parent 'MakeRedirect::Output';
+
+=head1 NAME
+
+dbrw - insert rewrite rules into MySQL database for vmod_dbrw
+
+=head1 SYNOPSIS
+
+B<makeredirect dbrw>
+[B<-inv>]
+[B<-P> I<DBPORT>]
+[B<-d> I<DBNAME>]
+[B<-h> I<DBHOST>]
+[B<-p> I<DBPASS>]
+[B<-s> I<SCHEME>]
+[B<-u> I<DBUSER>]
+[B<--comment=>I<TEXT>]
+[B<--database=>I<DBNAME>]
+[B<--defaults-file=>I<FILE>
+[B<--dry-run>]
+[B<--host=>I<DBHOST>]
+[B<--init>]
+[B<--params=>I<DBPARAMS>]
+[B<--password=>I<DBPASS>]
+[B<--port=>I<DBPORT>]
+[B<--scheme=>I<SCHEME>]
+[B<--user=>I<DBUSER>]
+[B<--vcl>]
+[B<--verbose>]
+
+=head1 DESCRIPTION
+
+This module maintains a database of redirects for use with B<vmod_dbrw>.
+B<Vmod_dbrw> is a loadable module for Varnish Cache that enables it to
+programmatically redirect HTTP requests based on lookups in a MySQL database.
+
+It supports three distinct database structures (I<schemes>), each designed
+for a particular purpose.  The scheme is selected with the B<--scheme>
+option.
+
+The B<--init> option allows the user to create and initialize the database
+of the selected scheme.
+
+The B<--vcl> option prints a fragment of VCL code that could be used in the
+Varnish VCL script to make use of the created database.
+
+=head1 OPTIONS
+
+=head2 Scheme selection
+
+=over 4
+
+=item B<-s>, B<--scheme=>I<SCHEME>
+
+Selects the database scheme to use.  This option must always be present.
+It must correspond to the actual database structure, if it already exists.
+I<SCHEME> is the scheme number as described in the table below.
+
+=back
+
+Currently, three database schemes are supported:
+
+=over 4
+
+=item B<0>
+
+Simple database with no hostname distinction.  Use this scheme if your
+redirects don't depend on the source hostname.
+
+=item B<1>
+
+A database with hostname distinction.  Use this scheme if the redirects
+have various source hostnames.
+
+=item B<2>
+
+A more compact version of B<1>.  Useful for a very large number of redirects.
+
+=back
+
+=head2 Database connection
+
+=over 4
+
+=item B<--defaults-file=>I<FILE>
+
+Sets the name of the MySQL defaults file to use.  Default is B<.my.cnf>
+in the user's home directory.
+
+The defaults file is the preferred method for supplying MySQL credentials.
+
+=item B<-d>, B<--database=>I<DBNAME>
+
+Sets the database name.  The database name can also be specified in
+the defaults file.  However, the use of this option is mandatory if
+the B<--vcl> or B<--init> operation modifier is given.
+
+=item B<-h>, B<--host=>I<DBHOST>
+
+Sets the hostname or IP of the MySQL server.
+
+=item B<-P>, B<--port=>I<DBPORT>
+
+Sets the port number the MySQL server is listening on.
+
+=item B<-u>, B<--user=>I<DBUSER>
+
+Sets the MySQL user name.
+
+=item B<-p>, B<--password=>I<DBPASS>
+
+Sets the MySQL user password.
+
+B<Note:> the use of this option imposes a security threat.  Please use the
+B<--defaults-file> instead.
+
+=item B<--params=>I<DBPARAMS>
+
+Sets additional MySQL database driver parameters.
+
+=back
+
+=head2 Operation modifiers
+
+=over 4
+
+=item B<-n>, B<--dry-run>
+
+Don't modify the database, but print verbosely what's being done.  In
+particular, print each database query that would have been executed
+(implies B<--verbose>).
+
+=item B<-v>, B<--verbose>
+
+Verbose mode.  Prints on standard error each database query being performed.
+
+=item B<-i>. B<--init>
+
+Create the database and initialize tables.
+
+=item B<--vcl>
+
+Produce on standard output a VCL template for using the created database.
+You can paste it into your VCL code (in B<sub vcl_recv>), with the necessary
+edits.  See
+L<http://www.gnu.org.ua/software/vmod-dbrw/manual/html_node/Rewrite.html>
+for details.
+
+=item B<--comment=>I<TEXT>
+
+=back
+
+=head2 Informational options
+
+=over 4
+
+=item B<-?>
+
+Produce a short help text and exit.
+
+=item B<--help>
+
+Display the manual page and exit.
+
+=item B<--usage>
+
+Display a short command line usage summary and exit.
+
+=back
+
+=head1 SEE ALSO
+
+B<makeredirect>(1),
+B<vmod-dbrw>(3),
+L<http://www.gnu.org.ua/software/vmod-dbrw>,
+L<MakeRedirect>.
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+use DBI;
+use File::Spec;
+use Inline::Files;
+use Safe;
+
+sub getopt {
+    my $self = shift;
+    $self->SUPER::getopt(
+	's|scheme=s' => 'scheme',
+	'i|init' => 'init',
+	'n|dry-run' => 'dry_run',
+	'v|verbose+' => 'verbose',
+	'd|database=s' => sub {
+	    my $self = shift;
+	    $self->{options}{connarg}{database} = $_[1];
+	},
+	'h|host=s' => sub {
+	    my $self = shift;
+	    $self->{options}{connarg}{host} = $_[1];
+	},
+	'P|port=s' => sub {
+	    my $self = shift;
+	    $self->{options}{connarg}{port} = $_[1];
+	},
+	'u|user=s' => 'dbuser',
+	'p|password=s' => 'dbpass',
+	'params=s' => 'dbparams',
+	'defaults-file=s' => 'defaults_file',
+	'comment=s' => 'comment',
+	'vcl' => 'vcl');
+    if ($self->{options}{dry_run}) {
+	$self->{last_insert_id} = 0;
+	$self->{options}{verbose}++;
+    }
+    unless (defined($self->{options}{scheme})) {
+	croak "pease supply scheme ID (use the --scheme option)";
+    }
+    if ($self->{options}{init}) {
+	$self->dbinit;
+    }
+    if ($self->{options}{vcl}) {
+	$self->vcl;
+    }
+}
+
+sub vcl {
+    my $self = shift;
+    my $handle = "VCL_$self->{options}{scheme}";
+    if (my $code = $self->get_code($handle)) {
+	$code =~ s/(?<!\\)\$database/$self->{options}{connarg}{database}/g;
+	$code =~ s/\\\$/\$/g;
+	print $code;
+    }
+    exit 0;
+}
+
+sub dbinit {
+    my $self = shift;
+    my $dbname = delete $self->{options}{connarg}{database};
+    unless ($dbname) {
+	croak "please supply the database name (use the --database option)"
+    }
+    $self->read_struct;
+    $self->open;
+    $self->sql_query_finish("CREATE DATABASE $dbname CHARACTER SET utf8");
+    unless ($self->{options}{dry_run}) {
+	$self->close;
+        $self->{options}{connarg}{database} = $dbname;
+        $self->open;
+    }
+    foreach my $dfn (@{$self->{struct}}) {
+	$self->sql_query_finish($dfn);
+    }
+    $self->close;
+}
+
+sub ruleset {
+    my ($self, $host, $rules) = @_;
+    my $www_host;
+    foreach my $key (sort { $b cmp $a } keys %{$rules}) {
+	my $r = $rules->{$key};
+	my $args = $self->insert_args($r, $r->src, $r->dst,
+				      $self->host_id($host));
+	$self->sql_insert('rules', %$args);
+	if ($r->www && $host) {
+	    unless ($www_host) {
+		($www_host = $host) =~ s{^www\.}{}
+		   or $www_host = 'www.' . $host;
+	    }
+	    my $src = $r->src->clone;
+	    $src->host($www_host);
+	    $args = $self->insert_args($r, $src, $r->dst,
+				       $self->host_id($www_host));
+	    $self->sql_insert('rules', %$args);
+	}
+    }
+}
+
+sub get_code {
+    my ($self, $handle) = @_;
+    local $/;
+    unless (exists($self->{code}{$handle})) {
+        local $/;
+        $self->{code}{$handle} = <$handle>;
+    }
+    return $self->{code}{$handle};
+}
+
+sub host_id {
+    my ($self, $host) = @_;
+    my $res;
+    unless ($res = $self->{host_id}{$host}) {
+	my $handle = "HOSTID_$self->{options}{scheme}";
+	if (my $code = $self->get_code($handle)) {
+	    my %qarg;
+	    my $cpt = new Safe;
+	    ${$cpt->varglob('hostname')} = $host;
+	    ${$cpt->varglob('result')} = \%qarg;
+	    $cpt->reval($code);
+	    croak "$handle: $@" if ($@);
+  	    croak "No select hash in $handle" unless $qarg{select};
+            $res = $self->get_host_id(%{$qarg{select}});
+
+	    unless ($res) {
+		croak "No insert hash in $handle" unless $qarg{insert};
+		$self->sql_insert($qarg{insert}{table}, %{$qarg{insert}{args}});
+	        $res = $self->last_insert_id($qarg{insert}{table},
+					     $qarg{insert}{id} // 'id');
+	    }
+	    $self->{host_id}{$host} = $res
+	}
+    }
+    return $res
+}    
+
+sub get_host_id {
+    my $self = shift;
+    local %_ = @_;
+    my $sth = $self->sql_query($_{query}, @{$_{args}});
+    my $res;
+    if (my $rows = $sth->fetchall_arrayref([0], 1)) {
+	$res = $rows->[0][0];
+    }
+    $sth->finish;
+    return $res;
+}
+
+sub insert_args {
+    my ($self, $rule, $src, $dst, $host_id) = @_;
+    my %args;
+    my $handle = "INSERT_$self->{options}{scheme}";
+
+    if ($rule->exact) {
+	$handle .= "_EXACT";
+    } elsif ($rule->nosub) {
+        $handle .= "_NOSUB";
+    } else {
+        $handle .= "_DEFAULT";
+    }
+    my $code = $self->get_code($handle);
+    if ($self->{options}{comment}) {
+	$args{comment} = $self->{options}{comment};
+    }
+    my $cpt = new Safe;
+    ${$cpt->varglob('src')} = $src->clone;
+    ${$cpt->varglob('dst')} = $dst->clone;
+    ${$cpt->varglob('host_id')} = $host_id;
+    ${$cpt->varglob('result')} = \%args;
+    *{$cpt->varglob('quoterx')} = sub {
+	my $s = shift;
+	$s =~ s/([\\|()\[\]{}^\$*+?.])/\\$1/g;
+	$s;
+    };
+    $cpt->reval($code);
+    croak "$handle: $@" if ($@);
+    return \%args;
+}
+
+sub read_struct {
+    my $self = shift;
+    my $handle = "STRUCT_$self->{options}{scheme}";
+    my @dfn;
+    while (<$handle>) {
+	chomp;
+	s/^\s+//;
+	s/\s+$//;
+	next if /^(?:--.*)?$/;
+	push @dfn, $_;
+	if (/\);$/) {
+	    push @{$self->{struct}}, join('', @dfn);
+	    @dfn = ();
+	}
+    }
+}    
+
+sub open {
+    my $self = shift;
+
+    my @connarg = map { "$_=$self->{options}{connarg}{$_}" }
+	            keys %{$self->{options}{connarg}};
+    if (my $p = $self->{options}{dbparams}) {
+	push @connarg, $p;
+    }
+
+    unless ($self->{options}{defaults_file}) {
+	my $f = File::Spec->catfile($ENV{HOME}, '.my.cnf');
+	if (-f $f) {
+	    $self->{options}{defaults_file} = $f;
+	}
+    }
+    if (my $p = $self->{options}{defaults_file}) {
+	push @connarg, ";mysql_read_default_file=$p";
+    }
+
+    unless (@connarg) {
+	croak 'Database parameters not initialized.  Please use the --database (optionally - --host and --port) option.'
+    }
+
+    my $arg = join(':', ('DBI', 'mysql', @connarg));
+
+    my $dbh = DBI->connect($arg, $self->{options}{dbuser},
+			   $self->{options}{dbpass},
+			   { RaiseError => 0, PrintError => 1, AutoCommit => 1})
+	or croak "can't connect to the database server";
+    $self->{dbh} = $dbh;
+}
+
+sub dbh { shift->{dbh} }
+sub last_insert_id {
+    my $self = shift;
+    if ($self->{options}{dry_run}) {
+	$self->{last_insert_id}++;
+    } else {
+	$self->dbh->last_insert_id(undef,
+				   $self->{options}{connarg}{database},
+				   @_);
+    }
+}
+
+sub close {
+    my $self = shift;
+    $self->dbh->disconnect;
+}
+
+sub sql_query {
+    my ($self, $query, @args) = @_;
+    if ($self->{options}{verbose}) {
+	my $n = () = $query =~ /\Q?/g;
+	croak "declared number of parameters doesn't match actual arguments"
+	    unless $n == @args;
+	my @q = split /\?/, $query;
+	my $s = join('',
+		     ((map { ($q[$_], "'" . $args[$_] . "'" ) } (0 .. $#args)),
+		      $q[$#q]));
+	warn "DEBUG: $s\n";
+    }
+    return if $self->{options}{dry_run} && $query !~ /^select/i;
+    my $sth = $self->dbh->prepare($query);
+    $sth->execute(@args) or croak($sth->errstr);
+    $sth;
+}
+
+sub sql_query_finish {
+    my $self = shift;
+    if (my $sth = $self->sql_query(@_)) {
+	$sth->finish;
+    }
+}
+
+sub sql_insert {
+    my ($self, $table, %args) = @_;
+    my @fields = sort keys %args;
+    my $fieldnames = join(',', @fields);
+    my $valmap = join(',', ('?') x @fields);
+    $self->sql_query_finish("INSERT INTO $table ($fieldnames) VALUES ($valmap)",
+		     map { $args{$_} } @fields);
+}
+
+1;
+__STRUCT_0__
+CREATE TABLE rules (
+  id INT AUTO_INCREMENT,
+  url varchar(255) NOT NULL DEFAULT '',
+  dest varchar(255) DEFAULT NULL,
+  value varchar(255) DEFAULT NULL,
+  pattern varchar(255) DEFAULT NULL,
+  flags char(64) DEFAULT NULL,
+  prio int NOT NULL DEFAULT '0',
+  comment varchar(255) DEFAULT NULL,
+  KEY (id),
+  UNIQUE KEY (url)  
+);
+
+__VCL_0__
+dbrw.config("mysql", "database=$database",
+            {"SELECT dest,pattern,value,flags
+                FROM rules
+               WHERE url IN (\$(urlprefixes $url))
+	       ORDER BY LENGTH(dest) DESC, prio ASC"});
+set req.http.X-Redirect-To = dbrw.rewrite("url=" + req.url);
+if (req.http.X-Redirect-To != "") {
+    return(synth(301, "Redirect"));
+}
+
+__INSERT_0_EXACT__
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local;
+
+__INSERT_0_NOSUB__
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
+
+__INSERT_0_DEFAULT__
+$result->{url} = $src->local;
+$result->{dest} = $dst->local . '$1';
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
+
+__STRUCT_1__
+CREATE TABLE rules (
+  id INT AUTO_INCREMENT,
+  host varchar(255) NOT NULL DEFAULT '',
+  url varchar(255) NOT NULL DEFAULT '',
+  dest varchar(255) DEFAULT NULL,
+  value varchar(255) DEFAULT NULL,
+  pattern varchar(255) DEFAULT NULL,
+  flags char(64) DEFAULT NULL,
+  prio int NOT NULL DEFAULT '0',
+  comment varchar(255) DEFAULT NULL,
+  KEY (id),  
+  UNIQUE KEY source (host,url)
+);
+
+__VCL_1__
+dbrw.config("mysql", "database=$database",
+            {"SELECT dest,pattern,value,flags
+                FROM rules
+               WHERE host='$host'
+		 AND url IN (\$(urlprefixes $url))
+	       ORDER BY LENGTH(dest) DESC, prio ASC"});
+set req.http.X-Redirect-To = dbrw.rewrite("host=" + req.host + ";" +
+					  "url=" + req.url);
+if (req.http.X-Redirect-To != "") {
+    return(synth(301, "Redirect"));
+}
+
+__INSERT_1_EXACT__
+$result->{host} = $src->host if $src->host;
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local;
+
+__INSERT_1_NOSUB__
+$result->{host} = $src->host if $src->host;
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local;
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
+
+__INSERT_1_DEFAULT__
+$result->{host} = $src->host if $src->host;
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local . '$1';
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
+
+__STRUCT_2__
+CREATE TABLE hosts (
+  id int AUTO_INCREMENT,
+  name varchar(255),
+  comment varchar(255) DEFAULT NULL,
+  KEY (id),  
+  KEY name (name)
+);
+
+CREATE TABLE rules (
+  id INT AUTO_INCREMENT,
+  host_id int NOT NULL,
+  url varchar(255) NOT NULL DEFAULT '',
+  dest varchar(255) DEFAULT NULL,
+  value varchar(255) DEFAULT NULL,
+  pattern varchar(255) DEFAULT NULL,
+  flags char(64) DEFAULT NULL,
+  prio int NOT NULL DEFAULT '0',
+  comment varchar(255) DEFAULT NULL,
+  KEY (id),  
+  UNIQUE KEY source (host_id,url)
+);
+
+__VCL_2__
+dbrw.config("mysql", "database=$database",
+            {"SELECT rules.dest,rules.pattern,rules.value,rules.flags
+                FROM rules,hosts
+               WHERE hosts.name='$host'
+		 AND rules.host_id=hosts.id
+		 AND rules.url IN (\$(urlprefixes $url))
+	       ORDER BY LENGTH(rules.dest) DESC, rules.prio ASC"});
+set req.http.X-Redirect-To = dbrw.rewrite("host=" + req.host + ";" +
+					  "url=" + req.url);
+if (req.http.X-Redirect-To != "") {
+    return(synth(301, "Redirect"));
+}
+
+__HOSTID_2__
+$result->{select} = {
+    query => 'SELECT id FROM hosts WHERE name=?',
+    args => [ $hostname ]
+};
+$result->{insert} = {
+    table => 'hosts',
+    args => {
+	name => $hostname
+    }
+};
+
+__INSERT_2_EXACT__
+$result->{host_id} = $host_id;
+$result->{url}     = $src->local;
+$result->{dest}    = $dst->local;
+
+__INSERT_2_NOSUB__
+$result->{host_id} = $host_id;
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local;
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
+
+__INSERT_2_DEFAULT__
+$result->{host_id} = $host_id;
+$result->{url}  = $src->local;
+$result->{dest} = $dst->local . '$1';
+$result->{value} = '$uri';
+$result->{pattern} = quoterx($src->path) . "(/.*)?";
diff --git a/lib/MakeRedirect/Output/rewrite.pm b/lib/MakeRedirect/Output/rewrite.pm
index f9ed7c8..7faec11 100644
--- a/lib/MakeRedirect/Output/rewrite.pm
+++ b/lib/MakeRedirect/Output/rewrite.pm
@@ -115,7 +115,7 @@ sub ruleset {
 
 =head1 NAME
 
-rewrite - generate mod_rewrite rules
+rewrite - generate redirection rules for mod_rewrite
 
 =head1 SYNOPSIS
 
diff --git a/lib/MakeRedirect/URI.pm b/lib/MakeRedirect/URI.pm
index ccb5055..3fe1e82 100644
--- a/lib/MakeRedirect/URI.pm
+++ b/lib/MakeRedirect/URI.pm
@@ -70,18 +70,22 @@ sub scheme_prefix {
     $self->{scheme} ? ($self->scheme . '://') : '';
 }
 
-sub canonical {
+sub local {
     my ($self) = @_;
-    my $s;
-    if ($self->host) {
-	$s = $self->scheme_prefix . $self->host . ($self->{path} || '/');
-    } else {
-	$s = $self->path;
-    }
+    my $s = $self->{path} || '/';
     if ($self->query) {
 	$s .= '?' . $self->query;
     }
     return $s;
+}    
+
+sub canonical {
+    my ($self) = @_;
+    my $s = $self->local;
+    if ($self->host) {
+	$s = $self->scheme_prefix . $self->host . $s;
+    }
+    return $s;
 }
 
 use overload