Простой пример использования rlm_perl во FreeRadius2

Вопросы по UTM 3.0 и UTM 4.0 (поддержка прекращена)
Закрыто
Аватара пользователя
marvin
Сообщения: 77
Зарегистрирован: Сб мар 24, 2007 11:18
Откуда: Нижняя Тура

Простой пример использования rlm_perl во FreeRadius2

Сообщение marvin »

Выкладываю на всякий случай экспериментальный perl скрипт для FreeRadius 2.x:

Код: Выделить всё

#
#  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&#40;%RAD_REQUEST %RAD_REPLY %RAD_CHECK&#41;;
use Data&#58;&#58;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 &#40;user is locked out&#41; */
    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 &#40;pairs modified&#41; */
    use constant    RLM_MODULE_NUMCODES=>  9;#  /* How many return codes there are */

#  Global variables can persist across different calls to the module.
#
#
#       &#123;
#        my %static_global_hash = &#40;&#41;;
#
#               sub post_auth &#123;
#               ...
#               &#125;
#               ...
#       &#125;

my $dbh;

sub CLONE&#40;&#41;&#123;
    $dbh = DBI->connect&#40;"DBI&#58;mysql&#58;UTM", 'root', ''&#41; or return RLM_MODULE_FAIL;
&#125;

# Function to handle authorize
sub authorize &#123;
    # For debugging purposes only
    # &log_request_attributes;

    # Here's where your authorization code comes
    # You can call another function from here&#58;
    # &test_call;

    my $query = $dbh->prepare&#40;"SELECT password FROM users WHERE login = '$RAD_REQUEST&#123;'User-Name'&#125;'"&#41;;
    $query->execute&#40;&#41;; my $row = $query->fetchrow_hashref;

    $RAD_CHECK&#123;'Cleartext-Password'&#125; = $row->&#123;password&#125;;

    return RLM_MODULE_OK;
&#125;

# Function to handle authenticate
sub authenticate &#123;
    # For debugging purposes only
    # &log_request_attributes;

    if &#40;$RAD_REQUEST&#123;'User-Name'&#125; =~ /^baduser/i&#41; &#123;
        # Reject user and tell him why
        $RAD_REPLY&#123;'Reply-Message'&#125; = "Denied access by rlm_perl function";
        return RLM_MODULE_REJECT;
    &#125; else &#123;
        # Accept user and set some attribute
        $RAD_REPLY&#123;'some-attribute'&#125; = "null";
        return RLM_MODULE_OK;
    &#125;
&#125;

# Function to handle preacct
sub preacct &#123;
    # For debugging purposes only
    # &log_request_attributes;

    return RLM_MODULE_OK;
&#125;

# Function to handle accounting
sub accounting &#123;
    # For debugging purposes only
    # &log_request_attributes;

    # You can call another subroutine from here
    # &test_call;

    if&#40;$RAD_REQUEST&#123;'Acct-Status-Type'&#125; ne 'Stop'&#41;&#123;
        $dbh->do&#40;"INSERT INTO radius_packets_accounting
                    &#40;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 &#41;
                    SELECT NULL, users.id, unix_timestamp&#40;now&#40;&#41;&#41;, 4, 10, '', '$RAD_REQUEST&#123;'Framed-IP-Address'&#125;', '$RAD_REQUEST&#123;'Acct-Authentic'&#125;', '$RAD_REQUEST&#123;'NAS-Port'&#125;', '$RAD_REQUEST&#123;'Acct-Delay-Time'&#125;', '$RAD_REQUEST&#123;'Service-Type'&#125;', '$RAD_REQUEST&#123;'Acct-Session-Id'&#125;', '$RAD_REQUEST&#123;'NAS-Port-Type'&#125;', '$RAD_REQUEST&#123;'User-Name'&#125;', '$RAD_REQUEST&#123;'Framed-Protocol'&#125;', '$RAD_REQUEST&#123;'NAS-IP-Address'&#125;', 1, 0, 0, 0, 0, 0 FROM users WHERE users.login='$RAD_REQUEST&#123;'User-Name'&#125;'"&#41;;
    &#125; else &#123;
        $dbh->do&#40;"INSERT INTO radius_packets_accounting
                    &#40;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 &#41;
                    SELECT NULL, users.id, unix_timestamp&#40;now&#40;&#41;&#41;, 4, 20, '', '$RAD_REQUEST&#123;'Framed-IP-Address'&#125;', '$RAD_REQUEST&#123;'Acct-Authentic'&#125;', '$RAD_REQUEST&#123;'NAS-Port'&#125;', '$RAD_REQUEST&#123;'Acct-Delay-Time'&#125;', '$RAD_REQUEST&#123;'Service-Type'&#125;', '$RAD_REQUEST&#123;'Acct-Session-Id'&#125;', '$RAD_REQUEST&#123;'NAS-Port-Type'&#125;', '$RAD_REQUEST&#123;'User-Name'&#125;', '$RAD_REQUEST&#123;'Framed-Protocol'&#125;', '$RAD_REQUEST&#123;'NAS-IP-Address'&#125;', 2, '$RAD_REQUEST&#123;'Acct-Input-Packets'&#125;', '$RAD_REQUEST&#123;'Acct-Input-Octets'&#125;', '$RAD_REQUEST&#123;'Acct-Output-Packets'&#125;', '$RAD_REQUEST&#123;'Acct-Output-Octets'&#125;', '$RAD_REQUEST&#123;'Acct-Session-Time'&#125;' FROM users WHERE users.login='$RAD_REQUEST&#123;'User-Name'&#125;'"&#41;;
    &#125;

    return RLM_MODULE_OK;
