#!/usr/bin/perl -w
#
# RADSQL - OpenRADIUS module that queries any DBI/DBD-supported database
#
# Usage: radsql [-d] [-n] [-c] [-a] database dbuser dbpass
#	 radsql -h
# 
# 'database' is a DBI connect string without the leading 'dbi:' part.
# -d increases verbosity on stderr and allows module to run standalone
# -n removes 'int' attribute containing number of rows affected from output
# -c treats first three returned columns (attribute, value, op) as check items;
#    instead of number of rows affected, returns 1 if all checks OK, -1 if no 
#    rows found, and 0 otherwise in the 'int' attribute.
# -a turns off autocommit; that means you must explicitly commit or rollback 
#    your transactions using COMMIT and ROLLBACK as SQL statements (which are 
#    trapped and passed to DBI's commit() and rollback() methods, resp.)
#
# The module uses the value of the first 'str' attribute from incoming requests
# as a SQL query and the value of the second 'str' attribute as a comma-
# separated list of attributes to use as bind variables. Attributes that are
# not present in the request will not be bound, so a NULL value will be used.
# Attributes may be listed multiple times; subsequent instances will be used
# in that case.
#
# If the query is the same as the one in the previous request, the query is 
# not reparsed, only re-executed (possibly using new bind variable values).
# This allows you to choose in the behaviour file whether you want to 
# put your values in the query, or use a fixed query and bind variables;
# the latter is much more efficient for most databases, especially Oracle.
#
# Each column returned by the query is sent to OpenRADIUS as 'columnname =
# value'. This allows the mapping SQL fields to RADIUS attributes to be done
# using 'AS' clauses in the SQL query instead of a fixed table as with radldap.
#
# There is one exception. If the name of a column is 'attribute', then its
# value will be used as the fieldname for the next column, instead of the
# fieldname as given by the table or 'AS' clause. This allows you to orient
# attribute sets vertically as well as horizontally (select ... as attribute,
# value from ...).
#
# Author: Emile van Bergen, emile@evbergen.xs4all.nl
#
# Permission to redistribute an original or modified version of this program in
# source, intermediate or object code form is hereby granted exclusively under
# the terms of the GNU General Public License, version 2. Please see the file
# COPYING for details, or refer to http://www.gnu.org/copyleft/gpl.html.
#
# History: 
# 2003/04/24 - EvB - Started
# 2003/04/28 - EvB - Added vertical attribute sets (select attribute, value...)
# 2003/05/01 - EvB - Added variable bind attribute set. Previously only str and 
#                    int, in fixed order (first all strs, then all ints).
#                  - Moved check item support from radchecksql to here
# 2004/08/08 - EvB - Added flag to turn autocommit off. Useful for postgres.
# 2005/10/13 - EvB - Fixed case in which certain ints could be parsed as 
# 		     IP addresses and thus bound incorrectly to SQL


########
# USES #
########

use Getopt::Long;
use DBI qw(:sql_types);
use strict qw(vars);


###########
# OPTIONS #
###########

my $usage = 0;
my $debug = 0;
my $noint = 0;
my $check = 0;
my $noautoc = 0;


########
# MAIN #
########

# Get options

Getopt::Long::Configure("bundling");
GetOptions("h"  => \$usage,
	   "d+" => \$debug,
	   "n"  => \$noint,
	   "a"  => \$noautoc,
	   "c"  => \$check);

if ($usage || !$ARGV[2]) {
    die("Usage: radsql [-d] [-n] [-a] [-c] database dbuser dbpass\n" .
        "       radsql -h\n");
}

# Check that we're running under OpenRADIUS, interface version 1

unless ($debug ||
	$ENV{'RADIUSINTERFACEVERSION'} &&
	$ENV{'RADIUSINTERFACEVERSION'} == 1) {
	die "radsql: ERROR: not running under OpenRADIUS, interface v1!\n";
}

# Connect to database

my $dbh = DBI->connect("dbi:" . $ARGV[0], $ARGV[1], $ARGV[2], { AutoCommit => !$noautoc }) or die "ERROR: Could not connect to @ARGV!\n";

# Set record separator to empty line and loop on input.

$/ = "\n\n";
$| = 1;			# Important - we're outputting to a pipe

my $sql;
my $lastsql;
my $sth;
my $a;
my $v;
my $t;
my $n;
my $ca;
my $cv;
my $co;
my $r;
my %pairs;
my %types;
my @bindvars;
my $lastidvar;
my $colcnt;
my $colref;
my $valref;

