Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • smradius/smradius
  • centiva-shail/smradius
  • nkukard/smradius
3 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 4688 additions and 219 deletions
dicts/dictionary.versanet deleted 100644 → 0
View file @ d7135ca2
#
# dictionary.versanet Vendor specfic attributes for versanet
#
#
# VersaNet Communications, Inc.
# Http://www.versa-net.com
#
#
#Versanet add Vendor specific terminal cause in our radius group.
#You can follow this to set it in NAS box.
#
# >> gr radius
# >> sh
# >> set 34 23
# >> co
#
#This will let our unit transfer every detail terminal cause
#information to Redius server's accounting log file and
#save as "Vendor Specific=Terminate Cause".
#
# Version: @(#)dictionary.versanet 1.00 22-Jul-1999 support@versanetcomm.com
#
VENDOR Versanet 2180
ATTRIBUTE Versanet-Termination-Cause 1 integer Versanet
VALUE Versanet-Termination-Cause Normal-Hangup-No-Error-Occurred 0
VALUE Versanet-Termination-Cause Call-Waiting-Caused-Disconnect 3
VALUE Versanet-Termination-Cause Physical-Carrier-Loss 4
VALUE Versanet-Termination-Cause No-err-correction-at-other-end 5
VALUE Versanet-Termination-Cause No-resp-to-feature-negotiation 6
VALUE Versanet-Termination-Cause 1st-modem-async-only-2nd-sync 7
VALUE Versanet-Termination-Cause No-framing-technique-in-common 8
VALUE Versanet-Termination-Cause No-protocol-in-common 9
VALUE Versanet-Termination-Cause Bad-resp-to-feature-negotiation 10
VALUE Versanet-Termination-Cause No-sync-info-from-remote-modem 11
VALUE Versanet-Termination-Cause Normal-Hangup-by-Remote-modem 12
VALUE Versanet-Termination-Cause Retransmission-limit-reached 13
VALUE Versanet-Termination-Cause Protocol-violation-occurred 14
VALUE Versanet-Termination-Cause Lost-DTR 15
VALUE Versanet-Termination-Cause Received-GSTN-cleardown 16
VALUE Versanet-Termination-Cause Inactivity-timeout 17
VALUE Versanet-Termination-Cause Speed-not-supported 18
VALUE Versanet-Termination-Cause Long-space-disconnect 19
VALUE Versanet-Termination-Cause Key-abort-disconnect 20
VALUE Versanet-Termination-Cause Clears-previous-disc-reason 21
VALUE Versanet-Termination-Cause No-connection-established 22
VALUE Versanet-Termination-Cause Disconnect-after-three-retrains 23
dicts/dictionary.wispr
View file @ b659b33b
# Copyright (C) 2007-2016, AllWorldIT
# Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 The FreeRADIUS Server Project
#
# The following dictionary file is a derivative work of the dictionary file
# from the FreeRADIUS Server Project, which is licensed GPLv2. This file
# therefore is also licensed under the terms of the GNU Public License,
# verison 2
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
# dictionary.wispr
#
......
dicts/dictionary.xedia deleted 100644 → 0
View file @ d7135ca2
##############################################################################
#
# XEDIA, AP series routers
# From Yard RADIUS, and Piotr Orlewicz, porlewicz@teleton.pl www.real-data.pl
#
# $Id: dictionary.xedia,v 1.1 2006/11/14 17:44:59 lem Exp $
#
#############################################################################
VENDOR Xedia 838
ATTRIBUTE Xedia-DNS-Server 1 ipaddr Xedia
ATTRIBUTE Xedia-NetBios-Server 2 ipaddr Xedia
ATTRIBUTE Xedia-Address-Pool 3 string Xedia
ATTRIBUTE Xedia-PPP-Echo-Interval 4 integer Xedia
ATTRIBUTE Xedia-SSH-Privileges 5 integer Xedia
ATTRIBUTE Xedia-Client-Access-Network 6 string Xedia
Radius/Dictionary.pm → lib/smradius/Radius/Dictionary.pm
View file @ b659b33b
package Radius::Dictionary;
# COPYRIGHT AND LICENSE
#
# Copyright 2007-2016, AllWorldIT
#
# Original work (c) Christopher Masto. Changes (c) 2002,2003 Luis
# E. Muñoz <luismunoz@cpan.org>.
#
# This software can be used under the same terms as perl itself. It also
# carries the same warranties.
#
# Please send bug reports (or patches) as well as feedback and
# suggestions to
#
# luismunoz@cpan.org
#
# When submitting bugs, it is very important that you include the
# relevant information for reproducing the bug. Packet dumps are most
# useful.
package smradius::Radius::Dictionary;
use strict;
use warnings;
......@@ -31,9 +50,9 @@ sub new {
sub readfile {
my ($self, $filename) = @_;
open(DICT, "< $filename") or return undef;
open(my $DICT, "<", $filename) or return;
while (defined(my $l = <DICT>)) {
while (defined(my $l = <$DICT>)) {
next if $l =~ /^\#/;
next unless my @l = split /\s+/, $l;
......@@ -166,7 +185,8 @@ sub readfile {
warn "Warning: Weird dictionary line: $l\n";
}
}
close DICT;
close $DICT;
return 1;
}
# Accessors for standard attributes
......
Radius/Packet.pm → lib/smradius/Radius/Packet.pm
View file @ b659b33b
package Radius::Packet;
# COPYRIGHT AND LICENSE
#
# Copyright 2007-2016, AllWorldIT
#
# Original work (c) Christopher Masto. Changes (c) 2002,2003 Luis
# E. Muñoz <luismunoz@cpan.org>.
#
# This software can be used under the same terms as perl itself. It also
# carries the same warranties.
#
# Please send bug reports (or patches) as well as feedback and
# suggestions to
#
# luismunoz@cpan.org
#
# When submitting bugs, it is very important that you include the
# relevant information for reproducing the bug. Packet dumps are most
# useful.
package smradius::Radius::Packet;
use strict;
require Exporter;
......@@ -13,7 +32,7 @@ $VSA = 26; # Type assigned in RFC2138 to the
# Vendor-Specific Attributes
# Be sure our dictionaries are current
use Radius::Dictionary 1.50;
use smradius::Radius::Dictionary 1.50;
use Carp;
use Socket;
use Digest::MD5;
......
lib/smradius/Radius/README.txt 0 → 100644
View file @ b659b33b
There are notable differences between Packet.pm and the Net::Radius Packet.pm, most notable raw value support.
smradius/attributes.pm → lib/smradius/attributes.pm
View file @ b659b33b
# Attribute handling functions
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2016, AllWorldIT
#
# 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
......@@ -24,24 +24,36 @@ use strict;
use warnings;
# Exporter stuff
require Exporter;
our (@ISA,@EXPORT);
@ISA = qw(Exporter);
use base qw(Exporter);
our (@EXPORT);
@EXPORT = qw(
addAttribute
checkAuthAttribute
checkAcctAttribute
setReplyAttribute
setReplyVAttribute
processConfigAttribute
getAttributeValue
addAttributeConditionalVariable
processAttributeConditionals
);
use AWITPT::Util;
# Check Math::Expression is installed
if (!eval {require Math::Expression; 1;}) {
print STDERR "You're missing Math::Expression, try 'apt-get install libmath-expression-perl'\n";
exit 1;
}
use smradius::logging;
use smradius::util;
# Attributes we do not handle
my @attributeCheckIgnoreList = (
'User-Password'
......@@ -51,13 +63,34 @@ my @attributeReplyIgnoreList = (
'SMRadius-Capping-Traffic-Limit',
'SMRadius-Capping-Uptime-Limit',
'SMRadius-Validity-ValidFrom',
'SMRadius-Validity-ValidTo'
'SMRadius-Validity-ValidTo',
'SMRadius-Validity-ValidWindow',
'SMRadius-Username-Transform',
'SMRadius-Evaluate',
'SMRadius-Peer-Address',
'SMRadius-Disable-WebUITopup',
'SMRadius-AutoTopup-Traffic-Enabled',
'SMRadius-AutoTopup-Traffic-Amount',
'SMRadius-AutoTopup-Traffic-Limit',
'SMRadius-AutoTopup-Traffic-Notify',
'SMRadius-AutoTopup-Traffic-NotifyTemplate',
'SMRadius-AutoTopup-Traffic-Threshold',
'SMRadius-AutoTopup-Uptime-Enabled',
'SMRadius-AutoTopup-Uptime-Amount',
'SMRadius-AutoTopup-Uptime-Limit',
'SMRadius-AutoTopup-Uptime-Notify',
'SMRadius-AutoTopup-Uptime-NotifyTemplate',
'SMRadius-AutoTopup-Uptime-Threshold',
'SMRadius-Config-Filter-Reply-Attribute',
'SMRadius-Config-Filter-Reply-VAttribute',
'SMRadius-FUP-Period',
'SMRadius-FUP-Traffic-Threshold',
);
my @attributeVReplyIgnoreList = (
);
## @fn addAttribute($server,$nattributes,$vattributes,$attribute)
## @fn addAttribute($server,$user,$attribute)
# Function to add an attribute to $attributes
#
# @param server Server instance
......@@ -66,17 +99,26 @@ my @attributeVReplyIgnoreList = (
# @param attribute Attribute to add, eg. Those from a database
sub addAttribute
{
my ($server,$nattributes,$vattributes,$attribute) = @_;
my ($server,$user,$attribute) = @_;
# Check we have the name, operator AND value
if (!defined($attribute->{'Name'}) || !defined($attribute->{'Operator'}) || !defined($attribute->{'Value'})) {
$server->log(LOG_DEBUG,"[ATTRIBUTES] Problem adding attribute with name = ".prettyUndef($attribute->{'Name'}).
", operator = ".prettyUndef($attribute->{'Operator'}).", value = ".prettyUndef($attribute->{'Value'}));
return;
}
# Clean them up a bit
$attribute->{'Name'} =~ s/\s*(\S+)\s*/$1/;
$attribute->{'Operator'} =~ s/\s*(\S+)\s*/$1/;
# Grab attribue name, operator and value
# Grab attribute name, operator and value
my $name = $attribute->{'Name'};
my $operator = $attribute->{'Operator'};
my $value = $attribute->{'Value'};
# Default attribute to add is normal
my $attributes = $nattributes;
my $attributes = $user->{'Attributes'};
# Check where we must add this attribute, maybe to the vendor attributes?
if ($name =~ /^\[(\d+):(\S+)\]$/) {
......@@ -86,7 +128,7 @@ sub addAttribute
# Reset attribute name
$attribute->{'Name'} = $name;
# Set the attributes to use to the vendor
$attributes = $vattributes;
$attributes = $user->{'VAttributes'};
}
# Check if this is an array
......@@ -109,6 +151,9 @@ sub addAttribute
} else {
$attributes->{$name}->{$operator} = $attribute;
}
# Process the item incase its a config attribute
return processConfigAttribute($server,$user,$attribute);
}
......@@ -121,7 +166,7 @@ sub addAttribute
# @param attribute Attribute to check, eg. One of the ones from the database
sub checkAuthAttribute
{
my ($server,$packetAttributes,$attribute) = @_;
my ($server,$user,$packetAttributes,$attribute) = @_;
# Check ignore list
......@@ -144,18 +189,21 @@ sub checkAuthAttribute
# Get packet attribute value
my $attrVal = $packetAttributes->{$attribute->{'Name'}};
$server->log(LOG_DEBUG,"[ATTRIBUTES] Processing CHECK attribute value ".niceUndef($attrVal)." against: '".
$server->log(LOG_DEBUG,"[ATTRIBUTES] Processing CHECK attribute value ".prettyUndef($attrVal)." against: '".
$attribute->{'Name'}."' ".$attribute->{'Operator'}." '".join("','",@attrValues)."'");
# Loop with all the test attribute values
foreach my $tattrVal (@attrValues) {
# Sanitize the operator
my ($operator) = ($attribute->{'Operator'} =~ /^(?:\|\|)?(.*)$/);
# Operator: ==
#
# Use: Attribute == Value
# As a check item, it matches if the named attribute is present in the request,
# AND has the given value.
#
if ($attribute->{'Operator'} eq '==' ) {
if ($operator eq '==' ) {
# Check for correct value
if (defined($attrVal) && $attrVal eq $tattrVal) {
$matched = 1;
......@@ -169,7 +217,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '>') {
} elsif ($operator eq '>') {
if (defined($attrVal) && $attrVal =~ /^[0-9]+$/) {
# Check for correct value
if ($attrVal > $tattrVal) {
......@@ -187,7 +235,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '<') {
} elsif ($operator eq '<') {
# Check for correct value
if (defined($attrVal) && $attrVal < $tattrVal) {
$matched = 1;
......@@ -201,7 +249,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '<=') {
} elsif ($operator eq '<=') {
# Check for correct value
if (defined($attrVal) && $attrVal <= $tattrVal) {
$matched = 1;
......@@ -215,7 +263,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '>=') {
} elsif ($operator eq '>=') {
# Check for correct value
if (defined($attrVal) && $attrVal >= $tattrVal) {
$matched = 1;
......@@ -229,7 +277,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '=*') {
} elsif ($operator eq '=*') {
# Check for matching value
if (defined($attrVal)) {
$matched = 1;
......@@ -243,9 +291,9 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '!=') {
} elsif ($operator eq '!=') {
# Check for correct value
if (defined($attrVal) && $attrVal ne $tattrVal) {
if (!defined($attrVal) || $attrVal ne $tattrVal) {
$matched = 1;
}
......@@ -257,7 +305,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '!*') {
} elsif ($operator eq '!*') {
# Skip if value not defined
if (!defined($attrVal)) {
$matched = 1;
......@@ -271,7 +319,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '=~') {
} elsif ($operator eq '=~') {
# Check for correct value
if (defined($attrVal) && $attrVal =~ /$tattrVal/) {
$matched = 1;
......@@ -286,7 +334,7 @@ sub checkAuthAttribute
#
# Not allowed as a reply item.
} elsif ($attribute->{'Operator'} eq '!~') {
} elsif ($operator eq '!~') {
# Check for correct value
if (defined($attrVal) && !($attrVal =~ /$tattrVal/)) {
$matched = 1;
......@@ -298,12 +346,114 @@ sub checkAuthAttribute
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
#
# As a reply item, it has an itendtical meaning, but the
# As a reply item, it has an idendtical meaning, but the
# attribute is added to the reply items.
} elsif ($operator eq '+=') {
# Check if we're a conditional and process
if ($attribute->{'Name'} eq "SMRadius-Evaluate") {
$matched = processConditional($server,$user,$attribute,$tattrVal);
} else {
$matched = 1;
}
# FIXME
# Operator: :=
#
# Use: Attribute := Value
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
} elsif ($operator eq ':=') {
# FIXME - Add or replace config items
# FIXME - Add attribute to request
# Check if we're a conditional and process
if ($attribute->{'Name'} eq "SMRadius-Evaluate") {
$matched = processConditional($server,$user,$attribute,$tattrVal);
} else {
$matched = 1;
}
# Attributes that are not defined
} else {
# Ignore
$matched = 2;
last;
}
}
# Some debugging info
if ($matched == 1) {
$server->log(LOG_DEBUG,"[ATTRIBUTES] - Attribute '".$attribute->{'Name'}."' matched");
} elsif ($matched == 2) {
$server->log(LOG_DEBUG,"[ATTRIBUTES] - Attribute '".$attribute->{'Name'}."' ignored");
} else {
$server->log(LOG_DEBUG,"[ATTRIBUTES] - Attribute '".$attribute->{'Name'}."' not matched");
}
return $matched;
}
## @fn checkAcctAttribute($server,$packetAttributes,$attribute)
# Function to check an attribute in the accounting stage
#
# @param server Server instance
# @param packetAttributes Hashref of attributes provided, eg. Those from the packet
# @param attribute Attribute to check, eg. One of the ones from the database
sub checkAcctAttribute
{
my ($server,$user,$packetAttributes,$attribute) = @_;
# Check ignore list
foreach my $ignoredAttr (@attributeCheckIgnoreList) {
# 2 = IGNORE, so return IGNORE for all ignored items
return 2 if ($attribute->{'Name'} eq $ignoredAttr);
}
# Matched & ok?
my $matched = 0;
# Figure out our attr values
my @attrValues;
if (ref($attribute->{'Value'}) eq "ARRAY") {
@attrValues = @{$attribute->{'Value'}};
} else {
@attrValues = ( $attribute->{'Value'} );
}
# Get packet attribute value
my $attrVal = $packetAttributes->{$attribute->{'Name'}};
$server->log(LOG_DEBUG,"[ATTRIBUTES] Processing CHECK attribute value ".prettyUndef($attrVal)." against: '".
$attribute->{'Name'}."' ".$attribute->{'Operator'}." '".join("','",@attrValues)."'");
# Loop with all the test attribute values
foreach my $tattrVal (@attrValues) {
# Sanitize the operator
my ($operator) = ($attribute->{'Operator'} =~ /^(?:\|\|)?(.*)$/);
# Operator: +=
#
# Use: Attribute += Value
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
#
# As a reply item, it has an idendtical meaning, but the
# attribute is added to the reply items.
} elsif ($attribute->{'Operator'} eq '+=') {
# FIXME - Add to config items
$matched = 1;
if ($operator eq '+=') {
# Check if we're a conditional and process
if ($attribute->{'Name'} eq "SMRadius-Evaluate") {
$matched = processConditional($server,$user,$attribute,$tattrVal);
} else {
$matched = 1;
}
# FIXME
# Operator: :=
......@@ -311,10 +461,16 @@ sub checkAuthAttribute
# Use: Attribute := Value
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
} elsif ($attribute->{'Operator'} eq ':=') {
} elsif ($operator eq ':=') {
# FIXME - Add or replace config items
# FIXME - Add attribute to request
$matched = 1;
# Check if we're a conditional and process
if ($attribute->{'Name'} eq "SMRadius-Evaluate") {
$matched = processConditional($server,$user,$attribute,$tattrVal);
} else {
$matched = 1;
}
# Attributes that are not defined
} else {
......@@ -394,7 +550,7 @@ sub setReplyAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# If no attribute of that name appears in the request, then this attribute is added.
#
# As a reply item, it has an itendtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an idendtical meaning, but for the reply items, instead of the request items.
} elsif ($attribute->{'Operator'} eq ':=') {
# Overwrite
......@@ -409,7 +565,7 @@ sub setReplyAttribute
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
#
# As a reply item, it has an itendtical meaning, but the
# As a reply item, it has an idendtical meaning, but the
# attribute is added to the reply items.
} elsif ($attribute->{'Operator'} eq '+=') {
......@@ -420,9 +576,8 @@ sub setReplyAttribute
# Attributes that are not defined
} else {
# Ignore and b0rk out
# Ignore invalid operator
$server->log(LOG_NOTICE,"[ATTRIBUTES] - Attribute '".$attribute->{'Name'}."' ignored, invalid operator?");
last;
}
return;
......@@ -459,7 +614,7 @@ sub setReplyVAttribute
@attrValues = ( $attribute->{'Value'} );
}
$server->log(LOG_DEBUG,"[VATTRIBUTES] Processing REPLY attribute: '".
$server->log(LOG_DEBUG,"[VATTRIBUTES] Processing REPLY vattribute: '".
$attribute->{'Name'}."' ".$attribute->{'Operator'}." '".join("','",@attrValues)."'");
......@@ -489,7 +644,7 @@ sub setReplyVAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# If no attribute of that name appears in the request, then this attribute is added.
#
# As a reply item, it has an itendtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an idendtical meaning, but for the reply items, instead of the request items.
} elsif ($attribute->{'Operator'} eq ':=') {
# Overwrite
......@@ -504,7 +659,7 @@ sub setReplyVAttribute
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
#
# As a reply item, it has an itendtical meaning, but the
# As a reply item, it has an idendtical meaning, but the
# attribute is added to the reply items.
} elsif ($attribute->{'Operator'} eq '+=') {
......@@ -526,7 +681,7 @@ sub setReplyVAttribute
## @fn processConfigAttribute($server,$packetAttributes,$attribute)
## @fn processConfigAttribute($server,$user,$attribute)
# Function to process a configuration attribute
#
# @param server Server instance
......@@ -534,11 +689,13 @@ sub setReplyVAttribute
# @param attribute Attribute to process, eg. One of the ones from the database
sub processConfigAttribute
{
my ($server,$configAttributes,$attribute) = @_;
my ($server,$user,$attribute) = @_;
# Make things easier?
my $configAttributes = $user->{'ConfigAttributes'};
# Matched & ok?
my $matched = 0;
# Did we get processed?
my $processed = 0;
# Figure out our attr values
my @attrValues;
......@@ -548,21 +705,18 @@ sub processConfigAttribute
@attrValues = ( $attribute->{'Value'} );
}
$server->log(LOG_DEBUG,"[ATTRIBUTES] Processing CONFIG attribute: '".$attribute->{'Name'}."' ".
$attribute->{'Operator'}." '".join("','",@attrValues)."'");
# Operator: +=
#
# Use: Attribute += Value
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
#
# As a reply item, it has an itendtical meaning, but the
# As a reply item, it has an idendtical meaning, but the
# attribute is added to the reply items.
if ($attribute->{'Operator'} eq '+=') {
$server->log(LOG_DEBUG,"[ATTRIBUTES] Operator '+=' triggered: Adding item to configuration items.");
push(@{$configAttributes->{$attribute->{'Name'}}},@attrValues);
$processed = 1;
# Operator: :=
#
......@@ -570,17 +724,21 @@ sub processConfigAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# If no attribute of that name appears in the request, then this attribute is added.
#
# As a reply item, it has an itendtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an idendtical meaning, but for the reply items, instead of the request items.
} elsif ($attribute->{'Operator'} eq ':=') {
$server->log(LOG_DEBUG,"[ATTRIBUTES] Operator ':=' triggered: Adding or replacing item in configuration items.");
@{$configAttributes->{$attribute->{'Name'}}} = @attrValues;
$processed = 1;
# Operators that are not defined
} else {
# Ignore
$server->log(LOG_DEBUG,"[ATTRIBUTES] - Attribute '".$attribute->{'Name'}."' ignored");
}
# If we got procsessed output some debug
if ($processed) {
$server->log(LOG_DEBUG,"[ATTRIBUTES] Processed CONFIG attribute: '".$attribute->{'Name'}."' ".
$attribute->{'Operator'}." '".join("','",@attrValues)."'");
}
return $processed;
}
......@@ -606,6 +764,113 @@ sub getAttributeValue
}
## @fn addAttributeConditionalVariable($user,$name,$value)
# Function that adds a conditional variable
#
# @param user User hash
# @param name Variable name
# @param value Variable value
sub addAttributeConditionalVariable
{
my ($user,$name,$value) = @_;
$user->{'AttributeConditionalVariables'}->{$name} = [ $value ];
return;
}
## @fn processConditional($server,$user,$attribute,$attrVal)
# This function processes a attribute conditional
#
# @param server Server hash
# @param user User hash
# @param attribute Attribute hash to process
# @param attrVal Current value we need to process
sub processConditional
{
my ($server,$user,$attribute,$attrVal) = @_;
# Split off expression
# NK: This probably needs a bit of work
my ($condition,$onTrue,$onFalse) = ($attrVal =~ /^([^\?]*)(?:\?\s*((?:\S+)?[^:]*)(?:\:\s*(.*))?)?$/);
# If there is no condition we cannot really continue?
if (!defined($condition)) {
$server->log(LOG_WARN,"[ATTRIBUTES] Conditional '$attrVal' cannot be parsed");
return 1;
}
$server->log(LOG_DEBUG,"[ATTRIBUTES] Conditional parsed ".$attribute->{'Name'}." => if ($condition) then {".
( $onTrue ? $onTrue : "-undef-")."} else {".( $onFalse ? $onFalse : "-undef-")."}");
# Create the environment
my @error;
my $mathEnv = Math::Expression->new(
'PrintErrFunc' => sub { @error = @_ },
'VarHash' => $user->{'AttributeConditionalVariables'}
);
# Parse and create math tree
my $mathTree = $mathEnv->Parse($condition);
# Check for error
if (@error) {
my $errorStr = sprintf($error[0],$error[1]);
$server->log(LOG_WARN,"[ATTRIBUTES] Conditional '$condition' in '$attrVal' does not parse: $errorStr");
return 1;
}
# Evaluate tree
my $res = $mathEnv->Eval($mathTree);
if (!defined($res)) {
$server->log(LOG_WARN,"[ATTRIBUTES] Conditional '$condition' in '$attrVal' does not evaluate");
return 1;
}
# Check result
# If we have a onTrue or onFalse we will return "Matched = True"
# If we don't have an onTrue or onFalse we will return the result of the $condition
my $attribStr;
if ($res && defined($onTrue)) {
$attribStr = $onTrue;
$res = 1;
} elsif (!$res && defined($onFalse)) {
$attribStr = $onFalse;
$res = 1;
} elsif (defined($onTrue) || defined($onFalse)) {
$res = 1;
}
$server->log(LOG_DEBUG,"[ATTRIBUTES] - Evaluated to '$res' returning '".(defined($attribStr) ? $attribStr : "-undef-")."'");
# Loop with attributes:
# We only get here if $res is set to 1 above, if its only a conditional with no onTrue & onFalse
# Then attribStr will be unef
if ($res && defined($attribStr)) {
# Sanitize the output
$attribStr =~ s/^\s*//;
$attribStr =~ s/\s*$//;
foreach my $rawAttr (split(/;/,$attribStr)) {
# Split off attribute string: name = value
my ($attrName,$attrVal) = ($rawAttr =~ /^\s*([^=]+)=\s*(.*)/);
# Build attribute
my $attribute = {
'Name' => $attrName,
'Operator' => ':=',
'Value' => $attrVal
};
# Add attribute
addAttribute($server,$user,$attribute);
}
}
return $res;
}
1;
# vim: ts=4
lib/smradius/client.pm 0 → 100644
View file @ b659b33b
# Radius client
# Copyright (C) 2007-2019, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
package smradius::client;
use strict;
use warnings;
use base qw(AWITPT::Object);
use Getopt::Long qw( GetOptionsFromArray );
use IO::Select;
use IO::Socket;
use smradius::version;
use smradius::Radius::Packet;
# Check Config::IniFiles is instaslled
if (!eval {require Config::IniFiles; 1;}) {
print STDERR "You're missing Config::IniFiles, try 'apt-get install libconfig-inifiles-perl'\n";
exit 1;
}
# Run the client
sub run
{
my ($self,@methodArgs) = @_;
# Instantiate if we're not already instantiated
$self = $self->new() if (!ref($self));
# The hash we're going to return
my $ret = { };
print(STDERR "SMRadClient v".VERSION." - Copyright (c) 2007-2019, AllWorldIT\n");
print(STDERR "\n");
# Set defaults
my $cfg;
$cfg->{'config_file'} = "/etc/smradiusd.conf";
# Grab runtime arguments
my @runArgs = @methodArgs ? @methodArgs : @ARGV;
# Parse command line params
my $cmdline;
%{$cmdline} = ();
if (!GetOptionsFromArray(
\@runArgs,
\%{$cmdline},
"config:s",
"raddb:s",
"listen:s",
"help",
)) {
print(STDERR "ERROR: Error parsing commandline arguments");
return 1;
}
# Check for some args
if ($cmdline->{'help'}) {
displayHelp();
return 0;
}
# Make sure we only have 2 additional args
if (@runArgs < 3) {
print(STDERR "ERROR: Invalid number of arguments\n");
displayHelp();
return 1;
}
if (!defined($cmdline->{'raddb'}) || $cmdline->{'raddb'} eq "") {
print(STDERR "ERROR: No raddb directory specified!\n");
displayHelp();
return 1;
}
# Get variables we need
my $server = shift(@runArgs);
my $type = shift(@runArgs);
$self->{'secret'} = shift(@runArgs);
# Validate type
if (!defined($type) || ( $type ne "acct" && $type ne "auth" && $type ne "disconnect")) {
print(STDERR "ERROR: Invalid packet type specified!\n");
displayHelp();
return 1;
}
print(STDERR "\n");
# Time to start loading the dictionary
print(STDERR "Loading dictionaries...");
my $raddb = smradius::Radius::Dictionary->new();
# Look for files in the dir
my $DIR;
if (!opendir($DIR, $cmdline->{'raddb'})) {
print(STDERR "ERROR: Cannot open '".$cmdline->{'raddb'}."': $!");
return 1;
}
my @raddb_files = readdir($DIR);
# And load the dictionary
foreach my $df (@raddb_files) {
my $df_fn = $cmdline->{'raddb'}."/$df";
# Load dictionary
if (!$raddb->readfile($df_fn)) {
print(STDERR "Failed to load dictionary '$df_fn': $!");
}
print(STDERR ".");
}
print(STDERR "\n");
# Decide what type of packet this is
my $port;
my $pkt_code;
if ($type eq "acct") {
$port = 1813;
$pkt_code = "Accounting-Request";
} elsif ($type eq "auth") {
$port = 1812;
$pkt_code = "Access-Request";
} elsif ($type eq "disconnect") {
$port = 1813;
$pkt_code = "Disconnect-Request";
}
print(STDERR "\nRequest:\n");
printf(STDERR " > Secret => '%s'\n",$self->{'secret'});
# Build packet
$self->{'packet'} = smradius::Radius::Packet->new($raddb);
$self->{'packet'}->set_code($pkt_code);
# Generate identifier
my $ident = int(rand(32768));
$self->{'packet'}->set_identifier($ident);
print(STDERR " > Identifier: $ident\n");
# Generate authenticator number
my $authen = int(rand(32768));
$self->{'packet'}->set_authenticator($authen);
print(STDERR " > Authenticator: $ident\n");
# Pull in attributes from STDIN if we're not being called as a function
if (!@runArgs) {
while (my $line = <STDIN>) {
$self->addAttributesFromString($line);
}
}
# Pull in attributes from commandline
while (my $line = shift(@runArgs)) {
$self->addAttributesFromString($line);
}
# Create UDP packet
my $udp_packet = $self->{'packet'}->pack();
# Create socket to send packet out on
my $sockTimeout = "10"; # 10 second timeout
my $sock = IO::Socket::INET->new(
PeerAddr => $server,
PeerPort => $port,
Type => SOCK_DGRAM,
Proto => 'udp',
Timeout => $sockTimeout,
);
if (!$sock) {
print(STDERR "ERROR: Failed to create socket\n");
return 1;
}
my $sock2;
# Check if we must listen on another IP/port
if (defined($cmdline->{'listen'}) && $cmdline->{'listen'} ne "") {
print(STDERR "Creating second socket\n");
# Check the details we were provided
my ($localAddr,$localPort) = split(/:/,$cmdline->{'listen'});
if (!defined($localPort)) {
print(STDERR "ERROR: The format for --listen is IP:Port\n");
return 1;
}
$sock2 = IO::Socket::INET->new(
LocalAddr => $localAddr,
LocalPort => $localPort,
Type => SOCK_DGRAM,
Proto => 'udp',
Timeout => $sockTimeout,
);
if (!$sock2) {
print(STDERR "ERROR: Failed to create second socket\n");
return 1;
}
}
# Check if we sent the packet...
if (!$sock->send($udp_packet)) {
print(STDERR "ERROR: Failed to send data on socket\n");
return 1;
}
# And time for the response
print(STDERR "\nResponse:\n");
# Once sent, we need to get a response back
my $rsock = IO::Select->new($sock);
if (!$rsock) {
print(STDERR "ERROR: Failed to select response data on socket\n");
return 1;
}
# Check if we can read a response after the select()
if (!$rsock->can_read($sockTimeout)) {
print(STDERR "ERROR: Failed to receive response data on socket\n");
return 1;
}
# Read packet
$sock->recv($udp_packet, 65536);
if (!$udp_packet) {
print(STDERR "ERROR: Receive response data failed on socket: $!\n");
return 1;
}
# Parse packet
my $pkt = smradius::Radius::Packet->new($raddb,$udp_packet);
print(STDERR " > Authenticated: ". (defined(auth_req_verify($udp_packet,$self->{'secret'},$authen)) ? "yes" : "no") ."\n");
print(STDERR $pkt->str_dump());
# Setup response
$ret->{'request'} = $self->hashedPacket($self->{'packet'});
$ret->{'response'} = $self->hashedPacket($pkt);
my $udp_packet2;
if (defined($sock2)) {
my $rsock2 = IO::Select->new($sock2);
if (!$rsock2) {
print(STDERR "ERROR: Failed to select response data on socket2\n");
return 1;
}
# Check if we can read a response after the select()
if (!$rsock2->can_read($sockTimeout)) {
print(STDERR "ERROR: Failed to receive response data on socket2\n");
return 1;
}
# Read packet
my $udp_packet2;
$sock2->recv($udp_packet2, 65536);
if (!$udp_packet2) {
print(STDERR "ERROR: Receive response data failed on socket2: $!\n");
return 1;
}
my $pkt2 = smradius::Radius::Packet->new($raddb,$udp_packet2);
print(STDERR $pkt2->str_dump());
# Save the packet we got
$ret->{'listen'}->{'response'} = $self->hashedPacket($pkt2);
}
# If we were called as a function, return hashed version of the response packet
if (@methodArgs) {
return $ret;
}
return 0;
}
# Return a hashed version of the packet
sub hashedPacket
{
my ($self,$pkt) = @_;
my $res = {};
$res->{'code'} = $pkt->code();
$res->{'identifier'} = $pkt->identifier();
foreach my $attrName (sort $pkt->attributes()) {
my $attrVal = $pkt->rawattr($attrName);
$res->{'attributes'}->{$attrName} = $attrVal;
}
foreach my $attrVendor ($pkt->vendors()) {
foreach my $attrName ($pkt->vsattributes($attrVendor)) {
$res->{'vattributes'}->{$attrVendor}->{$attrName} = $pkt->vsattr($attrVendor,$attrName);
}
}
return $res;
}
# Allow adding attribute from a string
sub addAttributesFromString
{
my ($self,$line) = @_;
# Remove EOL
chomp($line);
# Split on , and newline
my @rawAttributes = split(/[,\n]+/,$line);
foreach my $attr (@rawAttributes) {
# Pull off attribute name & value
my ($name,$value) = ($attr =~ /\s*(\S+)\s*=\s?(.+)/);
$self->addAttribute($name,$value);
}
return;
}
# Add attribute to packet
sub addAttribute
{
my ($self,$name,$value) = @_;
# Add to packet
print(STDERR " > Adding '$name' => '$value'\n");
if ($name eq "User-Password") {
$self->{'packet'}->set_password($value,$self->{'secret'});
} else {
$self->{'packet'}->set_attr($name,$value);
}
return;
}
# Display help
sub displayHelp {
print(STDERR<<EOF);
Usage: $0 [args] <server> <acct|auth|disconnect> <secret> [ATTR=VALUE,...]
--raddb=<DIR> Directory where the radius dictionary files are
EOF
return;
}
1;
# vim: ts=4
lib/smradius/config.pm 0 → 100644
View file @ b659b33b
# SMRadius config information
# Copyright (C) 2007-2015, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
## @class smradius::config
# Configuration handling class
package smradius::config;
use strict;
use warnings;
# Exporter stuff
use base qw(Exporter);
our @EXPORT = qw(
);
our @EXPORT_OK = qw(
);
use AWITPT::Util;
use smradius::logging;
# Our vars
my $config;
## @fn Init($server)
# Initialize this module with a server object
#
# @param server Server object we need to setup
sub Init
{
my $server = shift;
# Setup configuration
$config = $server->{'inifile'};
# Setup database config
my $db;
$db->{'DSN'} = $config->{'database'}{'dsn'};
$db->{'Username'} = $config->{'database'}{'username'};
$db->{'Password'} = $config->{'database'}{'password'};
$db->{'enabled'} = 0;
# Check we have all the config we need
if (!defined($db->{'DSN'})) {
$server->log(LOG_NOTICE,"smradius/config.pm: No 'DSN' defined in config file for 'database'");
}
$server->{'smradius'}{'database'} = $db;
# Setup event timezone config
if (defined($config->{'server'}{'event_timezone'})) {
$server->{'smradius'}{'event_timezone'} = $config->{'server'}{'event_timezone'};
} else {
$server->{'smradius'}{'event_timezone'} = "GMT";
}
# Should we use the packet timestamp?
if (defined($config->{'radius'}{'use_packet_timestamp'})) {
if (defined(my $val = isBoolean($config->{'radius'}{'use_packet_timestamp'}))) {
$server->{'smradius'}{'use_packet_timestamp'} = $val;
} else {
$server->log(LOG_NOTICE,"smradius/config.pm: Value for 'use_packet_timestamp' is invalid");
}
} else {
$server->{'smradius'}{'use_packet_timestamp'} = 0;
}
# Should we use abuse prevention?
if (defined($config->{'radius'}{'use_abuse_prevention'})) {
if (defined(my $val = isBoolean($config->{'radius'}{'use_abuse_prevention'}))) {
$server->{'smradius'}{'use_abuse_prevention'} = $val;
} else {
$server->log(LOG_NOTICE,"smradius/config.pm: Value for 'use_abuse_prevention' is invalid");
}
} else {
$server->{'smradius'}{'use_abuse_prevention'} = 0;
}
if (defined($config->{'radius'}{'access_request_abuse_threshold'})) {
if ($config->{'radius'}{'access_request_abuse_threshold'} =~ /^[1-9][0-9]*$/i) {
$server->{'smradius'}{'access_request_abuse_threshold'} = $config->{'radius'}{'access_request_abuse_threshold'};
} else {
$server->log(LOG_NOTICE,"smradius/config.pm: Value for 'access_request_abuse_threshold' is invalid");
}
} else {
$server->{'smradius'}{'access_request_abuse_threshold'} = 10;
}
if (defined($config->{'radius'}{'accounting_request_abuse_threshold'})) {
if ($config->{'radius'}{'accounting_request_abuse_threshold'} =~ /^[1-9][0-9]*$/i) {
$server->{'smradius'}{'accounting_request_abuse_threshold'} = $config->{'radius'}{'accounting_request_abuse_threshold'};
} else {
$server->log(LOG_NOTICE,"smradius/config.pm: Value for 'accounting_request_abuse_threshold' is invalid");
}
} else {
$server->{'smradius'}{'accounting_request_abuse_threshold'} = 5;
}
$server->log(LOG_NOTICE,"smradius/config.pm: Using ". ( $server->{'smradius'}{'use_packet_timestamp'} ? 'packet' : 'server' ) ." timestamp");
$server->log(LOG_NOTICE,"smradius/config.pm: Using timezone '".$server->{'smradius'}{'event_timezone'}."'");
$server->log(LOG_NOTICE,"smradius/config.pm: Abuse prevention ".( $server->{'smradius'}{'use_abuse_prevention'} ?
'active (access-threshold = '.$server->{'smradius'}{'access_request_abuse_threshold'}.
', accounting-threshold = '.$server->{'smradius'}{'accounting_request_abuse_threshold'}.')'
: 'inactive'));
return;
}
## @fn getConfig
# Get the config hash
#
# @return Hash ref of all our config items
sub getConfig
{
return $config;
}
1;
# vim: ts=4
smradius/constants.pm → lib/smradius/constants.pm
View file @ b659b33b
# SMRadius Constants
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2015, AllWorldIT
#
# 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
......@@ -20,31 +20,36 @@
## @class smradius::constants
# SMRadius constants package
package smradius::constants;
use base qw(Exporter);
use strict;
use warnings;
# Exporter stuff
require Exporter;
our (@ISA,@EXPORT,@EXPORT_OK);
@ISA = qw(Exporter);
our (@EXPORT,@EXPORT_OK);
@EXPORT = qw(
RES_OK
RES_ERROR
MOD_RES_ACK
MOD_RES_NACK
MOD_RES_SKIP
GIGAWORD_VALUE
);
@EXPORT_OK = ();
use constant {
RES_OK => 0,
RES_ERROR => -1,
RES_OK => 0,
RES_ERROR => -1,
MOD_RES_SKIP => 0,
MOD_RES_ACK => 1,
MOD_RES_NACK => 2,
MOD_RES_SKIP => 0,
MOD_RES_ACK => 1,
MOD_RES_NACK => 2,
GIGAWORD_VALUE => 2**32,
};
......
smradiusd → lib/smradius/daemon.pm 100755 → 100644
View file @ b659b33b
#!/usr/bin/perl
# Radius daemon
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2019, AllWorldIT
#
# 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
......@@ -17,37 +16,101 @@
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
package smradius::daemon;
use strict;
use warnings;
# Set library directory
use lib qw(
../ ./
smradius
awitpt/db
);
package radiusd;
# Check if we have Net::Server::PreFork installed
if (!eval {require Net::Server::PreFork; 1;}) {
print STDERR "You're missing Net::Server::PreFork, try 'apt-get install libnet-server-perl'\n";
exit 1;
}
# Check Config::IniFiles is instaslled
if (!eval {require Config::IniFiles; 1;}) {
print STDERR "You're missing Config::IniFiles, try 'apt-get install libconfig-inifiles-perl'\n";
exit 1;
}
# Check DateTime is installed
if (!eval {require DateTime; 1;}) {
print STDERR "You're missing DateTime, try 'apt-get install libdatetime-perl'\n";
exit 1;
}
# Check Crypt::DES is installed
if (!eval {require Crypt::DES; 1;}) {
print STDERR "You're missing DateTime, try 'apt-get install libcrypt-des-perl'\n";
exit 1;
}
# Check Crypt::RC4 is installed
if (!eval {require Crypt::RC4; 1;}) {
print STDERR "You're missing Crypt::RC4, try 'apt-get install libcrypt-rc4-perl'\n";
exit 1;
}
use base qw(Net::Server::PreFork);
use Config::IniFiles;
use DateTime;
use Getopt::Long;
# Check Digest::MD4 is installed
if (!eval {require Digest::MD4; 1;}) {
print STDERR "You're missing Digest::MD4, try 'apt-get install libdigest-md4-perl'\n";
exit 1;
}
# Check Digest::SHA is installed
if (!eval {require Digest::SHA; 1;}) {
print STDERR "You're missing Digest::SHA, try 'apt-get install libdigest-sha-perl'\n";
exit 1;
}
# Check Date::Parse is installed
if (!eval {require Date::Parse; 1;}) {
print STDERR "You're missing TimeDate, try 'apt-get install libtimedate-perl'\n";
exit 1;
}
# Check Cache::FastMmap is installed
if (!eval {require Cache::FastMmap; 1;}) {
print STDERR "You're missing DateTime, try 'apt-get install libcache-fastmmap-perl'\n";
exit 1;
} else {
eval {use AWITPT::Cache;};
}
# Check MIME::Lite is installed
if (!eval {require MIME::Lite; 1;}) {
print STDERR "You're missing MIME::Lite, try 'apt-get install libmime-lite-perl'\n";
exit 1;
}
## no critic (BuiltinFunctions::ProhibitStringyEval)
eval qq{
use base qw(Net::Server::PreFork);
};
## use critic
use Getopt::Long qw( GetOptionsFromArray );
use Socket;
use Sys::Syslog;
use Time::HiRes qw( gettimeofday tv_interval );
use AWITPT::DB::DBLayer;
use AWITPT::Util qw( booleanize );
use smradius::Radius::Packet;
use smradius::version;
use smradius::constants;
use smradius::daemon::request;
use smradius::logging;
use smradius::config;
use awitpt::db::dbilayer;
use awitpt::cache;
use smradius::util;
use smradius::attributes;
use Radius::Packet;
use Socket;
......@@ -68,12 +131,13 @@ sub configure {
# Set defaults
my $cfg;
$cfg->{'config_file'} = "/etc/smradiusd.conf";
$cfg->{'cache_file'} = '/var/run/smradius/cache';
$server->{'timeout'} = 120;
$server->{'background'} = "yes";
$server->{'pid_file'} = "/var/run/smradiusd.pid";
$server->{'pid_file'} = "/var/run/smradius/smradiusd.pid";
$server->{'log_level'} = 2;
$server->{'log_file'} = "/var/log/smradiusd.log";
$server->{'log_file'} = "/var/log/smradius/smradiusd.log";
$server->{'host'} = "*";
$server->{'port'} = [ 1812, 1813 ];
......@@ -85,16 +149,23 @@ sub configure {
$server->{'max_servers'} = 25;
$server->{'max_requests'} = 1000;
# Work out runtime arguments
my @runArgs = @{$server->{'_run_args'}} ? @{$server->{'_run_args'}} : @ARGV;
# Parse command line params
my $cmdline;
%{$cmdline} = ();
GetOptions(
if (!GetOptionsFromArray(
\@runArgs,
\%{$cmdline},
"help",
"config:s",
"debug",
"fg",
) or die "Error parsing commandline arguments";
)) {
print(STDERR "ERROR: Error parsing commandline arguments");
return 1;
}
# Check for some args
if ($cmdline->{'help'}) {
......@@ -133,7 +204,7 @@ sub configure {
'min_spare_servers',
'max_spare_servers',
'max_servers',
'max_requests',
'max_requests'
);
foreach my $param (@server_params) {
$server->{$param} = $config{'server'}{$param} if (defined($config{'server'}{$param}));
......@@ -177,9 +248,9 @@ sub configure {
if (ref($config{'system'}{'modules'}) eq "ARRAY") {
foreach my $module (@{$config{'system'}{'modules'}}) {
$module =~ s/\s+//g;
# Skip comments
next if ($module =~ /^#/);
$module = "system/$module";
# Skip comments
next if ($module =~ /^#/);
$module = "system/$module";
push(@{$cfg->{'module_list'}},$module);
}
} else {
......@@ -198,9 +269,9 @@ sub configure {
if (ref($config{'features'}{'modules'}) eq "ARRAY") {
foreach my $module (@{$config{'features'}{'modules'}}) {
$module =~ s/\s+//g;
# Skip comments
next if ($module =~ /^#/);
$module = "features/$module";
# Skip comments
next if ($module =~ /^#/);
$module = "features/$module";
push(@{$cfg->{'module_list'}},$module);
}
} else {
......@@ -219,9 +290,9 @@ sub configure {
if (ref($config{'authentication'}{'mechanisms'}) eq "ARRAY") {
foreach my $module (@{$config{'authentication'}{'mechanisms'}}) {
$module =~ s/\s+//g;
# Skip comments
next if ($module =~ /^#/);
$module = "authentication/$module";
# Skip comments
next if ($module =~ /^#/);
$module = "authentication/$module";
push(@{$cfg->{'module_list'}},$module);
}
} else {
......@@ -237,9 +308,9 @@ sub configure {
if (ref($config{'authentication'}{'users'}) eq "ARRAY") {
foreach my $module (@{$config{'authentication'}{'users'}}) {
$module =~ s/\s+//g;
# Skip comments
next if ($module =~ /^#/);
$module = "userdb/$module";
# Skip comments
next if ($module =~ /^#/);
$module = "userdb/$module";
push(@{$cfg->{'module_list'}},$module);
}
} else {
......@@ -258,9 +329,9 @@ sub configure {
if (ref($config{'accounting'}{'modules'}) eq "ARRAY") {
foreach my $module (@{$config{'accounting'}{'modules'}}) {
$module =~ s/\s+//g;
# Skip comments
next if ($module =~ /^#/);
$module = "accounting/$module";
# Skip comments
next if ($module =~ /^#/);
$module = "accounting/$module";
push(@{$cfg->{'module_list'}},$module);
}
} else {
......@@ -280,8 +351,8 @@ sub configure {
if (ref($config{'dictionary'}->{'load'}) eq "ARRAY") {
foreach my $dict (@{$config{'dictionary'}->{'load'}}) {
$dict =~ s/\s+//g;
# Skip comments
next if ($dict =~ /^#/);
# Skip comments
next if ($dict =~ /^#/);
push(@{$cfg->{'dictionary_list'}},$dict);
}
} else {
......@@ -293,10 +364,18 @@ sub configure {
}
}
# Check if the user specified a cache_file in the config
if (defined($config{'server'}{'cache_file'})) {
$cfg->{'cache_file'} = $config{'server'}{'cache_file'};
}
# Save our config and stuff
$self->{'config'} = $cfg;
$self->{'cmdline'} = $cmdline;
$self->{'inifile'} = \%config;
return;
}
......@@ -307,26 +386,28 @@ sub post_configure_hook {
my $config = $self->{'config'};
$self->log(LOG_NOTICE,"[SMRADIUS] SMRadius - v$VERSION");
# Init config
$self->log(LOG_NOTICE,"[SMRADIUS] Initializing configuration...");
$self->log(LOG_INFO,"[SMRADIUS] Initializing configuration...");
smradius::config::Init($self);
$self->log(LOG_NOTICE,"[SMRADIUS] Configuration initialized.");
$self->log(LOG_INFO,"[SMRADIUS] Configuration initialized.");
# Load dictionaries
$self->log(LOG_NOTICE,"[SMRADIUS] Initializing dictionaries...");
my $dict = new Radius::Dictionary;
$self->log(LOG_INFO,"[SMRADIUS] Initializing dictionaries...");
my $dict = smradius::Radius::Dictionary->new();
foreach my $df (@{$config->{'dictionary_list'}}) {
# Load dictionary
if (!$dict->readfile($df)) {
$self->log(LOG_WARN,"[SMRADIUS] Failed to load dictionary '$df': $!");
}
$self->log(LOG_DEBUG,"[SMRADIUS] Loaded module '$df'.");
$self->log(LOG_DEBUG,"[SMRADIUS] Loaded dictionary '$df'.");
}
$self->log(LOG_NOTICE,"[SMRADIUS] Dictionaries initialized.");
$self->log(LOG_INFO,"[SMRADIUS] Dictionaries initialized.");
# Store the dictionary
$self->{'radius'}->{'dictionary'} = $dict;
$self->log(LOG_NOTICE,"[SMRADIUS] Initializing modules...");
$self->log(LOG_INFO,"[SMRADIUS] Initializing modules...");
# Load modules
foreach my $module (@{$config->{'module_list'}}) {
# Split off dir and mod name
......@@ -334,23 +415,31 @@ sub post_configure_hook {
my ($mod_dir,$mod_name) = ($1,$2);
# Load module
my $res = eval("
## no critic (BuiltinFunctions::ProhibitStringyEval)
my $res = eval qq{
use smradius::modules::${mod_dir}::${mod_name};
plugin_register(\$self,\"${mod_name}\",\$smradius::modules::${mod_dir}::${mod_name}::pluginInfo);
");
};
## use critic
if ($@ || (defined($res) && $res != 0)) {
$self->log(LOG_WARN,"[SMRADIUS] Error loading module $module ($@)");
} else {
$self->log(LOG_DEBUG,"[SMRADIUS] Plugin '$module' loaded.");
}
}
$self->log(LOG_NOTICE,"[SMRADIUS] Plugins initialized.");
$self->log(LOG_INFO,"[SMRADIUS] Plugins initialized.");
$self->log(LOG_NOTICE,"[SMRADIUS] Initializing system modules.");
$self->log(LOG_INFO,"[SMRADIUS] Initializing system modules.");
# Init caching engine
# awitpt::cache::Init($self);
$self->log(LOG_NOTICE,"[SMRADIUS] System modules initialized.");
AWITPT::Cache::Init($self,{
'cache_file' => $self->{'config'}{'cache_file'},
'cache_file_user' => $self->{'server'}->{'user'},
'cache_file_group' => $self->{'server'}->{'group'}
});
$self->log(LOG_INFO,"[SMRADIUS] System modules initialized.");
return;
}
......@@ -379,6 +468,7 @@ sub plugin_register {
}
# Initialize child
sub child_init_hook
{
......@@ -388,8 +478,8 @@ sub child_init_hook
$self->SUPER::child_init_hook();
$self->log(LOG_DEBUG,"[SMRADIUS] Starting up caching engine");
awitpt::cache::connect($self);
$self->log(LOG_INFO,"[SMRADIUS] Starting up caching engine");
AWITPT::Cache::connect($self);
# Do we need database support?
if ($self->{'smradius'}->{'database'}->{'enabled'}) {
......@@ -398,21 +488,22 @@ sub child_init_hook
$self->{'client'}->{'dbh_status'} = time();
# Init core database support
$self->{'client'}->{'dbh'} = awitpt::db::dbilayer::Init($self,'smradius');
$self->{'client'}->{'dbh'} = AWITPT::DB::DBILayer::Init($self,'smradius');
if (defined($self->{'client'}->{'dbh'})) {
# Check if we succeeded
if (!($self->{'client'}->{'dbh'}->connect())) {
# If we succeeded, record OK
$self->{'client'}->{'dbh_status'} = 0;
} else {
$self->log(LOG_WARN,"[SMRADIUS] Failed to connect to database: ".$self->{'client'}->{'dbh'}->Error().
$self->log(LOG_WARN,"[SMRADIUS] Failed to connect to database: ".$self->{'client'}->{'dbh'}->error().
" ($$)");
}
} else {
$self->log(LOG_WARN,"[SMRADIUS] Failed to Initialize: ".awitpt::db::dbilayer::internalError()." ($$)");
$self->log(LOG_WARN,"[SMRADIUS] Failed to Initialize: ".AWITPT::DB::DBILayer::internalError()." ($$)");
}
}
return;
}
......@@ -424,11 +515,14 @@ sub child_finish_hook {
$self->SUPER::child_finish_hook();
$self->log(LOG_DEBUG,"[SMRADIUS] Shutting down caching engine ($$)");
awitpt::cache::disconnect($self);
$self->log(LOG_INFO,"[SMRADIUS] Shutting down caching engine ($$)");
AWITPT::Cache::disconnect($self);
return;
}
# Process requests we get
sub process_request {
my $self = shift;
......@@ -438,17 +532,20 @@ sub process_request {
# Grab packet
my $udp_packet = $server->{'udp_data'};
my $rawPacket = $server->{'udp_data'};
# Check min size
if (length($udp_packet) < 18)
if (length($rawPacket) < 18)
{
$self->log(LOG_WARN, "[SMRADIUS] Packet too short - Ignoring");
return;
}
# Parse packet
my $pkt = new Radius::Packet($self->{'radius'}->{'dictionary'},$udp_packet);
# Very first timer ...
my $timer0 = [gettimeofday];
# Grab NOW()
my $now = time();
# VERIFY SOURCE SERVER
$self->log(LOG_DEBUG,"[SMRADIUS] Packet From = > ".$server->{'peeraddr'});
......@@ -476,52 +573,104 @@ sub process_request {
$timeout = 120;
}
# Get time left
my $timepassed = time() - $self->{'client'}->{'dbh_status'};
my $timepassed = $now - $self->{'client'}->{'dbh_status'};
# Then check...
if ($timepassed >= $timeout) {
$self->log(LOG_NOTICE,"[SMRADIUS] Client BYPASS timeout exceeded, reconnecting...");
$self->log(LOG_WARN,"[SMRADIUS] Client BYPASS timeout exceeded, reconnecting...");
exit 0;
} else {
$self->log(LOG_NOTICE,"[SMRADIUS] Client still in BYPASS mode, ".( $timeout - $timepassed ).
$self->log(LOG_WARN,"[SMRADIUS] Client still in BYPASS mode, ".( $timeout - $timepassed ).
"s left till next reconnect");
return;
}
}
# Setup database handle
awitpt::db::dblayer::setHandle($self->{'client'}->{'dbh'});
AWITPT::DB::DBLayer::setHandle($self->{'client'}->{'dbh'});
my $request = smradius::daemon::request->new($self);
if (!$request->setTimezone($self->{'smradius'}->{'event_timezone'})) {
$self->log(LOG_ERR,"[SMRADIUS] Setting event_timezone to '%s' failed",$self->{'smradius'}->{'event_timezone'});
return;
}
# Main user hash with everything in
my $user;
$user->{'ConfigAttributes'} = {};
$user->{'ReplyAttributes'} = {};
$user->{'ReplyVAttributes'} = {};
$request->parsePacket($self->{'radius'}->{'dictionary'},$rawPacket);
# Check if we need to override the packet timestamp, if we are not using the packet timestamp, set it to when we go the packet
if (!booleanize($self->{'smradius'}->{'use_packet_timestamp'})) {
$request->setTimestamp($now);
}
# Username should always be defined?
if (!$request->hasUsername()) {
$self->log(LOG_NOTICE,"[SMRADIUS] Packet with no username from ".$server->{'peeraddr'});
return;
}
# Private data
$user->{'_Internal'} = {
'Timestamp-Unix' => defined($pkt->rawattr('Event-Timestamp')) ? $pkt->rawattr('Event-Timestamp') : time()
};
my $eventTimestamp = DateTime->from_epoch( epoch => $user->{'_Internal'}->{'Timestamp-Unix'} );
$user->{'_Internal'}->{'Timestamp'} = $eventTimestamp->strftime('%Y-%m-%d %H:%M:%S');
# Set username
$user->{'Username'} = $pkt->attr('User-Name');
# TODO/FIXME: WIP
my $pkt = $request->{'packet'};
my $user = $request->{'user'};
my $logReason = "UNKNOWN";
# First thing we do is to make sure the NAS behaves if we using abuse prevention
if ($self->{'smradius'}->{'use_abuse_prevention'} && defined($user->{'Username'})) {
my ($res,$val) = cacheGetKeyPair('FloodCheck',$server->{'peeraddr'}."/".$user->{'Username'}."/".$pkt->code);
if (defined($val)) {
my $timePeriod = $now - $val;
# Check if we're still within the abuse threshold
if ($pkt->code eq "Access-Request" && $timePeriod < $self->{'smradius'}->{'access_request_abuse_threshold'}) {
$self->log(LOG_NOTICE,"[SMRADIUS] ABUSE: NAS trying too fast. NAS = ".$server->{'peeraddr'}.", user = ".$user->{'Username'}.
", code = ".$pkt->code.", timeout = ".($now - $val));
# Tell the NAS we got its packet
my $resp = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Access-Reject');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
$server->{'client'}->send(
auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"))
);
return;
} elsif ($pkt->code eq "Accounting-Request" && $timePeriod < $self->{'smradius'}->{'accounting_request_abuse_threshold'}) {
$self->log(LOG_NOTICE,"[SMRADIUS] ABUSE: NAS trying too fast. NAS = ".$server->{'peeraddr'}.", user = ".$user->{'Username'}.
", code = ".$pkt->code.", timeout = ".($now - $val));
# Tell the NAS we got its packet
my $resp = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Accounting-Response');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
$server->{'client'}->send(
auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"))
);
return;
}
}
# We give the benefit of the doubt and let a query take 60s. We update to right stamp at end of this function
cacheStoreKeyPair('FloodCheck',$server->{'peeraddr'}."/".$user->{'Username'}."/".$pkt->code,$now + 60);
}
#
# GRAB & PROCESS CONFIG
#
my $configured = 1;
foreach my $module (@{$self->{'module_list'}}) {
# Try find config attribute
if ($module->{'Config_get'}) {
# Get result from config module
$self->log(LOG_INFO,"[SMRADIUS] CONFIG: Trying plugin '".$module->{'Name'}."' for incoming connection");
$self->log(LOG_DEBUG,"[SMRADIUS] CONFIG: Trying plugin '".$module->{'Name'}."' for incoming connection");
my $res = $module->{'Config_get'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] CONFIG: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_WARN,"[SMRADIUS] CONFIG: Error with plugin '".$module->{'Name'}."'");
$logReason = "Config Error";
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -529,44 +678,79 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] CONFIG: Configuration retrieved from '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] CONFIG: Configuration retrieved from '".$module->{'Name'}."'");
$logReason = "Config Retrieved";
# Check if we got a negative result back
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] CONFIG: Configuration rejection when using '".$module->{'Name'}."'");
goto CHECK_RESULT;
$self->log(LOG_DEBUG,"[SMRADIUS] CONFIG: Configuration rejection when using '".$module->{'Name'}."'");
$logReason = "Config Rejected";
# FIXME/TODO NK WIP
return;
# $configured = 0;
# last;
}
}
}
# FIXME - need secret
# FIXME - need acl list
#
# START PROCESSING
# USERNAME TRANSFORM
#
# UserDB module if we using/need it
my $userdb;
# If we have a config attribute to transform username, use it
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Username-Transform'})) {
$self->log(LOG_DEBUG,"[SMRADIUS] Attribute 'SMRadius-Username-Transform' exists, transforming username.");
# NK: Not ready for prime time yet
# # Get clients(NAS) username transform pattern
# my $transform = shift(@{$user->{'ConfigAttributes'}->{'SMRadius-Username-Transform'}});
# if ($transform =~ /^(@\S+)=(@\S+)$/i) {
#
# # Set old and new, prevents warnings
# my ($old,$new) = ($1,$2);
#
# # Use client username transform on temp username
# my $tempUsername = $user->{'Username'};
# $tempUsername =~ s/$old/$new/;
#
# # Override username
# $user->{'Username'} = $tempUsername;
# } else {
# $self->log(LOG_DEBUG,"[SMRADIUS] No string replacement possible on pattern '".
# $transform."', using username '".$user->{'Username'}."'");
# }
}
#
# FIND USER
#
# Get the user timer
my $timer1 = [gettimeofday];
# FIXME - need secret
# FIXME - need acl list
# Common stuff for multiple codes....
if ($pkt->code eq "Accounting-Request" || $pkt->code eq "Access-Request") {
#
# FIND USER
#
# Loop with modules to try find user
foreach my $module (@{$self->{'module_list'}}) {
# Try find user
if ($module->{'User_find'}) {
$self->log(LOG_INFO,"[SMRADIUS] FIND: Trying plugin '".$module->{'Name'}."' for username '".
$self->log(LOG_DEBUG,"[SMRADIUS] FIND: Trying plugin '".$module->{'Name'}."' for username '".
$user->{'Username'}."'");
my ($res,$userdb_data) = $module->{'User_find'}($self,$user,$pkt);
my ($res,$userDB_Data) = $module->{'User_find'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] FIND: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_WARN,"[SMRADIUS] FIND: Error with plugin '".$module->{'Name'}."'");
$logReason = "Error Finding User";
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -574,14 +758,17 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] FIND: Username found with '".$module->{'Name'}."'");
$userdb = $module;
$user->{'_UserDB_Data'} = $userdb_data;
$self->log(LOG_DEBUG,"[SMRADIUS] FIND: Username found with '".$module->{'Name'}."'");
$user->{'_UserDB'} = $module;
$user->{'_UserDB_Data'} = $userDB_Data;
# The user ID is supposed to be global unique, on the same level as the username
$user->{'ID'} = $user->{'_UserDB_Data'}->{'ID'};
last;
# Or a negative result
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] FIND: Username not found with '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] FIND: Username not found with '".$module->{'Name'}."'");
$logReason = "User Not Found";
last;
}
......@@ -590,24 +777,41 @@ sub process_request {
}
#
# PROCESS PACKET
#
# Process the packet timer
my $timer2 = [gettimeofday];
# Is this an accounting request
if ($pkt->code eq "Accounting-Request") {
$self->log(LOG_DEBUG,"[SMRADIUS] Accounting Request Packet");
# Add onto logline
$request->addLogLine(". REQUEST => ");
foreach my $attrName ($pkt->attributes) {
$request->addLogLine(
"%s: '%s'",
$attrName,
$pkt->rawattr($attrName)
);
}
#
# GET USER
#
# Get user data
if (defined($userdb) && defined($userdb->{'User_get'})) {
my $res = $userdb->{'User_get'}($self,$user,$pkt);
if (defined($user->{'_UserDB'}) && defined($user->{'_UserDB'}->{'User_get'})) {
my $res = $user->{'_UserDB'}->{'User_get'}($self,$user,$pkt);
# Check result
if (defined($res) && ref($res) eq "HASH") {
# We're only after the attributes here
$user->{'Attributes'} = $res->{'Attributes'};
$user->{'VAttributes'} = $res->{'VAttributes'};
if ($res) {
$self->log(LOG_WARN,"[SMRADIUS] GET: Error returned from '".$user->{'_UserDB'}->{'Name'}.
"' for username '".$user->{'Username'}."'");
}
}
......@@ -615,12 +819,13 @@ sub process_request {
foreach my $module (@{$self->{'module_list'}}) {
# Try find user
if ($module->{'Accounting_log'}) {
$self->log(LOG_INFO,"[SMRADIUS] ACCT: Trying plugin '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] ACCT: Trying plugin '".$module->{'Name'}."'");
my $res = $module->{'Accounting_log'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] ACCT: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_WARN,"[SMRADIUS] ACCT: Error with plugin '".$module->{'Name'}."'");
$logReason = "Accounting Log Error";
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -628,36 +833,32 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] ACCT: Accounting logged using '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] ACCT: Accounting logged using '".$module->{'Name'}."'");
$logReason = "Accounting Logged";
# Check if we got a negative result back
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] ACCT: Accounting NOT LOGGED using '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] ACCT: Accounting NOT LOGGED using '".$module->{'Name'}."'");
$logReason = "Accounting NOT Logged";
}
}
}
# Tell the NAS we got its packet
my $resp = Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Accounting-Response');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
$udp_packet = auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"));
$server->{'client'}->send($udp_packet);
# Are we going to POD the user?
my $PODUser = 0;
# Loop with modules that have post-authentication hooks
# Loop with modules that have post-accounting hooks
foreach my $module (@{$self->{'module_list'}}) {
# Try authenticate
if ($module->{'Feature_Post-Accounting_hook'}) {
$self->log(LOG_INFO,"[SMRADIUS] POST-ACCT: Trying plugin '".$module->{'Name'}."' for '".
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Trying plugin '".$module->{'Name'}."' for '".
$user->{'Username'}."'");
my $res = $module->{'Feature_Post-Accounting_hook'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_WARN,"[SMRADIUS] POST-ACCT: Error with plugin '".$module->{'Name'}."'");
$logReason = "Post Accounting Error";
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -665,61 +866,182 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] POST-ACCT: Passed post accounting hook by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Passed post accounting hook by '".$module->{'Name'}."'");
$logReason = "Post Accounting Success";
# Or a negative result
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] POST-ACCT: Failed post accounting hook by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Failed post accounting hook by '".$module->{'Name'}."'");
$logReason = "Failed Post Accounting";
$PODUser = 1;
}
}
}
# Check if we must POD the user
if ($PODUser) {
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Trying to disconnect user...");
# Tell the NAS we got its packet
my $resp = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Accounting-Response');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
$server->{'client'}->send(
auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"))
);
# CoA and POD only apply to accounting updates...
if ($pkt->rawattr('Acct-Status-Type') eq "3") {
my $resp = Radius::Packet->new($self->{'radius'}->{'dictionary'});
# Build a list of our attributes in the packet
my $acctAttributes;
foreach my $attr ($pkt->attributes) {
$acctAttributes->{$attr} = $pkt->rawattr($attr);
}
# Loop with attributes we got from the user
foreach my $attrName (keys %{$user->{'Attributes'}}) {
# Loop with operators
foreach my $attrOp (keys %{$user->{'Attributes'}->{$attrName}}) {
# Grab attribute
my $attr = $user->{'Attributes'}->{$attrName}->{$attrOp};
# Check attribute against accounting attributes
my $res = checkAcctAttribute($self,$user,$acctAttributes,$attr);
# We don't care if it fails
}
}
$resp->set_code('Disconnect-Request');
my $id = $$ & 0xff;
$resp->set_identifier( $id );
# The coaReq may be either POD or CoA
my $coaReq = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_attr('User-Name',$pkt->attr('User-Name'));
$resp->set_attr('Framed-IP-Address',$pkt->attr('Framed-IP-Address'));
$resp->set_attr('NAS-IP-Address',$pkt->attr('NAS-IP-Address'));
# Set packet identifier
$coaReq->set_identifier( $$ & 0xff );
$udp_packet = auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"));
# Check if we must POD the user, if so we set the code to disconnect
if ($PODUser) {
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Trying to disconnect user...");
$coaReq->set_code('Disconnect-Request');
} else {
# If this is *not* a POD, we need to process reply attributes
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Sending CoA...");
$coaReq->set_code('CoA-Request');
# Process the reply attributes
$self->_processReplyAttributes($request,$user,$coaReq);
}
# NAS identification
$coaReq->set_attr('NAS-IP-Address',$pkt->attr('NAS-IP-Address'));
# Session identification
$coaReq->set_attr('User-Name',$pkt->attr('User-Name'));
$coaReq->set_attr('NAS-Port',$pkt->attr('NAS-Port'));
$coaReq->set_attr('Acct-Session-Id',$pkt->attr('Acct-Session-Id'));
# Add onto logline
$request->addLogLine(". REPLY => ");
foreach my $attrName ($coaReq->attributes) {
$request->addLogLine(
"%s: '%s'",
$attrName,
$coaReq->rawattr($attrName)
);
}
# Generate coaReq packet
my $coaReq_packet = auth_resp($coaReq->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"));
# Array CoA servers to contact
my @coaServers;
# Check for old POD server attribute
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-PODServer'})) {
$self->log(LOG_DEBUG,"[SMRADIUS] SMRadius-Config-PODServer is defined");
@coaServers = @{$user->{'ConfigAttributes'}->{'SMRadius-Config-PODServer'}};
}
# Check for new CoA server attribute
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-CoAServer'})) {
$self->log(LOG_DEBUG,"[SMRADIUS] SMRadius-Config-CoAServer is defined");
@coaServers = @{$user->{'ConfigAttributes'}->{'SMRadius-Config-CoAServer'}};
}
# If we didn't get provided a CoA server, use the peer address
if (!@coaServers) {
push(@coaServers,$server->{'peeraddr'});
}
# Check address format
foreach my $coaServer (@coaServers) {
# Remove IPv6 portion for now...
$coaServer =~ s/^::ffff://;
# Check for valid IP
my ($coaServerIP,$coaServerPort) = ($coaServer =~ /^([0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})(?::([0-9]+))?/);
if (!defined($coaServerIP)) {
$self->log(LOG_NOTICE,"[SMRADIUS] POST-ACCT: CoAServer '$coaServer' looks incorrect");
next;
}
# Create socket to send packet out on
my $podServer = "10.254.254.239";
my $podServerPort = "1700";
my $podServerTimeout = "10"; # 10 second timeout
my $podSock = new IO::Socket::INET(
PeerAddr => $podServer,
PeerPort => $podServerPort,
# Set default CoA server port
$coaServerPort //= 1700;
$self->log(LOG_DEBUG,"[SMRADIUS] POST-ACCT: Trying CoAServer => IP: '".$coaServer."' Port: '".$coaServerPort."'");
# Create socket to send packet out on
my $coaServerTimeout = "2"; # 2 second timeout
my $coaSock = IO::Socket::INET->new(
PeerAddr => $coaServerIP,
PeerPort => $coaServerPort,
Type => SOCK_DGRAM,
Proto => 'udp',
TimeOut => $podServerTimeout,
) or return $self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to create socket to send POD on: $!");
TimeOut => $coaServerTimeout,
);
# Check if we sent the packet...
if (!$podSock->send($udp_packet)) {
return $self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to send data on socket: $!");
}
if (!$coaSock) {
$self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to create socket to send CoA on: $!");
next;
}
# Once sent, we need to get a response back
my $sh = new IO::Select($podSock)
or return $self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to select data on socket: $!");
# Check if we sent the packet...
if (!$coaSock->send($coaReq_packet)) {
$self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to send data on CoA socket: $!");
next;
}
$sh->can_read($podServerTimeout)
or return $self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to receive data on socket: $!");
# Once sent, we need to get a response back
my $select = IO::Select->new($coaSock);
if (!$select) {
$self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to select data on socket: $!");
next;
}
my $data;
$podSock->recv($data, 65536)
or return $self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Receive data failed: $!");
# my @stuff = unpack('C C n a16 a*', $data);
# $self->log(LOG_DEBUG,"STUFF: ".Dumper(\@stuff));
if (!$select->can_read($coaServerTimeout)) {
$self->log(LOG_ERR,"[SMRADIUS] POST-ACCT: Failed to receive data on socket: $!");
next;
}
# Grab CoA response
my $coaRes_packet;
$coaSock->recv($coaRes_packet, 65536);
if (!$coaRes_packet) {
$self->log(LOG_INFO,"[SMRADIUS] POST-ACCT: No data received in response to our request to '$coaServerIP:$coaServerPort': $!");
$request->addLogLine(". No response to CoA/POD");
next;
}
# Parse the radius packet
my $coaRes = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'},$coaRes_packet);
# Check status
if ($coaRes->code eq "CoA-ACK") {
$request->addLogLine(". CoA Success");
last;
} elsif ($coaRes->code eq "CoA-NACK") {
$request->addLogLine(". CoA Fail");
} elsif ($coaRes->code eq "Disconnect-ACK") {
$request->addLogLine(". POD Success");
last;
} elsif ($coaRes->code eq "Disconnect-NACK") {
$request->addLogLine(". POD Fail");
} else {
$request->addLogLine(". Invalid CoA/POD response");
}
}
}
# Or maybe a access request
......@@ -736,8 +1058,8 @@ sub process_request {
# If no user is found, bork out ...
if (!defined($userdb)) {
$self->log(LOG_INFO,"[SMRADIUS] FIND: No plugin found for username '".$user->{'Username'}."'");
if (!defined($user->{'_UserDB'})) {
$self->log(LOG_DEBUG,"[SMRADIUS] FIND: No plugin found for username '".$user->{'Username'}."'");
goto CHECK_RESULT;
}
......@@ -746,20 +1068,17 @@ sub process_request {
#
# Get user data
if ($userdb->{'User_get'}) {
my $res = $userdb->{'User_get'}($self,$user,$pkt);
if ($user->{'_UserDB'}->{'User_get'}) {
my $res = $user->{'_UserDB'}->{'User_get'}($self,$user,$pkt);
# Check result
if (!defined($res) || ref($res) ne "HASH") {
$self->log(LOG_WARN,"[SMRADIUS] GET: No data returned from '".$userdb->{'Name'}.
if ($res) {
$self->log(LOG_WARN,"[SMRADIUS] GET: Error returned from '".$user->{'_UserDB'}->{'Name'}.
"' for username '".$user->{'Username'}."'");
goto CHECK_RESULT;
}
# Setup user dataw
$user->{'Attributes'} = $res->{'Attributes'};
$user->{'VAttributes'} = $res->{'VAttributes'};
} else {
$self->log(LOG_INFO,"[SMRADIUS] GET: No 'User_get' function available for module '".$userdb->{'Name'}."'");
$self->log(LOG_ERR,"[SMRADIUS] GET: No 'User_get' function available for module '".$user->{'_UserDB'}->{'Name'}."'");
goto CHECK_RESULT;
}
......@@ -772,12 +1091,12 @@ sub process_request {
foreach my $module (@{$self->{'module_list'}}) {
# Try authenticate
if ($module->{'Authentication_try'}) {
$self->log(LOG_INFO,"[SMRADIUS] AUTH: Trying plugin '".$module->{'Name'}."' for '".$user->{'Username'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] AUTH: Trying plugin '".$module->{'Name'}."' for '".$user->{'Username'}."'");
my $res = $module->{'Authentication_try'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] AUTH: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_ERR,"[SMRADIUS] AUTH: Error with plugin '".$module->{'Name'}."'");
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -785,14 +1104,16 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] AUTH: Authenticated by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] AUTH: Authenticated by '".$module->{'Name'}."'");
$logReason = "User Authenticated";
$mechanism = $module;
$authenticated = 1;
last;
# Or a negative result
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] AUTH: Failed authentication by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] AUTH: Failed authentication by '".$module->{'Name'}."'");
$logReason = "User NOT Authenticated";
$mechanism = $module;
last;
......@@ -805,14 +1126,14 @@ sub process_request {
foreach my $module (@{$self->{'module_list'}}) {
# Try authenticate
if ($module->{'Feature_Post-Authentication_hook'}) {
$self->log(LOG_INFO,"[SMRADIUS] POST-AUTH: Trying plugin '".$module->{'Name'}.
$self->log(LOG_DEBUG,"[SMRADIUS] POST-AUTH: Trying plugin '".$module->{'Name'}.
"' for '".$user->{'Username'}."'");
my $res = $module->{'Feature_Post-Authentication_hook'}($self,$user,$pkt);
# Check result
if (!defined($res)) {
$self->log(LOG_DEBUG,"[SMRADIUS] POST-AUTH: Error with plugin '".$module->{'Name'}."'");
$self->log(LOG_ERR,"[SMRADIUS] POST-AUTH: Error with plugin '".$module->{'Name'}."'");
# Check if we skipping this plugin
} elsif ($res == MOD_RES_SKIP) {
......@@ -820,11 +1141,13 @@ sub process_request {
# Check if we got a positive result back
} elsif ($res == MOD_RES_ACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] POST-AUTH: Passed authenticated by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] POST-AUTH: Passed authenticated by '".$module->{'Name'}."'");
$logReason = "Post Authentication Success";
# Or a negative result
} elsif ($res == MOD_RES_NACK) {
$self->log(LOG_NOTICE,"[SMRADIUS] POST-AUTH: Failed authentication by '".$module->{'Name'}."'");
$self->log(LOG_DEBUG,"[SMRADIUS] POST-AUTH: Failed authentication by '".$module->{'Name'}."'");
$logReason = "Post Authentication Failure";
$authenticated = 0;
# Do we want to run the other modules ??
last;
......@@ -842,6 +1165,8 @@ sub process_request {
foreach my $attr ($pkt->attributes) {
$authAttributes->{$attr} = $pkt->rawattr($attr);
}
# Peer address
$authAttributes->{'SMRadius-Peer-Address'} = $server->{'peeraddr'};
# Loop with attributes we got from the user
foreach my $attrName (keys %{$user->{'Attributes'}}) {
# Loop with operators
......@@ -849,7 +1174,7 @@ sub process_request {
# Grab attribute
my $attr = $user->{'Attributes'}->{$attrName}->{$attrOp};
# Check attribute against authorization attributes
my $res = checkAuthAttribute($self,$authAttributes,$attr);
my $res = checkAuthAttribute($self,$user,$authAttributes,$attr);
if ($res == 0) {
$authorized = 0;
last;
......@@ -862,56 +1187,19 @@ sub process_request {
# Check if we authenticated or not
if ($authenticated && $authorized) {
$self->log(LOG_DEBUG,"[SMRADIUS] Authenticated and authorized");
$logReason = "User Authorized";
my $resp = Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Access-Accept');
my $resp = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Access-Accept');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
# Loop with attributes we got from the getReplyAttributes function, its a hash of arrays which are the values
my %replyAttributes = %{ $user->{'ReplyAttributes'} };
foreach my $attrName (keys %{$user->{'Attributes'}}) {
# Loop with operators
foreach my $attrOp (keys %{$user->{'Attributes'}->{$attrName}}) {
# Grab attribute
my $attr = $user->{'Attributes'}->{$attrName}->{$attrOp};
# Add this to the reply attribute?
setReplyAttribute($self,\%replyAttributes,$attr);
}
}
# Loop with reply attributes
foreach my $attrName (keys %replyAttributes) {
# Loop with values
foreach my $value (@{$replyAttributes{$attrName}}) {
# Add each value
$resp->set_attr($attrName,$value);
}
}
use Data::Dumper; print Dumper($user->{'ReplyVAttributes'});
use Data::Dumper; print Dumper($user->{'VAttributes'});
# Loop with vendor reply attributes
my %replyVAttributes = %{ $user->{'ReplyVAttributes'} };
foreach my $attrName (keys %{$user->{'VAttributes'}}) {
# Loop with operators
foreach my $attrOp (keys %{$user->{'VAttributes'}->{$attrName}}) {
# Grab attribute
my $attr = $user->{'VAttributes'}->{$attrName}->{$attrOp};
# Add this to the reply attribute?
setReplyVAttribute($self,\%replyVAttributes,$attr);
}
}
foreach my $vendor (keys %replyVAttributes) {
# Loop with operators
foreach my $attrName (keys %{$replyVAttributes{$vendor}}) {
# Add each value
foreach my $value (@{$replyVAttributes{$vendor}->{$attrName}}) {
$resp->set_vsattr($vendor,$attrName,$value);
}
}
}
# Process the reply attributes
$self->_processReplyAttributes($request,$user,$resp);
$udp_packet = auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"));
$server->{'client'}->send($udp_packet);
$server->{'client'}->send(
auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"))
);
}
......@@ -919,13 +1207,15 @@ CHECK_RESULT:
# Check if found and authenticated
if (!$authenticated || !$authorized) {
$self->log(LOG_DEBUG,"[SMRADIUS] Authentication or authorization failure");
$logReason = "User NOT Authenticated or Authorized";
my $resp = Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Access-Reject');
my $resp = smradius::Radius::Packet->new($self->{'radius'}->{'dictionary'});
$resp->set_code('Access-Reject');
$resp->set_identifier($pkt->identifier);
$resp->set_authenticator($pkt->authenticator);
$udp_packet = auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"));
$server->{'client'}->send($udp_packet);
$server->{'client'}->send(
auth_resp($resp->pack, getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"))
);
}
# We don't know how to handle this
......@@ -933,10 +1223,36 @@ CHECK_RESULT:
$self->log(LOG_WARN,"[SMRADIUS] We cannot handle code: '".$pkt->code."'");
}
# END
my $timer9 = [gettimeofday];
my $timediff1 = tv_interval($timer0,$timer1);
my $timediff2 = tv_interval($timer1,$timer2);
my $timediff3 = tv_interval($timer2,$timer9);
my $timediff = tv_interval($timer0,$timer9);
# FIXME/TODO NK WIP
my $logLine = join(' ',@{$request->{'logLine'}});
my @logLineArgs = @{$request->{'logLineParams'}};
# How should we output this ...
if ($server->{'log_level'} > LOG_NOTICE) {
$self->log(LOG_NOTICE,"[SMRADIUS] Result: $logReason (%.3fs + %.3fs + %.3fs = %.3fs) => $logLine",
$timediff1,$timediff2,$timediff3,$timediff,@logLineArgs);
} else {
$self->log(LOG_NOTICE,"[SMRADIUS] Result: $logReason => $logLine",@logLineArgs);
}
# If we using abuse prevention record the time we ending off
if ($self->{'smradius'}->{'use_abuse_prevention'} && defined($user->{'Username'})) {
cacheStoreKeyPair('FloodCheck',$server->{'peeraddr'}."/".$user->{'Username'}."/".$pkt->code,time());
}
return;
}
# Initialize child
sub server_exit
{
......@@ -945,20 +1261,23 @@ sub server_exit
$self->log(LOG_DEBUG,"Destroying system modules.");
# Destroy cache
# cbp::cache::Destroy($self);
AWITPT::Cache::Destroy($self);
$self->log(LOG_DEBUG,"System modules destroyed.");
# Parent exit
$self->SUPER::server_exit();
return;
}
# Slightly better logging
sub log
sub log ## no critic (Subroutines::ProhibitBuiltinHomonyms)
{
my ($self,$level,$msg,@args) = @_;
# Check log level and set text
my $logtxt = "UNKNOWN";
if ($level == LOG_DEBUG) {
......@@ -980,14 +1299,19 @@ sub log
$msg = "[CORE] $logtxt: $msg";
}
$self->SUPER::log($level,"[".$self->log_time." - $$] $msg",@args);
# If we have args, this is more than likely a format string & args
if (@args > 0) {
$msg = sprintf($msg,@args);
}
return $self->SUPER::log($level,"[".$self->log_time." - $$] $msg");
}
# Display help
sub displayHelp {
print(STDERR "SMRadius v".VERSION." - Copyright (c) 2007-2009, AllWorldIT\n");
print(STDERR "SMRadius v$VERSION - Copyright (c) 2007-2016, AllWorldIT\n");
print(STDERR<<EOF);
......@@ -997,13 +1321,133 @@ Usage: $0 [args]
--fg Don't go into background
EOF
return;
}
#
# Internal functions
#
# Process reply attributes
sub _processReplyAttributes
{
my ($self,$request,$user,$pkt) = @_;
# Add attributes we got from plugins and process attributes attached to the user
my %replyAttributes = %{ $user->{'ReplyAttributes'} };
foreach my $attrName (keys %{$user->{'Attributes'}}) {
# Loop with operators
foreach my $attrOp (keys %{$user->{'Attributes'}->{$attrName}}) {
# Grab attribute
my $attr = $user->{'Attributes'}->{$attrName}->{$attrOp};
# Add this to the reply attribute?
setReplyAttribute($self,\%replyAttributes,$attr);
}
}
# Add vendor attributes we got from plugins and process attributes attached to the user
my %replyVAttributes = %{ $user->{'ReplyVAttributes'} };
foreach my $attrName (keys %{$user->{'VAttributes'}}) {
# Loop with operators
foreach my $attrOp (keys %{$user->{'VAttributes'}->{$attrName}}) {
# Grab attribute
my $attr = $user->{'VAttributes'}->{$attrName}->{$attrOp};
# Add this to the reply attribute?
setReplyVAttribute($self,\%replyVAttributes,$attr);
}
}
# Loop with reply attributes add them to our response, or output them to log if they were excluded
$request->addLogLine("RFILTER => ");
foreach my $attrName (keys %replyAttributes) {
# Loop with values
foreach my $value (@{$replyAttributes{$attrName}}) {
# Check for filter matches
my $excluded = 0;
foreach my $item (@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Filter-Reply-Attribute'}}) {
my @attrList = split(/[;,]/,$item);
foreach my $aItem (@attrList) {
$excluded = 1 if (lc($attrName) eq lc($aItem));
}
}
# If we must be filtered, just exclude it then
if (!$excluded) {
# Add each value
$pkt->set_attr($attrName,$value);
} else {
$request->addLogLine("%s ",$attrName);
}
}
}
# Loop with reply vendor attributes add them to our response, or output them to log if they were excluded
$request->addLogLine(". RVFILTER => ");
# Process reply vattributes already added
foreach my $vendor (keys %replyVAttributes) {
# Loop with operators
foreach my $attrName (keys %{$replyVAttributes{$vendor}}) {
# Add each value
foreach my $value (@{$replyVAttributes{$vendor}->{$attrName}}) {
# Check for filter matches
my $excluded = 0;
foreach my $item (@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Filter-Reply-VAttribute'}}) {
my @attrList = split(/[;,]/,$item);
foreach my $aItem (@attrList) {
$excluded = 1 if (lc($attrName) eq lc($aItem));
}
}
# If we must be filtered, just exclude it then
if (!$excluded) {
# This attribute is not excluded, so its ok
$pkt->set_vsattr($vendor,$attrName,$value);
} else {
$request->addLogLine("%s ",$attrName);
}
}
}
}
# Add attributes onto logline
$request->addLogLine(". REPLY => ");
foreach my $attrName ($pkt->attributes) {
$request->addLogLine(
"%s: '%s",
$attrName,
$pkt->rawattr($attrName)
);
}
# Add vattributes onto logline
$request->addLogLine(". VREPLY => ");
# Loop with vendors
foreach my $vendor ($pkt->vendors()) {
# Loop with attributes
foreach my $attrName ($pkt->vsattributes($vendor)) {
# Grab the value
my @attrRawVal = ( $pkt->vsattr($vendor,$attrName) );
my $attrVal = $attrRawVal[0][0];
# Sanatize it a bit
if ($attrVal =~ /[[:cntrl:]]/) {
$attrVal = "-nonprint-";
} else {
$attrVal = "'$attrVal'";
}
$request->addLogLine(
"%s/%s: %s",
$vendor,
$attrName,
$attrVal
);
}
}
return $self;
};
__PACKAGE__->run;
1;
# vim: ts=4
lib/smradius/daemon/request.pm 0 → 100644
View file @ b659b33b
# Radius daemon request processing
# Copyright (C) 2007-2016, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
package smradius::daemon::request;
use strict;
use warnings;
use base qw{AWITPT::Object};
use DateTime;
use DateTime::TimeZone;
use Try::Tiny;
use smradius::Radius::Packet;
# Parse radius packet
sub parsePacket
{
my ($self,$dictionary,$rawPacket) = @_;
# Parse the radius packet
$self->{'packet'} = smradius::Radius::Packet->new($dictionary,$rawPacket);
# Loop with packet attribute names and add to our log line
$self->addLogLine("PACKET => ");
foreach my $attrName (sort $self->{'packet'}->attributes()) {
# Make the value a bit more pretty to print
my $attrVal;
if ($attrName eq "User-Password") {
$attrVal = "-encrypted-";
} else {
$attrVal = $self->{'packet'}->rawattr($attrName);
}
# Add it onto the log line...
$self->addLogLine(
"%s: '%s'",
$attrName,
$attrVal,
);
}
# Set the username
$self->{'user'}->{'Username'} = $self->{'packet'}->attr('User-Name');
# Set the packet timestamp in unix time
if (my $timestamp = $self->{'packet'}->rawattr('Event-Timestamp')) {
$self->setTimestamp($timestamp);
} else {
$self->setTimestamp(time());
}
return $self;
}
# Set internal timestamp
sub setTimestamp
{
my ($self,$timestamp) = @_;
# Set timestamp
$self->{'user'}->{'_Internal'}->{'Timestamp-Unix'} = $timestamp;
# Grab real event timestamp in local time uzing the time zone
my $eventTimestamp = DateTime->from_epoch(
epoch => $self->{'user'}->{'_Internal'}->{'Timestamp-Unix'},
time_zone => $self->{'timezone'},
);
# Set the timestamp (not in unix)
$self->{'user'}->{'_Internal'}->{'Timestamp'} = $eventTimestamp->strftime('%Y-%m-%d %H:%M:%S');
return $self;
}
# Set internal time zone
sub setTimezone
{
my ($self,$timezone) = @_;
my $timezone_obj;
try {
$timezone_obj = DateTime::TimeZone->new('name' => $timezone);
};
# Retrun if we don't have a value, this means we failed
return if (!defined($timezone_obj));
$self->{'timezone'} = $timezone_obj;
return $self;
}
# Add something onto the log line in printf() style...
sub addLogLine
{
my ($self,$template,@params) = @_;
# Add on template and params
push(@{$self->{'logLine'}},$template);
push(@{$self->{'logLineParams'}},@params);
return $self;
}
# Return if the Username attribute of the user is defined
sub hasUsername
{
my $self = shift;
return defined($self->{'user'}->{'Username'});
}
#
# INTERNAL METHODS
#
# This method is called from the new-> method during instantiation
sub _init
{
my ($self) = @_;
# Initialize log line
$self->{'logLine'} = [ ];
$self->{'logLineParams'} = [ ];
$self->{'timezone'} = "UTC";
# Initialize user
$self->{'user'} = {
'Username' => undef,
'ConfigAttributes' => { },
'Attributes' => { },
'VAttributes' => { },
'ReplyAttributes' => { },
'ReplyVAttributes' => { },
'AttributeConditionalVariables' => { },
};
return $self;
}
1;
# vim: ts=4
smradius/logging.pm → lib/smradius/logging.pm
View file @ b659b33b
# Logging constants
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2015, AllWorldIT
#
# 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
......
lib/smradius/modules/accounting/mod_accounting_sql.pm 0 → 100644
View file @ b659b33b
# SQL accounting database
# Copyright (C) 2007-2019, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
package smradius::modules::accounting::mod_accounting_sql;
use strict;
use warnings;
# Modules we need
use smradius::constants;
use AWITPT::Cache;
use AWITPT::DB::DBLayer;
use AWITPT::Util;
use smradius::logging;
use smradius::util;
use POSIX qw(ceil);
use DateTime;
use Math::BigInt;
use Math::BigFloat;
# Exporter stuff
use base qw(Exporter);
our @EXPORT = qw(
);
our @EXPORT_OK = qw(
);
# Plugin info
our $pluginInfo = {
Name => "SQL Accounting Database",
Init => \&init,
# Cleanup run by smadmin
CleanupOrder => 30,
Cleanup => \&cleanup,
# Accounting database
Accounting_log => \&acct_log,
Accounting_getUsage => \&getUsage
};
# Module config
my $config;
## @internal
# Initialize module
sub init
{
my $server = shift;
my $scfg = $server->{'inifile'};
# Enable support for database
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Enabling database support");
if (!$server->{'smradius'}->{'database'}->{'enabled'}) {
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Enabling database support.");
$server->{'smradius'}->{'database'}->{'enabled'} = 1;
}
# Default configs...
$config->{'accounting_start_query'} = '
INSERT INTO
@TP@accounting
(
Username,
ServiceType,
FramedProtocol,
NASPort,
NASPortType,
CallingStationID,
CalledStationID,
NASPortID,
AcctSessionID,
FramedIPAddress,
AcctAuthentic,
EventTimestamp,
AcctStatusType,
NASIdentifier,
NASIPAddress,
AcctDelayTime,
AcctSessionTime,
AcctInputOctets,
AcctInputGigawords,
AcctInputPackets,
AcctOutputOctets,
AcctOutputGigawords,
AcctOutputPackets,
PeriodKey
)
VALUES
(
%{user.Username},
%{request.Service-Type},
%{request.Framed-Protocol},
%{request.NAS-Port},
%{request.NAS-Port-Type},
%{request.Calling-Station-Id},
%{request.Called-Station-Id},
%{request.NAS-Port-Id},
%{request.Acct-Session-Id},
%{request.Framed-IP-Address},
%{request.Acct-Authentic},
%{request.Timestamp},
%{request.Acct-Status-Type},
%{request.NAS-Identifier},
%{request.NAS-IP-Address},
%{request.Acct-Delay-Time},
%{request.Acct-Session-Time},
%{request.Acct-Input-Octets},
%{request.Acct-Input-Gigawords},
%{request.Acct-Input-Packets},
%{request.Acct-Output-Octets},
%{request.Acct-Output-Gigawords},
%{request.Acct-Output-Packets},
%{query.PeriodKey}
)
';
$config->{'accounting_update_get_records_query'} = '
SELECT
SUM(AcctInputOctets) AS AcctInputOctets,
SUM(AcctInputPackets) AS AcctInputPackets,
SUM(AcctOutputOctets) AS AcctOutputOctets,
SUM(AcctOutputPackets) AS AcctOutputPackets,
SUM(AcctInputGigawords) AS AcctInputGigawords,
SUM(AcctOutputGigawords) AS AcctOutputGigawords,
SUM(AcctSessionTime) AS AcctSessionTime,
PeriodKey
FROM
@TP@accounting
WHERE
Username = %{user.Username}
AND AcctSessionID = %{request.Acct-Session-Id}
AND NASIPAddress = %{request.NAS-IP-Address}
AND NASPort = %{request.NAS-Port}
GROUP BY
PeriodKey
ORDER BY
ID ASC
';
$config->{'accounting_update_query'} = '
UPDATE
@TP@accounting
SET
AcctSessionTime = %{query.Acct-Session-Time},
AcctInputOctets = %{query.Acct-Input-Octets},
AcctInputGigawords = %{query.Acct-Input-Gigawords},
AcctInputPackets = %{query.Acct-Input-Packets},
AcctOutputOctets = %{query.Acct-Output-Octets},
AcctOutputGigawords = %{query.Acct-Output-Gigawords},
AcctOutputPackets = %{query.Acct-Output-Packets},
AcctStatusType = %{request.Acct-Status-Type}
WHERE
Username = %{user.Username}
AND AcctSessionID = %{request.Acct-Session-Id}
AND NASIPAddress = %{request.NAS-IP-Address}
AND NASPort = %{request.NAS-Port}
AND PeriodKey = %{query.PeriodKey}
';
$config->{'accounting_stop_status_query'} = '
UPDATE
@TP@accounting
SET
AcctStatusType = %{request.Acct-Status-Type},
AcctTerminateCause = %{request.Acct-Terminate-Cause}
WHERE
Username = %{user.Username}
AND AcctSessionID = %{request.Acct-Session-Id}
AND NASIPAddress = %{request.NAS-IP-Address}
AND NASPort = %{request.NAS-Port}
';
$config->{'accounting_usage_query'} = '
SELECT
SUM(AcctInputOctets) AS AcctInputOctets,
SUM(AcctOutputOctets) AS AcctOutputOctets,
SUM(AcctInputGigawords) AS AcctInputGigawords,
SUM(AcctOutputGigawords) AS AcctOutputGigawords,
SUM(AcctSessionTime) AS AcctSessionTime
FROM
@TP@accounting
WHERE
Username = %{user.Username}
AND PeriodKey = %{query.PeriodKey}
';
$config->{'accounting_usage_query_period'} = '
SELECT
SUM(AcctInputOctets) AS AcctInputOctets,
SUM(AcctOutputOctets) AS AcctOutputOctets,
SUM(AcctInputGigawords) AS AcctInputGigawords,
SUM(AcctOutputGigawords) AS AcctOutputGigawords,
SUM(AcctSessionTime) AS AcctSessionTime
FROM
@TP@accounting
WHERE
Username = %{user.Username}
AND EventTimestamp > %{query.PeriodKey}
';
$config->{'accounting_select_duplicates_query'} = '
SELECT
ID
FROM
@TP@accounting
WHERE
Username = %{user.Username}
AND AcctSessionID = %{request.Acct-Session-Id}
AND NASIPAddress = %{request.NAS-IP-Address}
AND NASPort = %{request.NAS-Port}
AND PeriodKey = %{query.PeriodKey}
ORDER BY
ID
LIMIT 99 OFFSET 1
';
$config->{'accounting_delete_duplicates_query'} = '
DELETE FROM
@TP@accounting
WHERE
ID = %{query.DuplicateID}
';
$config->{'accounting_usage_cache_time'} = 300;
# Setup SQL queries
if (defined($scfg->{'mod_accounting_sql'})) {
# Pull in queries
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_start_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_start_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_start_query'}) eq "ARRAY") {
$config->{'accounting_start_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_start_query'}});
} else {
$config->{'accounting_start_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_start_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_update_get_records_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_update_get_records_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_update_get_records_query'}) eq "ARRAY") {
$config->{'accounting_update_get_records_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_update_get_records_query'}});
} else {
$config->{'accounting_update_get_records_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_update_get_records_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_update_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_update_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_update_query'}) eq "ARRAY") {
$config->{'accounting_update_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_update_query'}});
} else {
$config->{'accounting_update_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_update_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_stop_status_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_stop_status_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_stop_status_query'}) eq "ARRAY") {
$config->{'accounting_stop_status_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_stop_status_query'}});
} else {
$config->{'accounting_stop_status_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_stop_status_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_usage_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_usage_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_usage_query'}) eq "ARRAY") {
$config->{'accounting_usage_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_usage_query'}});
} else {
$config->{'accounting_usage_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_usage_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_usage_query_period'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_usage_query_period'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_usage_query_period'}) eq "ARRAY") {
$config->{'accounting_usage_query_period'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_usage_query_period'}});
} else {
$config->{'accounting_usage_query_period'} = $scfg->{'mod_accounting_sql'}->{'accounting_usage_query_period'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_select_duplicates_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_select_duplicates_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_select_duplicates_query'}) eq "ARRAY") {
$config->{'accounting_select_duplicates_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_select_duplicates_query'}});
} else {
$config->{'accounting_select_duplicates_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_select_duplicates_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_delete_duplicates_query'}) &&
$scfg->{'mod_accounting_sql'}->{'accounting_delete_duplicates_query'} ne "") {
if (ref($scfg->{'mod_accounting_sql'}->{'accounting_delete_duplicates_query'}) eq "ARRAY") {
$config->{'accounting_delete_duplicates_query'} = join(' ',
@{$scfg->{'mod_accounting_sql'}->{'accounting_delete_duplicates_query'}});
} else {
$config->{'accounting_delete_duplicates_query'} = $scfg->{'mod_accounting_sql'}->{'accounting_delete_duplicates_query'};
}
}
if (defined($scfg->{'mod_accounting_sql'}->{'accounting_usage_cache_time'})) {
# Check if we're a boolean
if (defined(my $val = isBoolean($scfg->{'mod_accounting_sql'}{'accounting_usage_cache_time'}))) {
# If val is true, we default to the default anyway
# We're disabled
if (!$val) {
$config->{'accounting_usage_cache_time'} = undef;
}
# We *could* have a value...
} elsif ($scfg->{'mod_accounting_sql'}{'accounting_usage_cache_time'} =~ /^[0-9]+$/) {
$config->{'accounting_usage_cache_time'} = $scfg->{'mod_accounting_sql'}{'accounting_usage_cache_time'};
} else {
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Value for 'accounting_usage_cache_time' is invalid");
}
}
}
# Log this for info sake
if (defined($config->{'accounting_usage_cache_time'})) {
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] getUsage caching ENABLED, cache time is %ds.",
$config->{'accounting_usage_cache_time'});
} else {
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] getUsage caching DISABLED");
}
}
# Function to get radius user data usage
# The 'period' parameter is optional and is the number of days to return usage for
sub getUsage
{
my ($server,$user,$packet,$period) = @_;
# Build template
my $template;
foreach my $attr ($packet->attributes) {
$template->{'request'}->{$attr} = $packet->rawattr($attr)
}
# Add user details
$template->{'user'}->{'ID'} = $user->{'ID'};
$template->{'user'}->{'Username'} = $user->{'Username'};
# Current PeriodKey, this is used for non-$period queries
my $now = DateTime->now->set_time_zone($server->{'smradius'}->{'event_timezone'});
# Query template to use below
my $queryTemplate;
# If we're doing a query for a specific period
if (defined($period)) {
# We need to switch out the query to the period query
$queryTemplate = "accounting_usage_query_period";
# Grab a clone of now, and create the start date DateTime object
my $startDate = $now->clone->subtract( 'days' => $period );
# And we add the start date
$template->{'query'}->{'PeriodKey'} = $startDate->ymd();
# If not, we just use PeriodKey as normal...
} else {
# Set the normal PeriodKey query template to use
$queryTemplate = "accounting_usage_query";
# And set the period key to this month
$template->{'query'}->{'PeriodKey'} = $now->strftime("%Y-%m");
}
# If we using caching, check how old the result is
if (defined($config->{'accounting_usage_cache_time'})) {
my ($res,$val) = cacheGetComplexKeyPair('mod_accounting_sql(getUsage)',$user->{'Username'}."/".
$template->{'query'}->{'PeriodKey'});
if (defined($val) && $val->{'CachedUntil'} > $user->{'_Internal'}->{'Timestamp-Unix'}) {
return $val;
}
}
# Replace template entries
my (@dbDoParams) = templateReplace($config->{$queryTemplate},$template);
# Fetch data
my $sth = DBSelect(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Database query failed: %s",AWITPT::DB::DBLayer::error());
return;
}
# Our usage hash
my %usageTotals;
$usageTotals{'TotalSessionTime'} = Math::BigInt->new(0);
$usageTotals{'TotalDataInput'} = Math::BigInt->new(0);
$usageTotals{'TotalDataOutput'} = Math::BigInt->new(0);
# Pull in usage and add up
while (my $row = hashifyLCtoMC($sth->fetchrow_hashref(),
qw(AcctSessionTime AcctInputOctets AcctInputGigawords AcctOutputOctets AcctOutputGigawords)
)) {
# Look for session time
if (defined($row->{'AcctSessionTime'}) && $row->{'AcctSessionTime'} > 0) {
$usageTotals{'TotalSessionTime'}->badd($row->{'AcctSessionTime'});
}
# Add input usage if we have any
if (defined($row->{'AcctInputOctets'}) && $row->{'AcctInputOctets'} > 0) {
$usageTotals{'TotalDataInput'}->badd($row->{'AcctInputOctets'});
}
if (defined($row->{'AcctInputGigawords'}) && $row->{'AcctInputGigawords'} > 0) {
my $inputGigawords = Math::BigInt->new($row->{'AcctInputGigawords'});
$inputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{'TotalDataInput'}->badd($inputGigawords);
}
# Add output usage if we have any
if (defined($row->{'AcctOutputOctets'}) && $row->{'AcctOutputOctets'} > 0) {
$usageTotals{'TotalDataOutput'}->badd($row->{'AcctOutputOctets'});
}
if (defined($row->{'AcctOutputGigawords'}) && $row->{'AcctOutputGigawords'} > 0) {
my $outputGigawords = Math::BigInt->new($row->{'AcctOutputGigawords'});
$outputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{'TotalDataOutput'}->badd($outputGigawords);
}
}
DBFreeRes($sth);
# Convert to bigfloat for accuracy
my $totalData = Math::BigFloat->new(0);
$totalData->badd($usageTotals{'TotalDataOutput'})->badd($usageTotals{'TotalDataInput'});
my $totalTime = Math::BigFloat->new(0);
$totalTime->badd($usageTotals{'TotalSessionTime'});
# Rounding up
my %res;
$res{'TotalDataUsage'} = $totalData->bdiv(1024)->bdiv(1024)->bceil()->bstr();
$res{'TotalSessionTime'} = $totalTime->bdiv(60)->bceil()->bstr();
# If we using caching and got here, it means that we must cache the result
if (defined($config->{'accounting_usage_cache_time'})) {
$res{'CachedUntil'} = $user->{'_Internal'}->{'Timestamp-Unix'} + $config->{'accounting_usage_cache_time'};
# Cache the result
cacheStoreComplexKeyPair('mod_accounting_sql(getUsage)',$user->{'Username'}."/".$template->{'query'}->{'PeriodKey'},\%res);
}
return \%res;
}
## @log
# Try find a user
#
# @param server Server object
# @param user User object
# @param packet Radius packet
#
# @return Result
sub acct_log
{
my ($server,$user,$packet) = @_;
# Build template
my $template;
foreach my $attr ($packet->attributes) {
$template->{'request'}->{$attr} = $packet->rawattr($attr);
}
# Fix event timestamp
$template->{'request'}->{'Timestamp'} = $user->{'_Internal'}->{'Timestamp'};
# Add user details
$template->{'user'}->{'ID'} = $user->{'ID'};
$template->{'user'}->{'Username'} = $user->{'Username'};
# Current PeriodKey
my $now = DateTime->now->set_time_zone($server->{'smradius'}->{'event_timezone'});
my $periodKey = $now->strftime("%Y-%m");
# For our queries
$template->{'query'}->{'PeriodKey'} = $periodKey;
# Default to being a new period, only if we update on INTERIM or STOP do we set this to 0
my $newPeriod = 1;
#
# U P D A T E & S T O P P A C K E T
#
if ($packet->rawattr('Acct-Status-Type') eq "2" || $packet->rawattr('Acct-Status-Type') eq "3") {
# Replace template entries
my @dbDoParams = templateReplace($config->{'accounting_update_get_records_query'},$template);
# Fetch previous records of the same session
my $sth = DBSelect(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Database query failed: %s",AWITPT::DB::DBLayer::error());
return;
}
# Convert session total gigawords into bytes
my $totalInputBytes = Math::BigInt->new($template->{'request'}->{'Acct-Input-Gigawords'});
my $totalOutputBytes = Math::BigInt->new($template->{'request'}->{'Acct-Output-Gigawords'});
$totalInputBytes->bmul(GIGAWORD_VALUE);
$totalOutputBytes->bmul(GIGAWORD_VALUE);
# Add byte counters
$totalInputBytes->badd($template->{'request'}->{'Acct-Input-Octets'});
$totalOutputBytes->badd($template->{'request'}->{'Acct-Output-Octets'});
# Packets, no conversion
my $totalInputPackets = Math::BigInt->new($template->{'request'}->{'Acct-Input-Packets'});
my $totalOutputPackets = Math::BigInt->new($template->{'request'}->{'Acct-Output-Packets'});
# We don't need bigint here, but why not ... lets keep everything standard
my $totalSessionTime = Math::BigInt->new($template->{'request'}->{'Acct-Session-Time'});
# Loop through previous records and subtract them from our session totals
while (my $sessionPart = hashifyLCtoMC($sth->fetchrow_hashref(),
qw(AcctInputOctets AcctInputPackets AcctOutputOctets AcctOutputPackets AcctInputGigawords AcctOutputGigawords
SessionTime PeriodKey)
)) {
# Make sure we treat undef values sort of sanely
$sessionPart->{'AcctInputGigawords'} //= 0;
$sessionPart->{'AcctInputOctets'} //= 0;
$sessionPart->{'AcctOutputGigawords'} //= 0;
$sessionPart->{'AcctOutputOctets'} //= 0;
$sessionPart->{'AcctInputPackets'} //= 0;
$sessionPart->{'AcctOutputPackets'} //= 0;
$sessionPart->{'AcctSessionTime'} //= 0;
# Convert the gigawords into bytes
my $sessionInputBytes = Math::BigInt->new($sessionPart->{'AcctInputGigawords'});
my $sessionOutputBytes = Math::BigInt->new($sessionPart->{'AcctOutputGigawords'});
$sessionInputBytes->bmul(GIGAWORD_VALUE);
$sessionOutputBytes->bmul(GIGAWORD_VALUE);
# Add the byte counters
$sessionInputBytes->badd($sessionPart->{'AcctInputOctets'});
$sessionOutputBytes->badd($sessionPart->{'AcctOutputOctets'});
# And packets
my $sessionInputPackets = Math::BigInt->new($sessionPart->{'AcctInputPackets'});
my $sessionOutputPackets = Math::BigInt->new($sessionPart->{'AcctOutputPackets'});
# Finally session time
my $sessionSessionTime = Math::BigInt->new($sessionPart->{'AcctSessionTime'});
# Check if this record is from an earlier period
if (defined($sessionPart->{'PeriodKey'}) && $sessionPart->{'PeriodKey'} ne $periodKey) {
# Subtract from our total, we can hit NEG!!! ... we check for that below
$totalInputBytes->bsub($sessionInputBytes);
$totalOutputBytes->bsub($sessionOutputBytes);
$totalInputPackets->bsub($sessionInputPackets);
$totalOutputPackets->bsub($sessionOutputPackets);
$totalSessionTime->bsub($sessionSessionTime);
# We need to continue this session in a new entry
$newPeriod = 1;
}
}
DBFreeRes($sth);
# Sanitize
if ($totalInputBytes->is_neg()) {
$totalInputBytes->bzero();
}
if ($totalOutputBytes->is_neg()) {
$totalOutputBytes->bzero();
}
if ($totalInputPackets->is_neg()) {
$totalInputPackets->bzero();
}
if ($totalOutputPackets->is_neg()) {
$totalOutputPackets->bzero();
}
if ($totalSessionTime->is_neg()) {
$totalSessionTime->bzero();
}
# Re-calculate
my ($inputGigawordsStr,$inputOctetsStr) = $totalInputBytes->bdiv(GIGAWORD_VALUE);
my ($outputGigawordsStr,$outputOctetsStr) = $totalOutputBytes->bdiv(GIGAWORD_VALUE);
# Conversion to strings
$template->{'query'}->{'Acct-Input-Gigawords'} = $inputGigawordsStr->bstr();
$template->{'query'}->{'Acct-Input-Octets'} = $inputOctetsStr->bstr();
$template->{'query'}->{'Acct-Output-Gigawords'} = $outputGigawordsStr->bstr();
$template->{'query'}->{'Acct-Output-Octets'} = $outputOctetsStr->bstr();
$template->{'query'}->{'Acct-Input-Packets'} = $totalInputPackets->bstr();
$template->{'query'}->{'Acct-Output-Packets'} = $totalOutputPackets->bstr();
$template->{'query'}->{'Acct-Session-Time'} = $totalSessionTime->bstr();
# Replace template entries
@dbDoParams = templateReplace($config->{'accounting_update_query'},$template);
# Update database
$sth = DBDo(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Failed to update accounting ALIVE record: ".
AWITPT::DB::DBLayer::error());
return MOD_RES_NACK;
}
# If we updated *something* ...
if ($sth ne "0E0") {
# Be very sneaky .... if we updated something, this is obviously NOT a new period
$newPeriod = 0;
# If we updated a few things ... possibly duplicates?
if ($sth > 1) {
fixDuplicates($server, $template);
}
}
}
#
# S T A R T P A C K E T
#
# Possible aswell if we are missing a start packet for this session or for the period
#
if ($packet->rawattr('Acct-Status-Type') eq "1" || $newPeriod) {
# Replace template entries
my @dbDoParams = templateReplace($config->{'accounting_start_query'},$template);
# Insert into database
my $sth = DBDo(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Failed to insert accounting START record: ".
AWITPT::DB::DBLayer::error());
return MOD_RES_NACK;
}
# Update first login?
if (defined($user->{'_UserDB'}->{'Users_data_get'}) && defined($user->{'_UserDB'}->{'Users_data_set'})) {
# Try get his first login
my $firstLogin = $user->{'_UserDB'}->{'Users_data_get'}($server,$user,'global','FirstLogin');
# If we don't get it, set it
if (!defined($firstLogin)) {
$user->{'_UserDB'}->{'Users_data_set'}($server,$user,'global','FirstLogin',$user->{'_Internal'}->{'Timestamp-Unix'});
}
}
}
#
# S T O P P A C K E T specifics
#
if ($packet->rawattr('Acct-Status-Type') eq "2") {
# Replace template entries
my @dbDoParams = templateReplace($config->{'accounting_stop_status_query'},$template);
# Update database (status)
my $sth = DBDo(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Failed to update accounting STOP record: %s",AWITPT::DB::DBLayer::error());
return MOD_RES_NACK;
}
}
return MOD_RES_ACK;
}
# Resolve duplicate records
sub fixDuplicates
{
my ($server, $template) = @_;
# Replace template entries
my @dbDoParams = templateReplace($config->{'accounting_select_duplicates_query'},$template);
# Select duplicates
my $sth = DBSelect(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Database query failed: %s",AWITPT::DB::DBLayer::error());
return;
}
# Pull in duplicates
my @IDList;
while (my $duplicates = hashifyLCtoMC($sth->fetchrow_hashref(), qw(ID))) {
push(@IDList,$duplicates->{'ID'});
}
DBFreeRes($sth);
# Loop through IDs and delete
DBBegin();
foreach my $duplicateID (@IDList) {
# Add ID list to the template
$template->{'query'}->{'DuplicateID'} = $duplicateID;
# Replace template entries
@dbDoParams = templateReplace($config->{'accounting_delete_duplicates_query'},$template);
# Delete duplicates
$sth = DBDo(@dbDoParams);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Database query failed: %s",AWITPT::DB::DBLayer::error());
DBRollback();
return;
}
}
# Commit changes to the database
$server->log(LOG_DEBUG,"[MOD_ACCOUNTING_SQL] Duplicate accounting records deleted");
DBCommit();
return
}
# Add up totals function
sub cleanup
{
my ($server,$runForDate) = @_;
# The datetime now
my $now = DateTime->from_epoch(epoch => $runForDate)->set_time_zone($server->{'smradius'}->{'event_timezone'});
# Use truncate to set all values after 'month' to their default values
my $thisMonth = $now->clone()->truncate( to => "month" );
# Last month..
my $lastMonth = $thisMonth->clone()->subtract( months => 1 );
my $prevPeriodKey = $lastMonth->strftime("%Y-%m");
# Begin transaction
DBBegin();
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Cleanup => Removing previous accounting summaries (if any)");
# Delete duplicate records
# NK: MYSQL SPECIFIC
my $sth = DBDo('
DELETE FROM
@TP@accounting_summary
WHERE
STR_TO_DATE(PeriodKey,"%Y-%m") >= ?',
$prevPeriodKey
);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Cleanup => Failed to delete accounting summary record: ".
AWITPT::DB::DBLayer::error());
DBRollback();
return;
}
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Cleanup => Generating accounting summaries");
# Select totals for last month
$sth = DBSelect('
SELECT
Username,
AcctSessionTime,
AcctInputOctets,
AcctInputGigawords,
AcctOutputOctets,
AcctOutputGigawords
FROM
@TP@accounting
WHERE
PeriodKey = ?
',
$prevPeriodKey
);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Cleanup => Failed to select accounting record: ".
AWITPT::DB::DBLayer::error());
return;
}
# Load items into array
my %usageTotals;
while (my $row = hashifyLCtoMC($sth->fetchrow_hashref(),
qw(Username AcctSessionTime AcctInputOctets AcctInputGigawords AcctOutputOctets AcctOutputGigawords)
)) {
# check if we've seen this user, if so just add up
if (defined($usageTotals{$row->{'Username'}})) {
# Look for session time
if (defined($row->{'AcctSessionTime'}) && $row->{'AcctSessionTime'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalSessionTime'}->badd($row->{'AcctSessionTime'});
}
# Add input usage if we have any
if (defined($row->{'AcctInputOctets'}) && $row->{'AcctInputOctets'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalDataInput'}->badd($row->{'AcctInputOctets'});
}
if (defined($row->{'AcctInputGigawords'}) && $row->{'AcctInputGigawords'} > 0) {
my $inputGigawords = Math::BigInt->new($row->{'AcctInputGigawords'});
$inputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{$row->{'Username'}}{'TotalDataInput'}->badd($inputGigawords);
}
# Add output usage if we have any
if (defined($row->{'AcctOutputOctets'}) && $row->{'AcctOutputOctets'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalDataOutput'}->badd($row->{'AcctOutputOctets'});
}
if (defined($row->{'AcctOutputGigawords'}) && $row->{'AcctOutputGigawords'} > 0) {
my $outputGigawords = Math::BigInt->new($row->{'AcctOutputGigawords'});
$outputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{$row->{'Username'}}{'TotalDataOutput'}->badd($outputGigawords);
}
# This is a new record...
} else {
# Make BigInts for this user
$usageTotals{$row->{'Username'}}{'TotalSessionTime'} = Math::BigInt->new(0);
$usageTotals{$row->{'Username'}}{'TotalDataInput'} = Math::BigInt->new(0);
$usageTotals{$row->{'Username'}}{'TotalDataOutput'} = Math::BigInt->new(0);
# Look for session time
if (defined($row->{'AcctSessionTime'}) && $row->{'AcctSessionTime'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalSessionTime'}->badd($row->{'AcctSessionTime'});
}
# Add input usage if we have any
if (defined($row->{'AcctInputOctets'}) && $row->{'AcctInputOctets'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalDataInput'}->badd($row->{'AcctInputOctets'});
}
if (defined($row->{'AcctInputGigawords'}) && $row->{'AcctInputGigawords'} > 0) {
my $inputGigawords = Math::BigInt->new($row->{'AcctInputGigawords'});
$inputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{$row->{'Username'}}{'TotalDataInput'}->badd($inputGigawords);
}
# Add output usage if we have any
if (defined($row->{'AcctOutputOctets'}) && $row->{'AcctOutputOctets'} > 0) {
$usageTotals{$row->{'Username'}}{'TotalDataOutput'}->badd($row->{'AcctOutputOctets'});
}
if (defined($row->{'AcctOutputGigawords'}) && $row->{'AcctOutputGigawords'} > 0) {
my $outputGigawords = Math::BigInt->new($row->{'AcctOutputGigawords'});
$outputGigawords->bmul(GIGAWORD_VALUE);
$usageTotals{$row->{'Username'}}{'TotalDataOutput'}->badd($outputGigawords);
}
}
}
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Cleanup => Creating new accounting summaries");
# Loop through users and insert totals
foreach my $username (keys %usageTotals) {
# Convert to bigfloat for accuracy
my $totalDataOutput = Math::BigFloat->new($usageTotals{$username}{'TotalDataOutput'});
my $totalDataInput = Math::BigFloat->new($usageTotals{$username}{'TotalDataInput'});
my $totalTime = Math::BigFloat->new($usageTotals{$username}{'TotalSessionTime'});
# Rounding up
my $res;
$res->{'TotalDataInput'} = $totalDataInput->bdiv(1024)->bdiv(1024)->bceil()->bstr();
$res->{'TotalDataOutput'} = $totalDataOutput->bdiv(1024)->bdiv(1024)->bceil()->bstr();
$res->{'TotalSessionTime'} = $totalTime->bdiv(60)->bceil()->bstr();
# Do query
$sth = DBDo('
INSERT INTO
@TP@accounting_summary
(
Username,
PeriodKey,
TotalSessionTime,
TotalInput,
TotalOutput
)
VALUES
(?,?,?,?,?)
',
$username,
$prevPeriodKey,
$res->{'TotalSessionTime'},
$res->{'TotalDataInput'},
$res->{'TotalDataOutput'}
);
if (!$sth) {
$server->log(LOG_ERR,"[MOD_ACCOUNTING_SQL] Cleanup => Failed to create accounting summary record: ".
AWITPT::DB::DBLayer::error());
DBRollback();
return;
}
# Lets log
$server->log(LOG_DEBUG,"[MOD_ACCOUNTING_SQL] Cleanup => INSERT: Username = '%s', PeriodKey = '%s', ".
"TotalSessionTime = '%s', TotalInput = '%s', TotalOutput = '%s'", $username, $prevPeriodKey,
$res->{'TotalSessionTime'}, $res->{'TotalDataInput'}, $res->{'TotalDataOutput'});
}
# Commit if succeeded
DBCommit();
$server->log(LOG_NOTICE,"[MOD_ACCOUNTING_SQL] Cleanup => Accounting summaries created");
}
1;
# vim: ts=4
smradius/modules/accounting/mod_accounting_test.pm → lib/smradius/modules/accounting/mod_accounting_test.pm
View file @ b659b33b
# Test accounting database
# Copyright (C) 2007-2009, AllWorldIT
#
# Copyright (C) 2007-2016, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
......@@ -99,15 +99,18 @@ Acct-Delay-Time: %{accounting.Acct-Delay-Time}
foreach my $attr ($packet->attributes) {
$template->{'accounting'}->{$attr} = $packet->attr($attr)
}
$template->{'user'} = $user;
if ($packet->attr('Acct-Status-Type') eq "Start") {
# Add user details
$template->{'user'}->{'ID'} = $user->{'ID'};
$template->{'user'}->{'Username'} = $user->{'Username'};
if ($packet->rawattr('Acct-Status-Type') eq "1") {
$server->log(LOG_DEBUG,"Start Packet: ".$packet->dump());
} elsif ($packet->attr('Acct-Status-Type') eq "Alive") {
} elsif ($packet->rawattr('Acct-Status-Type') eq "3") {
$server->log(LOG_DEBUG,"Alive Packet: ".$packet->dump());
} elsif ($packet->attr('Acct-Status-Type') eq "Stop") {
} elsif ($packet->rawattr('Acct-Status-Type') eq "2") {
$server->log(LOG_DEBUG,"Stop Packet: ".$packet->dump());
}
......
smradius/modules/authentication/mod_auth_chap.pm → lib/smradius/modules/authentication/mod_auth_chap.pm
View file @ b659b33b
# CHAP authentication
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2015, AllWorldIT
#
# References:
# RFC1944 - PPP Challenge Handshake Authentication Protocol (CHAP)
......
smradius/config.pm → lib/smradius/modules/authentication/mod_auth_macauth.pm
View file @ b659b33b
# SMRadius config information
# Copyright (C) 2007-2009, AllWorldIT
# MAC Authentication
# Copyright (C) 2007-2015, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
## @class smradius::config
# Configuration handling class
package smradius::config;
package smradius::modules::authentication::mod_auth_macauth;
use strict;
use warnings;
# Modules we need
use smradius::attributes;
use smradius::constants;
use smradius::logging;
# Exporter stuff
require Exporter;
our (@ISA,@EXPORT);
our (@ISA,@EXPORT,@EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT = qw(
);
@EXPORT_OK = qw(
);
use smradius::logging;
# Plugin info
our $pluginInfo = {
Name => "MAC Authentication",
Init => \&init,
# Authentication
Authentication_try => \&authenticate,
};
# Our vars
my $config;
## @fn Init($server)
# Initialize this module with a server object
#
# @param server Server object we need to setup
sub Init
## @internal
# Initialize module
sub init
{
my $server = shift;
}
# Setup configuration
$config = $server->{'inifile'};
my $db;
$db->{'DSN'} = $config->{'database'}{'dsn'};
$db->{'Username'} = $config->{'database'}{'username'};
$db->{'Password'} = $config->{'database'}{'password'};
$db->{'enabled'} = 0;
## @authenticate
# Try authenticate user
#
# @param server Server object
# @param user User hash
# @param packet Radius packet
#
# @return Result
sub authenticate
{
my ($server,$user,$packet) = @_;
# Check we have all the config we need
if (!defined($db->{'DSN'})) {
$server->log(LOG_NOTICE,"smradius/config.pm: No 'DSN' defined in config file for 'database'");
}
$server->{'smradius'}{'database'} = $db;
}
# This is not a MAC authentication request
if ($user->{'_UserDB'}->{'Name'} ne "SQL User Database (MAC authentication)") {
return MOD_RES_SKIP;
}
$server->log(LOG_DEBUG,"[MOD_AUTH_MACAUTH] This is a MAC authentication request");
## @fn getConfig
# Get the config hash
#
# @return Hash ref of all our config items
sub getConfig
{
return $config;
return MOD_RES_ACK;
}
1;
# vim: ts=4
smradius/modules/authentication/mod_auth_mschap.pm → lib/smradius/modules/authentication/mod_auth_mschap.pm
View file @ b659b33b
# Microsoft CHAP version 1 and 2 support
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2015, AllWorldIT
#
# References:
# RFC1994 - PPP Challenge Handshake Authentication Protocol (CHAP)
# RFC2443 - Microsoft PPP CHAP Extensions
# RFC2759 - Microsoft PPP CHAP Extensions, Version 2
# RFC2548 - Microsoft Vendor-specific RADIUS Attributes
# RFC3079 - Deriving Keys for use with Microsoft Point-to-Point
# Encryption (MPPE)
#
# 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
......@@ -36,8 +38,9 @@ use smradius::constants;
use smradius::logging;
use Crypt::DES;
use Crypt::RC4;
use Digest::SHA1;
use Digest::SHA;
use Digest::MD4 qw( md4 );
use Digest::MD5 qw( );
# Don't use unicode
use bytes;
......@@ -48,6 +51,8 @@ require Exporter;
our (@ISA,@EXPORT,@EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT = qw(
);
@EXPORT_OK = qw(
GenerateNTResponse
ChallengeHash
NtPasswordHash
......@@ -57,8 +62,6 @@ our (@ISA,@EXPORT,@EXPORT_OK);
CheckAuthenticatorResponse
NtChallengeResponse
);
@EXPORT_OK = qw(
);
use constant {
......@@ -142,22 +145,29 @@ sub authenticate
my $challenge = @{$rawChallenge}[0];
my $response = substr(@{$rawResponse}[0],2);
# print(STDERR "RECEIVED\n");
# print(STDERR "Challenge: len = ".length($challenge).", hex = ".unpack("H*",$challenge)."\n");
# print(STDERR "Reponse : len = ".length($response).", hex = ".unpack("H*",$response)."\n");
# print(STDERR "\n\n");
# print(STDERR "CHOPPED OFFF!!\n");
# Chop off NtResponse
my $NtResponse = substr($response,24,24);
# print(STDERR "NTRespons: len = ".length($NtResponse).", hex = ".unpack("H*",$NtResponse)."\n");
# print(STDERR "\n\n");
# print(STDERR "TEST\n");
# Generate our response
my $ourResponse = NtChallengeResponse($challenge,$unicodePassword);
# print(STDERR "Calculate: len = ".length($ourResponse).", hex = ".unpack("H*",$ourResponse)."\n");
# print(STDERR "\n\n");
# MPPE Code
##################
my $NtPasswordHash = NtPasswordHash($unicodePassword);
my $HashNtPasswordHash = HashNtPasswordHash($NtPasswordHash);
my $sendkey = pack("x8a16",$HashNtPasswordHash);
my $recvkey;
setReplyVAttribute($server,$user->{'ReplyVAttributes'}, {
'Vendor' => 311,
'Name' => 'MS-CHAP-MPPE-Keys',
'Operator' => ":=",
'Value' => $sendkey
});
##################
# Check responses match
if ($NtResponse eq $ourResponse) {
......@@ -174,29 +184,13 @@ sub authenticate
my $ident = unpack("C", substr(@{$rawResponse2}[0],0,1));
my $response = substr(@{$rawResponse2}[0],2);
# print(STDERR "RECEIVED\n");
# print(STDERR "Challenge: len = ".length($challenge).", hex = ".unpack("H*",$challenge)."\n");
# print(STDERR "Ident : $ident\n");
# print(STDERR "Response : len = ".length($response).", hex = ".unpack("H*",$response)."\n");
# print(STDERR "\n\n");
# print(STDERR "CHOPPED OFFF!!\n");
# Grab peer challenge and response
my $peerChallenge = substr($response,0,16);
my $NtResponse = substr($response,24,24);
# print(STDERR "PeerChallenge: len = ".length($peerChallenge).", hex = ".unpack("H*",$peerChallenge)."\n");
# print(STDERR "NTResponse: len = ".length($NtResponse).", hex = ".unpack("H*",$NtResponse)."\n");
# print(STDERR "\n\n");
# print(STDERR "TEST\n");
# Generate our challenge and our response
my $ourChallenge = ChallengeHash($peerChallenge,$challenge,$username);
my $ourResponse = NtChallengeResponse($ourChallenge,$unicodePassword);
# print(STDERR "OurChallenge: len = ".length($ourChallenge).", hex = ".unpack("H*",$ourChallenge)."\n");
# print(STDERR "OurResponse: len = ".length($ourResponse).", hex = ".unpack("H*",$ourResponse)."\n");
# print(STDERR "\n\n");
# Check response match
if ($NtResponse eq $ourResponse) {
......@@ -204,8 +198,57 @@ sub authenticate
my $authenticatorResponse = pack("C",$ident) . GenerateAuthenticatorResponse($unicodePassword,$ourResponse,
$peerChallenge,$challenge,$username);
# print(STDERR "Authenticator Response: len = ".length($authenticatorResponse).
# ", hex = ".unpack("H*",$authenticatorResponse)."\n");
# MPPE Code
################################
my $NtPasswordHash = NtPasswordHash($unicodePassword);
my $HashNtPasswordHash = HashNtPasswordHash($NtPasswordHash);
# Create master key
my $MasterKey = GetMasterKey($HashNtPasswordHash,$NtResponse);
# Create MPPE keys
my $mppe_sendKey = GetAsymmetricStartKey($MasterKey,16,1,1);
my $mppe_recvKey = GetAsymmetricStartKey($MasterKey,16,1,0);
# Generate salts ... this should be in its own module and salt_offset should be global
my $salt_offset = 0;
my $salt1 = pack("C2",(0x80 | ( (($salt_offset++) & 0x0f) << 3) |
(rand(255) & 0x07)),rand(255));
my $salt2 = pack("C2",(0x80 | ( (($salt_offset++) & 0x0f) << 3) |
(rand(255) & 0x07)),rand(255));
# Encode keys
my $mppe_sendKey_e = mppe_encode_key(
getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"),
$packet->authenticator,
$salt1,
$mppe_sendKey
);
my $mppe_recvKey_e = mppe_encode_key(
getAttributeValue($user->{'ConfigAttributes'},"SMRadius-Config-Secret"),
$packet->authenticator,
$salt2,
$mppe_recvKey
);
# Finally setup arguments
setReplyVAttribute($server,$user->{'ReplyVAttributes'}, {
'Vendor' => 311,
'Name' => 'MS-MPPE-Recv-Key',
'Operator' => ":=",
'Value' => $mppe_recvKey_e
});
setReplyVAttribute($server,$user->{'ReplyVAttributes'}, {
'Vendor' => 311,
'Name' => 'MS-MPPE-Send-Key',
'Operator' => ":=",
'Value' => $mppe_sendKey_e
});
#################################
setReplyVAttribute($server,$user->{'ReplyVAttributes'}, {
'Vendor' => 311,
......@@ -285,7 +328,7 @@ sub ChallengeHash
# SHA encryption
my $sha = Digest::SHA1->new();
my $sha = Digest::SHA->new();
$sha->add($PeerChallenge);
$sha->add($AuthenticatorChallenge);
$sha->add($UserName);
......@@ -522,7 +565,7 @@ sub GenerateAuthenticatorResponse
my $PasswordHashHash = HashNtPasswordHash($PasswordHash);
# SHA encryption
my $sha = Digest::SHA1->new();
my $sha = Digest::SHA->new();
$sha->add($PasswordHashHash);
$sha->add($NTResponse);
foreach my $item (@Magic1) {
......@@ -532,7 +575,7 @@ sub GenerateAuthenticatorResponse
my $Challenge = ChallengeHash($PeerChallenge, $AuthenticatorChallenge, $UserName);
$sha = Digest::SHA1->new();
$sha = Digest::SHA->new();
$sha->add($Digest);
$sha->add($Challenge);
foreach my $item (@Magic2) {
......@@ -769,5 +812,220 @@ sub NtChallengeResponse {
#
# RFC 3079
#
#GetMasterKey(
# IN 16-octet PasswordHashHash,
# IN 24-octet NTResponse,
# OUT 16-octet MasterKey )
#{
# 20-octet Digest
#
# ZeroMemory(Digest, sizeof(Digest));
#
# /*
# * SHSInit(), SHSUpdate() and SHSFinal()
# * are an implementation of the Secure Hash Standard [7].
# */
#
# SHSInit(Context);
# SHSUpdate(Context, PasswordHashHash, 16);
# SHSUpdate(Context, NTResponse, 24);
# SHSUpdate(Context, Magic1, 27);
# SHSFinal(Context, Digest);
#
# MoveMemory(MasterKey, Digest, 16);
#}
sub GetMasterKey
{
my ($PasswordHashHash,$NTResponse) = @_;
# "Magic" constants used in key derivations - in hex
my @Magic1 =
("54", "68", "69", "73", "20", "69", "73", "20", "74",
"68", "65", "20", "4d", "50", "50", "45", "20", "4d",
"61", "73", "74", "65", "72", "20", "4b", "65", "79");
my $sha = Digest::SHA->new();
$sha->add($PasswordHashHash);
$sha->add($NTResponse);
foreach my $item (@Magic1) {
$sha->add(pack("H*",$item));
}
my $Digest = $sha->digest();
# Cut off MasterKey
my $MasterKey = substr($Digest,0,16);
return $MasterKey;
}
#VOID
#GetAsymetricStartKey(
# IN 16-octet MasterKey,
# OUT 8-to-16 octet SessionKey,
# IN INTEGER SessionKeyLength,
# IN BOOLEAN IsSend,
# IN BOOLEAN IsServer )
#{
#
# 20-octet Digest;
#
# ZeroMemory(Digest, 20);
#
# if (IsSend) {
# if (IsServer) {
# s = Magic3
# } else {
# s = Magic2
# }
# } else {
# if (IsServer) {
# s = Magic2
# } else {
# s = Magic3
# }
# }
#
# /*
# * SHSInit(), SHSUpdate() and SHSFinal()
# * are an implementation of the Secure Hash Standard [7].
# */
#
# SHSInit(Context);
# SHSUpdate(Context, MasterKey, 16);
# SHSUpdate(Context, SHSpad1, 40);
# SHSUpdate(Context, s, 84);
# SHSUpdate(Context, SHSpad2, 40);
# SHSFinal(Context, Digest);
#
# MoveMemory(SessionKey, Digest, SessionKeyLength);
#}
sub GetAsymmetricStartKey
{
my ($MasterKey,$SessionKeyLength,$IsSend,$IsServer) = @_;
# "Magic" constants used in key derivations - in hex
my @Magic2 =
("4f", "6e", "20", "74", "68", "65", "20", "63", "6c", "69",
"65", "6e", "74", "20", "73", "69", "64", "65", "2c", "20",
"74", "68", "69", "73", "20", "69", "73", "20", "74", "68",
"65", "20", "73", "65", "6e", "64", "20", "6b", "65", "79",
"3b", "20", "6f", "6e", "20", "74", "68", "65", "20", "73",
"65", "72", "76", "65", "72", "20", "73", "69", "64", "65",
"2c", "20", "69", "74", "20", "69", "73", "20", "74", "68",
"65", "20", "72", "65", "63", "65", "69", "76", "65", "20",
"6b", "65", "79", "2e");
my @Magic3 =
("4f", "6e", "20", "74", "68", "65", "20", "63", "6c", "69",
"65", "6e", "74", "20", "73", "69", "64", "65", "2c", "20",
"74", "68", "69", "73", "20", "69", "73", "20", "74", "68",
"65", "20", "72", "65", "63", "65", "69", "76", "65", "20",
"6b", "65", "79", "3b", "20", "6f", "6e", "20", "74", "68",
"65", "20", "73", "65", "72", "76", "65", "72", "20", "73",
"69", "64", "65", "2c", "20", "69", "74", "20", "69", "73",
"20", "74", "68", "65", "20", "73", "65", "6e", "64", "20",
"6b", "65", "79", "2e");
# Pads used in key derivation - in hex
my @SHSpad1 =
("00", "00", "00", "00", "00", "00", "00", "00", "00", "00",
"00", "00", "00", "00", "00", "00", "00", "00", "00", "00",
"00", "00", "00", "00", "00", "00", "00", "00", "00", "00",
"00", "00", "00", "00", "00", "00", "00", "00", "00", "00");
my @SHSpad2 =
("f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2",
"f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2",
"f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2",
"f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2", "f2");
my @s;
if ($IsSend) {
if ($IsServer) {
@s = @Magic3;
} else {
@s = @Magic2;
}
} else {
if ($IsServer) {
@s = @Magic2;
} else {
@s = @Magic3;
}
}
my $sha = Digest::SHA->new();
$sha->add($MasterKey);
foreach my $item (@SHSpad1) {
$sha->add(pack("H*",$item));
}
foreach my $item (@s) {
$sha->add(pack("H*",$item));
}
foreach my $item (@SHSpad2) {
$sha->add(pack("H*",$item));
}
my $digest = $sha->digest();
# Cut off SessionKey
my $SessionKey = substr($digest,0,$SessionKeyLength);
return $SessionKey;
}
# Function to encode a key
sub mppe_encode_key
{
my ($secret,$vector,$salt,$enckey) = @_;
# Ok, to do this we need the length of the key first
my @plain = (
16, # Length
unpack("C*",pack("a31",$enckey))
);
# Create our first digest
my $sha = Digest::MD5->new();
$sha->add($secret);
$sha->add($vector);
$sha->add($salt);
# Unpack digest for calculation
my @buf = unpack("C*",$sha->digest());
# Calculate
for(my $i=0; $i < 16; $i++) {
$plain[$i] ^= $buf[$i];
}
# Second round
$sha = Digest::MD5->new();
$sha->add($secret);
# Add the values we calculated above
for (my $i = 0; $i < 16; $i++) {
$sha->add(pack("C",$plain[$i]));
}
# Unpack digest for calculation
@buf = unpack("C*",$sha->digest());
# Calculate
for (my $i = 0; $i < 16; $i++) {
$plain[$i+16] ^= $buf[$i];
}
# Pack salt, and result
my $key = pack("a2C32",$salt,@plain);
return $key;
}
1;
# vim: ts=4
smradius/modules/authentication/mod_auth_pap.pm → lib/smradius/modules/authentication/mod_auth_pap.pm
View file @ b659b33b
# PAP
# Copyright (C) 2007-2009, AllWorldIT
# Copyright (C) 2007-2015, AllWorldIT
#
# References:
# RFC1334 - PPP Authentication Protocols
......@@ -80,6 +80,8 @@ sub authenticate
# Check if this is PAP authentication
return MOD_RES_SKIP if (!defined($encPassword));
# Skip MAC authentication
return MOD_RES_SKIP if ($user->{'_UserDB'}->{'Name'} eq "SQL User Database (MAC authentication)");
$server->log(LOG_DEBUG,"[MOD_AUTH_PAP] This is a PAP authentication request");
......
lib/smradius/modules/features/mod_feature_capping.pm 0 → 100644
View file @ b659b33b
# Capping support
# Copyright (C) 2007-2019, AllWorldIT
#
# 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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
package smradius::modules::features::mod_feature_capping;
use strict;
use warnings;
# Modules we need
use smradius::attributes;
use smradius::constants;
use smradius::logging;
use smradius::util;
use AWITPT::Util;
use List::Util qw( min );
use MIME::Lite;
use POSIX qw( floor );
# Set our version
our $VERSION = "0.0.1";
# Load exporter
use base qw(Exporter);
our @EXPORT = qw(
);
our @EXPORT_OK = qw(
);
# Plugin info
our $pluginInfo = {
Name => "User Capping Feature",
Init => \&init,
# Authentication hook
'Feature_Post-Authentication_hook' => \&post_auth_hook,
# Accounting hook
'Feature_Post-Accounting_hook' => \&post_acct_hook,
};
# Some constants
my $TRAFFIC_LIMIT_ATTRIBUTE = 'SMRadius-Capping-Traffic-Limit';
my $UPTIME_LIMIT_ATTRIBUTE = 'SMRadius-Capping-Uptime-Limit';
my $TRAFFIC_TOPUP_ATTRIBUTE = 'SMRadius-Capping-Traffic-Topup';
my $TIME_TOPUP_ATTRIBUTE = 'SMRadius-Capping-Uptime-Topup';
my $config;
## @internal
# Initialize module
sub init
{
my $server = shift;
my $scfg = $server->{'inifile'};
# Defaults
$config->{'enable_mikrotik'} = 0;
$config->{'caveat_captrafzero'} = 0;
# Setup SQL queries
if (defined($scfg->{'mod_feature_capping'})) {
# Check if option exists
if (defined($scfg->{'mod_feature_capping'}{'enable_mikrotik'})) {
# Pull in config
if (defined(my $val = isBoolean($scfg->{'mod_feature_capping'}{'enable_mikrotik'}))) {
if ($val) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Mikrotik-specific vendor return attributes ENABLED");
$config->{'enable_mikrotik'} = $val;
}
} else {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Value for 'enable_mikrotik' is invalid");
}
}
# Check if we have the caveat setting
if (defined(my $val = isBoolean($scfg->{'mod_feature_capping'}{'caveat_captrafzero'}))) {
if ($val) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Caveat to swap '0' and -undef- for ".
"SMRadius-Capping-Traffic-Limit ENABLED");
$config->{'caveat_captrafzero'} = $val;
}
} else {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Value for 'caveat_captrafzero' is invalid");
}
}
return;
}
## @post_auth_hook($server,$user,$packet)
# Post authentication hook
#
# @param server Server object
# @param user User data
# @param packet Radius packet
#
# @return Result
sub post_auth_hook
{
my ($server,$user,$packet) = @_;
# Skip MAC authentication
return MOD_RES_SKIP if ($user->{'_UserDB'}->{'Name'} eq "SQL User Database (MAC authentication)");
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] POST AUTH HOOK");
#
# Get limits from attributes
#
my $uptimeLimit = _getAttributeKeyLimit($server,$user,$UPTIME_LIMIT_ATTRIBUTE);
my $trafficLimit = _getAttributeKeyLimit($server,$user,$TRAFFIC_LIMIT_ATTRIBUTE);
# Swap around 0 and undef if we need to apply the captrafzero caveat
if ($config->{'caveat_captrafzero'}) {
if (!defined($uptimeLimit)) {
$uptimeLimit = 0;
} elsif ($uptimeLimit == 0) {
$uptimeLimit = undef;
}
if (!defined($trafficLimit)) {
$trafficLimit = 0;
} elsif ($trafficLimit == 0) {
$trafficLimit = undef;
}
}
#
# Get current traffic and uptime usage
#
my $accountingUsage = _getAccountingUsage($server,$user,$packet);
if (!defined($accountingUsage)) {
return MOD_RES_SKIP;
}
#
# Get valid traffic and uptime topups
#
# Check if there was any data returned at all
my $uptimeTopupAmount = _getConfigAttributeNumeric($server,$user,$TIME_TOPUP_ATTRIBUTE) // 0;
my $trafficTopupAmount = _getConfigAttributeNumeric($server,$user,$TRAFFIC_TOPUP_ATTRIBUTE) // 0;
#
# Set the new uptime and traffic limits (limit, if any.. + topups)
#
# Uptime..
# // is a defined operator, $a ? defined($a) : $b
my $uptimeLimitWithTopups = ($uptimeLimit // 0) + $uptimeTopupAmount;
# Traffic..
# // is a defined operator, $a ? defined($a) : $b
my $trafficLimitWithTopups = ($trafficLimit // 0) + $trafficTopupAmount;
#
# Do auto-topups for both traffic and uptime
#
my $autoTopupTrafficAdded = _doAutoTopup($server,$user,$accountingUsage->{'TotalDataUsage'},"traffic",
$trafficLimitWithTopups,1);
if (defined($autoTopupTrafficAdded)) {
$trafficLimitWithTopups += $autoTopupTrafficAdded;
}
my $autoTopupUptimeAdded = _doAutoTopup($server,$user,$accountingUsage->{'TotalSessionTime'},"uptime",
$uptimeLimitWithTopups,2);
if (defined($autoTopupUptimeAdded)) {
$uptimeLimitWithTopups += $autoTopupUptimeAdded;
}
#
# Display our usages
#
_logUsage($server,$accountingUsage->{'TotalDataUsage'},$trafficLimit,$trafficTopupAmount,'traffic');
_logUsage($server,$accountingUsage->{'TotalSessionTime'},$uptimeLimit,$uptimeTopupAmount,'uptime');
#
# Add conditional variables
#
addAttributeConditionalVariable($user,"SMRadius_Capping_TotalDataUsage",$accountingUsage->{'TotalDataUsage'});
addAttributeConditionalVariable($user,"SMRadius_Capping_TotalSessionTime",$accountingUsage->{'TotalSessionTime'});
#
# Allow for capping overrides by attribute
#
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Uptime-Multiplier'})) {
my $multiplier = pop(@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Uptime-Multiplier'}});
my $newLimit = $uptimeLimitWithTopups * $multiplier;
my $newSessionTime = $accountingUsage->{'TotalSessionTime'} * $multiplier;
$uptimeLimitWithTopups = $newLimit;
$accountingUsage->{'TotalSessionTime'} = $newSessionTime;
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] User uptime multiplier '$multiplier' changes ".
"uptime limit ('$uptimeLimitWithTopups' => '$newLimit'), ".
"uptime usage ('".$accountingUsage->{'TotalSessionTime'}."' => '$newSessionTime')"
);
}
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Traffic-Multiplier'})) {
my $multiplier = pop(@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Traffic-Multiplier'}});
my $newLimit = $trafficLimitWithTopups * $multiplier;
my $newDataUsage = $accountingUsage->{'TotalDataUsage'} * $multiplier;
$trafficLimitWithTopups = $newLimit;
$accountingUsage->{'TotalDataUsage'} = $newDataUsage;
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] User traffic multiplier '$multiplier' changes ".
"traffic limit ('$trafficLimitWithTopups' => '$newLimit'), ".
"traffic usage ('".$accountingUsage->{'TotalDataUsage'}."' => '$newDataUsage')"
);
}
#
# Check if we've exceeded our limits
#
# Uptime...
if (defined($uptimeLimit)) {
# Check session time has not exceeded what we're allowed
if ($accountingUsage->{'TotalSessionTime'} >= $uptimeLimitWithTopups) {
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Usage of ".$accountingUsage->{'TotalSessionTime'}.
"min exceeds allowed limit of ".$uptimeLimitWithTopups."min");
return MOD_RES_NACK;
# Setup limits
} else {
# Check if we returning Mikrotik vattributes
# FIXME: NK - this is not mikrotik specific
if ($config->{'enable_mikrotik'}) {
# FIXME: NK - We should cap the maximum total session time to that which is already set, if something is set
# Setup reply attributes for Mikrotik HotSpots
my %attribute = (
'Name' => 'Session-Timeout',
'Operator' => '=',
'Value' => $uptimeLimitWithTopups - $accountingUsage->{'TotalSessionTime'}
);
setReplyAttribute($server,$user->{'ReplyAttributes'},\%attribute);
}
}
}
# Traffic
if (defined($trafficLimit)) {
# Capped
if ($accountingUsage->{'TotalDataUsage'} >= $trafficLimitWithTopups) {
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Usage of ".$accountingUsage->{'TotalDataUsage'}.
"Mbyte exceeds allowed limit of ".$trafficLimitWithTopups."Mbyte");
return MOD_RES_NACK;
# Setup limits
} else {
# Check if we returning Mikrotik vattributes
if ($config->{'enable_mikrotik'}) {
# Get remaining traffic
my $remainingTraffic = $trafficLimitWithTopups - $accountingUsage->{'TotalDataUsage'};
my $remainingTrafficLimit = ( $remainingTraffic % 4096 ) * 1024 * 1024;
my $remainingTrafficGigawords = floor($remainingTraffic / 4096);
# Setup reply attributes for Mikrotik HotSpots
foreach my $attrName ('Recv','Xmit','Total') {
my %attribute = (
'Vendor' => 14988,
'Name' => "Mikrotik-$attrName-Limit",
'Operator' => '=',
# Gigawords leftovers
'Value' => $remainingTrafficLimit
);
setReplyVAttribute($server,$user->{'ReplyVAttributes'},\%attribute);
%attribute = (
'Vendor' => 14988,
'Name' => "Mikrotik-$attrName-Limit-Gigawords",
'Operator' => '=',
# Gigawords
'Value' => $remainingTrafficGigawords
);
setReplyVAttribute($server,$user->{'ReplyVAttributes'},\%attribute);
}
}
}
}
return MOD_RES_ACK;
}
## @post_acct_hook($server,$user,$packet)
# Post authentication hook
#
# @param server Server object
# @param user User data
# @param packet Radius packet
#
# @return Result
sub post_acct_hook
{
my ($server,$user,$packet) = @_;
# We cannot cap a user if we don't have a UserDB module can we? no userdb, no cap?
return MOD_RES_SKIP if (!defined($user->{'_UserDB'}->{'Name'}));
# Skip MAC authentication
return MOD_RES_SKIP if ($user->{'_UserDB'}->{'Name'} eq "SQL User Database (MAC authentication)");
# User is either connecting 'START' or disconnecting 'STOP'
return MOD_RES_SKIP if ($packet->rawattr('Acct-Status-Type') ne "1" && $packet->rawattr('Acct-Status-Type') ne "3");
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] POST ACCT HOOK");
#
# Get limits from attributes
#
my $uptimeLimit = _getAttributeKeyLimit($server,$user,$UPTIME_LIMIT_ATTRIBUTE);
my $trafficLimit = _getAttributeKeyLimit($server,$user,$TRAFFIC_LIMIT_ATTRIBUTE);
# Swap around 0 and undef if we need to apply the captrafzero caveat
if ($config->{'caveat_captrafzero'}) {
if (!defined($uptimeLimit)) {
$uptimeLimit = 0;
} elsif ($uptimeLimit == 0) {
$uptimeLimit = undef;
}
if (!defined($trafficLimit)) {
$trafficLimit = 0;
} elsif ($trafficLimit == 0) {
$trafficLimit = undef;
}
}
#
# Get current traffic and uptime usage
#
#
my $accountingUsage = _getAccountingUsage($server,$user,$packet);
if (!defined($accountingUsage)) {
return MOD_RES_SKIP;
}
#
# Get valid traffic and uptime topups
#
# Check if there was any data returned at all
my $uptimeTopupAmount = _getConfigAttributeNumeric($server,$user,$TIME_TOPUP_ATTRIBUTE) // 0;
my $trafficTopupAmount = _getConfigAttributeNumeric($server,$user,$TRAFFIC_TOPUP_ATTRIBUTE) // 0;
#
# Set the new uptime and traffic limits (limit, if any.. + topups)
#
# Uptime..
# // is a defined operator, $a ? defined($a) : $b
my $uptimeLimitWithTopups = ($uptimeLimit // 0) + $uptimeTopupAmount;
# Traffic..
# // is a defined operator, $a ? defined($a) : $b
my $trafficLimitWithTopups = ($trafficLimit // 0) + $trafficTopupAmount;
#
# Do auto-topups for both traffic and uptime
#
my $autoTopupTrafficAdded = _doAutoTopup($server,$user,$accountingUsage->{'TotalDataUsage'},"traffic",
$trafficLimitWithTopups,1);
if (defined($autoTopupTrafficAdded)) {
$trafficLimitWithTopups += $autoTopupTrafficAdded;
}
my $autoTopupUptimeAdded = _doAutoTopup($server,$user,$accountingUsage->{'TotalSessionTime'},"uptime",
$uptimeLimitWithTopups,2);
if (defined($autoTopupUptimeAdded)) {
$uptimeLimitWithTopups += $autoTopupUptimeAdded;
}
#
# Display our usages
#
_logUsage($server,$accountingUsage->{'TotalDataUsage'},$trafficLimit,$trafficTopupAmount,'traffic');
_logUsage($server,$accountingUsage->{'TotalSessionTime'},$uptimeLimit,$uptimeTopupAmount,'uptime');
#
# Add conditional variables
#
# Add attribute conditionals BEFORE override
addAttributeConditionalVariable($user,"SMRadius_Capping_TotalDataUsage",$accountingUsage->{'TotalDataUsage'});
addAttributeConditionalVariable($user,"SMRadius_Capping_TotalSessionTime",$accountingUsage->{'TotalSessionTime'});
#
# Allow for capping overrides by user attribute
#
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Uptime-Multiplier'})) {
my $multiplier = pop(@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Uptime-Multiplier'}});
my $newLimit = $uptimeLimitWithTopups * $multiplier;
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] User cap uptime multiplier '$multiplier' changes limit ".
"from '$uptimeLimitWithTopups' to '$newLimit'");
$uptimeLimitWithTopups = $newLimit;
}
if (defined($user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Traffic-Multiplier'})) {
my $multiplier = pop(@{$user->{'ConfigAttributes'}->{'SMRadius-Config-Capping-Traffic-Multiplier'}});
my $newLimit = $trafficLimitWithTopups * $multiplier;
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] User cap traffic multiplier '$multiplier' changes limit ".
"from '$trafficLimitWithTopups' to '$newLimit'");
$trafficLimitWithTopups = $newLimit;
}
#
# Check if we've exceeded our limits
#
# Uptime..
if (defined($uptimeLimit)) {
# Capped
if ($accountingUsage->{'TotalSessionTime'} >= $uptimeLimitWithTopups) {
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Usage of ".$accountingUsage->{'TotalSessionTime'}.
"min exceeds allowed limit of ".$uptimeLimitWithTopups."min");
return MOD_RES_NACK;
}
}
# Traffic
if (defined($trafficLimit)) {
# Capped
if ($accountingUsage->{'TotalDataUsage'} >= $trafficLimitWithTopups) {
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Usage of ".$accountingUsage->{'TotalDataUsage'}.
"Mbyte exceeds allowed limit of ".$trafficLimitWithTopups."Mbyte");
return MOD_RES_NACK;
}
}
return MOD_RES_ACK;
}
## @internal
# Code snippet to grab the current attribute key limit by processing the user attributes
sub _getAttributeKeyLimit
{
my ($server,$user,$attributeKey) = @_;
# Short circuit return if we don't have the uptime key set
return if (!defined($user->{'Attributes'}->{$attributeKey}));
# Short circuit if we do not have a valid attribute operator: ':='
if (!defined($user->{'Attributes'}->{$attributeKey}->{':='})) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] No valid operators for attribute '".
$user->{'Attributes'}->{$attributeKey}."'");
return;
}
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Attribute '".$attributeKey."' is defined");
# Check for valid attribute value
if (!defined($user->{'Attributes'}->{$attributeKey}->{':='}->{'Value'}) ||
$user->{'Attributes'}->{$attributeKey}->{':='}->{'Value'} !~ /^\d+$/) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Attribute '".$user->{'Attributes'}->{$attributeKey}->{':='}->{'Value'}.
"' is NOT a numeric value");
return;
}
return $user->{'Attributes'}->{$attributeKey}->{':='}->{'Value'};
}
## @internal
# Code snippet to grab the current accounting usage of a user
sub _getAccountingUsage
{
my ($server,$user,$packet) = @_;
foreach my $module (@{$server->{'module_list'}}) {
# Do we have the correct plugin?
if (defined($module->{'Accounting_getUsage'})) {
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] Found plugin: '".$module->{'Name'}."'");
# Fetch users session uptime & bandwidth used
if (my $res = $module->{'Accounting_getUsage'}($server,$user,$packet)) {
return $res;
}
$server->log(LOG_ERR,"[MOD_FEATURE_CAPPING] No usage data found for user '".$user->{'Username'}."'");
}
}
return;
}
## @internal
# Code snippet to log our uptime usage
sub _logUsage
{
my ($server,$accountingUsage,$limit,$topupAmount,$type) = @_;
my $typeKey = ucfirst($type);
# Check if our limit is defined
if (defined($limit) && $limit == 0) {
$limit = '-topup-';
} else {
$limit = '-none-';
}
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] Capping information [type: %s, total: %s, limit: %s, topups: %s]",
$type,$accountingUsage,$limit,$topupAmount);
return;
}
## @internal
# Function snippet to return a user attribute
sub _getConfigAttributeNumeric
{
my ($server,$user,$attributeName) = @_;
# Short circuit if the attribute does not exist
return 0 if (!defined($user->{'ConfigAttributes'}->{$attributeName}));
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] Config attribute '".$attributeName."' is defined");
# Check for value
if (!defined($user->{'ConfigAttributes'}->{$attributeName}->[0])) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Config attribute '".$attributeName."' has no value");
return 0;
}
# Is it a number?
if ($user->{'ConfigAttributes'}->{$attributeName}->[0] !~ /^\d+$/) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] Config attribute '".$user->{'ConfigAttributes'}->{$attributeName}->[0].
"' is NOT a numeric value");
return 0;
}
return $user->{'ConfigAttributes'}->{$attributeName}->[0];
}
## @internal
# Function snippet to return a attribute
sub _getAttribute
{
my ($server,$user,$attributeName) = @_;
# Check the attribute exists
return if (!defined($user->{'Attributes'}->{$attributeName}));
$server->log(LOG_DEBUG,"[MOD_FEATURE_CAPPING] User attribute '".$attributeName."' is defined");
# Check the required operator is present in this case :=
if (!defined($user->{'Attributes'}->{$attributeName}->{':='})) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] User attribute '".$attributeName."' has no ':=' operator");
return;
}
# Check the operator value is defined...
if (!defined($user->{'Attributes'}->{$attributeName}->{':='}->{'Value'})) {
$server->log(LOG_NOTICE,"[MOD_FEATURE_CAPPING] User attribute '".$attributeName."' has no value");
return;
}
return $user->{'Attributes'}->{$attributeName}->{':='}->{'Value'};
}
## @internal
# Function which impelments our auto-topup functionality
sub _doAutoTopup
{
my ($server,$user,$accountingUsage,$type,$usageLimit,$topupType) = @_;
my $scfg = $server->{'inifile'};
# Get the key, which has the first letter uppercased
my $typeKey = ucfirst($type);
# Booleanize the attribute and check if its enabled
if (my $enabled = booleanize(_getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-Enabled"))) {
$server->log(LOG_INFO,'[MOD_FEATURE_CAPPING] AutoTopups for %s is enabled',$type);
} else {
$server->log(LOG_DEBUG,'[MOD_FEATURE_CAPPING] AutoTopups for %s is not enabled',$type);
return;
}
# Do sanity checks on the auto-topup amount
my $autoTopupAmount = _getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-Amount");
if (!defined($autoTopupAmount)) {
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s-Amount must have a value',$typeKey);
return;
}
if (!isNumber($autoTopupAmount)){
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s-Amount must be a number and be > 0, instead it was '.
'\'%s\', IGNORING SMRadius-AutoTopup-%s-Enabled',$typeKey,$autoTopupAmount,$typeKey);
return;
}
# Do sanity checks on the auto-topup threshold
my $autoTopupThreshold = _getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-Threshold");
if (defined($autoTopupThreshold) && !isNumber($autoTopupThreshold)){
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s-Threshold must be a number and be > 0, instead it was '.
'\'%s\', IGNORING SMRadius-AutoTopup-%s-Threshold',$typeKey,$autoTopupAmount,$typeKey);
$autoTopupThreshold = undef;
}
# Check that if the auto-topup limit is defined, that it is > 0
my $autoTopupLimit = _getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-Limit");
if (defined($autoTopupLimit) && !isNumber($autoTopupLimit)) {
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s-Limit must be a number and be > 0, instead it was '.
'\'%s\', IGNORING SMRadius-AutoTopup-%s-Enabled',$typeKey,$autoTopupAmount,$typeKey);
return;
}
# Pull in ahow many auto-topups were already added
my $autoTopupsAdded = _getConfigAttributeNumeric($server,$user,"SMRadius-Capping-$typeKey-AutoTopup") // 0;
# Default to an auto-topup threshold of the topup amount divided by two if none has been provided
$autoTopupThreshold //= floor($autoTopupAmount / 2);
# Check if we're still within our usage limit and return
if (($usageLimit + $autoTopupsAdded - $accountingUsage) > $autoTopupThreshold) {
$server->log(LOG_DEBUG,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s: CHECK => usageLimit(%s) + autoTopupsAdded(%s) - '.
'accountingUsage(%s) < autoTopupThreshold(%s) = not eligble for auto-topup yet',$typeKey,
$usageLimit,$autoTopupsAdded,$accountingUsage,$autoTopupThreshold);
return;
} else {
$server->log(LOG_DEBUG,'[MOD_FEATURE_CAPPING] SMRadius-AutoTopup-%s: CHECK => usageLimit(%s) + autoTopupsAdded(%s) - '.
'accountingUsage(%s) < autoTopupThreshold(%s) = eligble, processing',$typeKey,
$usageLimit,$autoTopupsAdded,$accountingUsage,$autoTopupThreshold);
}
# Check the difference between our accounting usage and our usage limit
my $usageDelta = $accountingUsage - $usageLimit;
# Make sure our delta is at least 0
$usageDelta = 0 if ($usageDelta < 0);
# Calculate how many topups are needed
my $autoTopupsRequired = floor($usageDelta / $autoTopupAmount) + 1;
# Default the topups to add to the number required
my $autoTopupsToAdd = $autoTopupsRequired;
# If we have an auto-topup limit, recalculate how many we must add... maybe it exceeds
if (defined($autoTopupLimit)) {
my $autoTopupsAllowed = floor(($autoTopupLimit - $autoTopupsAdded) / $autoTopupAmount);
$autoTopupsToAdd = min($autoTopupsRequired,$autoTopupsAllowed);
# We cannot add a negative amount of auto-topups, if we have a negative amount, we have hit our limit
$autoTopupsToAdd = 0 if ($autoTopupsToAdd < 0);
}
# Total topup amount
my $autoTopupsToAddAmount = $autoTopupsToAdd * $autoTopupAmount;
# The datetime now
my $now = DateTime->now->set_time_zone($server->{'smradius'}->{'event_timezone'});
# Use truncate to set all values after 'month' to their default values
my $thisMonth = $now->clone()->truncate( to => "month" );
# This month, in string form
my $thisMonth_str = $thisMonth->strftime("%Y-%m-%d");
# Next month..
my $nextMonth = $thisMonth->clone()->add( months => 1 );
my $nextMonth_str = $nextMonth->strftime("%Y-%m-%d");
# Lets see if a module accepts to add a topup
my $res;
foreach my $module (@{$server->{'module_list'}}) {
# Do we have the correct plugin?
if (defined($module->{'Feature_Config_Topop_add'})) {
$server->log(LOG_INFO,"[MOD_FEATURE_CAPPING] Found plugin: '".$module->{'Name'}."'");
# Try add topup
$res = $module->{'Feature_Config_Topop_add'}($server,$user,$thisMonth_str,$nextMonth_str,
($topupType | 4),$autoTopupAmount);
# Skip to end if we added a topup
if ($res == MOD_RES_ACK) {
my $topupsRemaining = $autoTopupsToAdd - 1;
while ($topupsRemaining > 0) {
# Try add another topup
$res = $module->{'Feature_Config_Topop_add'}($server,$user,$thisMonth_str,$nextMonth_str,
($topupType | 4),$autoTopupAmount);
$topupsRemaining--;
}
last;
}
}
}
# If not, return undef
if (!defined($res) || $res != MOD_RES_ACK) {
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] Auto-Topup(s) cannot be added, no module replied with ACK');
return;
}
$server->log(LOG_INFO,'[MOD_FEATURE_CAPPING] Auto-Topups added [type: %s, threshold: %s, amount: %s, required: %s, limit: %s, added: %s]',
$type,$autoTopupThreshold,$autoTopupAmount,$autoTopupsRequired,$autoTopupLimit,$autoTopupsToAdd);
# Grab notify destinations
my $notify;
if (!defined($notify = _getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-Notify"))) {
$server->log(LOG_INFO,'[MOD_FEATURE_CAPPING] AutoTopups notify destination is not specified, NOT notifying');
goto END;
}
$server->log(LOG_INFO,'[MOD_FEATURE_CAPPING] AutoTopups notify destination is \'%s\'',$notify);
# Grab notify template
my $notifyTemplate;
if (!defined($notifyTemplate = _getAttribute($server,$user,"SMRadius-AutoTopup-$typeKey-NotifyTemplate"))) {
$server->log(LOG_INFO,'[MOD_FEATURE_CAPPING] AutoTopups notify template is not specified, NOT notifying');
goto END;
}
# NOTE: $autoTopupToAdd and autoTopupsToAddAmount will be 0 if no auto-topups were added
# Create variable hash to pass to TT
my $variables = {
'user' => {
'ID' => $user->{'ID'},
'username' => $user->{'Username'},
},
'usage' => {
'total' => $accountingUsage,
'limit' => $usageLimit,
},
'autotopup' => {
'amount' => $autoTopupAmount,
'limit' => $autoTopupLimit,
'added' => $autoTopupsAdded,
'toAdd' => $autoTopupsToAdd,
'toAddAmount' => $autoTopupsToAddAmount,
},
};
# Split off notification targets
my @notificationTargets = split(/[,;\s]+/,$notify);
foreach my $notifyTarget (@notificationTargets) {
# Parse template
my ($notifyMsg,$error) = quickTemplateToolkit($notifyTemplate,{
%{$variables},
'notify' => { 'target' => $notifyTarget }
});
# Check if we have a result, if not, report the error
if (!defined($notifyMsg)) {
my $errorMsg = $error->info();
$errorMsg =~ s/\r?\n/\\n/g;
$server->log(LOG_WARN,'[MOD_FEATURE_CAPPING] AutoTopups notify template parsing failed: %s',$errorMsg);
next;
}
my %messageHeaders = ();
# Split message into lines
my @lines = split(/\r?\n/,$notifyMsg);
while (defined($lines[0]) && (my $line = $lines[0]) =~ /(\S+): (.*)/) {
my ($header,$value) = ($1,$2);
$messageHeaders{$header} = $value;
# Remove line
shift(@lines);
# Last if our next line is undefined
last if (!defined($lines[0]));
# If the next line is blank, remove it, and continue below
if ($lines[0] =~ /^\s*$/) {
# Remove blank line
shift(@lines);
last;
}
}
# Create message
my $msg = MIME::Lite->new(
'Type' => 'multipart/mixed',
'Date' => $now->strftime('%a, %d %b %Y %H:%M:%S %z'),
%messageHeaders
);
# Attach body
$msg->attach(
'Type' => 'TEXT',
'Encoding' => '8bit',
'Data' => join("\n",@lines),
);
# Send email
my $smtpServer = $scfg->{'server'}{'smtp_server'} // 'localhost';
eval { $msg->send("smtp",$smtpServer); };
if (my $error = $@) {
$server->log(LOG_WARN,"[MOD_FEATURE_CAPPING] Email sending failed: '%s'",$error);
}
}
END:
return $autoTopupsToAddAmount;
}
1;
# vim: ts=4