Код: Выделить всё
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
#
# Copyright 2002 The FreeRADIUS server project
# Copyright 2002 Boian Jordanov <bjordanov@orbitel.bg>
#
#
# Example code for use with rlm_perl
#
# You can use every module that comes with your perl distribution!
#
# If you are using DBI and do some queries to DB, please be sure to
# use the CLONE function to initialize the DBI connection to DB.
#
use strict;
use DBI;
# use ...
# This is very important ! Without this script will not get the filled hashesh from main.
use vars qw(%RAD_REQUEST %RAD_REPLY %RAD_CHECK);
use Data::Dumper;
# This is hash wich hold original request from radius
#my %RAD_REQUEST;
# In this hash you add values that will be returned to NAS.
#my %RAD_REPLY;
#This is for check items
#my %RAD_CHECK;
#
# This the remapping of return values
#
use constant RLM_MODULE_REJECT=> 0;# /* immediately reject the request */
use constant RLM_MODULE_FAIL=> 1;# /* module failed, don't reply */
use constant RLM_MODULE_OK=> 2;# /* the module is OK, continue */
use constant RLM_MODULE_HANDLED=> 3;# /* the module handled the request, so stop. */
use constant RLM_MODULE_INVALID=> 4;# /* the module considers the request invalid. */
use constant RLM_MODULE_USERLOCK=> 5;# /* reject the request (user is locked out) */
use constant RLM_MODULE_NOTFOUND=> 6;# /* user not found */
use constant RLM_MODULE_NOOP=> 7;# /* module succeeded without doing anything */
use constant RLM_MODULE_UPDATED=> 8;# /* OK (pairs modified) */
use constant RLM_MODULE_NUMCODES=> 9;# /* How many return codes there are */
# Global variables can persist across different calls to the module.
#
#
# {
# my %static_global_hash = ();
#
# sub post_auth {
# ...
# }
# ...
# }
my $dbh;
sub CLONE(){
$dbh = DBI->connect("DBI:mysql:UTM", 'root', '') or return RLM_MODULE_FAIL;
}
# Function to handle authorize
sub authorize {
# For debugging purposes only
# &log_request_attributes;
# Here's where your authorization code comes
# You can call another function from here:
# &test_call;
my $query = $dbh->prepare("SELECT password FROM users WHERE login = '$RAD_REQUEST{'User-Name'}'");
$query->execute(); my $row = $query->fetchrow_hashref;
$RAD_CHECK{'Cleartext-Password'} = $row->{password};
return RLM_MODULE_OK;
}
# Function to handle authenticate
sub authenticate {
# For debugging purposes only
# &log_request_attributes;
if ($RAD_REQUEST{'User-Name'} =~ /^baduser/i) {
# Reject user and tell him why
$RAD_REPLY{'Reply-Message'} = "Denied access by rlm_perl function";
return RLM_MODULE_REJECT;
} else {
# Accept user and set some attribute
$RAD_REPLY{'some-attribute'} = "null";
return RLM_MODULE_OK;
}
}
# Function to handle preacct
sub preacct {
# For debugging purposes only
# &log_request_attributes;
return RLM_MODULE_OK;
}
# Function to handle accounting
sub accounting {
# For debugging purposes only
# &log_request_attributes;
# You can call another subroutine from here
# &test_call;
if($RAD_REQUEST{'Acct-Status-Type'} ne 'Stop'){
$dbh->do("INSERT INTO radius_packets_accounting
(id, uid, recv_date, Code, Identifier, Authentic, Framed_IP_Address, Acct_Authentic, NAS_Port, Acct_Delay_Time, Service_Type, Acct_Session_Id, NAS_Port_Type, User_Name,Framed_Protocol, NAS_IP_Address, Acct_Status_Type, Acct_Input_Packets, Acct_Input_Octets, Acct_Output_Packets, Acct_Output_Octets, Acct_Session_Time )
SELECT NULL, users.id, unix_timestamp(now()), 4, 10, '', '$RAD_REQUEST{'Framed-IP-Address'}', '$RAD_REQUEST{'Acct-Authentic'}', '$RAD_REQUEST{'NAS-Port'}', '$RAD_REQUEST{'Acct-Delay-Time'}', '$RAD_REQUEST{'Service-Type'}', '$RAD_REQUEST{'Acct-Session-Id'}', '$RAD_REQUEST{'NAS-Port-Type'}', '$RAD_REQUEST{'User-Name'}', '$RAD_REQUEST{'Framed-Protocol'}', '$RAD_REQUEST{'NAS-IP-Address'}', 1, 0, 0, 0, 0, 0 FROM users WHERE users.login='$RAD_REQUEST{'User-Name'}'");
} else {
$dbh->do("INSERT INTO radius_packets_accounting
(id, uid, recv_date, Code, Identifier, Authentic, Framed_IP_Address, Acct_Authentic, NAS_Port, Acct_Delay_Time, Service_Type, Acct_Session_Id, NAS_Port_Type, User_Name,Framed_Protocol, NAS_IP_Address, Acct_Status_Type, Acct_Input_Packets, Acct_Input_Octets, Acct_Output_Packets, Acct_Output_Octets, Acct_Session_Time )
SELECT NULL, users.id, unix_timestamp(now()), 4, 20, '', '$RAD_REQUEST{'Framed-IP-Address'}', '$RAD_REQUEST{'Acct-Authentic'}', '$RAD_REQUEST{'NAS-Port'}', '$RAD_REQUEST{'Acct-Delay-Time'}', '$RAD_REQUEST{'Service-Type'}', '$RAD_REQUEST{'Acct-Session-Id'}', '$RAD_REQUEST{'NAS-Port-Type'}', '$RAD_REQUEST{'User-Name'}', '$RAD_REQUEST{'Framed-Protocol'}', '$RAD_REQUEST{'NAS-IP-Address'}', 2, '$RAD_REQUEST{'Acct-Input-Packets'}', '$RAD_REQUEST{'Acct-Input-Octets'}', '$RAD_REQUEST{'Acct-Output-Packets'}', '$RAD_REQUEST{'Acct-Output-Octets'}', '$RAD_REQUEST{'Acct-Session-Time'}' FROM users WHERE users.login='$RAD_REQUEST{'User-Name'}'");
}
return RLM_MODULE_OK;
}
# Function to handle checksimul
sub checksimul {
# For debugging purposes only
# &log_request_attributes;
return RLM_MODULE_OK;
}
# Function to handle pre_proxy
sub pre_proxy {
# For debugging purposes only
# &log_request_attributes;
return RLM_MODULE_OK;
}
# Function to handle post_proxy
sub post_proxy {
# For debugging purposes only
# &log_request_attributes;
return RLM_MODULE_OK;
}
# Function to handle post_auth
sub post_auth {
# For debugging purposes only
# &log_request_attributes;
my $query = $dbh->prepare(
"SELECT inet_ntoa(ip_addr.ip_addr) AS ip
FROM users, ip_addr
LEFT JOIN ip_addr_used ON (ip_addr.ip_addr=ip_addr_used.ip_addr AND ip_addr_used.use_end_date=0)
WHERE (users.login LIKE '$RAD_REQUEST{'User-Name'}'
AND ip_addr.uid = users.id AND ip_addr_used.ip_addr IS NULL)
OR (users.login LIKE '$RAD_REQUEST{'User-Name'}'
AND ip_addr.uid=users.id AND ip_addr_used.ip_addr IS NOT NULL)
ORDER BY ip_addr_used.use_start_date LIMIT 1");
$query->execute(); my $row = $query->fetchrow_hashref;
$RAD_REPLY{'Framed-IP-Address'} = $row->{ip};
$RAD_REPLY{'Framed-IP-Netmask'} = "255.255.255.255";
$dbh->do("UPDATE ip_addr_used SET use_end_date = unix_timestamp(now())
WHERE ip_addr = inet_aton('$RAD_REPLY{'Framed-IP-Address'}')
AND use_start_date != unix_timestamp(now())
AND use_end_date = 0");
$dbh->do("INSERT INTO ip_addr_used
SELECT NULL, inet_aton('$RAD_REPLY{'Framed-IP-Address'}'), users.id, unix_timestamp(now()), 0, 0
FROM users
WHERE users.login LIKE '$RAD_REQUEST{'User-Name'}'");
return RLM_MODULE_OK;
}
# Function to handle xlat
sub xlat {
# For debugging purposes only
# &log_request_attributes;
# Loads some external perl and evaluate it
my ($filename,$a,$b,$c,$d) = @_;
&radiusd::radlog(1, "From xlat $filename ");
&radiusd::radlog(1,"From xlat $a $b $c $d ");
local *FH;
open FH, $filename or die "open '$filename' $!";
local($/) = undef;
my $sub = <FH>;
close FH;
my $eval = qq{ sub handler{ $sub;} };
eval $eval;
eval {main->handler;};
}
# Function to handle detach
sub detach {
# For debugging purposes only
# &log_request_attributes;
# Do some logging.
&radiusd::radlog(0,"rlm_perl::Detaching. Reloading. Done.");
}
#
# Some functions that can be called from other functions
#
sub test_call {
# Some code goes here
}
sub log_request_attributes {
# This shouldn't be done in production environments!
# This is only meant for debugging!
for (keys %RAD_REQUEST) {
&radiusd::radlog(1, "RAD_REQUEST: $_ = $RAD_REQUEST{$_}");
}
}