&#125;

# Function to handle checksimul
sub checksimul &#123;
    # For debugging purposes only
    # &log_request_attributes;

    return RLM_MODULE_OK;
&#125;

# Function to handle pre_proxy
sub pre_proxy &#123;
    # For debugging purposes only
    # &log_request_attributes;

    return RLM_MODULE_OK;
&#125;

# Function to handle post_proxy
sub post_proxy &#123;
    # For debugging purposes only
    # &log_request_attributes;

    return RLM_MODULE_OK;
&#125;

# Function to handle post_auth
sub post_auth &#123;
    # For debugging purposes only
    # &log_request_attributes;

    my $query = $dbh->prepare&#40;
        "SELECT inet_ntoa&#40;ip_addr.ip_addr&#41; AS ip
            FROM users, ip_addr
                LEFT JOIN ip_addr_used ON &#40;ip_addr.ip_addr=ip_addr_used.ip_addr AND ip_addr_used.use_end_date=0&#41;
            WHERE &#40;users.login LIKE '$RAD_REQUEST&#123;'User-Name'&#125;'
                AND ip_addr.uid = users.id AND ip_addr_used.ip_addr IS NULL&#41;
                OR &#40;users.login LIKE '$RAD_REQUEST&#123;'User-Name'&#125;'
                AND ip_addr.uid=users.id AND ip_addr_used.ip_addr IS NOT NULL&#41;
            ORDER BY ip_addr_used.use_start_date LIMIT 1"&#41;;

    $query->execute&#40;&#41;; my $row = $query->fetchrow_hashref;

    $RAD_REPLY&#123;'Framed-IP-Address'&#125; = $row->&#123;ip&#125;;
    $RAD_REPLY&#123;'Framed-IP-Netmask'&#125; = "255.255.255.255";

    $dbh->do&#40;"UPDATE ip_addr_used SET use_end_date = unix_timestamp&#40;now&#40;&#41;&#41;
                WHERE ip_addr = inet_aton&#40;'$RAD_REPLY&#123;'Framed-IP-Address'&#125;'&#41;
                    AND use_start_date != unix_timestamp&#40;now&#40;&#41;&#41;
                    AND use_end_date = 0"&#41;;

    $dbh->do&#40;"INSERT INTO ip_addr_used
                SELECT NULL, inet_aton&#40;'$RAD_REPLY&#123;'Framed-IP-Address'&#125;'&#41;, users.id, unix_timestamp&#40;now&#40;&#41;&#41;, 0, 0
                    FROM users
                    WHERE users.login LIKE '$RAD_REQUEST&#123;'User-Name'&#125;'"&#41;;

    return RLM_MODULE_OK;
&#125;

# Function to handle xlat
sub xlat &#123;
    # For debugging purposes only
    # &log_request_attributes;

    # Loads some external perl and evaluate it
    my &#40;$filename,$a,$b,$c,$d&#41; = @_;
    &radiusd&#58;&#58;radlog&#40;1, "From xlat $filename "&#41;;
    &radiusd&#58;&#58;radlog&#40;1,"From xlat $a $b $c $d "&#41;;
    local *FH;
    open FH, $filename or die "open '$filename' $!";
    local&#40;$/&#41; = undef;
    my $sub = <FH>;
    close FH;
    my $eval = qq&#123; sub handler&#123; $sub;&#125; &#125;;
    eval $eval;
    eval &#123;main->handler;&#125;;
&#125;

# Function to handle detach
sub detach &#123;
    # For debugging purposes only
    # &log_request_attributes;

    # Do some logging.
    &radiusd&#58;&#58;radlog&#40;0,"rlm_perl&#58;&#58;Detaching. Reloading. Done."&#41;;
&#125;

#
# Some functions that can be called from other functions
#

sub test_call &#123;
    # Some code goes here
&#125;

sub log_request_attributes &#123;
    # This shouldn't be done in production environments!
    # This is only meant for debugging!
    for &#40;keys %RAD_REQUEST&#41; &#123;
        &radiusd&#58;&#58;radlog&#40;1, "RAD_REQUEST&#58; $_ = $RAD_REQUEST&#123;$_&#125;"&#41;;
    &#125;
&#125;

Закрыто