MESG: 
while(<STDIN>) {

	# get pairs from message as hash of array refs

	%pairs = ();
	%types = ();
	PAIR: 
	while(s/^\s*
	        ([A-Za-z0-9:-]+)			    # attribute ($1)
		\s*=\s*
		(
		  (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}).*|   # ip ($3)
		  (\d+).*|				    # int or date ($4)
		  "([^"]*)".*|				    # quoted str ($5)
		  ([^"].*)				    # bare str ($6)
		)
		(\n|$)//mx) {

	    $a = $1;
	    if (defined $4) {
		$v = $4; 
		$types{$a} = 1; 
	    } else {
		if (defined $3) { $v = $3; }
		if (defined $5) { $v = $5; }
		elsif (defined $6) { $v = $6; }
		$v =~ s/\\x([a-fA-F0-9]{1,2})/pack("H2", $1)/ge; 
		$types{$a} = 0; 
	    }

	    push @{$pairs{$a}}, $v;
	    print STDERR "parsing:   a=[$a] v=[$v] t=[$types{$a}]\n"
		if ($debug > 1);
	}

	# Get SQL statement and list of attribute names for bind variables

	$sql = shift @{$pairs{str}};
	$t = shift @{$pairs{str}};
	if (defined $t) { 
	    ($t, $lastidvar) = split('/', $t);
	    @bindvars = split(',', $t); 
	}
	else { @bindvars = (); $t = ''; }
	print STDERR "statement: [$sql]\nbindlist:  [$t]\n" if ($debug);
	if ($debug > 1) {
	    foreach $a (keys %pairs) { print STDERR "pair:      a=[$a] v=[@{$pairs{$a}}] isint=$types{$a}\n"; }
	}
	next MESG unless $sql;

	# Trap COMMIT and ROLLBACK; DBI requires us to use its own abstractions
	# for whatever reason

	if (uc $sql eq "COMMIT")   { $r = $dbh->commit();   next MESG; }
	if (uc $sql eq "ROLLBACK") { $r = $dbh->rollback(); next MESG; }

	# Prepare statement if not same as last one

	if (!$sth || $sql ne $lastsql) {
	    if ($sth) { $sth->finish; }
	    $sth = $dbh->prepare($sql) or die "ERROR: Could not parse SQL!\n";
	    $lastsql = $sql;
	}

	# Replace attribute names in bind var array with ref to actual
	# value, type

	foreach $a (@bindvars) { $a = [$a, shift @{$pairs{$a}}, $types{$a}]; }

	# Bind the variables

	$n = 0;
	foreach $a (@bindvars) {
	    $n++;
	    if (!defined $a->[2]) { 
		$debug and print STDERR "bindvar $n: NULL\n"; 
		$sth->bind_param($n, undef);
		next;
	    }
	    print STDERR "bindvar $n: a=[$a->[0]] v=[$a->[1]] i=[$a->[2]]\n" 
		if $debug;
	    $sth->bind_param($n, $a->[1], $a->[2] ? SQL_INTEGER : SQL_VARCHAR)
		or die "ERROR: Could not bind variable $n!\n";
	}

	# Execute statement
	
	$r = $sth->execute or die "ERROR: Could not execute SQL!\n";
	if ($r eq "0E0") { $r = 1; }	# 'NULL' records affected equals success

	# See if an attribute was given to hold the 'last_insert_id', possibly
	# together with a sequence name, as required by some DBDs.

	if (defined($lastidvar)) {
	    ($lastidvar, my $lastidseq) = split('=', $lastidvar);
	    if (!defined($dbh->can('last_insert_id'))) {
		# DBD::Mysql should implement last_insert_id, but doesn't.
		# We test for that instead of mysql_lastid though, so that it 
		# can better its ways without us having to do anything.
		print STDERR "lastidvar: a=[$lastidvar] (using mysql_lastid)\n";
		print "$lastidvar=" . $sth->{mysql_lastid} . "\n";
	    }
	    elsif (defined($lastidseq)) {
		# Could be further qualified using dots or whatever, if needed
		print STDERR "lastidvar: a=[$lastidvar] seq=[$lastidseq]\n";
		print "$lastidvar=" . 
		      $dbh->last_insert_id(undef,undef,undef,undef,{sequence=>$lastidseq}) .
		      "\n";
	    }
	    else {
		print STDERR "lastidvar: a=[$lastidvar]\n";
		print "$lastidvar=" . 
		      $dbh->last_insert_id(undef, undef, undef, undef) .
		      "\n";
	    }
	}

	# If no columns returned, we're done

	$colcnt = $sth->{NUM_OF_FIELDS};
	next MESG unless $colcnt;

	# If we're not doing the check item thing, return rows of columns

	if ($check == 0) {
	    $colref = $sth->{NAME};
	    $r = 0;
	    while($valref = $sth->fetchrow_arrayref) {
		COL: for($n = 0; $n < $colcnt; $n++) {
		    next COL unless defined $valref->[$n];
		    $a = $colref->[$n];
		    if ($a eq 'attribute') { $a = $valref->[$n++]; }
		    $v = $valref->[$n];
		    $v =~ s/([\\'"\x00-\x1f\x7f-\xff])/"\\x" . unpack('H2', $1)/ge;
		    print "$a=$v\n";
		    print STDERR "returning: $a=[$v]\n" if $debug;
		}
		$r++;
	    }
	    next MESG;
	}

	# Otherwise, do the check item thing

	if ($colcnt != 3) {
	    die "ERROR: Radcheck query returns $colcnt columns instead of 3!\n";
	}

	$r = -1;
	ROW: while(($ca, $co, $cv) = $sth->fetchrow_array) {

	    $v = ${$pairs{$ca}}[0]; 
	    if ($types{$ca}) {
		$v = 0 unless defined $v;
		OP: {
		    $r &= $v <  $cv, last OP if $co eq '<';
		    $r &= $v <= $cv, last OP if $co eq '<=';
		    $r &= $v != $cv, last OP if $co eq '!=';
		    $r &= $v >= $cv, last OP if $co eq '>=';
		    $r &= $v >  $cv, last OP if $co eq '>';
		    $r &= $v == $cv;
		}
	    } else {
		$v = '' unless defined $v;
		OP: { 
		    $r &= $v lt $cv, last OP if $co eq '<';
		    $r &= $v le $cv, last OP if $co eq '<=';
		    $r &= $v ne $cv, last OP if $co eq '!=';
		    $r &= $v ge $cv, last OP if $co eq '>=';
		    $r &= $v gt $cv, last OP if $co eq '>';
		    $r &= $v eq $cv;
		}
	    }
	    print STDERR "a=[$ca] cv=[$cv] co=[$co] v=[$v] r=[$r]\n"
		if ($debug > 1);
	}
}
continue {
	
	print STDERR "returning: r=[$r]\n" if $debug;
	print "int=$r\n" unless $noint;
	print "\n";
}

# vim:softtabstop=4:sw=4